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;