| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT LIBRARY COMPONENTS -- |
| -- -- |
| -- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2004-2014, 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 in this file 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 |
| |
| pragma Annotate (CodePeer, Skip_Analysis); |
| |
| ----------------------- |
| -- 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; |
| |
| 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; |
| |
| -- If node is not present, return (exception will be raised in caller) |
| |
| if Z = 0 then |
| return; |
| 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 |
| BL : Natural renames Left'Unrestricted_Access.Busy; |
| LL : Natural renames Left'Unrestricted_Access.Lock; |
| |
| BR : Natural renames Right'Unrestricted_Access.Busy; |
| LR : Natural renames Right'Unrestricted_Access.Lock; |
| |
| L_Node : Count_Type; |
| R_Node : Count_Type; |
| |
| Result : Boolean; |
| |
| begin |
| if Left'Address = Right'Address then |
| return True; |
| end if; |
| |
| if Left.Length /= Right.Length then |
| return False; |
| end if; |
| |
| -- If the containers are empty, return a result immediately, so as to |
| -- not manipulate the tamper bits unnecessarily. |
| |
| if Left.Length = 0 then |
| return True; |
| end if; |
| |
| -- Per AI05-0022, the container implementation is required to detect |
| -- element tampering by a generic actual subprogram. |
| |
| BL := BL + 1; |
| LL := LL + 1; |
| |
| BR := BR + 1; |
| LR := LR + 1; |
| |
| L_Node := Left.First; |
| R_Node := Right.First; |
| Result := True; |
| while L_Node /= 0 loop |
| if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then |
| Result := False; |
| exit; |
| end if; |
| |
| L_Node := Next (Left, L_Node); |
| R_Node := Next (Right, R_Node); |
| end loop; |
| |
| BL := BL - 1; |
| LL := LL - 1; |
| |
| BR := BR - 1; |
| LR := LR - 1; |
| |
| return Result; |
| |
| exception |
| when others => |
| BL := BL - 1; |
| LL := LL - 1; |
| |
| BR := BR - 1; |
| LR := LR - 1; |
| |
| raise; |
| 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; |
