generic_discrete_indefinite_map.adb

--                                                                    --
--  package                         Copyright (c)  Dmitry A. Kazakov  --
--     Generic_Discrete_Indefinite_Map             Luebeck            --
--  Implementation                                 Spring, 2012       --
--                                                                    --
--                                Last revision :  22:45 07 Apr 2016  --
--                                                                    --
--  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 Generic_Discrete_Indefinite_Map is
   use Range_Maps;

   procedure Add
             (  Container : in out Map;
                Items     : Map
             )  is
      Other : Range_Maps.Map renames Range_Maps.Map (Items);
      This  : Range_Type;
   begin
      for Index in 1..Get_Size (Other) loop
         This := Get_Key (Other, Index);
         Add
         (  Container,
            This.From,
            This.To,
            Ptr (Get (Other, Index)).Object.all
         );
      end loop;
   end Add;

   procedure Locate
             (  Map   : in out Range_Maps.Map;
                Keys  : in out Range_Type;
                First : out Integer;
                Last  : out Integer;
                Item  : Object_Type
             )  is
      Size : constant Integer := Get_Size (Map);
   begin
         -- Lower bound
      First := Find (Map, (Keys.From, Keys.From));
      if First < 0 then -- Keys.From is before -From_Index
         First := -First;
         if First > 1 then
            declare
               This : constant Range_Type := Get_Key (Map, First - 1);
            begin
               if (  Key_Type'Succ (This.To) = Keys.From
                  and then
                     Ptr (Get (Map, First - 1)).Object.all = Item
                  )
               then
                  Keys.From := This.From;
                  First     := First - 1;
               end if;
            end;
         end if;
      else -- Keys.From is inside From_Index
         Keys.From := Get_Key (Map, First).From;
      end if;
         -- Upper bound
      Last := First;
      if Last <= Size then
         loop
            declare
               This : constant Range_Type := Get_Key (Map, Last);
            begin
               if Keys.To <= This.To then -- Ends here
                  if Keys.To >= This.From then
                     Keys.To := This.To;
                  elsif Keys.To = Key_Type'Pred (This.From) then
                     if Ptr (Get (Map, Last)).Object.all = Item then
                        Keys.To := This.To;
                     else
                        Last := Last - 1;
                     end if;
                  else
                     Last := Last - 1;
                  end if;
                  exit;
               end if;
            end;
            exit when Last = Size;
            Last := Last + 1;
         end loop;
      else
         Last := Size;
      end if;
   end Locate;

   procedure Add
             (  Container : in out Map;
                Key       : Key_Type;
                Item      : Object_Type
             )  is
   begin
      Add (Container, Key, Key, Item);
   end Add;

   procedure Add
             (  Container : in out Map;
                From, To  : Key_Type;
                Item      : Object_Type
             )  is
      Map       : Range_Maps.Map renames Range_Maps.Map (Container);
      First     : Integer;
      Last      : Integer;
      Reference : Handle;
      Keys      : Range_Type := (From, To);
   begin
      if From <= To then
         Locate (Map, Keys, First, Last, Item);
         for Index in First..Last loop
            Reference := Get (Map, Index);
            if Ptr (Reference).Object.all /= Item then
               raise Constraint_Error;
            end if;
         end loop;
         for Index in reverse First..Last loop
            Remove (Map, Index);
         end loop;
         if not Is_Valid (Reference) then
            Set (Reference, new Token);
            Ptr (Reference).Object := new Object_Type'(Item);
         end if;
         Add (Map, (Keys.From, Keys.To), Reference);
      elsif Key_Type'Pred (From) /= To then
         raise Constraint_Error;
      end if;
   end Add;

   function Create return Map is
      Result : Map;
   begin
      return Result;
   end Create;

   function Create (Key : Key_Type; Item : Object_Type) return Map is
      Reference : Handle;
      Result    : Map;
   begin
      Set (Reference, new Token);
      Ptr (Reference).Object := new Object_Type'(Item);
      Add (Range_Maps.Map (Result), (Key, Key), Reference);
      return Result;
   end Create;

   function Create (From, To : Key_Type; Item : Object_Type)
      return Map is
      Reference : Handle;
      Result    : Map;
   begin
      if To < From then
         raise Constraint_Error;
      end if;
      Set (Reference, new Token);
      Ptr (Reference).Object := new Object_Type'(Item);
      Add (Range_Maps.Map (Result), (From, To), Reference);
      return Result;
   end Create;

   procedure Erase (Container : in out Map) is
   begin
      Erase (Range_Maps.Map (Container));
   end Erase;

   procedure Finalize (Container : in out Map) is
   begin
      Finalize (Range_Maps.Map (Container));
   end Finalize;

   procedure Finalize (Reference : in out Token) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object_Type, Object_Ptr);
   begin
      Free (Reference.Object);
   end Finalize;

   function Find (Container : Map; Key : Key_Type) return Integer is
      Index : constant Integer := abs Find (Container, (Key, Key));
   begin
      if (  Index <= Get_Size (Container)
         and then
            Get_Key (Container, Index).From <= Key
         )
      then
         return Index;
      else
         return -Index;
      end if;
   end Find;

   function Find (Container : Map; From, To : Key_Type)
      return Integer is
   begin
      if To < From then
         raise Constraint_Error;
      end if;
      declare
         Index : constant Integer := abs Find (Container, (From, From));
         This  : Range_Type;
      begin
         if Index <= Get_Size (Container) then
            This := Get_Key (Container, Index);
            if From >= This.From and then To <= This.To then
               return Index;
            end if;
         end if;
         return -Index;
      end;
   end Find;

   function From (Container : Map; Index : Positive) return Key_Type is
   begin
      return Get_Key (Range_Maps.Map (Container), Index).From;
   end From;

   function Get (Container : Map; Key : Key_Type) return Object_Type is
   begin
      return
         Ptr
         (  Get
            (  Range_Maps.Map (Container),
               Find (Container, Key)
         )  ) .Object.all;
   end Get;

   procedure Get_Key
             (  Container : Map;
                Index     : Positive;
                From      : out Key_Type;
                To        : out Key_Type
             )  is
      This : constant Range_Type := Get_Key (Container, Index);
   begin
      From := This.From;
      To   := This.To;
   end Get_Key;

   function Get_Size (Container : Map) return Natural is
   begin
      return Get_Size (Range_Maps.Map (Container));
   end Get_Size;

   function Intersect (Left, Right : Range_Type) return Boolean is
   begin
      return Left.To >= Right.From and then Left.From <= Right.To;
   end Intersect;

   function Is_Empty (Container : Map) return Boolean is
   begin
      return Is_Empty (Range_Maps.Map (Container));
   end Is_Empty;

   function Is_In (Container : Map; Key : Key_Type)
      return Boolean is
   begin
      return Find (Container, (Key, Key)) > 0;
   end Is_In;

   function Is_In (Container : Map; From, To : Key_Type)
      return Boolean is
   begin
      if To < From then
         return False;
      else
         return Find (Container, (From, To)) > 0;
      end if;
   end Is_In;

   function Is_Not_In (Container : Map; From, To : Key_Type)
      return Boolean is
   begin
      if To < From then
         return True;
      else
         declare
            Index : Integer := Find (Container, (From, From));
         begin
            if Index > 0 then
               return False;
            elsif From = To then
               return True;
            else
               Index := -Index;
               return
               (  Index > Get_Size (Container)
               or else
                  not Intersect ((From, To), Get_Key (Container, Index))
               );
            end if;
         end;
      end if;
   end Is_Not_In;

   function Less (Left, Right : Range_Type) return Boolean is
   begin
      return Left.To < Right.From;
   end Less;

   function Range_Get (Container : Map; Index : Positive)
      return Object_Type is
   begin
      return Ptr (Get (Range_Maps.Map (Container), Index)).Object.all;
   end Range_Get;

   procedure Range_Remove (Container : in out Map; Index : Positive) is
   begin
      Remove (Range_Maps.Map (Container), Index);
   end Range_Remove;

   procedure Range_Replace
             (  Container : in out Map;
                Index     : Positive;
                Item      : Object_Type
             )  is
      Map       : Range_Maps.Map renames Range_Maps.Map (Container);
      Reference : Handle := Get (Map, Index);
   begin
      if Ptr (Reference).Object.all /= Item then
         Set (Reference, new Token);
         Ptr (Reference).Object := new Object_Type'(Item);
         Replace (Range_Maps.Map (Container), Index, Reference);
      end if;
   end Range_Replace;

   procedure Remove (Container : in out Map; Key : Key_Type) is
      Map   : Range_Maps.Map renames Range_Maps.Map (Container);
      Index : constant Integer := Find (Container, Key);
   begin
      if Index > 0 then
         declare
            This : constant Range_Type := Get_Key (Map, Index);
            Item : constant Handle     := Get (Map, Index);
         begin
            Remove (Map, Index);
            if This.From /= This.To then
               if This.From = Key then
                  Add (Map, (Key_Type'Succ (Key), This.To), Item);
               elsif This.To = Key then
                  Add (Map, (This.From, Key_Type'Pred (Key)), Item);
               else
                  Add (Map, (This.From, Key_Type'Pred (Key)), Item);
                  Add (Map, (Key_Type'Succ (Key), This.To), Item);
               end if;
            end if;
         end;
      end if;
   end Remove;

   procedure Remove (Container : in out Map; From, To : Key_Type) is
      Map   : Range_Maps.Map renames Range_Maps.Map (Container);
      Index : Integer;
   begin
      if To >= From then
         Index := abs Find (Map, (From, From));
         while Index <= Get_Size (Map) loop
            declare
               This : constant Range_Type := Get_Key (Map, Index);
               Item : constant Handle     := Get (Map, Index);
            begin
               exit when This.From > To;
               Remove (Map, Index);
               if This.From >= From then
                  if This.To >= To then -- Remove head
                     Add (Map, (Key_Type'Succ (To), This.To), Item);
                     return;
                  end if; -- Remove completely
               else -- Leave the head
                  Add (Map, (This.From, Key_Type'Pred (From)), Item);
                  if This.To > To then -- Keep the tail
                     Add (Map, (Key_Type'Succ (To), This.To), Item);
                     return;
                  end if;
                  Index := Index + 1; -- Remove tail
               end if;
            end;
         end loop;
      end if;
   end Remove;

   procedure Remove (Container : in out Map; Items : Map) is
      Other : Range_Maps.Map renames Range_Maps.Map (Items);
      This  : Range_Type;
   begin
      for Index in reverse 1..Get_Size (Other) loop
         This := Get_Key (Other, Index);
         Remove (Container, This.From, This.To);
      end loop;
   end;

   procedure Replace
             (  Container : in out Map;
                Key       : Key_Type;
                Item      : Object_Type
             )  is
   begin
      Replace (Container, Key, Key, Item);
   end Replace;

   procedure Replace
             (  Container : in out Map;
                From, To  : Key_Type;
                Item      : Object_Type
             )  is
      Map       : Range_Maps.Map renames Range_Maps.Map (Container);
      First     : Integer;
      Last      : Integer;
      Reference : Handle;
      Keys      : Range_Type := (From, To);
   begin
      if From > To then
         raise Constraint_Error;
      end if;
      Locate (Map, Keys, First, Last, Item);
      if First < Last then -- Several intervals
         if Keys.To > To then
            Reference := Get (Map, Last);
            if Ptr (Reference).Object.all /= Item then
               Remove (Map, Last);
               Add (Map, (Key_Type'Succ (To), Keys.To), Reference);
               Keys.To := To;
               Last    := Last - 1;
               Invalidate (Reference);
            end if;
         end if;
         if Keys.From < From then
            Reference := Get (Map, First);
            if Ptr (Reference).Object.all = Item then
               Remove (Map, First);
               Add (Map, (Keys.From, Key_Type'Pred (From)), Reference);
               Keys.From := From;
               First     := First + 1;
               Invalidate (Reference);
            end if;
         end if;
         for Index in reverse First..Last loop
            Remove (Map, Index);
         end loop;
         if not Is_Valid (Reference) then
            Set (Reference, new Token);
            Ptr (Reference).Object := new Object_Type'(Item);
         end if;
         Add (Map, (Keys.From, Keys.To), Reference);
      elsif First = Last then -- Single interval
         Reference := Get (Map, First);
         if Ptr (Reference).Object.all = Item then
            if Get_Key (Map, First) /= (Keys.From, Keys.To) then
               Remove (Map, First);
               Add (Map, (Keys.From, Keys.To), Reference);
            end if;
         else
            Remove (Map, First);
            if Keys.From < From then
               Add (Map, (Keys.From, Key_Type'Pred (From)), Reference);
            end if;
            if Keys.To > To then
               Add (Map, (Key_Type'Succ (To), Keys.To), Reference);
            end if;
            Set (Reference, new Token);
            Ptr (Reference).Object := new Object_Type'(Item);
            Add (Map, (From, To), Reference);
         end if;
      else -- Adding new interval
         Set (Reference, new Token);
         Ptr (Reference).Object := new Object_Type'(Item);
         Add (Map, (Keys.From, Keys.To), Reference);
      end if;
   end Replace;

   procedure Replace (Container : in out Map; Items : Map) is
      Other : Range_Maps.Map renames Range_Maps.Map (Items);
      This  : Range_Type;
   begin
      for Index in 1..Get_Size (Other) loop
         This := Get_Key (Other, Index);
         Replace
         (  Container,
            This.From,
            This.To,
            Ptr (Get (Other, Index)).Object.all
         );
      end loop;
   end Replace;

   function To (Container : Map; Index : Positive) return Key_Type is
   begin
      return Get_Key (Range_Maps.Map (Container), Index).To;
   end To;

   function "=" (Left, Right : Map) return Boolean is
   begin
      return Range_Maps.Map (Left) = Range_Maps.Map (Right);
   end "=";

end Generic_Discrete_Indefinite_Map;