File : charles-multisets-sorted-unbounded.adb


pragma License (Modified_GPL);

------------------------------------------------------------------------------

--                                                                          --

--                      CHARLES CONTAINER LIBRARY                           --

--                                                                          --

--              Copyright (C) 2001-2003 Matthew J Heaney                    --

--                                                                          --

-- The Charles Container Library ("Charles") is free software; you can      --

-- redistribute it and/or modify it under terms of the GNU General Public   --

-- License as published by the Free Software Foundation; either version 2,  --

-- or (at your option) any later version.  Charles is distributed in the    --

-- hope that it will be useful, but WITHOUT ANY WARRANTY; without even the  --

-- implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. --

-- See the GNU General Public License for more details.  You should have    --

-- received a copy of the GNU General Public License distributed with       --

-- Charles;  see file COPYING.TXT.  If not, write to the Free Software      --

-- Foundation,  59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.    --

--                                                                          --

-- As a special exception, if other files instantiate generics from this    --

-- unit, or you link this unit with other files to produce an executable,   --

-- this unit does not by itself cause the resulting executable to be        --

-- covered by the GNU General Public License.  This exception does not      --

-- however invalidate any other reasons why the executable file might be    --

-- covered by the GNU Public License.                                       --

--                                                                          --

-- Charles is maintained by Matthew J Heaney.                               --

--                                                                          --

-- http://home.earthlink.net/~matthewjheaney/index.html                     --

-- mailto:matthewjheaney@earthlink.net                                      --

--                                                                          --

------------------------------------------------------------------------------


with Ada.Unchecked_Deallocation;
with System;  use type System.Address;

package body Charles.Multisets.Sorted.Unbounded is

   type Node_Type is
      record   --make this a limited record for Ada0Y

         Parent  : Node_Access;
         Left    : Node_Access;
         Right   : Node_Access;
         Color   : Color_Type;
         Element : aliased Element_Type;
      end record;
      
   function "=" (L, R : Node_Type) return Boolean is abstract;
   pragma Warnings (Off, "=");
      

   function Parent (Node : Node_Access)
      return Node_Access is
   begin
      return Node.Parent;
   end;
      
   function Left (Node : Node_Access)
      return Node_Access is
   begin
      return Node.Left;
   end;

   function Right (Node : Node_Access)
      return Node_Access is
   begin
      return Node.Right;
   end;
      
   function Color (Node : Node_Access)
      return Color_Type is
   begin
      return Node.Color;
   end;
      
   procedure Set_Parent
     (Node   : Node_Access;
      Parent : Node_Access) is
   begin
      Node.Parent := Parent;
   end;

   procedure Set_Left
     (Node : Node_Access;
      Left : Node_Access) is
   begin
      Node.Left := Left;
   end;

   procedure Set_Right
     (Node  : Node_Access;
      Right : Node_Access) is
   begin
      Node.Right := Right;
   end;

   procedure Set_Color
     (Node  : Node_Access;
      Color : Color_Type) is
   begin
      Node.Color := Color;
   end;
   
   
   procedure Free is 
      new Ada.Unchecked_Deallocation (Node_Type, Node_Access);


   use Trees;


   procedure Delete_Tree (X : in out Node_Access) is
      Y : Node_Access;
   begin
      while X /= null loop
         Y := X.Right;
         Delete_Tree (Y);
         Y := X.Left;
         Free (X);
         X := Y;
      end loop;
   end;
 
   
   procedure Clear (Container : in out Container_Type) is
      X : Node_Access := Root (Container.Tree);
   begin
      Initialize (Container.Tree);
      Delete_Tree (X);
   end;



   procedure Initialize (Container : in out Container_Type) is
   
      Tree : Tree_Type renames Container.Tree;
   begin
      Tree.Back := new Node_Type;
      Tree.Back.Color := Red;
      
      Initialize (Tree);
   end;
   

   function Copy_Node (Source : Node_Access) return Node_Access is
      pragma Inline (Copy_Node);

      Target : Node_Access := 
         new Node_Type'(Parent => null,
                        Left   => null,
                        Right  => null,
                        Color  => Source.Color,
                        Element => Source.Element);
   begin
      return Target;
   end;
   
   function Copy_Tree (Source_Root : Node_Access) return Node_Access is
      Target_Root : Node_Access := Copy_Node (Source_Root);
      P, X : Node_Access;
   begin
      if Source_Root.Right /= null then
         Target_Root.Right := Copy_Tree (Source_Root.Right);
      end if;
      
      P := Target_Root;      
      X := Source_Root.Left;
      
      while X /= null loop
         declare
            Y : Node_Access := Copy_Node (X);
         begin
            P.Left := Y;
            Y.Parent := P;
            
            if X.Right /= null then
               Y.Right := Copy_Tree (X.Right);
            end if;
            
            P := Y;
            X := X.Left;
         end;
      end loop;            

      return Target_Root;
   exception
      when others =>
         Delete_Tree (Target_Root);
         raise;
   end;

      
   procedure Adjust (Container : in out Container_Type) is

      Tree : Tree_Type renames Container.Tree;

      Length : constant Natural := Tree.Length;
      
      X : constant Node_Access := Root (Tree);
      Y : Node_Access;

   begin
   
      begin
         Tree.Back := new Node_Type;
      exception
         when others =>
            Tree.Back := null;
            Tree.Length := 0;
            raise;
      end;

      Tree.Back.Color := Red;
      
      Initialize (Tree);

      if X /= null then
         Y := Copy_Tree (X);
         
         Set_Root (Tree, Y);
         Set_First (Tree, Min (Y));
         Set_Last (Tree, Max (Y)); 
         
         Tree.Length := Length;
      end if;       
      
   end Adjust;

   
   procedure Assign
     (Target : in out Container_Type;
      Source : in     Container_Type) is

   begin
   
      if Target'Address = Source'Address then
         return;
      end if;
      
      if Is_Empty (Source) then
         Clear (Target);
         return;
      end if;
      
      declare
         Source_Root : constant Node_Access := Root (Source.Tree);
         Target_Root : Node_Access := Copy_Tree (Source_Root);
      begin
         begin
            Clear (Target);
         exception
            when others => 
               Delete_Tree (Target_Root);
               raise;
         end;

         Set_Root (Target.Tree, Target_Root);
         Set_First (Target.Tree, Min (Target_Root));
         Set_Last (Target.Tree, Max (Target_Root)); 
         
         Target.Tree.Length := Source.Tree.Length;
      end;
         
   end Assign;

     
   procedure Finalize (Container : in out Container_Type) is
   
      Tree : Tree_Type renames Container.Tree;
      
      Back : Node_Access := Tree.Back;
      Root : Node_Access;
   begin
      if Back /= null then
         Root := Trees.Root (Tree);
         
         Tree.Back := null;
         Tree.Length := 0;
      
         Delete_Tree (Root);           
         Free (Back);
      end if;
   end;
   

   function Is_Equal is
      new Trees.Generic_Equal ("=");

   function "=" (Left, Right : Container_Type) return Boolean is
   begin
      if Left'Address = Right'Address then
         return True;
      end if;
      
      return Is_Equal (Left.Tree, Right.Tree);
   end;
   
   
   function Succ (Iterator : Iterator_Type) return Iterator_Type is
   begin
      return (Node => Succ (Iterator.Node));
   end;


   function Succ 
     (Iterator : Iterator_Type;
      Offset   : Natural) return Iterator_Type is
   begin
      return (Node => Succ (Iterator.Node, Offset));
   end;


   function Offset
     (From, To : Iterator_Type) return Natural is
   begin
      return Offset (From.Node, To.Node);
   end;
   

   function Is_Less (L, R : Node_Access) return Boolean is
      pragma Inline (Is_Less);
   begin
      return L.Element < R.Element;
   end;
      

   function Is_Less (Left, Right : Iterator_Type) return Boolean is
   begin
      return Is_Less (Left.Node, Right.Node);
   end;
   

   function Is_Less 
     (Left  : Node_Access;
      Right : Element_Type) return Boolean is
      
      pragma Inline (Is_Less);
   begin
      return Left.Element < Right;
   end;
   
   
   function Is_Less 
     (Left  : Iterator_Type;
      Right : Element_Type) return Boolean is
   begin
      return Is_Less (Left.Node, Right);
   end;

   function Is_Less
     (Left  : Element_Type;
      Right : Node_Access) return Boolean is
      
      pragma Inline (Is_Less);
   begin
      return Left < Right.Element;
   end;
      
   function Is_Less 
     (Left  : Element_Type;
      Right : Iterator_Type) return Boolean is
   begin
      return Is_Less (Left, Right.Node);
   end;
   
      
   function Is_Equal (Left, Right : Iterator_Type) return Boolean is
   begin
      return Left.Node.Element = Right.Node.Element;
   end;
   
   
   function Is_Equal
     (Left  : Iterator_Type;
      Right : Element_Type) return Boolean is
   begin
      return Left.Node.Element = Right;
   end;

   
   function Is_Equal
     (Left  : Element_Type;
      Right : Iterator_Type) return Boolean is
   begin
      return Left = Right.Node.Element;
   end;


   
   function "<" is new Trees.Generic_Less (Is_Less);

   function "<" (Left, Right : Container_Type) return Boolean is
   begin
      if Left'Address = Right'Address then
         return False;
      end if;
      
      return Left.Tree < Right.Tree;
   end;
   
   
   function "<=" (Left, Right : Container_Type) return Boolean is
   begin
      return not (Left > Right);
   end;
   

   function ">" (Left, Right : Container_Type) return Boolean is
   begin
      return Right < Left;
   end;
   

   function ">=" (Left, Right : Container_Type) return Boolean is
   begin
      return not (Left < Right);
   end;


   function Length (Container : Container_Type) return Natural is
   begin
      return Container.Tree.Length;
   end;
   
   function Is_Empty (Container : Container_Type) return Boolean is
   begin
      return Container.Tree.Length = 0;
   end;
   

   package Keys is new Trees.Generic_Keys (Element_Type, Is_Less, Is_Less);
   use Keys;
   
      
   procedure Insert
     (Container : in out Container_Type;
      New_Item  : in     Element_Type;  
      Iterator  :    out Iterator_Type) is      
      
      function New_Node return Node_Access is      
         pragma Inline (New_Node);

         Node : constant Node_Access := 
           new Node_Type'(Parent => null,
                          Left   => null,
                          Right  => null,
                          Color  => Red,
                          Element => New_Item);
      begin
         return Node;
      end;   
      
      procedure Insert is
         new Keys.Generic_Unconditional_Insert (New_Node);
   begin
      Insert (Container.Tree, New_Item, Iterator.Node);      
      pragma Debug (Check_Invariant (Container.Tree));
   end;
   
         
   procedure Insert
     (Container : in out Container_Type;
      New_Item  : in     Element_Type) is

      Iterator : Iterator_Type;
   begin
      Insert (Container, New_Item, Iterator);
   end;
   
         
   procedure Insert
     (Container : in out Container_Type;
      Position  : in     Iterator_Type;
      New_Item  : in     Element_Type;  
      Iterator  :    out Iterator_Type) is      
      
      function New_Node return Node_Access is
         pragma Inline (New_Node);

         Node : constant Node_Access := 
           new Node_Type'(Parent => null,
                          Left   => null,
                          Right  => null,
                          Color  => Red,
                          Element => New_Item);
      begin
         return Node;
      end;   
               
      procedure Insert_With_Hint is
         new Keys.Generic_Unconditional_Insert_With_Hint (New_Node);
   begin
      Insert_With_Hint 
        (Container.Tree, 
         Position.Node, 
         New_Item, 
         Iterator.Node);
      
      pragma Debug (Check_Invariant (Container.Tree));
   end;
   
   
      
   procedure Insert
     (Container : in out Container_Type;
      Position  : in     Iterator_Type;
      New_Item  : in     Element_Type) is

      Iterator : Iterator_Type;
   begin
      Insert (Container, Position, New_Item, Iterator);
   end;



   procedure Delete
     (Container : in out Container_Type;
      First     : in out Node_Access;
      Back      : in     Node_Access) is
      
      pragma Inline (Delete);

      Tree : Tree_Type renames Container.Tree;
      
   begin
   
      while First /= Back 
        and then First /= Tree.Back 
      loop
               
         declare
            Next : constant Node_Access := Succ (First);
         begin
            Delete (Tree, First);

            declare
               X : Node_Access := First;
            begin
               First := Next;
               Free (X);
            end;
         end;

         pragma Debug (Check_Invariant (Tree));
         
      end loop;
      
   end Delete;

      
   package body Generic_Keys is
   
      function Is_Less
        (Left  : Key_Type;
         Right : Node_Access) return Boolean is
         
         pragma Inline (Is_Less);
      begin
         return Left < Right.Element;
      end;
      
      function Is_Less
        (Left  : Node_Access;
         Right : Key_Type) return Boolean is
      
         pragma Inline (Is_Less);
      begin
         return Left.Element < Right;
      end;
      
      package Alternate_Keys is
         new Trees.Generic_Keys (Key_Type, Is_Less, Is_Less);
         
      use Alternate_Keys;
      
      function Count
        (Container : Container_Type;
         Key       : Key_Type) return Natural is
      begin
         return Count (Container.Tree, Key);
      end;

      function Find 
        (Container : Container_Type;
         Key       : Key_Type) return Iterator_Type is
      begin
         return (Node => Find (Container.Tree, Key));
      end;

      function Is_In 
        (Key       : Key_Type;
         Container : Container_Type) return Boolean is
      begin
         return Find (Container.Tree, Key) /= Container.Tree.Back;
      end;
      
      function Lower_Bound
        (Container : Container_Type;
         Key       : Key_Type) return Iterator_Type is
      begin
         return (Node => Lower_Bound (Container.Tree, Key));
      end;

      function Upper_Bound
        (Container : Container_Type;
         Key       : Key_Type) return Iterator_Type is
      begin
         return (Node => Upper_Bound (Container.Tree, Key));
      end;
      
      procedure Equal_Range
        (Container   : in     Container_Type;
         Key         : in     Key_Type;
         First, Back :    out Iterator_Type) is
      begin
         Equal_Range (Container.Tree, Key, First.Node, Back.Node);
      end;
      
         
      procedure Generic_Insert
        (Container : in out Container_Type;
         Key       : in     Key_Type;
         Iterator  :    out Iterator_Type) is
         
         function New_Node return Node_Access is
            pragma Inline (New_Node);
            
            Node : Node_Access := new Node_Type;
         begin
            Set_Key (Node.Element, Key);
            Node.Color := Red;
            
            return Node;
         exception
            when others =>
               Free (Node);
               raise;
         end;   
      
         procedure Insert is
            new Alternate_Keys.Generic_Unconditional_Insert (New_Node);
      begin
         Insert (Container.Tree, Key, Iterator.Node);
      end;      


      procedure Generic_Insert_With_Hint
        (Container : in out Container_Type;
         Position  : in     Iterator_Type;
         Key       : in     Key_Type;
         Iterator  :    out Iterator_Type) is
         
         function New_Node return Node_Access is
            pragma Inline (New_Node);
            
            Node : Node_Access := new Node_Type;
         begin
            Set_Key (Node.Element, Key);
            Node.Color := Red;
            
            return Node;
         exception
            when others =>
               Free (Node);
               raise;
         end;   
                  
         procedure Insert is
            new Alternate_Keys.Generic_Unconditional_Insert_With_Hint 
              (New_Node);
      begin
         Insert (Container.Tree, Position.Node, Key, Iterator.Node);
      end;      

               
      procedure Delete
        (Container : in out Container_Type;
         Key       : in     Key_Type) is
         
         First, Back : Node_Access;
      begin
         Equal_Range (Container.Tree, Key, First, Back);
         Delete (Container, First, Back);
      end;
         
      procedure Delete
        (Container : in out Container_Type;
         Key       : in     Key_Type;
         Count     :    out Natural) is
         
         First, Back : Node_Access;
      begin
         Equal_Range (Container.Tree, Key, First, Back);
         Count := Offset (First, Back);
         Delete (Container, First, Back);
      end;
   
   end Generic_Keys;


   function First (Container : Container_Type) return Iterator_Type is
   begin
      return (Node => First (Container.Tree));
   end;
   
   function Last (Container : Container_Type) return Iterator_Type is
   begin
      return (Node => Last (Container.Tree));
   end;
   
   function Back (Container : Container_Type) return Iterator_Type is
   begin
      return (Node => Container.Tree.Back);
   end;
  
   
   function Pred (Iterator : Iterator_Type) return Iterator_Type is
   begin
      return (Node => Pred (Iterator.Node));
   end;


   function Pred 
     (Iterator : Iterator_Type;
      Offset   : Natural) return Iterator_Type is
   begin
      return (Node => Pred (Iterator.Node, Offset));
   end;

   
   procedure Increment (Iterator : in out Iterator_Type) is
   begin
      Iterator := Succ (Iterator);
   end;
   
   procedure Increment 
     (Iterator : in out Iterator_Type;
      Offset   : in     Natural) is
   begin
      Iterator := Succ (Iterator, Offset);
   end;
      
   procedure Decrement (Iterator : in out Iterator_Type) is
   begin
      Iterator := Pred (Iterator);
   end;
   
   procedure Decrement 
     (Iterator : in out Iterator_Type;
      Offset   : in     Natural) is
   begin
      Iterator := Pred (Iterator, Offset);
   end;

   function Element (Iterator : Iterator_Type) return Element_Type is
   begin
      return Iterator.Node.Element;
   end;
   
   procedure Swap (Left, Right : in out Container_Type) is
   begin
      Swap (Left.Tree, Right.Tree);
   end;
   

   function Generic_Element
     (Iterator : Iterator_Type) return Element_Access is
   begin
      return Iterator.Node.Element'Access;
   end;
   

   function First_Element (Container : Container_Type) return Element_Type is
   begin
      return First (Container.Tree).Element;
   end;

   
   function Last_Element (Container : Container_Type) return Element_Type is
   begin
      return Last (Container.Tree).Element;
   end;
   

   function Generic_Modify_Element
     (Iterator : Iterator_Type) return Element_Access is
   begin
      return Iterator.Node.Element'Access;
   end;
   
   procedure Copy_Element
     (Iterator : in     Iterator_Type;
      Item     :    out Element_Type) is
   begin
      Item := Iterator.Node.Element;
   end;


   
   function Find 
     (Container : Container_Type;
      Item      : Element_Type) return Iterator_Type is
   begin
      return (Node => Find (Container.Tree, Item));
   end;
   
   
   function Is_In 
     (Item      : Element_Type;
      Container : Container_Type) return Boolean is
      
      Node : constant Node_Access := Find (Container.Tree, Item);
   begin
      return Node /= Container.Tree.Back;
   end;


   function Count
     (Container : Container_Type;
      Item      : Element_Type) return Natural is
   begin
      return Count (Container.Tree, Item);
   end;


   procedure Delete
     (Container : in out Container_Type;
      Iterator  : in out Iterator_Type) is
   begin
      if Iterator.Node = null 
        or else Iterator.Node = Container.Tree.Back
      then
         return;
      end if;
      
      declare
         Next : constant Node_Access := Succ (Iterator.Node);
      begin
         Delete (Container.Tree, Iterator.Node);

         declare
            X : Node_Access := Iterator.Node;
         begin
            Iterator.Node := Next;
            Free (X);
         end;
      end;

      pragma Debug (Check_Invariant (Container.Tree));
   end;   


   procedure Delete_Sans_Increment
     (Container : in out Container_Type;
      Iterator  : in out Iterator_Type) is
   begin
      if Iterator.Node = null 
        or else Iterator.Node = Container.Tree.Back
      then
         return;
      end if;
      
      Delete (Container.Tree, Iterator.Node);
      
      declare
         X : Node_Access := Iterator.Node;
      begin
         Iterator.Node := Container.Tree.Back;
         Free (X);
      end;
      
      pragma Debug (Check_Invariant (Container.Tree));
   end;

      
   procedure Delete_Sans_Assign
     (Container : in out Container_Type;
      Iterator  : in     Iterator_Type) is
      
      Tree : Tree_Type renames Container.Tree;
      X    : Node_Access := Iterator.Node;
      
   begin
   
      if X = null or else X = Tree.Back then
         return;
      end if;
      
      Delete (Tree, X);      
      Free (X);
      
      pragma Debug (Check_Invariant (Container.Tree));
      
   end Delete_Sans_Assign;
   

   procedure Delete_First (Container : in out Container_Type) is
   begin
      Delete_Sans_Assign (Container, First (Container));
   end;

   
   procedure Delete_Last (Container : in out Container_Type) is
   begin
      Delete_Sans_Assign (Container, Last (Container));
   end;
   


   procedure Delete
     (Container : in out Container_Type;
      First     : in out Iterator_Type;
      Back      : in     Iterator_Type) is
   begin
      if First.Node = null or Back.Node = null then
         return;
      end if;
      
      if First.Node = Trees.First (Container.Tree) 
        and then Back.Node = Container.Tree.Back 
      then
         Clear (Container);
      else
         Delete (Container, First.Node, Back.Node);
      end if;
   end Delete;


   procedure Delete
     (Container : in out Container_Type;
      Item      : in     Element_Type;
      Count     :    out Natural) is
     
      First, Back : Node_Access;
   begin
      Equal_Range (Container.Tree, Item, First, Back);
      Count := Offset (First, Back);
      Delete (Container, First, Back);
   end;
   

   procedure Delete
     (Container : in out Container_Type;
      Item      : in     Element_Type) is
      
      First, Back : Node_Access;
   begin
      Equal_Range (Container.Tree, Item, First, Back);
      Delete (Container, First, Back);
   end;

      
      
   function Lower_Bound
     (Container : Container_Type;
      Item      : Element_Type) return Iterator_Type is
   begin
      return (Node => Lower_Bound (Container.Tree, Item));
   end;


   function Upper_Bound
     (Container : Container_Type;
      Item      : Element_Type) return Iterator_Type is
   begin
      return (Node => Upper_Bound (Container.Tree, Item));
   end;
   
   
   procedure Equal_Range 
     (Container : in     Container_Type;
      Item      : in     Element_Type;
      First     :    out Iterator_Type;
      Back      :    out Iterator_Type) is
   begin
      Equal_Range 
        (Container.Tree,
         Item,
         First.Node,
         Back.Node);
   end;


   procedure Generic_Select_Element
     (Iterator : in Iterator_Type) is
   begin
      Process (Iterator.Node.Element);
   end;
   
     
   procedure Generic_Iteration
     (First, Back : in Iterator_Type) is
     
      I : Iterator_Type := First;
   begin
      while I /= Back loop
         Process (I);
         I := Succ (I);
      end loop;
   end;
      

   procedure Generic_Reverse_Iteration
     (First, Back : in Iterator_Type) is
     
      I : Iterator_Type := Back;
   begin
      while I /= First loop
         I := Pred (I);
         Process (I);
      end loop;
   end;


   procedure Generic_Select_Elements
     (First, Back : in Iterator_Type) is
     
      I : Iterator_Type := First;
   begin
      while I /= Back loop
         Process (I.Node.Element);
         I := Succ (I);
      end loop;
   end;
      


   procedure Generic_Reverse_Select_Elements
     (First, Back : in Iterator_Type) is
     
      I : Iterator_Type := Back;
   begin
      while I /= First loop
         I := Pred (I);
         Process (I.Node.Element);
      end loop;
   end;
      


end Charles.Multisets.Sorted.Unbounded;