File : asgc-tree-expandable_managed.adb
-- The Ada Structured Library - A set of container classes and general
-- tools for use with Ada95.
-- Copyright (C) 1998-1999 Corey Minyard (minyard@acm.org)
--
-- This library is free software; you can redistribute it and/or modify it
-- under the terms of the GNU General Public License as published by the
-- Free Software Foundation; either version 2 of the License, or (at your
-- option) any later version.
--
-- This library 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 along
-- with this library; if not, write to the Free Software Foundation, Inc.,
-- 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.
--
with Ada.Unchecked_Deallocation;
package body Asgc.Tree.Expandable_Managed is
procedure Free_Iterator is new Ada.Unchecked_Deallocation(Iterator,
Iterator_Ptr);
procedure Free_Node_Array is
new Ada.Unchecked_Deallocation(Node_Array,
Node_Array_Ptr);
------------------------------------------------------------------------
-- Increase the size of an expandable data container.
procedure Increase_Data_Size (O : in out Object'Class) is
New_Array : Node_Array_Ptr;
begin
if (O.Increment = 0) then
raise Container_Full;
end if;
New_Array := new Node_Array(1 .. (O.Data.all'Last
+ Node_Ref(O.Increment)));
New_Array(1 .. O.Data.all'Last) := O.Data.all;
for I in O.Data.all'Last + 1 .. New_Array.all'Last loop
New_Array(I).Up := O.Free_List;
O.Free_List := I;
end loop;
Free_Node_Array(O.Data);
O.Data := New_Array;
end Increase_Data_Size;
------------------------------------------------------------------------
-- Allocate a free node for a new item in the tree.
procedure Alloc_Node (O : in out Object'Class;
Item : out Node_Ref) is
begin
if (O.Free_List = Null_Node) then
Increase_Data_Size(O);
end if;
Item := O.Free_List;
O.Free_List := O.Data(Item).Up;
O.Data(Item).Up := Null_Node;
O.Data(Item).Left := Null_Node;
O.Data(Item).Right := Null_Node;
O.Data(Item).Balance := '=';
end Alloc_Node;
------------------------------------------------------------------------
-- Free a node that is no longer in use.
procedure Free_Node (O : in out Object'Class;
Item : in out Node_Ref) is
begin
O.Data(Item).Up := O.Free_List;
O.Free_List := Item;
Item := Null_Node;
end Free_Node;
------------------------------------------------------------------------
-- Check that an object is valid, that is has not been freed. This is
-- not a perfect check, but will hopefully help find some bugs.
procedure Check_Object (O : in Object'Class) is
begin
if (O.Is_Free) then
raise Object_Free;
end if;
end Check_Object;
------------------------------------------------------------------------
-- Check that an iterator is valid. It must not have been freed, it
-- must be initialized, its object must be valid, and it must not have
-- been modified since the last time the iterator was positioned.
procedure Check_Iterator (Iter : in Iterator'Class) is
begin
if (Iter.Is_Free) then
raise Iterator_Free;
end if;
if (Iter.Robj = null) then
raise Invalid_Iterator;
end if;
Check_Object(Iter.Robj.all);
if (Iter.Update /= Iter.Robj.Update) then
raise Object_Updated;
end if;
if (Iter.Pos = Null_Node) then
raise Invalid_Iterator;
end if;
end Check_Iterator;
------------------------------------------------------------------------
-- Check an iterator, but don't bother checking its positions. This is
-- primarily for methods that set some the position of the iterator.
procedure Check_Iterator_No_Pos (Iter : in Iterator'Class) is
begin
if (Iter.Is_Free) then
raise Iterator_Free;
end if;
if (Iter.Robj = null) then
raise Invalid_Iterator;
end if;
Check_Object(Iter.Robj.all);
end Check_Iterator_No_Pos;
------------------------------------------------------------------------
-- Verify that the current node is consistent. This is designed to be
-- called recursively on each child. Curr is the node to test.
-- Max_Depth will return the maximum depth of the tree based at the
-- node. Count is used to count the total number of items in the tree,
-- every visited node adds one. If Balanced is True, then the tree is a
-- balanced tree and special checks are required.
procedure Verify_Tree_Node (O : in Object'Class;
Curr : in Node_Ref;
Max_Depth : out Integer;
Count : in out Integer;
Balanced : in Boolean) is
Left_Size : Integer := 0;
Right_Size : Integer := 0;
begin
if (Curr = Null_Node) then
-- We are past the bottom, just return.
Max_Depth := 0;
else
Count := Count + 1;
-- Verify that the up pointers of my left child point to me and
-- that my left child is less than me. Then verify the left
-- child.
if (O.Data(Curr).Left /= Null_Node) then
if (O.Data(O.Data(Curr).Left).Up /= Curr) then
raise Internal_Tree_Error;
end if;
if (O.Data(O.Data(Curr).Left).Val >= O.Data(Curr).Val) then
raise Internal_Tree_Error;
end if;
Verify_Tree_Node(O,
O.Data(Curr).Left,
Left_Size,
Count,
Balanced);
end if;
-- Verify that the up pointers of my right child point to me and
-- that my right child is greater than me. Then verify the right
-- child.
if (O.Data(Curr).Right /= Null_Node) then
if (O.Data(O.Data(Curr).Right).Up /= Curr) then
raise Internal_Tree_Error;
end if;
if (O.Data(O.Data(Curr).Right).Val <= O.Data(Curr).Val) then
raise Internal_Tree_Error;
end if;
Verify_Tree_Node(O,
O.Data(Curr).Right,
Right_Size,
Count,
Balanced);
end if;
if (Balanced) then
-- Verify that my balance values are correct with the AVL
-- algorithm. If Balance is '-', then my left tree should be
-- one smaller than my right tree. An '=' balance means my
-- subtrees are of equal depth. A '+' means that my right tree
-- should be one smaller than my left tree. All other values
-- mean the tree is not balanced and that is an error.
case (Left_Size - Right_Size) is
when -1 =>
if (O.Data(Curr).Balance /= '-') then
raise Internal_Tree_Error;
end if;
when 0 =>
if (O.Data(Curr).Balance /= '=') then
raise Internal_Tree_Error;
end if;
when +1 =>
if (O.Data(Curr).Balance /= '+') then
raise Internal_Tree_Error;
end if;
when others =>
raise Internal_Tree_Error;
end case;
end if;
-- Return the proper Max_Depth.
if (Left_Size > Right_Size) then
Max_Depth := Left_Size + 1;
else
Max_Depth := Right_Size + 1;
end if;
end if;
end Verify_Tree_Node;
------------------------------------------------------------------------
-- Move to the first item in the subtree referenced by Curr by going
-- down the left children until we hit the end.
procedure Move_To_First (O : in Object'Class;
Curr : in out Node_Ref;
Done : out Boolean) is
begin
if (Curr = Null_Node) then
Done := True;
else
while (O.Data(Curr).Left /= Null_Node) loop
Curr := O.Data(Curr).Left;
end loop;
Done := False;
end if;
end Move_To_First;
------------------------------------------------------------------------
-- Move to the last item in the subtree referenced by Curr by going
-- down the right children until we hit the end.
procedure Move_To_Last (O : in Object'Class;
Curr : in out Node_Ref;
Done : out Boolean) is
begin
if (Curr = Null_Node) then
Done := True;
else
while (O.Data(Curr).Right /= Null_Node) loop
Curr := O.Data(Curr).Right;
end loop;
Done := False;
end if;
end Move_To_Last;
------------------------------------------------------------------------
-- Move to the next item in the tree in an in-fix fashion.
procedure Move_To_Next (O : in Object'Class;
Pos : in out Node_Ref;
Done : out Boolean) is
Curr : Node_Ref := Pos;
begin
-- First we look to the right. If we have a right node, then move
-- there.
if (O.Data(Curr).Right /= Null_Node) then
Curr := O.Data(Curr).Right;
-- Now move all the way down the left tree.
Move_To_First(O, Curr, Done);
Pos := Curr;
else
-- No right node, so we move up until we move up a link that we
-- came to from the left side of an Node.
loop
if (O.Data(Curr).Up = Null_Node) then
Done := True;
exit;
end if;
if (Curr = O.Data(O.Data(Curr).Up).Left) then
Done := False;
Pos := O.Data(Curr).Up;
exit;
elsif (Curr = O.Data(O.Data(Curr).Up).Right) then
Curr := O.Data(Curr).Up;
else
raise Internal_Tree_Error;
end if;
end loop;
end if;
end Move_To_Next;
------------------------------------------------------------------------
-- Move to the next item in the tree in an in-fix fashion.
procedure Move_To_Prev (O : in Object'Class;
Pos : in out Node_Ref;
Done : out Boolean) is
Curr : Node_Ref := Pos;
begin
-- First we look to the left. If we have a left node, then move
-- there.
if (O.Data(Curr).Left /= Null_Node) then
Curr := O.Data(Curr).Left;
-- Now move all the way down the right tree.
Move_To_Last(O, Curr, Done);
Pos := Curr;
else
-- No left node, so we move up until we move up a link that we
-- came to from the right side of an Node.
loop
if (O.Data(Curr).Up = Null_Node) then
Done := True;
exit;
end if;
if (Curr = O.Data(O.Data(Curr).Up).Right) then
Done := False;
Pos := O.Data(Curr).Up;
exit;
elsif (Curr = O.Data(O.Data(Curr).Up).Left) then
Curr := O.Data(Curr).Up;
else
raise Internal_Tree_Error;
end if;
end loop;
end if;
end Move_To_Prev;
------------------------------------------------------------------------
-- Replace Curr in the tree with Val with respect to Curr's parent.
-- For instance, if Curr is the left child of its parent, then set
-- Val to be the new left child of its parent.
procedure Replace_Up_Down_Link (O : in out Object'Class;
Curr : in Node_Ref;
Val : in Node_Ref) is
Tree_Curr : Node_Ref := Curr;
begin
if (O.Data(Curr).Up = Null_Node) then
O.Root := Val;
elsif (O.Data(O.Data(Curr).Up).Right = Tree_Curr) then
O.Data(O.Data(Curr).Up).Right := Val;
elsif (O.Data(O.Data(Curr).Up).Left = Tree_Curr) then
O.Data(O.Data(Curr).Up).Left := Val;
else
raise Internal_Tree_Error;
end if;
O.Data(Val).Up := O.Data(Curr).Up;
end Replace_Up_Down_Link;
------------------------------------------------------------------------
-- A left-left reorder from the AVL algorithm. Read you data
-- structures book for information on AVL trees.
procedure Reorder_Left_Left (O : in out Object'Class;
Curr : in Node_Ref;
Left : in Node_Ref) is
begin
Replace_Up_Down_Link(O, Curr, Left);
O.Data(Curr).Up := Left;
O.Data(Curr).Left := O.Data(Left).Right;
O.Data(Left).Right := Curr;
if (O.Data(Curr).Left /= Null_Node) then
O.Data(O.Data(Curr).Left).Up := O.Data(Left).Right;
end if;
end Reorder_Left_Left;
------------------------------------------------------------------------
-- A right-right reorder from the AVL algorithm. Read you data
-- structures book for information on AVL trees.
procedure Reorder_Right_Right (O : in out Object'Class;
Curr : in Node_Ref;
Right : in Node_Ref) is
begin
Replace_Up_Down_Link(O, Curr, Right);
O.Data(Curr).Up := Right;
O.Data(Curr).Right := O.Data(Right).Left;
O.Data(Right).Left := Curr;
if (O.Data(Curr).Right /= Null_Node) then
O.Data(O.Data(Curr).Right).Up := O.Data(Right).Left;
end if;
end Reorder_Right_Right;
------------------------------------------------------------------------
-- A right-left reorder from the AVL algorithm. Read you data
-- structures book for information on AVL trees.
procedure Reorder_Right_Left (O : in out Object'Class;
Curr : in Node_Ref;
Right : in Node_Ref;
Head : in Node_Ref) is
begin
Replace_Up_Down_Link(O, Curr, Head);
O.Data(Curr).Up := Head;
O.Data(Right).Up := O.Data(Curr).Up;
O.Data(Right).Left := O.Data(Head).Right;
if (O.Data(Right).Left /= Null_Node) then
O.Data(O.Data(Right).Left).Up := Right;
end if;
O.Data(Head).Right := O.Data(Curr).Right;
O.Data(Curr).Right := O.Data(Head).Left;
O.Data(Head).Left := Curr;
if (O.Data(Curr).Right /= Null_Node) then
O.Data(O.Data(Curr).Right).Up := O.Data(Head).Left;
end if;
end Reorder_Right_Left;
------------------------------------------------------------------------
-- A left-right reorder from the AVL algorithm. Read you data
-- structures book for information on AVL trees.
procedure Reorder_Left_Right (O : in out Object'Class;
Curr : in Node_Ref;
Left : in Node_Ref;
Head : in Node_Ref) is
begin
Replace_Up_Down_Link(O, Curr, Head);
O.Data(Curr).Up := Head;
O.Data(Left).Up := O.Data(Curr).Up;
O.Data(Left).Right := O.Data(Head).Left;
if (O.Data(Left).Right /= Null_Node) then
O.Data(O.Data(Left).Right).Up := Left;
end if;
O.Data(Head).Left := O.Data(Curr).Left;
O.Data(Curr).Left := O.Data(Head).Right;
O.Data(Head).Right := Curr;
if (O.Data(Curr).Left /= Null_Node) then
O.Data(O.Data(Curr).Left).Up := O.Data(Head).Right;
end if;
end Reorder_Left_Right;
------------------------------------------------------------------------
-- Rebalance a balanced tree after a delete. When an item is deleted
-- from the tree, the tree does a reorganization to account for the
-- deleted item. D_Up is generally the parent of the deleted item;
-- Last is Left if the deleted item was the left child of D_Up or right
-- if it was the right child. Read your data structures book on AVL
-- trees for details on this algorithm.
procedure Balance_On_Delete (O : in out Object'Class;
D_Up : in Node_Ref;
Last : in Last_Direction) is
Dir : Last_Direction := Last;
Curr : Node_Ref := D_Up;
Head : Node_Ref;
Right_Node : Node_Ref;
Left_Node : Node_Ref;
Up : Node_Ref;
begin
while (Dir /= None) loop
if (Dir = Left) then
case (O.Data(Curr).Balance) is
when '-' =>
Right_Node := O.Data(Curr).Right;
case (O.Data(Right_Node).Balance) is
when '-' =>
Reorder_Right_Right(O, Curr, Right_Node);
O.Data(Right_Node).Balance := '=';
O.Data(Curr).Balance := '=';
Curr := Right_Node;
Up := O.Data(Curr).Up;
when '=' =>
Reorder_Right_Right(O, Curr, Right_Node);
O.Data(Right_Node).Balance := '+';
O.Data(Curr).Balance := '-';
Curr := Right_Node;
Up := Null_Node;
when '+' =>
Head := O.Data(Right_Node).Left;
Reorder_Right_Left(O, Curr, Right_Node, Head);
case (O.Data(Head).Balance) is
when '+' =>
O.Data(Curr).Balance := '=';
O.Data(Right_Node).Balance := '-';
when '=' =>
O.Data(Curr).Balance := '=';
O.Data(Right_Node).Balance := '=';
when '-' =>
O.Data(Curr).Balance := '+';
O.Data(Right_Node).Balance := '=';
end case;
O.Data(Head).Balance := '=';
Curr := Head;
Up := O.Data(Curr).Up;
end case;
when '=' =>
O.Data(Curr).Balance := '-';
Up := Null_Node;
when '+' =>
O.Data(Curr).Balance := '=';
Up := O.Data(Curr).Up;
end case;
else
case (O.Data(Curr).Balance) is
when '-' =>
O.Data(Curr).Balance := '=';
Up := O.Data(Curr).Up;
when '=' =>
O.Data(Curr).Balance := '+';
Up := Null_Node;
when '+' =>
Left_Node := O.Data(Curr).Left;
case (O.Data(Left_Node).Balance) is
when '+' =>
Reorder_Left_Left(O, Curr, Left_Node);
O.Data(Left_Node).Balance := '=';
O.Data(Curr).Balance := '=';
Curr := Left_Node;
Up := O.Data(Curr).Up;
when '=' =>
Reorder_Left_Left(O, Curr, Left_Node);
O.Data(Left_Node).Balance := '-';
O.Data(Curr).Balance := '+';
Curr := Left_Node;
Up := Null_Node;
when '-' =>
Head := O.Data(Left_Node).Right;
Reorder_Left_Right(O, Curr, Left_Node, Head);
case (O.Data(Head).Balance) is
when '-' =>
O.Data(Curr).Balance := '=';
O.Data(Left_Node).Balance := '+';
when '=' =>
O.Data(Curr).Balance := '=';
O.Data(Left_Node).Balance := '=';
when '+' =>
O.Data(Curr).Balance := '-';
O.Data(Left_Node).Balance := '=';
end case;
O.Data(Head).Balance := '=';
Curr := Head;
Up := O.Data(Curr).Up;
end case;
end case;
end if;
if (Up = Null_Node) then
Dir := None;
elsif (O.Data(Up).Right = Curr) then
Dir := Right;
Curr := Up;
elsif (O.Data(Up).Left = Curr) then
Dir := Left;
Curr := Up;
else
raise Internal_Tree_Error;
end if;
end loop;
end Balance_On_Delete;
------------------------------------------------------------------------
-- Rebalance a balanced tree after an insertion. Insertions alway
-- happen at leafs, so they are a little easier to handle than
-- deletions. Read your data structures book on AVL trees for details
-- on this algorithm.
procedure Balance_On_Add (O : in out Object'Class;
New_Node : in Node_Ref) is
Curr : Node_Ref := O.Data(New_Node).Up;
Head : Node_Ref;
Right_Node : Node_Ref;
Left_Node : Node_Ref;
Up : Node_Ref;
Last_Dir : Last_Direction;
Old_Last_Dir : Last_Direction := None;
begin
if (O.Data(Curr).Left = New_Node) then
Last_Dir := Left;
elsif (O.Data(Curr).Right = New_Node) then
Last_Dir := Right;
else
raise Internal_Tree_Error;
end if;
while (Curr /= Null_Node) loop
if (Last_Dir = Left) then
case (O.Data(Curr).Balance) is
when '-' =>
O.Data(Curr).Balance := '=';
Up := Null_Node;
when '=' =>
O.Data(Curr).Balance := '+';
Up := O.Data(Curr).Up;
when '+' =>
Left_Node := O.Data(Curr).Left;
if (Old_Last_Dir = Left) then
Reorder_Left_Left(O, Curr, Left_Node);
O.Data(Curr).Balance := '=';
O.Data(Left_Node).Balance := '=';
elsif (Old_Last_Dir = Right) then
Head := O.Data(Left_Node).Right;
Reorder_Left_Right(O, Curr, Left_Node, Head);
if (O.Data(Head).Balance = '-') then
O.Data(Curr).Balance := '=';
O.Data(Left_Node).Balance := '+';
O.Data(Head).Balance := '=';
elsif (O.Data(Head).Balance = '=') then
O.Data(Curr).Balance := '=';
O.Data(Left_Node).Balance := '=';
O.Data(Head).Balance := '=';
elsif (O.Data(Head).Balance = '+') then
O.Data(Curr).Balance := '-';
O.Data(Left_Node).Balance := '=';
O.Data(Head).Balance := '=';
end if;
else
raise Internal_Tree_Error;
end if;
Up := Null_Node;
end case;
else
case (O.Data(Curr).Balance) is
when '+' =>
O.Data(Curr).Balance := '=';
Up := Null_Node;
when '=' =>
O.Data(Curr).Balance := '-';
Up := O.Data(Curr).Up;
when '-' =>
Right_Node := O.Data(Curr).Right;
if (Old_Last_Dir = Right) then
Reorder_Right_Right(O, Curr, Right_Node);
O.Data(Curr).Balance := '=';
O.Data(Right_Node).Balance := '=';
elsif (Old_Last_Dir = Left) then
Head := O.Data(Right_Node).Left;
Reorder_Right_Left(O, Curr, Right_Node, Head);
if (O.Data(Head).Balance = '+') then
O.Data(Curr).Balance := '=';
O.Data(Right_Node).Balance := '-';
O.Data(Head).Balance := '=';
elsif (O.Data(Head).Balance = '=') then
O.Data(Curr).Balance := '=';
O.Data(Right_Node).Balance := '=';
O.Data(Head).Balance := '=';
elsif (O.Data(Head).Balance = '-') then
O.Data(Curr).Balance := '+';
O.Data(Right_Node).Balance := '=';
O.Data(Head).Balance := '=';
end if;
else
raise Internal_Tree_Error;
end if;
Up := Null_Node;
end case;
end if;
Old_Last_Dir := Last_Dir;
if (Up = Null_Node) then
Last_Dir := None;
Curr := Null_Node;
elsif (O.Data(Up).Right = Curr) then
Last_Dir := Right;
Curr := Up;
elsif (O.Data(Up).Left = Curr) then
Last_Dir := Left;
Curr := Up;
else
raise Internal_Tree_Error;
end if;
end loop;
end Balance_On_Add;
------------------------------------------------------------------------
-- Delete the item Curr from the tree. If Last = Left, then curr is
-- the left child of its parent. If Last = Right, the it is the right
-- child of its parent. If Last = None, then Curr is the root of the
-- tree.
procedure Delete_Item (O : in out Object'Class;
Curr : in out Node_Ref;
Last : in Last_Direction) is
Swap : Node_Ref;
Delete_Dir : Last_Direction;
Deleted_Up : Node_Ref;
begin
O.Update := O.Update + 1;
if ((O.Data(Curr).Left = Null_Node)
and (O.Data(Curr).Right = Null_Node))
then
-- Delete a leaf node, which is pretty easy.
case Last is
when None =>
O.Root := Null_Node;
Delete_Dir := None;
when Left =>
O.Data(O.Data(Curr).Up).Left := Null_Node;
Delete_Dir := Left;
when Right =>
O.Data(O.Data(Curr).Up).Right := Null_Node;
Delete_Dir := Right;
end case;
Deleted_Up := O.Data(Curr).Up;
elsif (O.Data(Curr).Left = Null_Node) then
-- Easy case, only a right tree. Just pull the right tree up.
case Last is
when None =>
O.Root := O.Data(Curr).Right;
Delete_Dir := None;
when Left =>
O.Data(O.Data(Curr).Up).Left := O.Data(Curr).Right;
Delete_Dir := Left;
when Right =>
O.Data(O.Data(Curr).Up).Right := O.Data(Curr).Right;
Delete_Dir := Right;
end case;
O.Data(O.Data(Curr).Right).Up := O.Data(Curr).Up;
Deleted_Up := O.Data(Curr).Up;
elsif (O.Data(Curr).Right = Null_Node) then
-- Easy case, only a left tree. Just pull the left tree up.
case Last is
when None =>
O.Root := O.Data(Curr).Left;
Delete_Dir := None;
when Left =>
O.Data(O.Data(Curr).Up).Left := O.Data(Curr).Left;
Delete_Dir := Left;
when Right =>
O.Data(O.Data(Curr).Up).Right := O.Data(Curr).Left;
Delete_Dir := Right;
end case;
O.Data(O.Data(Curr).Left).Up := O.Data(Curr).Up;
Deleted_Up := O.Data(Curr).Up;
else
-- Hard case, both a left and right tree. We search down
-- the leftmost branch of the right subtree of the current
-- node. The current node can be replace with this node.
Swap := O.Data(Curr).Right;
if (O.Data(Swap).Left = Null_Node) then
-- We have a situation like this:
--
-- A
-- B C
-- D E G
--
-- Remove "C" (the swap value) from the tree here to end
-- up with
--
-- A
-- B G
-- D E
--
-- Later A will be removed and C put in its place.
O.Data(Curr).Right := O.Data(Swap).Right;
if (O.Data(Swap).Right /= Null_Node) then
O.Data(O.Data(Swap).Right).Up := Curr;
end if;
Delete_Dir := Right;
Deleted_Up := Swap;
else
-- We have a situation like:
--
-- A
-- B C
-- D E F G
--
-- We find the leftmost child of "C", which will be the value
-- in the tree that will be immediately after "A". Then we
-- remove it from the tree in anticipation of replacing A with
-- it. In the above case, we would remove "F".
Swap := O.Data(Swap).Left;
while (O.Data(Swap).Left /= Null_Node) loop
Swap := O.Data(Swap).Left;
end loop;
O.Data(O.Data(Swap).Up).Left := O.Data(Swap).Right;
if (O.Data(Swap).Right /= Null_Node) then
-- the Swap value had a right child, just make it the left
-- child of swap's parent.
O.Data(O.Data(Swap).Right).Up := O.Data(Swap).Up;
end if;
Delete_Dir := Left;
Deleted_Up := O.Data(Swap).Up;
end if;
-- Now swap points to the node we will replace the deleted one
-- with, so remove the node to delete and replace it with Swap.
O.Data(Swap).Right := O.Data(Curr).Right;
O.Data(Swap).Left := O.Data(Curr).Left;
O.Data(Swap).Up := O.Data(Curr).Up;
O.Data(Swap).Balance := O.Data(Curr).Balance;
O.Data(O.Data(Curr).Left).Up := Swap;
if (O.Data(Curr).Right /= Null_Node) then
O.Data(O.Data(Curr).Right).Up := Swap;
end if;
-- Now fix Swap's new parent to reference it.
case Last is
when None =>
O.Root := Swap;
when Right =>
O.Data(O.Data(Curr).Up).Right := Swap;
when Left =>
O.Data(O.Data(Curr).Up).Left := Swap;
end case;
end if;
O.Count := O.Count - 1;
if (O.Balanced) then
Balance_On_Delete(O, Deleted_Up, Delete_Dir);
end if;
if (O.Cb /= null) then
Deleted(O.Cb, Asgc.Object(O), O.Data(Curr).Val);
end if;
Free_Node(O, Curr);
end Delete_Item;
------------------------------------------------------------------------
-- Search the tree for the given value and return the node that has it.
-- This routine will return Null_Node if the value is not in the
-- container.
function Local_Search (O : in Object'Class;
Val : in Contained_Type)
return Node_Ref is
Curr : Node_Ref;
begin
Curr := O.Root;
while ((Curr /= Null_Node)
and then (O.Data(Curr).Val /= Val)) loop
if (Val > O.Data(Curr).Val) then
Curr := O.Data(Curr).Right;
else
Curr := O.Data(Curr).Left;
end if;
end loop;
return Curr;
end Local_Search;
------------------------------------------------------------------------
-- Add an item to the container and return a reference to the newly
-- added node in Added_Node.
procedure Local_Add (O : in out Object'Class;
Val : in Contained_Type;
Added_Node : out Node_Ref) is
Curr : Node_Ref := O.Root;
New_Node : Node_Ref;
begin
if (Curr = Null_Node) then
-- Adding to an empty tree is pretty simple.
Alloc_Node(O, O.Root);
O.Data(O.Root).Val := Val;
O.Count := O.Count + 1;
if (O.Cb /= null) then
Added(O.Cb, Asgc.Object(O), O.Data(O.Root).Val);
end if;
Added_Node := O.Root;
else
-- Search for the leaf position to place the node at, then add it
-- at that location.
loop
if (Val > O.Data(Curr).Val) then
-- Go down the right subtree.
if (O.Data(Curr).Right = Null_Node) then
-- No right subtree, just add it as the right child here.
Alloc_Node(O, New_Node);
O.Data(Curr).Right := New_Node;
O.Data(O.Data(Curr).Right).Up := Curr;
O.Data(O.Data(Curr).Right).Val := Val;
O.Count := O.Count + 1;
Curr := O.Data(Curr).Right;
if (O.Balanced) then
Balance_On_Add(O, Curr);
end if;
if (O.Cb /= null) then
Added(O.Cb, Asgc.Object(O), O.Data(Curr).Val);
end if;
exit;
else
-- The right subtree exists, go down it.
Curr := O.Data(Curr).Right;
end if;
elsif (Val < O.Data(Curr).Val) then
-- Go down the left subtree.
if (O.Data(Curr).Left = Null_Node) then
-- No left subtree, just add it as the left child here.
Alloc_Node(O, New_Node);
O.Data(Curr).Left := New_Node;
O.Data(O.Data(Curr).Left).Up := Curr;
O.Data(O.Data(Curr).Left).Val := Val;
O.Count := O.Count + 1;
Curr := O.Data(Curr).Left;
if (O.Balanced) then
Balance_On_Add(O, Curr);
end if;
if (O.Cb /= null) then
Added(O.Cb, Asgc.Object(O), O.Data(Curr).Val);
end if;
exit;
else
-- The left subtree exists, go down it.
Curr := O.Data(Curr).Left;
end if;
else
-- The item is already in the tree.
raise Item_Already_Exists;
end if;
end loop;
Added_Node := New_Node;
end if;
O.Update := O.Update + 1;
end Local_Add;
------------------------------------------------------------------------
-- This is a controlled type, so we have those methods to handle.
------------------------------------------------------------------------
procedure Initialize (O : in out Object) is
begin
for I in 1 .. O.Initial_Size loop
O.Data(I).Up := O.Free_List;
O.Free_List := I;
end loop;
end Initialize;
------------------------------------------------------------------------
procedure Adjust (O : in out Object) is
New_Tree : Node_Ref := Null_Node;
New_Curr : Node_Ref;
Old_Curr : Node_Ref := O.Root;
Done : Boolean;
begin
O.Data := new Node_Array'(O.Data.all);
New_Curr := O.Root;
if (O.Cb /= null) then
Move_To_First(O, New_Curr, Done);
while (not Done) loop
Copied(O.Cb, O, O.Data(New_Curr).Val);
Move_To_Next(O, New_Curr, Done);
end loop;
end if;
end Adjust;
------------------------------------------------------------------------
procedure Finalize (O : in out Object) is
Curr : Node_Ref := O.Root;
Temp : Node_Ref;
begin
-- Do a postfix, left first traversal of the tree, deleting nodes as
-- we are at them.
while (Curr /= Null_Node) loop
if (O.Data(Curr).Left /= Null_Node) then
Temp := Curr;
Curr := O.Data(Curr).Left;
O.Data(Temp).Left := Null_Node;
elsif (O.Data(Curr).Right /= Null_Node) then
Temp := Curr;
Curr := O.Data(Curr).Right;
O.Data(Temp).Right := Null_Node;
else
Temp := O.Data(Curr).Up;
if (O.Cb /= null) then
Deleted(O.Cb, O, O.Data(Curr).Val);
end if;
Curr := Temp;
end if;
end loop;
Free_Node_Array(O.Data);
O.Is_Free := True;
end Finalize;
------------------------------------------------------------------------
procedure Finalize (Iter : in out Iterator) is
begin
Iter.Is_Free := True;
end Finalize;
------------------------------------------------------------------------
-- The functions that follow are defined as abstract in previous
-- packages. See those packages for descriptions of what these
-- methods do.
------------------------------------------------------------------------
procedure Verify_Integrity (O : in Object) is
Count : Integer := 0;
Depth : Integer;
begin
Check_Object(O);
Verify_Tree_Node(O, O.Root, Depth, Count, O.Balanced);
if (Count /= O.Count) then
raise Internal_Tree_Error;
end if;
end Verify_Integrity;
------------------------------------------------------------------------
function Copy (O : in Object) return Asgc.Object_Class is
Retval : Object_Ptr;
begin
Retval := new Object(Balanced => O.Balanced,
initial_Size => O.Initial_Size,
Increment => O.Increment);
Retval.all := O;
return Asgc.Object_Class(Retval);
end Copy;
------------------------------------------------------------------------
procedure Add (O : in out Object;
Val : in Contained_Type) is
New_Node : Node_Ref;
begin
Check_Object(O);
Local_Add(O, Val, New_Node);
end Add;
------------------------------------------------------------------------
procedure Delete (O : in out Object;
Val : in Contained_Type) is
Last : Last_Direction := None;
Curr : Node_Ref := O.Root;
begin
Check_Object(O);
-- Find the item to delete. We can't use Local_Search because we
-- need to know if we are the parent's left or right child.
while (Curr /= Null_Node) loop
if (Val > O.Data(Curr).Val) then
Curr := O.Data(Curr).Right;
Last := Right;
elsif (Val < O.Data(Curr).Val) then
Curr := O.Data(Curr).Left;
Last := Left;
else
-- We found it, now delete it.
Delete_Item(O, Curr, Last);
-- Leaving the routine!
return;
end if;
end loop;
raise Item_Not_Found;
end Delete;
------------------------------------------------------------------------
function Value_Exists (O : in Object;
Val : in Contained_Type)
return Boolean is
begin
Check_Object(O);
return (Local_Search(O, Val) /= Null_Node);
end Value_Exists;
------------------------------------------------------------------------
function Member_Count (O : in Object)
return Natural is
begin
Check_Object(O);
return O.Count;
end Member_Count;
------------------------------------------------------------------------
function "=" (O1, O2 : in Object) return Boolean is
Curr1 : Node_Ref := O1.Root;
Curr2 : Node_Ref := O2.Root;
Done1, Done2 : Boolean := False;
Retval : Boolean := True;
begin
Check_Object(O1);
Check_Object(O2);
if (O1.Count /= O2.Count) then
Retval := False;
else
-- Compare equality by doing an in-fix traversal of both trees and
-- verifying that they have exactly the same values at each
-- position. Note that the trees do not have to have exactly the
-- same structure, just the same in-fix traversal. So the
-- following two trees would compare as equal.
--
-- 3 2
-- 2 1 3
-- 1
-- Move to the first node and start traversing.
Move_To_First(O1, Curr1, Done1);
Move_To_First(O2, Curr2, Done2);
if (Done1 /= Done2) then
-- The trees have the same number of nodes, so they should hit
-- Done at the same time.
raise Internal_Tree_Error;
end if;
while (not Done1) loop
if (O1.Data(Curr1).Val /= O2.Data(Curr2).Val) then
Retval := False;
exit;
end if;
Move_To_Next(O1, Curr1, Done1);
Move_To_Next(O2, Curr2, Done2);
if (Done1 /= Done2) then
-- The trees have the same number of nodes, so they should
-- hit Done at the same time.
raise Internal_Tree_Error;
end if;
end loop;
end if;
return Retval;
end "=";
------------------------------------------------------------------------
procedure Add (Iter : in out Iterator;
Val : in Contained_Type) is
begin
Check_Iterator_No_Pos(Iter);
Local_Add(Iter.Robj.all, Val, Iter.Pos);
Iter.Update := Iter.Robj.Update;
end Add;
------------------------------------------------------------------------
procedure Search (Iter : in out Iterator;
Val : in Contained_Type;
Found : out Boolean) is
Curr : Node_Ref;
begin
Check_Iterator(Iter);
Curr := Local_Search(Iter.Robj.all, Val);
if (Curr = Null_Node) then
Found := False;
else
Iter.Pos := Curr;
Found := True;
end if;
end Search;
------------------------------------------------------------------------
procedure Root (Iter : in out Iterator;
Is_End : out End_Marker) is
begin
Check_Iterator_No_Pos(Iter);
Iter.Pos := Iter.Robj.Root;
if (Iter.Pos = Null_Node) then
Is_End := Past_End;
else
Iter.Update := Iter.Robj.Update;
Is_End := Not_Past_End;
end if;
end Root;
------------------------------------------------------------------------
procedure Left (Iter : in out Iterator;
Is_End : out End_Marker) is
begin
Check_Iterator(Iter);
if (Iter.Robj.Data(Iter.Pos).Left /= Null_Node) then
Is_End := Not_Past_End;
Iter.Pos := Iter.Robj.Data(Iter.Pos).Left;
else
Is_End := Past_End;
end if;
end Left;
------------------------------------------------------------------------
procedure Right (Iter : in out Iterator;
Is_End : out End_Marker) is
begin
Check_Iterator(Iter);
if (Iter.Robj.Data(Iter.Pos).Right /= Null_Node) then
Is_End := Not_Past_End;
Iter.Pos := Iter.Robj.Data(Iter.Pos).Right;
else
Is_End := Past_End;
end if;
end Right;
------------------------------------------------------------------------
procedure Up (Iter : in out Iterator;
Is_End : out End_Marker) is
begin
Check_Iterator(Iter);
if (Iter.Robj.Data(Iter.Pos).Up /= Null_Node) then
Is_End := Not_Past_End;
Iter.Pos := Iter.Robj.Data(Iter.Pos).Up;
else
Is_End := Past_End;
end if;
end Up;
------------------------------------------------------------------------
function New_Iterator (O : access Object) return Asgc.Iterator_Class is
Retval : Iterator_Ptr;
begin
Check_Object(O.all);
Retval := new Iterator;
Retval.Robj := Object_Class(O);
return Asgc.Iterator_Class(Retval);
end New_Iterator;
------------------------------------------------------------------------
function New_Iterator (O : in Object_class) return Iterator is
Retval : Iterator;
begin
Retval.Robj := O;
return Retval;
end New_Iterator;
------------------------------------------------------------------------
procedure Free (Iter : access Iterator) is
To_Free : Iterator_Ptr := Iterator_Ptr(Iter);
begin
if (Iter.Is_Free) then
raise Iterator_Free;
end if;
Free_Iterator(To_Free);
end Free;
------------------------------------------------------------------------
procedure Set_Container (Iter : in out Iterator;
O : in Asgc.Object_Class) is
begin
Check_Object(Object'Class(O.all));
Iter.Robj := Object_Class(O);
Iter.Update := Invalid_Update;
end Set_Container;
------------------------------------------------------------------------
procedure First (Iter : in out Iterator; Is_End : out End_Marker) is
Done : Boolean;
begin
Check_Iterator_No_Pos(Iter);
Iter.Pos := Iter.Robj.Root;
Move_To_First(Iter.Robj.all, Iter.Pos, Done);
Iter.Update := Iter.Robj.Update;
if (Done) then
Is_End := Past_End;
else
Is_End := Not_Past_End;
end if;
end First;
------------------------------------------------------------------------
procedure Last (Iter : in out Iterator; Is_End : out End_Marker) is
Done : Boolean;
begin
Check_Iterator_No_Pos(Iter);
Iter.Pos := Iter.Robj.Root;
Move_To_Last(Iter.Robj.all, Iter.Pos, Done);
Iter.Update := Iter.Robj.Update;
if (Done) then
Is_End := Past_End;
else
Is_End := Not_Past_End;
end if;
end Last;
------------------------------------------------------------------------
procedure Next (Iter : in out Iterator; Is_End : out End_Marker) is
Done : Boolean;
begin
Check_Iterator(Iter);
Move_To_Next(Iter.Robj.all, Iter.Pos, Done);
if (Done) then
Is_End := Past_End;
else
Is_End := Not_Past_End;
end if;
end Next;
------------------------------------------------------------------------
procedure Prev (Iter : in out Iterator; Is_End : out End_Marker) is
Done : Boolean;
begin
Check_Iterator(Iter);
Move_To_Prev(Iter.Robj.all, Iter.Pos, Done);
if (Done) then
Is_End := Past_End;
else
Is_End := Not_Past_End;
end if;
end Prev;
------------------------------------------------------------------------
procedure Delete (Iter : in out Iterator; Is_End : out End_Marker) is
New_Pos : Node_Ref;
Done : Boolean;
O : Object_Ptr;
begin
Check_Iterator(Iter);
O := Object_Ptr(Iter.Robj);
New_Pos := Iter.Pos;
Move_To_Next(Iter.Robj.all, New_Pos, Done);
-- Find out if we are the root, from the left of the node above, or
-- to the right of the node above.
if (O.Data(Iter.Pos).Up = Null_Node) then
Delete_Item(O.all, Iter.Pos, None);
elsif (O.all.Data(O.all.Data(Iter.Pos).Up).Left = Iter.Pos) then
Delete_Item(O.all, Iter.Pos, Left);
elsif (O.all.Data(O.all.Data(Iter.Pos).Up).Right = Iter.Pos) then
Delete_Item(O.all, Iter.Pos, Right);
else
raise Internal_Tree_Error;
end if;
if (Done) then
Is_End := Past_End;
Iter.Pos := Null_Node;
else
Iter.Update := O.Update;
Is_End := Not_Past_End;
Iter.Pos := New_Pos;
end if;
end Delete;
------------------------------------------------------------------------
function Is_Same (Iter1, Iter2 : in Iterator) return Boolean is
begin
Check_Iterator(Iter1);
Check_Iterator(Iter2);
if (Iter1.Robj /= Iter2.Robj) then
raise Iterator_Mismatch;
end if;
return (Iter1.Pos = Iter2.Pos);
end Is_Same;
------------------------------------------------------------------------
function Get (Iter : in Iterator) return Contained_Type is
begin
Check_Iterator(Iter);
return Iter.Robj.Data(Iter.Pos).Val;
end Get;
------------------------------------------------------------------------
procedure Get_Incr (Iter : in out Iterator;
Val : out Contained_Type;
Is_End : out End_Marker) is
Done : Boolean;
begin
Check_Iterator(Iter);
Val := Iter.Robj.Data(Iter.Pos).Val;
Move_To_Next(Iter.Robj.all, Iter.Pos, Done);
if (Done) then
Is_End := Past_End;
else
Is_End := Not_Past_End;
end if;
end Get_Incr;
------------------------------------------------------------------------
procedure Get_Decr (Iter : in out Iterator;
Val : out Contained_Type;
Is_End : out End_Marker) is
Done : Boolean;
begin
Check_Iterator(Iter);
Val := Iter.Robj.Data(Iter.Pos).Val;
Move_To_Prev(Iter.Robj.all, Iter.Pos, Done);
if (Done) then
Is_End := Past_End;
else
Is_End := Not_Past_End;
end if;
end Get_Decr;
------------------------------------------------------------------------
function "=" (Iter1, Iter2 : in Iterator) return Boolean is
begin
Check_Iterator(Iter1);
Check_Iterator(Iter2);
return (Iter1.Robj.Data(Iter1.Pos).Val = Iter2.Robj.Data(Iter2.Pos).Val);
end "=";
------------------------------------------------------------------------
function "=" (Iter : in Iterator; Val : in Contained_Type) return Boolean is
begin
Check_Iterator(Iter);
return (Iter.Robj.Data(Iter.Pos).Val = Val);
end "=";
------------------------------------------------------------------------
function "=" (Val : in Contained_Type; Iter : in Iterator) return Boolean is
begin
Check_Iterator(Iter);
return (Val = Iter.Robj.Data(Iter.Pos).Val);
end "=";
------------------------------------------------------------------------
function ">" (Iter1, Iter2 : in Iterator) return Boolean is
begin
Check_Iterator(Iter1);
Check_Iterator(Iter2);
return (Iter1.Robj.Data(Iter1.Pos).Val > Iter2.Robj.Data(Iter2.Pos).Val);
end ">";
------------------------------------------------------------------------
function ">" (Iter : in Iterator; Val : in Contained_Type) return Boolean is
begin
Check_Iterator(Iter);
return (Iter.Robj.Data(Iter.Pos).Val > Val);
end ">";
------------------------------------------------------------------------
function ">" (Val : in Contained_Type; Iter : in Iterator) return Boolean is
begin
Check_Iterator(Iter);
return (Val > Iter.Robj.Data(Iter.Pos).Val);
end ">";
------------------------------------------------------------------------
function "<" (Iter1, Iter2 : in Iterator) return Boolean is
begin
Check_Iterator(Iter1);
Check_Iterator(Iter2);
return (Iter1.Robj.Data(Iter1.Pos).Val < Iter2.Robj.Data(Iter2.Pos).Val);
end "<";
------------------------------------------------------------------------
function "<" (Iter : in Iterator; Val : in Contained_Type) return Boolean is
begin
Check_Iterator(Iter);
return (Iter.Robj.Data(Iter.Pos).Val < Val);
end "<";
------------------------------------------------------------------------
function "<" (Val : in Contained_Type; Iter : in Iterator) return Boolean is
begin
Check_Iterator(Iter);
return (Val < Iter.Robj.Data(Iter.Pos).Val);
end "<";
------------------------------------------------------------------------
function ">=" (Iter1, Iter2 : in Iterator) return Boolean is
begin
Check_Iterator(Iter1);
Check_Iterator(Iter2);
return (Iter1.Robj.Data(Iter1.Pos).Val
>= Iter2.Robj.Data(Iter2.Pos).Val);
end ">=";
------------------------------------------------------------------------
function ">=" (Iter : in Iterator; Val : in Contained_Type)
return Boolean is
begin
Check_Iterator(Iter);
return (Iter.Robj.Data(Iter.Pos).Val >= Val);
end ">=";
------------------------------------------------------------------------
function ">=" (Val : in Contained_Type; Iter : in Iterator)
return Boolean is
begin
Check_Iterator(Iter);
return (Val >= Iter.Robj.Data(Iter.Pos).Val);
end ">=";
------------------------------------------------------------------------
function "<=" (Iter1, Iter2 : in Iterator) return Boolean is
begin
Check_Iterator(Iter1);
Check_Iterator(Iter2);
return (Iter1.Robj.Data(Iter1.Pos).Val
<= Iter2.Robj.Data(Iter2.Pos).Val);
end "<=";
------------------------------------------------------------------------
function "<=" (Iter : in Iterator; Val : in Contained_Type)
return Boolean is
begin
Check_Iterator(Iter);
return (Iter.Robj.Data(Iter.Pos).Val <= Val);
end "<=";
------------------------------------------------------------------------
function "<=" (Val : in Contained_Type; Iter : in Iterator)
return Boolean is
begin
Check_Iterator(Iter);
return (Val <= Iter.Robj.Data(Iter.Pos).Val);
end "<=";
end Asgc.Tree.Expandable_Managed;