package body Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access);
procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access);
procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access);
procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access);
procedure Check_Invariant (Tree : Tree_Type) is
Root : constant Node_Access := Tree.Root;
function Check (Node : Node_Access) return Natural;
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;
begin
if Root = Null_Node then
pragma Assert (Tree.First = Null_Node);
pragma Assert (Tree.Last = Null_Node);
pragma Assert (Tree.Length = 0);
null;
else
pragma Assert (Color (Root) = Black);
pragma Assert (Tree.Length > 0);
pragma Assert (Tree.Root /= Null_Node);
pragma Assert (Tree.First /= Null_Node);
pragma Assert (Tree.Last /= Null_Node);
pragma Assert (Parent (Tree.Root) = Null_Node);
pragma Assert ((Tree.Length > 1)
or else (Tree.First = Tree.Last
and Tree.First = Tree.Root));
pragma Assert (Left (Tree.First) = Null_Node);
pragma Assert (Right (Tree.Last) = Null_Node);
declare
L : constant Node_Access := Left (Root);
R : constant Node_Access := Right (Root);
NL : constant Natural := Check (L);
NR : constant Natural := Check (R);
begin
pragma Assert (NL = NR);
null;
end;
end if;
end Check_Invariant;
procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is
X : Node_Access := Node;
W : Node_Access;
begin
while X /= Tree.Root
and then Color (X) = Black
loop
if X = Left (Parent (X)) then
W := Right (Parent (X));
if Color (W) = Red then
Set_Color (W, Black);
Set_Color (Parent (X), Red);
Left_Rotate (Tree, Parent (X));
W := Right (Parent (X));
end if;
if (Left (W) = Null_Node or else Color (Left (W)) = Black)
and then
(Right (W) = Null_Node or else Color (Right (W)) = Black)
then
Set_Color (W, Red);
X := Parent (X);
else
if Right (W) = Null_Node
or else Color (Right (W)) = Black
then
if Left (W) /= Null_Node then
Set_Color (Left (W), Black);
end if;
Set_Color (W, Red);
Right_Rotate (Tree, W);
W := Right (Parent (X));
end if;
Set_Color (W, Color (Parent (X)));
Set_Color (Parent (X), Black);
Set_Color (Right (W), Black);
Left_Rotate (Tree, Parent (X));
X := Tree.Root;
end if;
else
pragma Assert (X = Right (Parent (X)));
W := Left (Parent (X));
if Color (W) = Red then
Set_Color (W, Black);
Set_Color (Parent (X), Red);
Right_Rotate (Tree, Parent (X));
W := Left (Parent (X));
end if;
if (Left (W) = Null_Node or else Color (Left (W)) = Black)
and then
(Right (W) = Null_Node or else Color (Right (W)) = Black)
then
Set_Color (W, Red);
X := Parent (X);
else
if Left (W) = Null_Node or else Color (Left (W)) = Black then
if Right (W) /= Null_Node then
Set_Color (Right (W), Black);
end if;
Set_Color (W, Red);
Left_Rotate (Tree, W);
W := Left (Parent (X));
end if;
Set_Color (W, Color (Parent (X)));
Set_Color (Parent (X), Black);
Set_Color (Left (W), Black);
Right_Rotate (Tree, Parent (X));
X := Tree.Root;
end if;
end if;
end loop;
Set_Color (X, Black);
end Delete_Fixup;
procedure Delete_Node_Sans_Free
(Tree : in out Tree_Type;
Node : Node_Access)
is
X, Y : Node_Access;
Z : constant Node_Access := Node;
pragma Assert (Z /= Null_Node);
begin
pragma Assert (Tree.Length > 0);
pragma Assert (Tree.Root /= Null_Node);
pragma Assert (Tree.First /= Null_Node);
pragma Assert (Tree.Last /= Null_Node);
pragma Assert (Parent (Tree.Root) = Null_Node);
pragma Assert ((Tree.Length > 1)
or else (Tree.First = Tree.Last
and then Tree.First = Tree.Root));
pragma Assert ((Left (Node) = Null_Node)
or else (Parent (Left (Node)) = Node));
pragma Assert ((Right (Node) = Null_Node)
or else (Parent (Right (Node)) = Node));
pragma Assert (((Parent (Node) = Null_Node) and then (Tree.Root = Node))
or else ((Parent (Node) /= Null_Node) and then
((Left (Parent (Node)) = Node)
or else (Right (Parent (Node)) = Node))));
if Left (Z) = Null_Node then
if Right (Z) = Null_Node then
if Z = Tree.First then
Tree.First := Parent (Z);
end if;
if Z = Tree.Last then
Tree.Last := Parent (Z);
end if;
if Color (Z) = Black then
Delete_Fixup (Tree, Z);
end if;
pragma Assert (Left (Z) = Null_Node);
pragma Assert (Right (Z) = Null_Node);
if Z = Tree.Root then
pragma Assert (Tree.Length = 1);
pragma Assert (Parent (Z) = Null_Node);
Tree.Root := Null_Node;
elsif Z = Left (Parent (Z)) then
Set_Left (Parent (Z), Null_Node);
else
pragma Assert (Z = Right (Parent (Z)));
Set_Right (Parent (Z), Null_Node);
end if;
else
pragma Assert (Z /= Tree.Last);
X := Right (Z);
if Z = Tree.First then
Tree.First := Min (X);
end if;
if Z = Tree.Root then
Tree.Root := X;
elsif Z = Left (Parent (Z)) then
Set_Left (Parent (Z), X);
else
pragma Assert (Z = Right (Parent (Z)));
Set_Right (Parent (Z), X);
end if;
Set_Parent (X, Parent (Z));
if Color (Z) = Black then
Delete_Fixup (Tree, X);
end if;
end if;
elsif Right (Z) = Null_Node then
pragma Assert (Z /= Tree.First);
X := Left (Z);
if Z = Tree.Last then
Tree.Last := Max (X);
end if;
if Z = Tree.Root then
Tree.Root := X;
elsif Z = Left (Parent (Z)) then
Set_Left (Parent (Z), X);
else
pragma Assert (Z = Right (Parent (Z)));
Set_Right (Parent (Z), X);
end if;
Set_Parent (X, Parent (Z));
if Color (Z) = Black then
Delete_Fixup (Tree, X);
end if;
else
pragma Assert (Z /= Tree.First);
pragma Assert (Z /= Tree.Last);
Y := Next (Z);
pragma Assert (Left (Y) = Null_Node);
X := Right (Y);
if X = Null_Node then
if Y = Left (Parent (Y)) then
pragma Assert (Parent (Y) /= Z);
Delete_Swap (Tree, Z, Y);
Set_Left (Parent (Z), Z);
else
pragma Assert (Y = Right (Parent (Y)));
pragma Assert (Parent (Y) = Z);
Set_Parent (Y, Parent (Z));
if Z = Tree.Root then
Tree.Root := Y;
elsif Z = Left (Parent (Z)) then
Set_Left (Parent (Z), Y);
else
pragma Assert (Z = Right (Parent (Z)));
Set_Right (Parent (Z), Y);
end if;
Set_Left (Y, Left (Z));
Set_Parent (Left (Y), Y);
Set_Right (Y, Z);
Set_Parent (Z, Y);
Set_Left (Z, Null_Node);
Set_Right (Z, Null_Node);
declare
Y_Color : constant Color_Type := Color (Y);
begin
Set_Color (Y, Color (Z));
Set_Color (Z, Y_Color);
end;
end if;
if Color (Z) = Black then
Delete_Fixup (Tree, Z);
end if;
pragma Assert (Left (Z) = Null_Node);
pragma Assert (Right (Z) = Null_Node);
if Z = Right (Parent (Z)) then
Set_Right (Parent (Z), Null_Node);
else
pragma Assert (Z = Left (Parent (Z)));
Set_Left (Parent (Z), Null_Node);
end if;
else
if Y = Left (Parent (Y)) then
pragma Assert (Parent (Y) /= Z);
Delete_Swap (Tree, Z, Y);
Set_Left (Parent (Z), X);
Set_Parent (X, Parent (Z));
else
pragma Assert (Y = Right (Parent (Y)));
pragma Assert (Parent (Y) = Z);
Set_Parent (Y, Parent (Z));
if Z = Tree.Root then
Tree.Root := Y;
elsif Z = Left (Parent (Z)) then
Set_Left (Parent (Z), Y);
else
pragma Assert (Z = Right (Parent (Z)));
Set_Right (Parent (Z), Y);
end if;
Set_Left (Y, Left (Z));
Set_Parent (Left (Y), Y);
declare
Y_Color : constant Color_Type := Color (Y);
begin
Set_Color (Y, Color (Z));
Set_Color (Z, Y_Color);
end;
end if;
if Color (Z) = Black then
Delete_Fixup (Tree, X);
end if;
end if;
end if;
Tree.Length := Tree.Length - 1;
end Delete_Node_Sans_Free;
procedure Delete_Swap
(Tree : in out Tree_Type;
Z, Y : Node_Access)
is
pragma Assert (Z /= Y);
pragma Assert (Parent (Y) /= Z);
Y_Parent : constant Node_Access := Parent (Y);
Y_Color : constant Color_Type := Color (Y);
begin
Set_Parent (Y, Parent (Z));
Set_Left (Y, Left (Z));
Set_Right (Y, Right (Z));
Set_Color (Y, Color (Z));
if Tree.Root = Z then
Tree.Root := Y;
elsif Right (Parent (Y)) = Z then
Set_Right (Parent (Y), Y);
else
pragma Assert (Left (Parent (Y)) = Z);
Set_Left (Parent (Y), Y);
end if;
if Right (Y) /= Null_Node then
Set_Parent (Right (Y), Y);
end if;
if Left (Y) /= Null_Node then
Set_Parent (Left (Y), Y);
end if;
Set_Parent (Z, Y_Parent);
Set_Color (Z, Y_Color);
Set_Left (Z, Null_Node);
Set_Right (Z, Null_Node);
end Delete_Swap;
function Generic_Equal (Left, Right : Tree_Type) return Boolean is
L_Node : Node_Access;
R_Node : Node_Access;
begin
if Left.Length /= Right.Length then
return False;
end if;
L_Node := Left.First;
R_Node := Right.First;
while L_Node /= Null_Node loop
if not Is_Equal (L_Node, R_Node) then
return False;
end if;
L_Node := Next (L_Node);
R_Node := Next (R_Node);
end loop;
return True;
end Generic_Equal;
procedure Generic_Iteration (Tree : Tree_Type) is
procedure Iterate (P : Node_Access);
procedure Iterate (P : Node_Access) is
X : Node_Access := P;
begin
while X /= Null_Node loop
Iterate (Left (X));
Process (X);
X := Right (X);
end loop;
end Iterate;
begin
Iterate (Tree.Root);
end Generic_Iteration;
procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type) is
pragma Assert (Tree.Length = 0);
Node, Last_Node : Node_Access;
begin
if N = 0 then
return;
end if;
Node := New_Node;
pragma Assert (Node /= Null_Node);
pragma Assert (Color (Node) = Red);
Set_Color (Node, Black);
Tree.Root := Node;
Tree.First := Node;
Tree.Last := Node;
Tree.Length := 1;
for J in Count_Type range 2 .. N loop
Last_Node := Node;
pragma Assert (Last_Node = Tree.Last);
Node := New_Node;
pragma Assert (Node /= Null_Node);
pragma Assert (Color (Node) = Red);
Set_Right (Node => Last_Node, Right => Node);
Tree.Last := Node;
Set_Parent (Node => Node, Parent => Last_Node);
Rebalance_For_Insert (Tree, Node);
Tree.Length := Tree.Length + 1;
end loop;
end Generic_Read;
procedure Generic_Reverse_Iteration (Tree : Tree_Type)
is
procedure Iterate (P : Node_Access);
procedure Iterate (P : Node_Access) is
X : Node_Access := P;
begin
while X /= Null_Node loop
Iterate (Right (X));
Process (X);
X := Left (X);
end loop;
end Iterate;
begin
Iterate (Tree.Root);
end Generic_Reverse_Iteration;
procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is
Y : constant Node_Access := Right (X);
pragma Assert (Y /= Null_Node);
begin
Set_Right (X, Left (Y));
if Left (Y) /= Null_Node then
Set_Parent (Left (Y), X);
end if;
Set_Parent (Y, Parent (X));
if X = Tree.Root then
Tree.Root := Y;
elsif X = Left (Parent (X)) then
Set_Left (Parent (X), Y);
else
pragma Assert (X = Right (Parent (X)));
Set_Right (Parent (X), Y);
end if;
Set_Left (Y, X);
Set_Parent (X, Y);
end Left_Rotate;
function Max (Node : Node_Access) return Node_Access is
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;
function Min (Node : Node_Access) return Node_Access is
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;
procedure Move (Target, Source : in out Tree_Type) is
begin
if Target.Length > 0 then
raise Constraint_Error;
end if;
Target := Source;
Source := (First => Null_Node,
Last => Null_Node,
Root => Null_Node,
Length => 0);
end Move;
function Next (Node : Node_Access) return Node_Access is
begin
if Node = Null_Node then
return Null_Node;
end if;
if Right (Node) /= Null_Node then
return Min (Right (Node));
end if;
declare
X : Node_Access := Node;
Y : Node_Access := Parent (Node);
begin
while Y /= Null_Node
and then X = Right (Y)
loop
X := Y;
Y := Parent (Y);
end loop;
return Y;
end;
end Next;
function Previous (Node : Node_Access) return Node_Access is
begin
if Node = Null_Node then
return Null_Node;
end if;
if Left (Node) /= Null_Node then
return Max (Left (Node));
end if;
declare
X : Node_Access := Node;
Y : Node_Access := Parent (Node);
begin
while Y /= Null_Node
and then X = Left (Y)
loop
X := Y;
Y := Parent (Y);
end loop;
return Y;
end;
end Previous;
procedure Rebalance_For_Insert
(Tree : in out Tree_Type;
Node : Node_Access)
is
X : Node_Access := Node;
pragma Assert (X /= Null_Node);
pragma Assert (Color (X) = Red);
Y : Node_Access;
begin
while X /= Tree.Root and then Color (Parent (X)) = Red loop
if Parent (X) = Left (Parent (Parent (X))) then
Y := Right (Parent (Parent (X)));
if Y /= Null_Node and then Color (Y) = Red then
Set_Color (Parent (X), Black);
Set_Color (Y, Black);
Set_Color (Parent (Parent (X)), Red);
X := Parent (Parent (X));
else
if X = Right (Parent (X)) then
X := Parent (X);
Left_Rotate (Tree, X);
end if;
Set_Color (Parent (X), Black);
Set_Color (Parent (Parent (X)), Red);
Right_Rotate (Tree, Parent (Parent (X)));
end if;
else
pragma Assert (Parent (X) = Right (Parent (Parent (X))));
Y := Left (Parent (Parent (X)));
if Y /= Null_Node and then Color (Y) = Red then
Set_Color (Parent (X), Black);
Set_Color (Y, Black);
Set_Color (Parent (Parent (X)), Red);
X := Parent (Parent (X));
else
if X = Left (Parent (X)) then
X := Parent (X);
Right_Rotate (Tree, X);
end if;
Set_Color (Parent (X), Black);
Set_Color (Parent (Parent (X)), Red);
Left_Rotate (Tree, Parent (Parent (X)));
end if;
end if;
end loop;
Set_Color (Tree.Root, Black);
end Rebalance_For_Insert;
procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is
X : constant Node_Access := Left (Y);
pragma Assert (X /= Null_Node);
begin
Set_Left (Y, Right (X));
if Right (X) /= Null_Node then
Set_Parent (Right (X), Y);
end if;
Set_Parent (X, Parent (Y));
if Y = Tree.Root then
Tree.Root := X;
elsif Y = Left (Parent (Y)) then
Set_Left (Parent (Y), X);
else
pragma Assert (Y = Right (Parent (Y)));
Set_Right (Parent (Y), X);
end if;
Set_Right (X, Y);
Set_Parent (Y, X);
end Right_Rotate;
end Ada.Containers.Red_Black_Trees.Generic_Operations;