------------------------------------------------------------------------------
--                                                                          --
--                      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 Ada.Unchecked_Deallocation;
with Charles.Algorithms.Generic_Lexicographical_Compare;

package body Charles.Lists.Double.Unbounded is

   procedure Free is
      new Ada.Unchecked_Deallocation (Node_Type, Node_Access);


   function New_Back return Node_Access is

      Back : constant Node_Access := new Node_Type;
   begin
      Back.Next := Back;
      Back.Prev := Back;

      return Back;
   end;


   function Empty_Container return Container_Type is
   begin
      return (Controlled with Back => New_Back, Length => 0);
   end;


   procedure Adjust (Container : in out Container_Type) is

      Back   : constant Node_Access := Container.Back;
      Length : constant Natural := Container.Length;

      Src_Node, Dst_Node : Node_Access;

   begin

      Container.Back := null;
      Container.Length := 0;

      Container.Back := New_Back;

      if Length = 0 then
         return;
      end if;

      Src_Node := Back.Next;
      Dst_Node := Container.Back;

      loop

         pragma Assert (Src_Node /= Back);

         Dst_Node.Next := new Node_Type'(Element => Src_Node.Element,
                                         Next    => Container.Back,
                                         Prev    => Dst_Node);

         Dst_Node := Dst_Node.Next;

         Container.Back.Prev := Dst_Node;  --fix per Phil Thornley

         Container.Length := Container.Length + 1;

         if Container.Length = Length then
            return;
         end if;

         Src_Node := Src_Node.Next;

      end loop;

   end Adjust;


   procedure Finalize (Container : in out Container_Type) is
   begin

      if Container.Back = null then
         return;
      end if;

      Clear (Container);

      declare
         X : Node_Access := Container.Back;
      begin
         Container.Back := null;
         Free (X);
      end;

   end Finalize;


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

      LI : Iterator_Type := First (Left);
      RI : Iterator_Type := First (Right);

   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 LI.Node.Element /= RI.Node.Element then
            return False;
         end if;

         LI := Succ (LI);
         RI := Succ (RI);

      end loop;

      return True;

   end "=";


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

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

      function Succ (Iter : Node_Access) return Node_Access is
         pragma Inline (Succ);
      begin
         return Iter.Next;
      end;

      function Lexicographical_Compare is
         new Algorithms.Generic_Lexicographical_Compare (Node_Access);

      LF : constant Node_Access := Left.Back.Next;
      LB : constant Node_Access := Left.Back;

      RF : constant Node_Access := Right.Back.Next;
      RB : constant Node_Access := Right.Back;

   begin

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

      return Lexicographical_Compare (LF, LB, RF, RB);

   end Generic_Less;



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


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


   procedure Clear (Container : in out Container_Type) is
   begin

      while Container.Length > 0 loop
         Delete_Last (Container);
      end loop;

   end Clear;


   procedure Swap (Left, Right : in out Container_Type) is

      L_Node : constant Node_Access := Left.Back;
      L_Length : constant Natural := Left.Length;

   begin

      Left.Back := Right.Back;
      Left.Length := Right.Length;

      Right.Back := L_Node;
      Right.Length := L_Length;

   end Swap;



   procedure Generic_Iteration
     (Container : in Container_Type) is

      I : Iterator_Type := First (Container);
      J : constant Iterator_Type := Back (Container);

   begin

      while I /= J loop
         Process (I);
         Increment (I);
      end loop;

   end Generic_Iteration;


   procedure Generic_Reverse_Iteration
     (Container : in Container_Type) is

      I : Iterator_Type := Back (Container);
      J : constant Iterator_Type := First (Container);

   begin

      while I /= J loop
         Decrement (I);
         Process (I);
      end loop;

   end Generic_Reverse_Iteration;


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

   begin

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

      Clear (Target);

      declare
         procedure Process (I : Iterator_Type) is
            pragma Inline (Process);
         begin
            Append (Target, New_Item => I.Node.Element);
         end;

         procedure Iterate is
            new Generic_Iteration;
      begin
         Iterate (Source);
      end;

   end Assign;


   procedure Prepend
     (Container : in out Container_Type;
      New_Item  : in     Element_Type) is
   begin
      Insert (Container, First (Container), New_Item);
   end;

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


   procedure Delete
     (Container : in out Container_Type;
      Iterator  : in out Iterator_Type) is

      Node : Node_Access := Iterator.Node;

   begin

      if Node = null
        or else Node = Container.Back
      then
         return;
      end if;

      Container.Length := Container.Length - 1;

      Iterator := Iterator_Type'(Node => Node.Next);

      Node.Next.Prev := Node.Prev;
      Node.Prev.Next := Node.Next;

      Free (Node);

   end Delete;


   procedure Delete_First (Container : in out Container_Type) is
      Iterator : Iterator_Type := First (Container);
   begin
      Delete (Container, Iterator);
   end;

   procedure Delete_Last (Container : in out Container_Type) is
      Iterator : Iterator_Type := Last (Container);
   begin
      Delete (Container, Iterator);
   end;


   procedure Insert
     (Container : in out Container_Type;
      Before    : in     Node_Access;
      New_Item  : in     Element_Type;
      New_Node  :    out Node_Access) is

   begin

      New_Node := new Node_Type'(Element => New_Item,
                                 Next    => Before,
                                 Prev    => Before.Prev);

      Before.Prev.Next := New_Node;
      Before.Prev := New_Node;

      Container.Length := Container.Length + 1;

   end Insert;


   procedure Insert
     (Container : in out Container_Type;
      Before    : in     Node_Access;
      New_Node  :    out Node_Access) is

   begin

      New_Node := new Node_Type;

      New_Node.Next := Before;
      New_Node.Prev := Before.Prev;

      Before.Prev.Next := New_Node;
      Before.Prev := New_Node;

      Container.Length := Container.Length + 1;

   end Insert;


   procedure Insert
     (Container : in out Container_Type;
      Before    : in     Iterator_Type;
      New_Item  : in     Element_Type;
      Iterator  :    out Iterator_Type) is
   begin
      Insert (Container, Before.Node, New_Item, Iterator.Node);
   end;



   procedure Insert
     (Container : in out Container_Type;
      Before    : in     Iterator_Type;
      New_Item  : in     Element_Type) is

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


   procedure Insert
     (Container : in out Container_Type;
      Before    : in     Iterator_Type;
      Iterator  :    out Iterator_Type) is
   begin
      Insert (Container, Before.Node, Iterator.Node);
   end;


   procedure Generic_Delete
     (Container : in out Container_Type) is

      I : Iterator_Type := First (Container);
      J : constant Iterator_Type := Back (Container);

   begin

      while I /= J loop

         if Predicate (I.Node.Element) then
            Delete (Container, I);
         else
            Increment (I);
         end if;

      end loop;

   end Generic_Delete;



   procedure Delete
     (Container : in out Container_Type;
      Item      : in     Element_Type) is

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

      procedure Delete is
        new Generic_Delete (Predicate);
   begin
      Delete (Container);
   end;


   procedure Reverse_Container (Container : in Container_Type) is

      procedure Swap (L, R : Node_Access) is

         LN : constant Node_Access := L.Next;
         LP : constant Node_Access := L.Prev;

         RN : constant Node_Access := R.Next;
         RP : constant Node_Access := R.Prev;

      begin

         LP.Next := R;
         RN.Prev := L;

         L.Next := RN;
         R.Prev := LP;

         if LN = R then

            pragma Assert (RP = L);

            L.Prev := R;
            R.Next := L;

         else

            L.Prev := RP;
            RP.Next := L;

            R.Next := LN;
            LN.Prev := R;

         end if;

      end Swap;

      I : Iterator_Type := First (Container);
      J : Iterator_Type := Back (Container);

   begin

      while I /= J loop

         Decrement (J);

         exit when I = J;

         Swap (I.Node, J.Node);

         Increment (J);

         exit when I = J;

         Decrement (I);

         exit when I = J;

         Swap (J.Node, I.Node);

         Increment (I);

      end loop;

   end Reverse_Container;


   function First
     (Container : Container_Type) return Iterator_Type is
   begin
      return (Node => Container.Back.Next);
   end;


   function First_Element
     (Container : Container_Type) return Element_Type is

      I : constant Iterator_Type := First (Container);
   begin
      return I.Node.Element;
   end;


   function Back
     (Container : Container_Type) return Iterator_Type is
   begin
      return (Node => Container.Back);
   end;


   function Last
     (Container : Container_Type) return Iterator_Type is
   begin
      return Pred (Back (Container));
   end;


   function Last_Element
     (Container : Container_Type) return Element_Type is

      I : constant Iterator_Type := Last (Container);
   begin
      return I.Node.Element;
   end;


   function Element
     (Iterator : Iterator_Type) return Element_Type is
   begin
      return Iterator.Node.Element;
   end;


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


   procedure Replace_Element
     (Iterator : Iterator_Type;
      By       : Element_Type) is
   begin
      Iterator.Node.Element := By;
   end;


   function Generic_Find
     (Container : Container_Type;
      Position  : Iterator_Type := Null_Iterator) return Iterator_Type is

      I : Iterator_Type := Position;
      J : constant Iterator_Type := Back (Container);

   begin

      if I = Null_Iterator then
         I := First (Container);
      end if;

      while I /= J loop

         if Predicate (I.Node.Element) then
            return I;
         end if;

         Increment (I);

      end loop;

      return J;

   end Generic_Find;


   function Find
     (Container : Container_Type;
      Item      : Element_Type;
      Position  : Iterator_Type := Null_Iterator) return Iterator_Type is

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

      function Find is
         new Generic_Find (Predicate);
   begin
      return Find (Container, Position);
   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;
      Position  : Iterator_Type := Null_Iterator) return Iterator_Type is

      I : Iterator_Type := Position;
      J : constant Iterator_Type := Back (Container);

   begin

      if I = Null_Iterator then
         I := Last (Container);
      end if;

      while I /= J loop

         if Predicate (I.Node.Element) then
            return I;
         end if;

         Decrement (I);

      end loop;

      return Back (Container);

   end Generic_Reverse_Find;


   function Reverse_Find
     (Container : Container_Type;
      Item      : Element_Type;
      Position  : Iterator_Type := Null_Iterator) return Iterator_Type is

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

      function Reverse_Find is
         new Generic_Reverse_Find (Predicate);
   begin
      return Reverse_Find (Container, Position);
   end;


   procedure Splice
     (Container : in out Container_Type;
      Before    : in     Iterator_Type;
      Source    : in out Container_Type) is

   begin

      if Container'Address = Source'Address
        or else Before = Null_Iterator
        or else Source.Length = 0
      then
         return;
      end if;

      Before.Node.Prev.Next := Source.Back.Next;
      Source.Back.Next.Prev := Before.Node.Prev;

      Before.Node.Prev := Source.Back.Prev;
      Source.Back.Prev.Next := Before.Node;

      Source.Back.Next := Source.Back;
      Source.Back.Prev := Source.Back;

      Container.Length := Container.Length + Source.Length;
      Source.Length := 0;

   end Splice;


   procedure Splice
     (Container : in Container_Type;
      Before    : in Iterator_Type;
      Iterator  : in Iterator_Type) is

   begin

      if Before = Null_Iterator
        or else Iterator = Null_Iterator
        or else Iterator = Back (Container)
        or else Iterator = Before
        or else Succ (Iterator) = Before
      then
         return;
      end if;

      pragma Assert (Container.Length > 0);

      Iterator.Node.Prev.Next := Iterator.Node.Next;
      Iterator.Node.Next.Prev := Iterator.Node.Prev;

      Before.Node.Prev.Next := Iterator.Node;
      Iterator.Node.Prev := Before.Node.Prev;

      Before.Node.Prev := Iterator.Node;
      Iterator.Node.Next := Before.Node;

   end Splice;


   procedure Splice
     (Container : in out Container_Type;
      Before    : in     Iterator_Type;
      Source    : in out Container_Type;
      Iterator  : in     Iterator_Type) is

   begin

      if Before = Null_Iterator
        or else Iterator = Null_Iterator
        or else Iterator = Back (Source)
        or else Iterator = Before
        or else Succ (Iterator) = Before
      then
         return;
      end if;

      pragma Assert (Source.Length > 0);

      Iterator.Node.Prev.Next := Iterator.Node.Next;
      Iterator.Node.Next.Prev := Iterator.Node.Prev;

      Before.Node.Prev.Next := Iterator.Node;
      Iterator.Node.Prev := Before.Node.Prev;

      Before.Node.Prev := Iterator.Node;
      Iterator.Node.Next := Before.Node;

      if Container'Address /= Source'Address then
         Container.Length := Container.Length + 1;
         Source.Length := Source.Length - 1;
      end if;

   end Splice;


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


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


   procedure Increment (Iterator : in out Iterator_Type) is
   begin
      Iterator := Succ (Iterator);
   end;


   procedure Decrement (Iterator : in out Iterator_Type) is
   begin
      Iterator := Pred (Iterator);
   end;


   procedure Generic_Delete_Duplicates
     (Container : in out Container_Type) is

      I : Iterator_Type := First (Container);
      J : Iterator_Type := Succ (I);

      K : constant Iterator_Type := Back (Container);

   begin

      while J /= K loop

         if Predicate (I.Node.Element, J.Node.Element) then
            Delete (Container, J);
         else
            I := J;
            J := Succ (I);
         end if;

      end loop;

   end Generic_Delete_Duplicates;


   procedure Delete_Duplicates (Container : in out Container_Type) is

      procedure Delete_Equal is
         new Generic_Delete_Duplicates (Predicate => "=");
   begin
      Delete_Equal (Container);
   end;


   procedure Generic_Merge
     (Container : in out Container_Type;
      Source    : in out Container_Type) is

      LI : Iterator_Type := First (Container);
      LB : constant Iterator_Type := Back (Container);

      RI : Iterator_Type := First (Source);
      RB : constant Iterator_Type := Back (Source);

   begin

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

      while RI /= RB loop

         if LI = LB then
            Splice (Container, LB, Source);
            return;
         end if;

         if RI.Node.Element < LI.Node.Element then

            declare
               RJ : constant Iterator_Type := RI;
            begin
               RI := Succ (RI);
               Splice (Container, LI, Source, RJ);
            end;

         else

            LI := Succ (LI);

         end if;

      end loop;

   end Generic_Merge;


   procedure Generic_Sort (Container : in Container_Type) is

      procedure Partition
        (Pivot : in Node_Access;
         Back  : in Node_Access) is

         Node : Node_Access := Pivot.Next;

      begin

         while Node /= Back loop

            if Node.Element < Pivot.Element then

               declare
                  Prev : constant Node_Access := Node.Prev;
                  Next : constant Node_Access := Node.Next;
               begin
                  Prev.Next := Next;
                  Next.Prev := Prev;

                  Node.Next := Pivot;
                  Node.Prev := Pivot.Prev;

                  Pivot.Prev := Node;
                  Node.Prev.Next := Node;

                  Node := Next;
               end;

            else

               Node := Node.Next;

            end if;

         end loop;

      end Partition;


      procedure Sort (Front, Back : Node_Access) is

         Pivot : constant Node_Access := Front.Next;

      begin

         if Pivot /= Back then

            Partition (Pivot, Back);

            Sort (Front, Pivot);

            Sort (Pivot, Back);

         end if;

      end Sort;

   begin

      Sort (Front => Container.Back, Back => Container.Back);

   end Generic_Sort;


end Charles.Lists.Double.Unbounded;
