1128 lines
33 KiB
Ada
1128 lines
33 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT LIBRARY COMPONENTS --
|
|
-- --
|
|
-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2004-2015, 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 Warnings (Off, "variable ""Busy*"" is not referenced");
|
|
pragma Warnings (Off, "variable ""Lock*"" is not referenced");
|
|
-- See comment in Ada.Containers.Helpers
|
|
|
|
-----------------------
|
|
-- 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
|
|
TC_Check (Tree.TC);
|
|
|
|
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
|
|
TC_Check (Tree.TC);
|
|
|
|
-- 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
|
|
-- Per AI05-0022, the container implementation is required to detect
|
|
-- element tampering by a generic actual subprogram.
|
|
|
|
Lock_Left : With_Lock (Left.TC'Unrestricted_Access);
|
|
Lock_Right : With_Lock (Right.TC'Unrestricted_Access);
|
|
|
|
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;
|
|
|
|
-- 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;
|
|
|
|
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 Checks and then Len < 0 then
|
|
raise Program_Error with "bad container length (corrupt stream)";
|
|
end if;
|
|
|
|
if Len = 0 then
|
|
return;
|
|
end if;
|
|
|
|
if Checks and then 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;
|