File : charles-red_black_trees.adb
pragma License (Modified_GPL);
------------------------------------------------------------------------------
-- --
-- CHARLES CONTAINER LIBRARY --
-- --
-- Copyright (C) 2001-2003 Matthew J Heaney --
-- --
-- The Charles Container Library ("Charles") is free software; you can --
-- redistribute it and/or modify it under terms of the GNU General Public --
-- License as published by the Free Software Foundation; either version 2, --
-- or (at your option) any later version. Charles is distributed in the --
-- hope that it will be useful, but WITHOUT 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 --
-- Charles; see file COPYING.TXT. 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. --
-- --
-- Charles is maintained by Matthew J Heaney. --
-- --
-- http://home.earthlink.net/~matthewjheaney/index.html --
-- mailto:matthewjheaney@earthlink.net --
-- --
------------------------------------------------------------------------------
with Charles.Algorithms.Generic_Lexicographical_Compare;
with Charles.Algorithms.Generic_Compare;
package body Charles.Red_Black_Trees is
function Root (Tree : Tree_Type) return Node_Access is
begin
return Parent (Tree.Back);
end;
procedure Set_Root
(Tree : Tree_Type;
Root : Node_Access) is
begin
Set_Parent (Tree.Back, Root);
end;
function First (Tree : Tree_Type) return Node_Access is
begin
return Left (Tree.Back);
end;
procedure Set_First
(Tree : Tree_Type;
First : Node_Access) is
begin
Set_Left (Tree.Back, First);
end;
function Last (Tree : Tree_Type) return Node_Access is
begin
return Right (Tree.Back);
end;
procedure Set_Last
(Tree : Tree_Type;
Last : Node_Access) is
begin
Set_Right (Tree.Back, Last);
end;
procedure Swap (Left, Right : in out Tree_Type) is
L_Length : constant Natural := Left.Length;
L_Back : constant Node_Access := Left.Back;
begin
Left.Length := Right.Length;
Left.Back := Right.Back;
Right.Length := L_Length;
Right.Back := L_Back;
end;
procedure Initialize (Tree : in out Tree_Type) is
begin
pragma Assert (Tree.Back /= Null_Node);
pragma Assert (Color (Tree.Back) = Red);
Set_Parent (Tree.Back, Null_Node);
Set_Left (Tree.Back, Tree.Back);
Set_Right (Tree.Back, Tree.Back);
Tree.Length := 0;
end;
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;
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;
-- procedure Generic_Adjust (Tree : in out Tree_Type) is
-- Back : constant Node_Access := Tree.Back;
-- Length : constant Natural := Tree.Length;
--
-- X : constant Node_Access := Root (Tree);
-- begin
--
-- Tree.Back := Null_Node;
-- Tree.Length := 0;
--
-- Initialize (Tree);
-- if X /= Null_Node then
-- Set_Root (Tree, Copy_Tree (X));
-- Set_First (Tree, Min (Root (Tree)));
-- Set_Last (Tree, Max (Root (Tree)));
-- Tree.Length := Length;
-- end if;
--
-- end Generic_Adjust;
-- procedure Assign
-- (Tree : in out Tree_Type;
-- Root : in Node_Access) is
-- begin
-- if Root /= Null_Node then
-- Set_Root (Tree, Copy_Tree (X));
-- Set_First (Tree, Min (Root (Tree)));
-- Set_Last (Tree, Max (Root (Tree)));
-- Tree.Length := Length;
-- end if;
function Succ (Node : Node_Access) return Node_Access is
begin
--CLR p249
if Right (Node) /= Null_Node then
if Color (Node) = Red then
--This is possibly the Back node.
declare
P : constant Node_Access := Parent (Node);
begin
if P = Null_Node then
--This is the Back of an empty tree.
return Node;
end if;
declare
PP : constant Node_Access := Parent (P);
begin
if PP = Node then
--This is the Back of a non-empty tree.
pragma Assert (Color (P) = Black);
return Left (Node); --First
end if;
end;
end;
end if;
return Min (Right (Node));
end if;
declare
X : Node_Access := Node;
Y : Node_Access := Parent (Node);
begin
while X = Right (Y) loop
X := Y;
Y := Parent (Y);
end loop;
if Right (X) /= Y then
return Y;
else
return X;
end if;
end;
end Succ;
function Succ (Node : Node_Access; Offset : Natural) return Node_Access is
Result : Node_Access := Node;
begin
for I in 1 .. Offset loop
Result := Succ (Result);
end loop;
return Result;
end;
function Pred (Node : Node_Access) return Node_Access is
begin
if Left (Node) /= Null_Node then
if Color (Node) = Red then
--This is possibly the Back node.
declare
P : constant Node_Access := Parent (Node);
begin
if P = Null_Node then
--This is the Back of an empty tree.
return Node;
end if;
declare
PP : constant Node_Access := Parent (P);
begin
if PP = Node then
--This is the Back of a non-empty tree.
pragma Assert (Color (P) = Black);
return Right (Node); --Last
end if;
end;
end;
end if;
return Max (Left (Node));
end if;
declare
X : Node_Access := Node;
Y : Node_Access := Parent (Node);
begin
while X = Left (Y) loop
X := Y;
Y := Parent (Y);
end loop;
if Left (X) /= Y then
return Y;
else
return X;
end if;
end;
end Pred;
function Pred (Node : Node_Access; Offset : Natural) return Node_Access is
Result : Node_Access := Node;
begin
for I in 1 .. Offset loop
Result := Pred (Result);
end loop;
return Result;
end;
procedure Check_Invariant (Tree : Tree_Type) is
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;
Root : constant Node_Access := Red_Black_Trees.Root (Tree);
begin
pragma Assert (Color (Tree.Back) = Red);
if Root = Null_Node then
pragma Assert (First (Tree) = Tree.Back);
pragma Assert (Last (Tree) = Tree.Back);
pragma Assert (Tree.Length = 0);
null;
else
pragma Assert (Color (Root) = Black);
pragma Assert (Tree.Length > 0);
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;
procedure Left_Rotate
(Tree : in out Tree_Type;
X : in Node_Access) is
--CLR p266
Y : 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 = Root (Tree) then
Set_Root (Tree, 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;
procedure Right_Rotate
(Tree : in out Tree_Type;
Y : in Node_Access) is
X : 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 = Root (Tree) then
Set_Root (Tree, 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;
procedure Rebalance_For_Insert
(Tree : in out Tree_Type;
Node : in Node_Access) is
--CLR p.268
X : Node_Access := Node;
pragma Assert (X /= Null_Node);
pragma Assert (Color (X) = Red);
Y : Node_Access;
begin
--Set_Color (X, Red);
while X /= Root (Tree) 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 (Root (Tree), Black);
end Rebalance_For_Insert;
function Generic_Equal (Left, Right : Tree_Type) return Boolean is
function Compare is
new Algorithms.Generic_Compare (Node_Access, Succ, Is_Equal, "=");
begin
if Left.Length /= Right.Length then
return False;
end if;
return Compare (First (Left), Left.Back, First (Right));
end Generic_Equal;
function Generic_Less (Left, Right : Tree_Type) return Boolean is
function Lexicographical_Compare is
new Algorithms.Generic_Lexicographical_Compare (Node_Access, Succ);
begin
if Left.Length > Right.Length then
return False;
end if;
return Lexicographical_Compare
(First (Left), Left.Back,
First (Right), Right.Back);
end Generic_Less;
function Offset (From, To : Node_Access)
return Natural is
Result : Integer'Base := 0;
Node : Node_Access := From;
begin
while Node /= To loop
Result := Result + 1;
Node := Succ (Node);
end loop;
return Result;
end;
procedure Delete_Fixup
(Tree : in out Tree_Type;
Node : in Node_Access) is
--CLR p274
X : Node_Access := Node;
W : Node_Access;
begin
while X /= Root (Tree) and 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 (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 := Root (Tree);
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 (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 := Root (Tree);
end if;
end if;
end loop;
Set_Color (X, Black);
end Delete_Fixup;
procedure Delete_Swap
(Tree : in out Tree_Type;
Z, Y : in 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 Root (Tree) = Z then
Set_Root (Tree, 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;
procedure Delete
(Tree : in out Tree_Type;
Node : in Node_Access) is
--CLR p273
X, Y : Node_Access;
Z : Node_Access := Node;
begin
pragma Assert (Z /= Null_Node);
pragma Assert (Z /= Tree.Back);
pragma Assert (Tree.Length > 0);
pragma Assert (Parent (Z) /= Null_Node);
if Left (Z) = Null_Node then
if Right (Z) = Null_Node then
if Z = First (Tree) then
Set_First (Tree, Parent (Z));
end if;
if Z = Last (Tree) then
Set_Last (Tree, 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 = Root (Tree) then
pragma Assert (Tree.Length = 1);
pragma Assert (Parent (Z) = Tree.Back);
Set_Root (Tree, 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 /= Last (Tree));
X := Right (Z);
if Z = First (Tree) then
Set_First (Tree, Min (X));
end if;
if Z = Root (Tree) then
Set_Root (Tree, 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 /= First (Tree));
X := Left (Z);
if Z = Last (Tree) then
Set_Last (Tree, Max (X));
end if;
if Z = Root (Tree) then
Set_Root (Tree, 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 /= First (Tree));
pragma Assert (Z /= Last (Tree));
Y := Succ (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 = Root (Tree) then
Set_Root (Tree, 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 = Root (Tree) then
Set_Root (Tree, 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;
package body Generic_Keys is
generic
with function New_Node return Node_Access;
procedure Generic_Insert_Post
(Tree : in out Tree_Type;
X, Y : in Node_Access;
Key : in Key_Type;
Z : out Node_Access);
procedure Generic_Insert_Post
(Tree : in out Tree_Type;
X, Y : in Node_Access;
Key : in Key_Type;
Z : out Node_Access) is
begin
if Y = Tree.Back
or else X /= Null_Node
or else Is_Less_Key_Node (Key, Y)
then
pragma Assert (Y = Tree.Back or else Left (Y) = Null_Node);
--Delay allocation as long as we can, in order to defend
--against exceptions propagated by relational operators.
Z := New_Node;
pragma Assert (Z /= Null_Node);
pragma Assert (Color (Z) = Red);
Set_Left (Y, Z);
if Y = Tree.Back then
Set_Root (Tree, Z);
Set_Last (Tree, Z);
elsif Y = First (Tree) then
Set_First (Tree, Z);
end if;
else
pragma Assert (Right (Y) = Null_Node);
--Delay allocation as long as we can, in order to defend
--against exceptions propagated by relational operators.
Z := New_Node;
pragma Assert (Z /= Null_Node);
pragma Assert (Color (Z) = Red);
Set_Right (Y, Z);
if Y = Last (Tree) then
Set_Last (Tree, Z);
end if;
end if;
Set_Parent (Z, Y);
Rebalance_For_Insert (Tree, Z);
Tree.Length := Tree.Length + 1;
end Generic_Insert_Post;
procedure Generic_Conditional_Insert
(Tree : in out Tree_Type;
Key : in Key_Type;
Node : out Node_Access;
Success : out Boolean) is
Y : Node_Access := Tree.Back;
X : Node_Access := Root (Tree);
procedure Insert_Post is
new Generic_Insert_Post (New_Node);
begin
Success := True;
while X /= Null_Node loop
Y := X;
Success := Is_Less_Key_Node (Key, X);
if Success then
X := Left (X);
else
X := Right (X);
end if;
end loop;
Node := Y;
if Success then
if Node = First (Tree) then
Insert_Post (Tree, X, Y, Key, Node);
return;
end if;
Node := Pred (Node);
end if;
if Is_Less_Node_Key (Node, Key) then
Insert_Post (Tree, X, Y, Key, Node);
Success := True;
return;
end if;
Success := False;
end Generic_Conditional_Insert;
procedure Generic_Conditional_Insert_With_Hint
(Tree : in out Tree_Type;
Position : in Node_Access;
Key : in Key_Type;
Node : out Node_Access;
Success : out Boolean) is
procedure Insert_Sans_Hint is
new Generic_Conditional_Insert (New_Node);
procedure Insert_Post is
new Generic_Insert_Post (New_Node);
begin
if Position = Null_Node then
Insert_Sans_Hint (Tree, Key, Node, Success);
return;
end if;
if Position = Tree.Back then
if Tree.Length > 0
and then Is_Less_Node_Key (Last (Tree), Key)
then
Insert_Post (Tree, Null_Node, Last (Tree), Key, Node);
Success := True;
else
Insert_Sans_Hint (Tree, Key, Node, Success);
end if;
return;
end if;
pragma Assert (Tree.Length > 0);
if Is_Less_Key_Node (Key, Position) then
if Position = First (Tree) then
Insert_Post (Tree, Position, Position, Key, Node);
Success := True;
return;
end if;
declare
Before : constant Node_Access := Pred (Position);
begin
if Is_Less_Node_Key (Before, Key) then
if Right (Before) = Null_Node then
Insert_Post (Tree, Null_Node, Before, Key, Node);
else
Insert_Post (Tree, Position, Position, Key, Node);
end if;
Success := True;
else
Insert_Sans_Hint (Tree, Key, Node, Success);
end if;
end;
return;
end if;
if Is_Less_Node_Key (Position, Key) then
if Position = Last (Tree) then
Insert_Post (Tree, Null_Node, Last (Tree), Key, Node);
Success := True;
return;
end if;
declare
After : constant Node_Access := Succ (Position);
begin
if Is_Less_Key_Node (Key, After) then
if Right (Position) = Null_Node then
Insert_Post (Tree, Null_Node, Position, Key, Node);
else
Insert_Post (Tree, After, After, Key, Node);
end if;
Success := True;
else
Insert_Sans_Hint (Tree, Key, Node, Success);
end if;
end;
return;
end if;
Node := Position;
Success := False;
end Generic_Conditional_Insert_With_Hint;
procedure Generic_Unconditional_Insert
(Tree : in out Tree_Type;
Key : in Key_Type;
Node : out Node_Access) is
Y : Node_Access := Tree.Back;
X : Node_Access := Root (Tree);
procedure Insert_Post is
new Generic_Insert_Post (New_Node);
begin
while X /= Null_Node loop
Y := X;
if Is_Less_Key_Node (Key, X) then
X := Left (X);
else
X := Right (X);
end if;
end loop;
Insert_Post (Tree, X, Y, Key, Node);
end Generic_Unconditional_Insert;
procedure Generic_Unconditional_Insert_With_Hint
(Tree : in out Tree_Type;
Position : in Node_Access;
Key : in Key_Type;
Node : out Node_Access) is
procedure Insert_Sans_Hint is
new Generic_Unconditional_Insert (New_Node);
procedure Insert_Post is
new Generic_Insert_Post (New_Node);
begin
if Position = Null_Node then
Insert_Sans_Hint (Tree, Key, Node);
return;
end if;
if Position = Tree.Back then
if Tree.Length = 0
or else Is_Less_Key_Node (Key, Last (Tree))
then
Insert_Sans_Hint (Tree, Key, Node);
else
Insert_Post (Tree, Null_Node, Last (Tree), Key, Node);
end if;
return;
end if;
pragma Assert (Tree.Length > 0);
if Is_Less_Node_Key (Position, Key) then
Insert_Sans_Hint (Tree, Key, Node);
return;
end if;
if Position = First (Tree) then
Insert_Post (Tree, Position, Position, Key, Node);
return;
end if;
declare
Before : constant Node_Access := Pred (Position);
begin
if Is_Less_Key_Node (Key, Before) then
Insert_Sans_Hint (Tree, Key, Node);
return;
end if;
if Right (Before) = Null_Node then
Insert_Post (Tree, Null_Node, Before, Key, Node);
else
Insert_Post (Tree, Position, Position, Key, Node);
end if;
end;
--TODO: interrogate node *after* position, too.
end Generic_Unconditional_Insert_With_Hint;
function Find
(Tree : Tree_Type;
Key : Key_Type) return Node_Access is
Y : Node_Access := Tree.Back;
X : Node_Access := Root (Tree);
begin
while X /= Null_Node loop
if Is_Less_Node_Key (X, Key) then
X := Right (X);
else
Y := X;
X := Left (X);
end if;
end loop;
if Y = Tree.Back then
return Tree.Back;
end if;
if Is_Less_Key_Node (Key, Y) then
return Tree.Back;
end if;
return Y;
end Find;
function Lower_Bound
(Tree : Tree_Type;
Key : Key_Type) return Node_Access is
Y : Node_Access := Tree.Back;
X : Node_Access := Root (Tree);
begin
while X /= Null_Node loop
if Is_Less_Node_Key (X, Key) then
X := Right (X);
else
Y := X;
X := Left (X);
end if;
end loop;
return Y;
end Lower_Bound;
function Upper_Bound
(Tree : Tree_Type;
Key : Key_Type) return Node_Access is
Y : Node_Access := Tree.Back;
X : Node_Access := Root (Tree);
begin
while X /= Null_Node loop
if Is_Less_Key_Node (Key, X) then
Y := X;
X := Left (X);
else
X := Right (X);
end if;
end loop;
return Y;
end Upper_Bound;
procedure Equal_Range
(Tree : in Tree_Type;
Key : in Key_Type;
First, Back : out Node_Access) is
begin
First := Lower_Bound (Tree, Key);
Back := Upper_Bound (Tree, Key);
end;
function Count
(Tree : Tree_Type;
Key : Key_Type) return Natural is
First, Back : Node_Access;
begin
Equal_Range (Tree, Key, First, Back);
return Offset (First, Back);
end;
end Generic_Keys;
end Charles.Red_Black_Trees;