URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-rbtgbo.adb] - Rev 749
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- -- -- -- 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 3, 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. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -- The references below to "CLR" refer to the following book, from which -- several of the algorithms here were adapted: -- Introduction to Algorithms -- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest -- Publisher: The MIT Press (June 18, 1990) -- ISBN: 0262031418 with System; use type System.Address; package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is ----------------------- -- Local Subprograms -- ----------------------- procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type); procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type); procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type); procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type); ---------------- -- Clear_Tree -- ---------------- procedure Clear_Tree (Tree : in out Tree_Type'Class) is begin if Tree.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (container is busy)"; end if; -- The lock status (which monitors "element tampering") always implies -- that the busy status (which monitors "cursor tampering") is set too; -- this is a representation invariant. Thus if the busy bit is not set, -- then the lock bit must not be set either. pragma Assert (Tree.Lock = 0); Tree.First := 0; Tree.Last := 0; Tree.Root := 0; Tree.Length := 0; Tree.Free := -1; end Clear_Tree; ------------------ -- Delete_Fixup -- ------------------ procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type) is -- CLR p. 274 X : Count_Type; W : Count_Type; N : Nodes_Type renames Tree.Nodes; begin X := Node; while X /= Tree.Root and then Color (N (X)) = Black loop if X = Left (N (Parent (N (X)))) then W := Right (N (Parent (N (X)))); if Color (N (W)) = Red then Set_Color (N (W), Black); Set_Color (N (Parent (N (X))), Red); Left_Rotate (Tree, Parent (N (X))); W := Right (N (Parent (N (X)))); end if; if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) and then (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) then Set_Color (N (W), Red); X := Parent (N (X)); else if Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black then -- As a condition for setting the color of the left child to -- black, the left child access value must be non-null. A -- truth table analysis shows that if we arrive here, that -- condition holds, so there's no need for an explicit test. -- The assertion is here to document what we know is true. pragma Assert (Left (N (W)) /= 0); Set_Color (N (Left (N (W))), Black); Set_Color (N (W), Red); Right_Rotate (Tree, W); W := Right (N (Parent (N (X)))); end if; Set_Color (N (W), Color (N (Parent (N (X))))); Set_Color (N (Parent (N (X))), Black); Set_Color (N (Right (N (W))), Black); Left_Rotate (Tree, Parent (N (X))); X := Tree.Root; end if; else pragma Assert (X = Right (N (Parent (N (X))))); W := Left (N (Parent (N (X)))); if Color (N (W)) = Red then Set_Color (N (W), Black); Set_Color (N (Parent (N (X))), Red); Right_Rotate (Tree, Parent (N (X))); W := Left (N (Parent (N (X)))); end if; if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) and then (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) then Set_Color (N (W), Red); X := Parent (N (X)); else if Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black then -- As a condition for setting the color of the right child -- to black, the right child access value must be non-null. -- A truth table analysis shows that if we arrive here, that -- condition holds, so there's no need for an explicit test. -- The assertion is here to document what we know is true. pragma Assert (Right (N (W)) /= 0); Set_Color (N (Right (N (W))), Black); Set_Color (N (W), Red); Left_Rotate (Tree, W); W := Left (N (Parent (N (X)))); end if; Set_Color (N (W), Color (N (Parent (N (X))))); Set_Color (N (Parent (N (X))), Black); Set_Color (N (Left (N (W))), Black); Right_Rotate (Tree, Parent (N (X))); X := Tree.Root; end if; end if; end loop; Set_Color (N (X), Black); end Delete_Fixup; --------------------------- -- Delete_Node_Sans_Free -- --------------------------- procedure Delete_Node_Sans_Free (Tree : in out Tree_Type'Class; Node : Count_Type) is -- CLR p. 273 X, Y : Count_Type; Z : constant Count_Type := Node; pragma Assert (Z /= 0); N : Nodes_Type renames Tree.Nodes; 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 /= 0); pragma Assert (Tree.First /= 0); pragma Assert (Tree.Last /= 0); pragma Assert (Parent (N (Tree.Root)) = 0); pragma Assert ((Tree.Length > 1) or else (Tree.First = Tree.Last and then Tree.First = Tree.Root)); pragma Assert ((Left (N (Node)) = 0) or else (Parent (N (Left (N (Node)))) = Node)); pragma Assert ((Right (N (Node)) = 0) or else (Parent (N (Right (N (Node)))) = Node)); pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node)) or else ((Parent (N (Node)) /= 0) and then ((Left (N (Parent (N (Node)))) = Node) or else (Right (N (Parent (N (Node)))) = Node)))); if Left (N (Z)) = 0 then if Right (N (Z)) = 0 then if Z = Tree.First then Tree.First := Parent (N (Z)); end if; if Z = Tree.Last then Tree.Last := Parent (N (Z)); end if; if Color (N (Z)) = Black then Delete_Fixup (Tree, Z); end if; pragma Assert (Left (N (Z)) = 0); pragma Assert (Right (N (Z)) = 0); if Z = Tree.Root then pragma Assert (Tree.Length = 1); pragma Assert (Parent (N (Z)) = 0); Tree.Root := 0; elsif Z = Left (N (Parent (N (Z)))) then Set_Left (N (Parent (N (Z))), 0); else pragma Assert (Z = Right (N (Parent (N (Z))))); Set_Right (N (Parent (N (Z))), 0); end if; else pragma Assert (Z /= Tree.Last); X := Right (N (Z)); if Z = Tree.First then Tree.First := Min (Tree, X); end if; if Z = Tree.Root then Tree.Root := X; elsif Z = Left (N (Parent (N (Z)))) then Set_Left (N (Parent (N (Z))), X); else pragma Assert (Z = Right (N (Parent (N (Z))))); Set_Right (N (Parent (N (Z))), X); end if; Set_Parent (N (X), Parent (N (Z))); if Color (N (Z)) = Black then Delete_Fixup (Tree, X); end if; end if; elsif Right (N (Z)) = 0 then pragma Assert (Z /= Tree.First); X := Left (N (Z)); if Z = Tree.Last then Tree.Last := Max (Tree, X); end if; if Z = Tree.Root then Tree.Root := X; elsif Z = Left (N (Parent (N (Z)))) then Set_Left (N (Parent (N (Z))), X); else pragma Assert (Z = Right (N (Parent (N (Z))))); Set_Right (N (Parent (N (Z))), X); end if; Set_Parent (N (X), Parent (N (Z))); if Color (N (Z)) = Black then Delete_Fixup (Tree, X); end if; else pragma Assert (Z /= Tree.First); pragma Assert (Z /= Tree.Last); Y := Next (Tree, Z); pragma Assert (Left (N (Y)) = 0); X := Right (N (Y)); if X = 0 then if Y = Left (N (Parent (N (Y)))) then pragma Assert (Parent (N (Y)) /= Z); Delete_Swap (Tree, Z, Y); Set_Left (N (Parent (N (Z))), Z); else pragma Assert (Y = Right (N (Parent (N (Y))))); pragma Assert (Parent (N (Y)) = Z); Set_Parent (N (Y), Parent (N (Z))); if Z = Tree.Root then Tree.Root := Y; elsif Z = Left (N (Parent (N (Z)))) then Set_Left (N (Parent (N (Z))), Y); else pragma Assert (Z = Right (N (Parent (N (Z))))); Set_Right (N (Parent (N (Z))), Y); end if; Set_Left (N (Y), Left (N (Z))); Set_Parent (N (Left (N (Y))), Y); Set_Right (N (Y), Z); Set_Parent (N (Z), Y); Set_Left (N (Z), 0); Set_Right (N (Z), 0); declare Y_Color : constant Color_Type := Color (N (Y)); begin Set_Color (N (Y), Color (N (Z))); Set_Color (N (Z), Y_Color); end; end if; if Color (N (Z)) = Black then Delete_Fixup (Tree, Z); end if; pragma Assert (Left (N (Z)) = 0); pragma Assert (Right (N (Z)) = 0); if Z = Right (N (Parent (N (Z)))) then Set_Right (N (Parent (N (Z))), 0); else pragma Assert (Z = Left (N (Parent (N (Z))))); Set_Left (N (Parent (N (Z))), 0); end if; else if Y = Left (N (Parent (N (Y)))) then pragma Assert (Parent (N (Y)) /= Z); Delete_Swap (Tree, Z, Y); Set_Left (N (Parent (N (Z))), X); Set_Parent (N (X), Parent (N (Z))); else pragma Assert (Y = Right (N (Parent (N (Y))))); pragma Assert (Parent (N (Y)) = Z); Set_Parent (N (Y), Parent (N (Z))); if Z = Tree.Root then Tree.Root := Y; elsif Z = Left (N (Parent (N (Z)))) then Set_Left (N (Parent (N (Z))), Y); else pragma Assert (Z = Right (N (Parent (N (Z))))); Set_Right (N (Parent (N (Z))), Y); end if; Set_Left (N (Y), Left (N (Z))); Set_Parent (N (Left (N (Y))), Y); declare Y_Color : constant Color_Type := Color (N (Y)); begin Set_Color (N (Y), Color (N (Z))); Set_Color (N (Z), Y_Color); end; end if; if Color (N (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'Class; Z, Y : Count_Type) is N : Nodes_Type renames Tree.Nodes; pragma Assert (Z /= Y); pragma Assert (Parent (N (Y)) /= Z); Y_Parent : constant Count_Type := Parent (N (Y)); Y_Color : constant Color_Type := Color (N (Y)); begin Set_Parent (N (Y), Parent (N (Z))); Set_Left (N (Y), Left (N (Z))); Set_Right (N (Y), Right (N (Z))); Set_Color (N (Y), Color (N (Z))); if Tree.Root = Z then Tree.Root := Y; elsif Right (N (Parent (N (Y)))) = Z then Set_Right (N (Parent (N (Y))), Y); else pragma Assert (Left (N (Parent (N (Y)))) = Z); Set_Left (N (Parent (N (Y))), Y); end if; if Right (N (Y)) /= 0 then Set_Parent (N (Right (N (Y))), Y); end if; if Left (N (Y)) /= 0 then Set_Parent (N (Left (N (Y))), Y); end if; Set_Parent (N (Z), Y_Parent); Set_Color (N (Z), Y_Color); Set_Left (N (Z), 0); Set_Right (N (Z), 0); end Delete_Swap; ---------- -- Free -- ---------- procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is pragma Assert (X > 0); pragma Assert (X <= Tree.Capacity); N : Nodes_Type renames Tree.Nodes; -- pragma Assert (N (X).Prev >= 0); -- node is active -- Find a way to mark a node as active vs. inactive; we could -- use a special value in Color_Type for this. ??? begin -- The set container actually contains two data structures: a list for -- the "active" nodes that contain elements that have been inserted -- onto the tree, and another for the "inactive" nodes of the free -- store. -- -- We desire that merely declaring an object should have only minimal -- cost; specially, we want to avoid having to initialize the free -- store (to fill in the links), especially if the capacity is large. -- -- The head of the free list is indicated by Container.Free. If its -- value is non-negative, then the free store has been initialized -- in the "normal" way: Container.Free points to the head of the list -- of free (inactive) nodes, and the value 0 means the free list is -- empty. Each node on the free list has been initialized to point -- to the next free node (via its Parent component), and the value 0 -- means that this is the last free node. -- -- If Container.Free is negative, then the links on the free store -- have not been initialized. In this case the link values are -- implied: the free store comprises the components of the node array -- started with the absolute value of Container.Free, and continuing -- until the end of the array (Nodes'Last). -- -- ??? -- It might be possible to perform an optimization here. Suppose that -- the free store can be represented as having two parts: one -- comprising the non-contiguous inactive nodes linked together -- in the normal way, and the other comprising the contiguous -- inactive nodes (that are not linked together, at the end of the -- nodes array). This would allow us to never have to initialize -- the free store, except in a lazy way as nodes become inactive. -- When an element is deleted from the list container, its node -- becomes inactive, and so we set its Prev component to a negative -- value, to indicate that it is now inactive. This provides a useful -- way to detect a dangling cursor reference. -- The comment above is incorrect; we need some other way to -- indicate a node is inactive, for example by using a special -- Color_Type value. ??? -- N (X).Prev := -1; -- Node is deallocated (not on active list) if Tree.Free >= 0 then -- The free store has previously been initialized. All we need to -- do here is link the newly-free'd node onto the free list. Set_Parent (N (X), Tree.Free); Tree.Free := X; elsif X + 1 = abs Tree.Free then -- The free store has not been initialized, and the node becoming -- inactive immediately precedes the start of the free store. All -- we need to do is move the start of the free store back by one. Tree.Free := Tree.Free + 1; else -- The free store has not been initialized, and the node becoming -- inactive does not immediately precede the free store. Here we -- first initialize the free store (meaning the links are given -- values in the traditional way), and then link the newly-free'd -- node onto the head of the free store. -- ??? -- See the comments above for an optimization opportunity. If the -- next link for a node on the free store is negative, then this -- means the remaining nodes on the free store are physically -- contiguous, starting as the absolute value of that index value. Tree.Free := abs Tree.Free; if Tree.Free > Tree.Capacity then Tree.Free := 0; else for I in Tree.Free .. Tree.Capacity - 1 loop Set_Parent (N (I), I + 1); end loop; Set_Parent (N (Tree.Capacity), 0); end if; Set_Parent (N (X), Tree.Free); Tree.Free := X; end if; end Free; ----------------------- -- Generic_Allocate -- ----------------------- procedure Generic_Allocate (Tree : in out Tree_Type'Class; Node : out Count_Type) is N : Nodes_Type renames Tree.Nodes; begin if Tree.Free >= 0 then Node := Tree.Free; -- We always perform the assignment first, before we -- change container state, in order to defend against -- exceptions duration assignment. Set_Element (N (Node)); Tree.Free := Parent (N (Node)); else -- A negative free store value means that the links of the nodes -- in the free store have not been initialized. In this case, the -- nodes are physically contiguous in the array, starting at the -- index that is the absolute value of the Container.Free, and -- continuing until the end of the array (Nodes'Last). Node := abs Tree.Free; -- As above, we perform this assignment first, before modifying -- any container state. Set_Element (N (Node)); Tree.Free := Tree.Free - 1; end if; -- When a node is allocated from the free store, its pointer components -- (the links to other nodes in the tree) must also be initialized (to -- 0, the equivalent of null). This simplifies the post-allocation -- handling of nodes inserted into terminal positions. Set_Parent (N (Node), Parent => 0); Set_Left (N (Node), Left => 0); Set_Right (N (Node), Right => 0); end Generic_Allocate; ------------------- -- Generic_Equal -- ------------------- function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is L_Node : Count_Type; R_Node : Count_Type; 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 /= 0 loop if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then return False; end if; L_Node := Next (Left, L_Node); R_Node := Next (Right, R_Node); end loop; return True; end Generic_Equal; ----------------------- -- Generic_Iteration -- ----------------------- procedure Generic_Iteration (Tree : Tree_Type'Class) is procedure Iterate (P : Count_Type); ------------- -- Iterate -- ------------- procedure Iterate (P : Count_Type) is X : Count_Type := P; begin while X /= 0 loop Iterate (Left (Tree.Nodes (X))); Process (X); X := Right (Tree.Nodes (X)); end loop; end Iterate; -- Start of processing for Generic_Iteration begin Iterate (Tree.Root); end Generic_Iteration; ------------------ -- Generic_Read -- ------------------ procedure Generic_Read (Stream : not null access Root_Stream_Type'Class; Tree : in out Tree_Type'Class) is Len : Count_Type'Base; Node, Last_Node : Count_Type; N : Nodes_Type renames Tree.Nodes; begin Clear_Tree (Tree); Count_Type'Base'Read (Stream, Len); if Len < 0 then raise Program_Error with "bad container length (corrupt stream)"; end if; if Len = 0 then return; end if; if Len > Tree.Capacity then raise Constraint_Error with "length exceeds capacity"; end if; -- Use Unconditional_Insert_With_Hint here instead ??? Allocate (Tree, Node); pragma Assert (Node /= 0); Set_Color (N (Node), Black); Tree.Root := Node; Tree.First := Node; Tree.Last := Node; Tree.Length := 1; for J in Count_Type range 2 .. Len loop Last_Node := Node; pragma Assert (Last_Node = Tree.Last); Allocate (Tree, Node); pragma Assert (Node /= 0); Set_Color (N (Node), Red); Set_Right (N (Last_Node), Right => Node); Tree.Last := Node; Set_Parent (N (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'Class) is procedure Iterate (P : Count_Type); ------------- -- Iterate -- ------------- procedure Iterate (P : Count_Type) is X : Count_Type := P; begin while X /= 0 loop Iterate (Right (Tree.Nodes (X))); Process (X); X := Left (Tree.Nodes (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 : not null access Root_Stream_Type'Class; Tree : Tree_Type'Class) is procedure Process (Node : Count_Type); pragma Inline (Process); procedure Iterate is new Generic_Iteration (Process); ------------- -- Process -- ------------- procedure Process (Node : Count_Type) is begin Write_Node (Stream, Tree.Nodes (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'Class; X : Count_Type) is -- CLR p. 266 N : Nodes_Type renames Tree.Nodes; Y : constant Count_Type := Right (N (X)); pragma Assert (Y /= 0); begin Set_Right (N (X), Left (N (Y))); if Left (N (Y)) /= 0 then Set_Parent (N (Left (N (Y))), X); end if; Set_Parent (N (Y), Parent (N (X))); if X = Tree.Root then Tree.Root := Y; elsif X = Left (N (Parent (N (X)))) then Set_Left (N (Parent (N (X))), Y); else pragma Assert (X = Right (N (Parent (N (X))))); Set_Right (N (Parent (N (X))), Y); end if; Set_Left (N (Y), X); Set_Parent (N (X), Y); end Left_Rotate; --------- -- Max -- --------- function Max (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type is -- CLR p. 248 X : Count_Type := Node; Y : Count_Type; begin loop Y := Right (Tree.Nodes (X)); if Y = 0 then return X; end if; X := Y; end loop; end Max; --------- -- Min -- --------- function Min (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type is -- CLR p. 248 X : Count_Type := Node; Y : Count_Type; begin loop Y := Left (Tree.Nodes (X)); if Y = 0 then return X; end if; X := Y; end loop; end Min; ---------- -- Next -- ---------- function Next (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type is begin -- CLR p. 249 if Node = 0 then return 0; end if; if Right (Tree.Nodes (Node)) /= 0 then return Min (Tree, Right (Tree.Nodes (Node))); end if; declare X : Count_Type := Node; Y : Count_Type := Parent (Tree.Nodes (Node)); begin while Y /= 0 and then X = Right (Tree.Nodes (Y)) loop X := Y; Y := Parent (Tree.Nodes (Y)); end loop; return Y; end; end Next; -------------- -- Previous -- -------------- function Previous (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type is begin if Node = 0 then return 0; end if; if Left (Tree.Nodes (Node)) /= 0 then return Max (Tree, Left (Tree.Nodes (Node))); end if; declare X : Count_Type := Node; Y : Count_Type := Parent (Tree.Nodes (Node)); begin while Y /= 0 and then X = Left (Tree.Nodes (Y)) loop X := Y; Y := Parent (Tree.Nodes (Y)); end loop; return Y; end; end Previous; -------------------------- -- Rebalance_For_Insert -- -------------------------- procedure Rebalance_For_Insert (Tree : in out Tree_Type'Class; Node : Count_Type) is -- CLR p. 268 N : Nodes_Type renames Tree.Nodes; X : Count_Type := Node; pragma Assert (X /= 0); pragma Assert (Color (N (X)) = Red); Y : Count_Type; begin while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then Y := Right (N (Parent (N (Parent (N (X)))))); if Y /= 0 and then Color (N (Y)) = Red then Set_Color (N (Parent (N (X))), Black); Set_Color (N (Y), Black); Set_Color (N (Parent (N (Parent (N (X))))), Red); X := Parent (N (Parent (N (X)))); else if X = Right (N (Parent (N (X)))) then X := Parent (N (X)); Left_Rotate (Tree, X); end if; Set_Color (N (Parent (N (X))), Black); Set_Color (N (Parent (N (Parent (N (X))))), Red); Right_Rotate (Tree, Parent (N (Parent (N (X))))); end if; else pragma Assert (Parent (N (X)) = Right (N (Parent (N (Parent (N (X))))))); Y := Left (N (Parent (N (Parent (N (X)))))); if Y /= 0 and then Color (N (Y)) = Red then Set_Color (N (Parent (N (X))), Black); Set_Color (N (Y), Black); Set_Color (N (Parent (N (Parent (N (X))))), Red); X := Parent (N (Parent (N (X)))); else if X = Left (N (Parent (N (X)))) then X := Parent (N (X)); Right_Rotate (Tree, X); end if; Set_Color (N (Parent (N (X))), Black); Set_Color (N (Parent (N (Parent (N (X))))), Red); Left_Rotate (Tree, Parent (N (Parent (N (X))))); end if; end if; end loop; Set_Color (N (Tree.Root), Black); end Rebalance_For_Insert; ------------------ -- Right_Rotate -- ------------------ procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is N : Nodes_Type renames Tree.Nodes; X : constant Count_Type := Left (N (Y)); pragma Assert (X /= 0); begin Set_Left (N (Y), Right (N (X))); if Right (N (X)) /= 0 then Set_Parent (N (Right (N (X))), Y); end if; Set_Parent (N (X), Parent (N (Y))); if Y = Tree.Root then Tree.Root := X; elsif Y = Left (N (Parent (N (Y)))) then Set_Left (N (Parent (N (Y))), X); else pragma Assert (Y = Right (N (Parent (N (Y))))); Set_Right (N (Parent (N (Y))), X); end if; Set_Right (N (X), Y); Set_Parent (N (Y), X); end Right_Rotate; --------- -- Vet -- --------- function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is Nodes : Nodes_Type renames Tree.Nodes; Node : Node_Type renames Nodes (Index); begin if Parent (Node) = Index or else Left (Node) = Index or else Right (Node) = Index then return False; end if; if Tree.Length = 0 or else Tree.Root = 0 or else Tree.First = 0 or else Tree.Last = 0 then return False; end if; if Parent (Nodes (Tree.Root)) /= 0 then return False; end if; if Left (Nodes (Tree.First)) /= 0 then return False; end if; if Right (Nodes (Tree.Last)) /= 0 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 Index /= Tree.First then return False; end if; if Parent (Node) /= 0 or else Left (Node) /= 0 or else Right (Node) /= 0 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 /= Index and then Tree.Last /= Index then return False; end if; end if; if Left (Node) /= 0 and then Parent (Nodes (Left (Node))) /= Index then return False; end if; if Right (Node) /= 0 and then Parent (Nodes (Right (Node))) /= Index then return False; end if; if Parent (Node) = 0 then if Tree.Root /= Index then return False; end if; elsif Left (Nodes (Parent (Node))) /= Index and then Right (Nodes (Parent (Node))) /= Index then return False; end if; return True; end Vet; end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
Go to most recent revision | Compare with Previous | Blame | View Log