File : asgc-tree-dynamic.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.Dynamic is
procedure Free_Node is new Ada.Unchecked_Deallocation(Node,
Node_Ptr);
procedure Free_Iterator is new Ada.Unchecked_Deallocation(Iterator,
Iterator_Ptr);
------------------------------------------------------------------------
-- Allocate a free node for a new item in the tree.
procedure Alloc_Node (O : in out Object'Class;
Item : out Node_Ptr) is
begin
Item := new Node;
end Alloc_Node;
------------------------------------------------------------------------
-- Free a node that is no longer in use.
procedure Free_Node (O : in out Object'Class;
Item : in out Node_Ptr) is
begin
Free_Node(Item);
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) 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_Ptr;
Max_Depth : out Integer;
Count : in out Integer;
Balanced : in Boolean) is
Left_Size : Integer := 0;
Right_Size : Integer := 0;
begin
if (Curr = null) 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 (Curr.Left /= null) then
if (Curr.Left.Up /= Curr) then
raise Internal_Tree_Error;
end if;
if (Curr.Left.Val >= Curr.Val) then
raise Internal_Tree_Error;
end if;
Verify_Tree_Node(O,
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 (Curr.Right /= null) then
if (Curr.Right.Up /= Curr) then
raise Internal_Tree_Error;
end if;
if (Curr.Right.Val <= Curr.Val) then
raise Internal_Tree_Error;
end if;
Verify_Tree_Node(O,
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 (Curr.Balance /= '-') then
raise Internal_Tree_Error;
end if;
when 0 =>
if (Curr.Balance /= '=') then
raise Internal_Tree_Error;
end if;
when +1 =>
if (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_Ptr;
Done : out Boolean) is
begin
if (Curr = null) then
Done := True;
else
while (Curr.Left /= null) loop
Curr := 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_Ptr;
Done : out Boolean) is
begin
if (Curr = null) then
Done := True;
else
while (Curr.Right /= null) loop
Curr := 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_Ptr;
Done : out Boolean) is
Curr : Node_Ptr := Pos;
begin
-- First we look to the right. If we have a right node, then move
-- there.
if (Curr.Right /= null) then
Curr := 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 (Curr.Up = null) then
Done := True;
exit;
end if;
if (Curr = Curr.Up.Left) then
Done := False;
Pos := Curr.Up;
exit;
elsif (Curr = Curr.Up.Right) then
Curr := 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_Ptr;
Done : out Boolean) is
Curr : Node_Ptr := Pos;
begin
-- First we look to the left. If we have a left node, then move
-- there.
if (Curr.Left /= null) then
Curr := 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 (Curr.Up = null) then
Done := True;
exit;
end if;
if (Curr = Curr.Up.Right) then
Done := False;
Pos := Curr.Up;
exit;
elsif (Curr = Curr.Up.Left) then
Curr := 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_Ptr;
Val : in Node_Ptr) is
Tree_Curr : Node_Ptr := Curr;
begin
if (Curr.Up = null) then
O.Root := Val;
elsif (Curr.Up.Right = Tree_Curr) then
Curr.Up.Right := Val;
elsif (Curr.Up.Left = Tree_Curr) then
Curr.Up.Left := Val;
else
raise Internal_Tree_Error;
end if;
Val.Up := 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_Ptr;
Left : in Node_Ptr) is
begin
Replace_Up_Down_Link(O, Curr, Left);
Curr.Up := Left;
Curr.Left := Left.Right;
Left.Right := Curr;
if (Curr.Left /= null) then
Curr.Left.Up := 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_Ptr;
Right : in Node_Ptr) is
begin
Replace_Up_Down_Link(O, Curr, Right);
Curr.Up := Right;
Curr.Right := Right.Left;
Right.Left := Curr;
if (Curr.Right /= null) then
Curr.Right.Up := 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_Ptr;
Right : in Node_Ptr;
Head : in Node_Ptr) is
begin
Replace_Up_Down_Link(O, Curr, Head);
Curr.Up := Head;
Right.Up := Curr.Up;
Right.Left := Head.Right;
if (Right.Left /= null) then
Right.Left.Up := Right;
end if;
Head.Right := Curr.Right;
Curr.Right := Head.Left;
Head.Left := Curr;
if (Curr.Right /= null) then
Curr.Right.Up := 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_Ptr;
Left : in Node_Ptr;
Head : in Node_Ptr) is
begin
Replace_Up_Down_Link(O, Curr, Head);
Curr.Up := Head;
Left.Up := Curr.Up;
Left.Right := Head.Left;
if (Left.Right /= null) then
Left.Right.Up := Left;
end if;
Head.Left := Curr.Left;
Curr.Left := Head.Right;
Head.Right := Curr;
if (Curr.Left /= null) then
Curr.Left.Up := 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_Ptr;
Last : in Last_Direction) is
Dir : Last_Direction := Last;
Curr : Node_Ptr := D_Up;
Head : Node_Ptr;
Right_Node : Node_Ptr;
Left_Node : Node_Ptr;
Up : Node_Ptr;
begin
while (Dir /= None) loop
if (Dir = Left) then
case (Curr.Balance) is
when '-' =>
Right_Node := Curr.Right;
case (Right_Node.Balance) is
when '-' =>
Reorder_Right_Right(O, Curr, Right_Node);
Right_Node.Balance := '=';
Curr.Balance := '=';
Curr := Right_Node;
Up := Curr.Up;
when '=' =>
Reorder_Right_Right(O, Curr, Right_Node);
Right_Node.Balance := '+';
Curr.Balance := '-';
Curr := Right_Node;
Up := null;
when '+' =>
Head := Right_Node.Left;
Reorder_Right_Left(O, Curr, Right_Node, Head);
case (Head.Balance) is
when '+' =>
Curr.Balance := '=';
Right_Node.Balance := '-';
when '=' =>
Curr.Balance := '=';
Right_Node.Balance := '=';
when '-' =>
Curr.Balance := '+';
Right_Node.Balance := '=';
end case;
Head.Balance := '=';
Curr := Head;
Up := Curr.Up;
end case;
when '=' =>
Curr.Balance := '-';
Up := null;
when '+' =>
Curr.Balance := '=';
Up := Curr.Up;
end case;
else
case (Curr.Balance) is
when '-' =>
Curr.Balance := '=';
Up := Curr.Up;
when '=' =>
Curr.Balance := '+';
Up := null;
when '+' =>
Left_Node := Curr.Left;
case (Left_Node.Balance) is
when '+' =>
Reorder_Left_Left(O, Curr, Left_Node);
Left_Node.Balance := '=';
Curr.Balance := '=';
Curr := Left_Node;
Up := Curr.Up;
when '=' =>
Reorder_Left_Left(O, Curr, Left_Node);
Left_Node.Balance := '-';
Curr.Balance := '+';
Curr := Left_Node;
Up := null;
when '-' =>
Head := Left_Node.Right;
Reorder_Left_Right(O, Curr, Left_Node, Head);
case (Head.Balance) is
when '-' =>
Curr.Balance := '=';
Left_Node.Balance := '+';
when '=' =>
Curr.Balance := '=';
Left_Node.Balance := '=';
when '+' =>
Curr.Balance := '-';
Left_Node.Balance := '=';
end case;
Head.Balance := '=';
Curr := Head;
Up := Curr.Up;
end case;
end case;
end if;
if (Up = null) then
Dir := None;
elsif (Up.Right = Curr) then
Dir := Right;
Curr := Up;
elsif (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_Ptr) is
Curr : Node_Ptr := New_Node.Up;
Head : Node_Ptr;
Right_Node : Node_Ptr;
Left_Node : Node_Ptr;
Up : Node_Ptr;
Last_Dir : Last_Direction;
Old_Last_Dir : Last_Direction := None;
begin
if (Curr.Left = New_Node) then
Last_Dir := Left;
elsif (Curr.Right = New_Node) then
Last_Dir := Right;
else
raise Internal_Tree_Error;
end if;
while (Curr /= null) loop
if (Last_Dir = Left) then
case (Curr.Balance) is
when '-' =>
Curr.Balance := '=';
Up := null;
when '=' =>
Curr.Balance := '+';
Up := Curr.Up;
when '+' =>
Left_Node := Curr.Left;
if (Old_Last_Dir = Left) then
Reorder_Left_Left(O, Curr, Left_Node);
Curr.Balance := '=';
Left_Node.Balance := '=';
elsif (Old_Last_Dir = Right) then
Head := Left_Node.Right;
Reorder_Left_Right(O, Curr, Left_Node, Head);
if (Head.Balance = '-') then
Curr.Balance := '=';
Left_Node.Balance := '+';
Head.Balance := '=';
elsif (Head.Balance = '=') then
Curr.Balance := '=';
Left_Node.Balance := '=';
Head.Balance := '=';
elsif (Head.Balance = '+') then
Curr.Balance := '-';
Left_Node.Balance := '=';
Head.Balance := '=';
end if;
else
raise Internal_Tree_Error;
end if;
Up := null;
end case;
else
case (Curr.Balance) is
when '+' =>
Curr.Balance := '=';
Up := null;
when '=' =>
Curr.Balance := '-';
Up := Curr.Up;
when '-' =>
Right_Node := Curr.Right;
if (Old_Last_Dir = Right) then
Reorder_Right_Right(O, Curr, Right_Node);
Curr.Balance := '=';
Right_Node.Balance := '=';
elsif (Old_Last_Dir = Left) then
Head := Right_Node.Left;
Reorder_Right_Left(O, Curr, Right_Node, Head);
if (Head.Balance = '+') then
Curr.Balance := '=';
Right_Node.Balance := '-';
Head.Balance := '=';
elsif (Head.Balance = '=') then
Curr.Balance := '=';
Right_Node.Balance := '=';
Head.Balance := '=';
elsif (Head.Balance = '-') then
Curr.Balance := '+';
Right_Node.Balance := '=';
Head.Balance := '=';
end if;
else
raise Internal_Tree_Error;
end if;
Up := null;
end case;
end if;
Old_Last_Dir := Last_Dir;
if (Up = null) then
Last_Dir := None;
Curr := null;
elsif (Up.Right = Curr) then
Last_Dir := Right;
Curr := Up;
elsif (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_Ptr;
Last : in Last_Direction) is
Swap : Node_Ptr;
Delete_Dir : Last_Direction;
Deleted_Up : Node_Ptr;
begin
O.Update := O.Update + 1;
if ((Curr.Left = null)
and (Curr.Right = null))
then
-- Delete a leaf node, which is pretty easy.
case Last is
when None =>
O.Root := null;
Delete_Dir := None;
when Left =>
Curr.Up.Left := null;
Delete_Dir := Left;
when Right =>
Curr.Up.Right := null;
Delete_Dir := Right;
end case;
Deleted_Up := Curr.Up;
elsif (Curr.Left = null) then
-- Easy case, only a right tree. Just pull the right tree up.
case Last is
when None =>
O.Root := Curr.Right;
Delete_Dir := None;
when Left =>
Curr.Up.Left := Curr.Right;
Delete_Dir := Left;
when Right =>
Curr.Up.Right := Curr.Right;
Delete_Dir := Right;
end case;
Curr.Right.Up := Curr.Up;
Deleted_Up := Curr.Up;
elsif (Curr.Right = null) then
-- Easy case, only a left tree. Just pull the left tree up.
case Last is
when None =>
O.Root := Curr.Left;
Delete_Dir := None;
when Left =>
Curr.Up.Left := Curr.Left;
Delete_Dir := Left;
when Right =>
Curr.Up.Right := Curr.Left;
Delete_Dir := Right;
end case;
Curr.Left.Up := Curr.Up;
Deleted_Up := 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 := Curr.Right;
if (Swap.Left = null) 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.
Curr.Right := Swap.Right;
if (Swap.Right /= null) then
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 := Swap.Left;
while (Swap.Left /= null) loop
Swap := Swap.Left;
end loop;
Swap.Up.Left := Swap.Right;
if (Swap.Right /= null) then
-- the Swap value had a right child, just make it the left
-- child of swap's parent.
Swap.Right.Up := Swap.Up;
end if;
Delete_Dir := Left;
Deleted_Up := 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.
Swap.Right := Curr.Right;
Swap.Left := Curr.Left;
Swap.Up := Curr.Up;
Swap.Balance := Curr.Balance;
Curr.Left.Up := Swap;
if (Curr.Right /= null) then
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 =>
Curr.Up.Right := Swap;
when Left =>
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), 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 if the value is not in the
-- container.
function Local_Search (O : in Object'Class;
Val : in Contained_Type)
return Node_Ptr is
Curr : Node_Ptr;
begin
Curr := O.Root;
while ((Curr /= null)
and then (Curr.Val /= Val)) loop
if (Val > Curr.Val) then
Curr := Curr.Right;
else
Curr := 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_Ptr) is
Curr : Node_Ptr := O.Root;
New_Node : Node_Ptr;
begin
if (Curr = null) then
-- Adding to an empty tree is pretty simple.
Alloc_Node(O, O.Root);
O.Root.Val := Val;
O.Count := O.Count + 1;
if (O.Cb /= null) then
Added(O.Cb, Asgc.Object(O), 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 > Curr.Val) then
-- Go down the right subtree.
if (Curr.Right = null) then
-- No right subtree, just add it as the right child here.
Alloc_Node(O, New_Node);
Curr.Right := New_Node;
Curr.Right.Up := Curr;
Curr.Right.Val := Val;
O.Count := O.Count + 1;
Curr := Curr.Right;
if (O.Balanced) then
Balance_On_Add(O, Curr);
end if;
if (O.Cb /= null) then
Added(O.Cb, Asgc.Object(O), Curr.Val);
end if;
exit;
else
-- The right subtree exists, go down it.
Curr := Curr.Right;
end if;
elsif (Val < Curr.Val) then
-- Go down the left subtree.
if (Curr.Left = null) then
-- No left subtree, just add it as the left child here.
Alloc_Node(O, New_Node);
Curr.Left := New_Node;
Curr.Left.Up := Curr;
Curr.Left.Val := Val;
O.Count := O.Count + 1;
Curr := Curr.Left;
if (O.Balanced) then
Balance_On_Add(O, Curr);
end if;
if (O.Cb /= null) then
Added(O.Cb, Asgc.Object(O), Curr.Val);
end if;
exit;
else
-- The left subtree exists, go down it.
Curr := 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
null;
end Initialize;
------------------------------------------------------------------------
procedure Adjust (O : in out Object) is
New_Tree : Node_Ptr := null;
New_Curr : Node_Ptr;
Old_Curr : Node_Ptr := O.Root;
Done : Boolean;
begin
if (O.Root /= null) then
New_Tree := new Node;
New_Tree.Val := Old_Curr.Val;
New_Tree.Balance := Old_Curr.Balance;
-- Do a prefix, left first traversal of the tree and copy the
-- nodes as we visit them.
New_Curr := New_Tree;
Main_Copy_Loop: loop
if (Old_Curr.Left /= null) then
-- Traverse down the left branch.
New_Curr.Left := new Node;
New_Curr.Left.Up := New_Curr;
New_Curr.Left.Val := Old_Curr.Left.Val;
New_Curr.Left.Balance := Old_Curr.Left.Balance;
New_Curr := New_Curr.Left;
Old_Curr := Old_Curr.Left;
elsif (Old_Curr.Right /= null) then
-- Traverse down the right branch.
New_Curr.Right := new Node;
New_Curr.Right.Up := New_Curr;
New_Curr.Right.Val := Old_Curr.Right.Val;
New_Curr.Right.Balance := Old_Curr.Right.Balance;
New_Curr := New_Curr.Right;
Old_Curr := Old_Curr.Right;
else
-- At the end of the branch, go up until we traverse from a
-- left branch and the right branch is not null.
loop
if ((Old_Curr.Up.Left = Old_Curr)
and (Old_Curr.Up.Right /= null))
then
-- We found the next item, so move to it and create
-- it.
Old_Curr := Old_Curr.Up;
New_Curr := New_Curr.Up;
New_Curr.Right := new Node;
New_Curr.Right.Up := New_Curr;
New_Curr.Right.Val := Old_Curr.Right.Val;
New_Curr.Right.Balance := Old_Curr.Right.Balance;
New_Curr := New_Curr.Right;
Old_Curr := Old_Curr.Right;
exit;
else
New_Curr := New_Curr.Up;
Old_Curr := Old_Curr.Up;
if (Old_Curr.Up = null) then
if (New_Curr.Up /= null) then
raise Internal_Tree_Error;
end if;
exit Main_Copy_Loop;
end if;
end if;
end loop;
end if;
end loop Main_Copy_Loop;
end if;
O.Root := New_Tree;
New_Curr := O.Root;
if (O.Cb /= null) then
Move_To_First(O, New_Curr, Done);
while (not Done) loop
Copied(O.Cb, O, 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_Ptr := O.Root;
Temp : Node_Ptr;
begin
-- Do a postfix, left first traversal of the tree, deleting nodes as
-- we are at them.
while (Curr /= null) loop
if (Curr.Left /= null) then
Temp := Curr;
Curr := Curr.Left;
Temp.Left := null;
elsif (Curr.Right /= null) then
Temp := Curr;
Curr := Curr.Right;
Temp.Right := null;
else
Temp := Curr.Up;
if (O.Cb /= null) then
Deleted(O.Cb, O, Curr.Val);
end if;
Free_Node(Curr);
Curr := Temp;
end if;
end loop;
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);
Retval.all := O;
return Asgc.Object_Class(Retval);
end Copy;
------------------------------------------------------------------------
procedure Add (O : in out Object;
Val : in Contained_Type) is
New_Node : Node_Ptr;
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_Ptr := 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) loop
if (Val > Curr.Val) then
Curr := Curr.Right;
Last := Right;
elsif (Val < Curr.Val) then
Curr := 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);
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_Ptr := O1.Root;
Curr2 : Node_Ptr := 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 (Curr1.Val /= 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_Ptr;
begin
Check_Iterator(Iter);
Curr := Local_Search(Iter.Robj.all, Val);
if (Curr = null) 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) 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.Pos.Left /= null) then
Is_End := Not_Past_End;
Iter.Pos := 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.Pos.Right /= null) then
Is_End := Not_Past_End;
Iter.Pos := 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.Pos.Up /= null) then
Is_End := Not_Past_End;
Iter.Pos := 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_Ptr;
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 (Iter.Pos.Up = null) then
Delete_Item(O.all, Iter.Pos, None);
elsif (Iter.Pos.Up.Left = Iter.Pos) then
Delete_Item(O.all, Iter.Pos, Left);
elsif (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;
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.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.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.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.Pos.Val = Iter2.Pos.Val);
end "=";
------------------------------------------------------------------------
function "=" (Iter : in Iterator; Val : in Contained_Type) return Boolean is
begin
Check_Iterator(Iter);
return (Iter.Pos.Val = Val);
end "=";
------------------------------------------------------------------------
function "=" (Val : in Contained_Type; Iter : in Iterator) return Boolean is
begin
Check_Iterator(Iter);
return (Val = Iter.Pos.Val);
end "=";
------------------------------------------------------------------------
function ">" (Iter1, Iter2 : in Iterator) return Boolean is
begin
Check_Iterator(Iter1);
Check_Iterator(Iter2);
return (Iter1.Pos.Val > Iter2.Pos.Val);
end ">";
------------------------------------------------------------------------
function ">" (Iter : in Iterator; Val : in Contained_Type) return Boolean is
begin
Check_Iterator(Iter);
return (Iter.Pos.Val > Val);
end ">";
------------------------------------------------------------------------
function ">" (Val : in Contained_Type; Iter : in Iterator) return Boolean is
begin
Check_Iterator(Iter);
return (Val > Iter.Pos.Val);
end ">";
------------------------------------------------------------------------
function "<" (Iter1, Iter2 : in Iterator) return Boolean is
begin
Check_Iterator(Iter1);
Check_Iterator(Iter2);
return (Iter1.Pos.Val < Iter2.Pos.Val);
end "<";
------------------------------------------------------------------------
function "<" (Iter : in Iterator; Val : in Contained_Type) return Boolean is
begin
Check_Iterator(Iter);
return (Iter.Pos.Val < Val);
end "<";
------------------------------------------------------------------------
function "<" (Val : in Contained_Type; Iter : in Iterator) return Boolean is
begin
Check_Iterator(Iter);
return (Val < Iter.Pos.Val);
end "<";
------------------------------------------------------------------------
function ">=" (Iter1, Iter2 : in Iterator) return Boolean is
begin
Check_Iterator(Iter1);
Check_Iterator(Iter2);
return (Iter1.Pos.Val
>= Iter2.Pos.Val);
end ">=";
------------------------------------------------------------------------
function ">=" (Iter : in Iterator; Val : in Contained_Type)
return Boolean is
begin
Check_Iterator(Iter);
return (Iter.Pos.Val >= Val);
end ">=";
------------------------------------------------------------------------
function ">=" (Val : in Contained_Type; Iter : in Iterator)
return Boolean is
begin
Check_Iterator(Iter);
return (Val >= Iter.Pos.Val);
end ">=";
------------------------------------------------------------------------
function "<=" (Iter1, Iter2 : in Iterator) return Boolean is
begin
Check_Iterator(Iter1);
Check_Iterator(Iter2);
return (Iter1.Pos.Val
<= Iter2.Pos.Val);
end "<=";
------------------------------------------------------------------------
function "<=" (Iter : in Iterator; Val : in Contained_Type)
return Boolean is
begin
Check_Iterator(Iter);
return (Iter.Pos.Val <= Val);
end "<=";
------------------------------------------------------------------------
function "<=" (Val : in Contained_Type; Iter : in Iterator)
return Boolean is
begin
Check_Iterator(Iter);
return (Val <= Iter.Pos.Val);
end "<=";
end Asgc.Tree.Dynamic;