------------------------------------------------------------------------------
--                                                                          --
--                        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 System;  use type System.Address;

with Charles.Algorithms.Generic_Lexicographical_Compare;
with Charles.Algorithms.Generic_Quicksort_Array;
--with Charles.Algorithms.Generic_Reverse_Random_Access;
--with Charles.Algorithms.Generic_Remove;

package body Charles.Vectors.Bounded is

   type Int is range System.Min_Int .. System.Max_Int;


   function "=" (Left, Right : Container_Type) return Boolean is
   begin

      if Left'Address = Right'Address then
         return True;
      end if;

      if Left.Length /= Right.Length then
         return False;
      end if;

      for I in 1 .. Left.Length loop

         if Left.Elements (I) /= Right.Elements (I) then
            return False;
         end if;

      end loop;

      return True;

   end "=";


   function Generic_Less (Left, Right : Container_Type) return Boolean is

      function Is_Less (LI, RI : Integer'Base) return Boolean is
         pragma Inline (Is_Less);
      begin
         return Left.Elements (LI) < Right.Elements (RI);
      end;

      function Lexicographical_Compare is
         new Algorithms.Generic_Lexicographical_Compare
            (Iterator_Type => Integer'Base,
             Succ          => Integer'Succ);

   begin -- Generic_Less

      if Left'Address = Right'Address then
         return False;
      end if;

      return Lexicographical_Compare
               (Left_First  => 1,
                Left_Back   => Left.Length + 1,
                Right_First => 1,
                Right_Back  => Right.Length + 1);

   end Generic_Less;


   function Length (Container : Container_Type) return Natural is
   begin
      return Container.Length;
   end;


   procedure Set_Length
     (Container : in out Container_Type;
      Length    : in     Natural) is

      subtype Length_Subtype is Natural range 0 .. Container.Size;
   begin
      Container.Length := Length_Subtype'(Length);
   end;



   procedure Set_Length
     (Container : in out Container_Type;
      Length    : in     Natural;
      New_Item  : in     Element_Type) is

      subtype Length_Subtype is Natural range 0 .. Container.Size;

      New_Length : constant Length_Subtype := Length;

   begin

      if New_Length > Container.Length then
         declare
            Target : Element_Array renames
              Container.Elements (Container.Length + 1 .. New_Length);
         begin
            Target := (others => New_Item);
         end;
      end if;

      Container.Length := New_Length;

   end Set_Length;



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


   procedure Clear (Container : in out Container_Type) is
   begin
      Container.Length := 0;
   end;


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

      subtype Length_Subtype is Natural range 0 .. Target.Size;

      New_Length : constant Length_Subtype := Source.Length;

   begin

      if Target'Address = Source'Address then
         return;
      end if;

      declare
         Src : Element_Array renames
           Source.Elements (1 .. New_Length);

         Tgt : Element_Array renames
           Target.Elements (1 .. New_Length);
      begin
         Tgt := Src;
      end;

      Target.Length := New_Length;

   end Assign;


   procedure Assign
     (Target : in out Container_Type;
      Source : in     Container_Type;
      First  : in     Index_Type'Base;
      Back   : in     Index_Type'Base) is

   begin

      if Back <= First then
         Clear (Target);
         return;
      end if;

      declare

         subtype First_Subtype is Index_Type'Base range
           Index_Type'First .. Last (Source);

         F : constant First_Subtype := First;

         L1 : constant Index_Type'Base := Index_Type'Pred (Back);
         L2 : constant Index_Type'Base := Last (Source);

         L : constant Index_Type'Base := Index_Type'Min (L1, L2);

         Src : Element_Array renames Source.Elements (F .. L);

         First_As_Int : constant Int := Index_Type'Pos (Index_Type'First);

         Last_As_Int  : constant Int'Base := First_As_Int + Src'Length - 1;
         Last : constant Index_Type'Base := Index_Type'Val (Last_As_Int);

         subtype Tgt_Range is Index_Type'Base range
           Index_Type'First .. Last;

      begin

         if Target'Address = Source'Address then

            declare
               Tgt : Element_Array renames
                 Target.Elements (Tgt_Range);
            begin
               Tgt := Src;
               Target.Last := Last;
            end;

            return;

         end if;

         if Target.Elements = null then

            declare
               subtype Tgt_Array is Element_Array (Tgt_Range);
               Tgt : constant Element_Array_Access := new Tgt_Array'(Src);
            begin
               Target.Elements := Tgt;
               Target.Last := Last;
            end;

            return;

         end if;

         if Src'Length <= Target.Elements'Length then

            declare
               Tgt : Element_Array renames
                 Target.Elements (Tgt_Range);
            begin
               Tgt := Src;
            end;

            Target.Last := Last;

            return;

         end if;

         declare
            subtype Tgt_Array is Element_Array (Tgt_Range);
            Tgt : constant Element_Array_Access := new Tgt_Array'(Src);

            X : Element_Array_Access := Target.Elements;
         begin
            Target.Elements := Tgt;
            Target.Last := Source.Last;

            Free (X);
         end;

      end;

   end Assign;


   procedure Append
     (Container : in out Container_Type;
      New_Item  : in     Element_Type) is
   begin
      Insert (Container, Before => Back (Container), New_Item => New_Item);
   end;


   procedure Delete_Last (Container : in out Container_Type) is
   begin
      if Container.Length > 0 then
         Container.Length := Container.Length - 1;
      end if;
   end;


   procedure Insert_N
     (Container : in out Container_Type;
      Before    : in     Index_Type'Base;
      Count     : in     Natural;
      New_Item  : in     Element_Type) is

      Old_Last : constant Last_Subtype := Container.Last;

      Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);

      N : constant Int := Integer'Pos (Count);

      New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N;

      New_Last : constant Last_Subtype := Index_Type'Val (New_Last_As_Int);

      New_First : Index_Type;

      Dst_Last : Index_Type;
      Dst      : Element_Array_Access;

   begin

      if Count = 0 then
         return;
      end if;

      declare
         subtype Before_Subtype is Index_Type'Base range
           Index_Type'First .. Index_Type'Succ (Container.Last);

         Old_First : constant Before_Subtype := Before;

         Old_First_As_Int : constant Int := Index_Type'Pos (Old_First);

         New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
      begin
         New_First := Index_Type'Val (New_First_As_Int);
      end;

      if Container.Elements = null then

         pragma Assert (New_First = Index_Type'First);

         declare
            subtype Elements_Subtype is
              Element_Array (Index_Type'First .. New_Last);
         begin
            Container.Elements := new Elements_Subtype'(others => New_Item);
         end;

         Container.Last := New_Last;

         return;

      end if;

      if New_Last <= Container.Elements'Last then

         declare
            E : Element_Array renames Container.Elements.all;
         begin
            E (New_First .. New_Last) := E (Before .. Container.Last);
            E (Before .. Index_Type'Pred (New_First)) := (others => New_Item);
         end;

         Container.Last := New_Last;

         return;

      end if;

      declare

         First : constant Int := Index_Type'Pos (Index_Type'First);

         New_Size : constant Int'Base := New_Last_As_Int - First + 1;

         Last : constant Int := Index_Type'Pos (Index_Type'Last);

         Max_Size : constant Int'Base := Last - First + 1;

         Size, Dst_Last_As_Int : Int'Base;

      begin

         if New_Size >= Max_Size / 2 then

            Dst_Last := Index_Type'Last;

         else

            Size := Container.Elements'Length;

            if Size = 0 then
               Size := 1;
            end if;

            while Size < New_Size loop
               Size := 2 * Size;
            end loop;

            Dst_Last_As_Int := First + Size - 1;
            Dst_Last := Index_Type'Val (Dst_Last_As_Int);

         end if;

      end;

      Dst := new Element_Array (Index_Type'First .. Dst_Last);

      declare
         Src : Element_Array renames Container.Elements.all;
      begin
         Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
           Src (Index_Type'First .. Index_Type'Pred (Before));

         Dst (Before .. Index_Type'Pred (New_First)) :=
           (others => New_Item);

         Dst (New_First .. New_Last) :=
           Src (Before .. Container.Last);
      exception
         when others =>
            Free (Dst);
            raise;
      end;

      declare
         X : Element_Array_Access := Container.Elements;
      begin
         Container.Elements := Dst;
         Container.Last := New_Last;

         Free (X);
      end;

   end Insert_N;


   procedure Insert_N
     (Container : in out Container_Type;
      Before    : in     Index_Type'Base;
      Count     : in     Natural) is

      Old_Last : constant Last_Subtype := Container.Last;

      Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last);

      N : constant Int := Integer'Pos (Count);

      New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N;

      New_Last : constant Last_Subtype := Index_Type'Val (New_Last_As_Int);

      New_First : Index_Type;

      Dst_Last : Index_Type;
      Dst      : Element_Array_Access;

   begin

      if Count = 0 then
         return;
      end if;

      declare
         subtype Before_Subtype is Index_Type'Base range
           Index_Type'First .. Index_Type'Succ (Container.Last);

         Old_First : constant Before_Subtype := Before;

         Old_First_As_Int : constant Int := Index_Type'Pos (Old_First);

         New_First_As_Int : constant Int'Base := Old_First_As_Int + N;
      begin
         New_First := Index_Type'Val (New_First_As_Int);
      end;

      if Container.Elements = null then

         pragma Assert (New_First = Index_Type'First);

         declare
            subtype Elements_Subtype is
              Element_Array (Index_Type'First .. New_Last);
         begin
            Container.Elements := new Elements_Subtype;
         end;

         Container.Last := New_Last;

         return;

      end if;

      if New_Last <= Container.Elements'Last then

         declare
            E : Element_Array renames Container.Elements.all;
         begin
            E (New_First .. New_Last) := E (Before .. Container.Last);
         end;

         Container.Last := New_Last;

         return;

      end if;

      declare

         First : constant Int := Index_Type'Pos (Index_Type'First);

         New_Size : constant Int'Base := New_Last_As_Int - First + 1;

         Last : constant Int := Index_Type'Pos (Index_Type'Last);

         Max_Size : constant Int'Base := Last - First + 1;

         Size, Dst_Last_As_Int : Int'Base;

      begin

         if New_Size >= Max_Size / 2 then

            Dst_Last := Index_Type'Last;

         else

            Size := Container.Elements'Length;

            if Size = 0 then
               Size := 1;
            end if;

            while Size < New_Size loop
               Size := 2 * Size;
            end loop;

            Dst_Last_As_Int := First + Size - 1;
            Dst_Last := Index_Type'Val (Dst_Last_As_Int);

         end if;

      end;

      Dst := new Element_Array (Index_Type'First .. Dst_Last);

      declare
         Src : Element_Array renames Container.Elements.all;
      begin
         Dst (Index_Type'First .. Index_Type'Pred (Before)) :=
           Src (Index_Type'First .. Index_Type'Pred (Before));

         Dst (New_First .. New_Last) :=
           Src (Before .. Container.Last);
      exception
         when others =>
            Free (Dst);
            raise;
      end;

      declare
         X : Element_Array_Access := Container.Elements;
      begin
         Container.Elements := Dst;
         Container.Last := New_Last;

         Free (X);
      end;

   end Insert_N;



   procedure Insert
     (Container : in out Container_Type;
      Before    : in     Index_Type'Base) is
   begin
      Insert_N (Container, Before, Count => 1);
   end;


   procedure Insert
     (Container : in out Container_Type;
      Before    : in     Index_Type'Base;
      New_Item  : in     Element_Type) is
   begin
      Insert_N (Container, Before, Count => 1, New_Item => New_Item);
   end;


   procedure Delete
     (Container : in out Container_Type;
      Index     : in     Index_Type'Base) is

   begin

      --We could treat specifying an index outside of the
      --active range as an error (and propagate CE), but for
      --now let's weaken the precondition and just treat
      --deleting from an empty vector (say) as a no-op.

      if Index < Index_Type'First then
         return;
      end if;

      if Index > Container.Last then
         return;
      end if;


      declare
         Old_Last : constant Index_Type := Container.Last;
         New_Last : constant Last_Subtype := Index_Type'Pred (Old_Last);

         EA : Element_Array renames Container.Elements.all;

         subtype Index_Subtype is Index_Type'Base range
           Index_Type'First .. Old_Last;
      begin
         EA (Index_Subtype'(Index) .. New_Last) :=
           EA (Index_Type'Succ (Index) .. Old_Last);

         Container.Last := New_Last;
      end;

   end Delete;


   procedure Delete
     (Container : in out Container_Type;
      First     : in     Index_Type'Base;
      Back      : in     Index_Type'Base) is

   begin

      if Back <= First then
         return;
      end if;

      declare
         I : constant Int := Index_Type'Pos (First);
         J : constant Int := Index_Type'Pos (Back);
         N : constant Int'Base := J - I;
      begin
         Delete_N (Container, Index => First, Count => Positive (N));
      end;

   end Delete;


   procedure Delete_N
     (Container : in out Container_Type;
      Index     : in     Index_Type'Base;
      Count     : in     Natural) is

      subtype First_Subtype is Index_Type'Base range
        Index_Type'First .. Container.Last;

      First : First_Subtype;
      First_As_Int : Int;

      Last  : Last_Subtype;

   begin

      if Count = 0 then
         return;
      end if;

      First := Index; --can raise CE
      First_As_Int := Index_Type'Pos (First);

      declare
         N : constant Int := Integer'Pos (Count);

         Last1_As_Int : constant Int'Base := First_As_Int + N - 1;
         Last2_As_Int : constant Int'Base := Index_Type'Pos (Container.Last);

         Last_As_Int : constant Int'Base := Int'Min (Last1_As_Int, Last2_As_Int);
      begin
         Last := Index_Type'Val (Last_As_Int);
      end;

      if Last = Container.Last then
         Container.Last := Index_Type'Pred (First);
         return;
      end if;

      declare
         Src_First : constant Index_Type := Index_Type'Succ (Last);
         Src_First_As_Int : constant Int := Index_Type'Pos (Src_First);

         Src_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);

         N : constant Int'Base := Src_Last_As_Int - Src_First_As_Int + 1;

         Tgt_Last_As_Int : constant Int'Base := First_As_Int + N - 1;
         Tgt_Last : constant Index_Type := Index_Type'Val (Tgt_Last_As_Int);

         Src : Element_Array renames
           Container.Elements (Src_First .. Container.Last);

         Tgt : Element_Array renames
           Container.Elements (First .. Tgt_Last);
      begin
         Tgt := Src;
         Container.Last := Tgt_Last;
      end;

   end Delete_N;


   function First
     (Container : Container_Type) return Index_Type is
      pragma Warnings (Off, Container);
   begin
      return Index_Type'First;
   end;


   function First_Element
     (Container : Container_Type) return Element_Type is
   begin
      return Element (Container, Index => First (Container));
   end;


   function Last
     (Container : Container_Type) return Index_Type'Base is
   begin
      return Container.Last;
   end;


   function Last_Element
     (Container : Container_Type) return Element_Type is
   begin
      return Element (Container, Index => Last (Container));
   end;


   function Back
     (Container : Container_Type) return Index_Type'Base is
   begin
      return Index_Type'Succ (Container.Last);
   end;


   function Element
     (Container : Container_Type;
      Index     : Index_Type'Base) return Element_Type is

      subtype Index_Subtype is Index_Type'Base range
         Index_Type'First .. Container.Last;
   begin
      return Container.Elements (Index_Subtype'(Index));
   end;


   function Generic_Element
     (Container : Container_Type;
      Index     : Index_Type'Base) return Element_Access is

      subtype Index_Subtype is Index_Type'Base range
         Index_Type'First .. Container.Last;
   begin
      return Container.Elements (Index_Subtype'(Index))'Access;
   end;


   procedure Replace_Element
     (Container : in Container_Type;
      Index     : in Index_Type'Base;
      By        : in Element_Type) is

      subtype Index_Subtype is Index_Type'Base range
         Index_Type'First .. Container.Last;
   begin
      Container.Elements (Index_Subtype'(Index)) := By;
   end;


   function Generic_Find
     (Container : Container_Type;
      Index     : Index_Type'Base := Index_Type'First) return Index_Type'Base is

      subtype T is Index_Type'Base range
        Index_Type'First .. Index_Type'Base'Last;

   begin

      for I in T'(Index) .. Container.Last loop
         if Predicate (Container.Elements (I)) then
            return I;
         end if;
      end loop;

      return Back (Container);

   end Generic_Find;


   function Find
     (Container : Container_Type;
      Item      : Element_Type;
      Index     : Index_Type'Base := Index_Type'First) return Index_Type'Base is

      function Predicate (Element : Element_Type) return Boolean is
         pragma Inline (Predicate);
      begin
         return Item = Element;
      end;

      function Find_Item is
         new Generic_Find (Predicate);
   begin
      return Find_Item (Container, Index);
   end;


   function Is_In
     (Item      : Element_Type;
      Container : Container_Type) return Boolean is
   begin
      return Find (Container, Item) /= Back (Container);
   end;


   function Generic_Reverse_Find
     (Container : Container_Type;
      Index     : Index_Type'Base := Index_Type'Last) return Index_Type'Base is

      Last : Index_Type'Base;

   begin

      if Index > Container.Last then
         Last := Container.Last;
      else
         Last := Index;
      end if;

      for I in reverse Index_Type'First .. Last loop
         if Predicate (Container.Elements (I)) then
            return I;
         end if;
      end loop;

      return Back (Container);

   end Generic_Reverse_Find;


   function Reverse_Find
     (Container : Container_Type;
      Item      : Element_Type;
      Index     : Index_Type'Base := Index_Type'Last) return Index_Type'Base is

      function Predicate (Element : Element_Type) return Boolean is
         pragma Inline (Predicate);
      begin
         return Item = Element;
      end;

      function Reverse_Find_Item is
         new Generic_Reverse_Find (Predicate);
   begin
      return Reverse_Find_Item (Container, Index);
   end;


   procedure Generic_Constant_Iteration (Container : in Container_Type) is
   begin
      for I in Index_Type'First .. Container.Last loop
         Process (Container.Elements (I));
      end loop;
   end;


   procedure Generic_Iteration (Container : in Container_Type) is
   begin
      for I in Index_Type'First .. Container.Last loop
         Process (Container.Elements (I));
      end loop;
   end;


   procedure Generic_Constant_Reverse_Iteration (Container : in Container_Type) is
   begin
      for I in reverse Index_Type'First .. Container.Last loop
         Process (Container.Elements (I));
      end loop;
   end;


   procedure Generic_Reverse_Iteration (Container : in Container_Type) is
   begin
      for I in reverse Index_Type'First .. Container.Last loop
         Process (Container.Elements (I));
      end loop;
   end;



   procedure Generic_Sort (Container : in Container_Type) is

      procedure Sort is
         new Algorithms.Generic_Quicksort_Array
           (Index_Type   => Index_Type,
            Element_Type => Element_Type,
            Array_Type   => Element_Array,
            "<"          => "<");
   begin

      if Container.Last >= Index_Type'First then
         Sort (Container.Elements (Index_Type'First .. Container.Last));
      end if;

   end Generic_Sort;


end Charles.Vectors.Bounded;
