------------------------------------------------------------------------------
--                                                                          --
--                      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 Charles.Prime_Numbers;
with System;  use type System.Address;
with Ada.Unchecked_Deallocation;

package body Charles.Hash_Tables is

   procedure Free is
      new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);


   function Index
     (Buckets : Buckets_Type;
      Node    : Node_Access) return Hash_Type is

      pragma Inline (Index);
   begin
      return Hash (Node) mod Buckets'Length;
   end;

   function Index
     (Hash_Table : Hash_Table_Type;
      Node       : Node_Access) return Hash_Type is
   begin
      return Index (Hash_Table.Buckets.all, Node);
   end;


   procedure Generic_Adjust (Hash_Table : in out Hash_Table_Type) is

      B : constant Buckets_Access := Hash_Table.Buckets;
      N : constant Natural := Hash_Table.Length;

      Src_Index : Hash_Type;
      Src_Node, Dst_Pred : Node_Access;

   begin

      Hash_Table.Buckets := null;
      Hash_Table.Length := 0;

      if N = 0 then
         return;
      end if;

      Hash_Table.Buckets := new Buckets_Type (B'Range);

      Src_Index := 0;

      loop

         loop

            Src_Node := B (Src_Index);

            exit when Src_Node /= Null_Node;

            Src_Index := Src_Index + 1;

         end loop;

         Hash_Table.Buckets (Src_Index) := New_Node (Src_Node);

         Hash_Table.Length := Hash_Table.Length + 1;

         if Hash_Table.Length = N then
            return;
         end if;

         Dst_Pred := Hash_Table.Buckets (Src_Index);
         pragma Assert (Index (Hash_Table, Dst_Pred) = Src_Index);

         loop

            Src_Node := Next (Src_Node);

            exit when Src_Node = Null_Node;

            Set_Next (Node => Dst_Pred, Next => New_Node (Src_Node));

            Dst_Pred := Next (Dst_Pred);
            pragma Assert (Index (Hash_Table, Dst_Pred) = Src_Index);

            Hash_Table.Length := Hash_Table.Length + 1;

            if Hash_Table.Length = N then
               return;
            end if;

         end loop;

         Src_Index := Src_Index + 1;

      end loop;

   end Generic_Adjust;


   procedure Finalize (Hash_Table : in out Hash_Table_Type) is

      B : Buckets_Access := Hash_Table.Buckets;
      N : Integer'Base := Hash_Table.Length;

      Node, X : Node_Access;

      Index : Hash_Type;

   begin

      if B = null then
         pragma Assert (N = 0);
         return;
      end if;

      Hash_Table.Buckets := null;

      if N = 0 then
         Free (B);
         return;
      end if;

      Hash_Table.Length := 0;

      Index := 0;

      loop

         loop

            Node := B (Index);

            exit when Node /= Null_Node;

            Index := Index + 1;

         end loop;

         loop

            X := Node;

            Node := Next (Node);

            Free (X);

            N := N - 1;

            if N = 0 then
               Free (B);
               return;
            end if;

            exit when Node = Null_Node;

         end loop;

         Index := Index + 1;

      end loop;

   end Finalize;


   procedure Generic_Assign
     (Target : in out Hash_Table_Type;
      Source : in     Hash_Table_Type) is

      Src_Index : Hash_Type;

      Src_Node, Dst_Prev : Node_Access;

   begin

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

      Clear (Target);

      if Source.Length = 0 then
         return;
      end if;

      if Target.Buckets = null
        or else Target.Buckets'Length /= Source.Buckets'Length
      then
         Free (Target.Buckets);
         Target.Buckets := new Buckets_Type (Source.Buckets'Range);
      end if;

      Src_Index := 0;

      loop

         loop

            Src_Node := Source.Buckets (Src_Index);

            exit when Src_Node /= Null_Node;

            Src_Index := Src_Index + 1;

         end loop;

         Target.Buckets (Src_Index) := New_Node (Src_Node);

         Target.Length := Target.Length + 1;

         if Target.Length = Source.Length then
            return;
         end if;

         Dst_Prev := Target.Buckets (Src_Index);
         pragma Assert (Index (Target, Dst_Prev) = Src_Index);

         loop

            Src_Node := Next (Src_Node);

            exit when Src_Node = Null_Node;

            Set_Next (Node => Dst_Prev, Next => New_Node (Src_Node));

            Dst_Prev := Next (Dst_Prev);
            pragma Assert (Index (Target, Dst_Prev) = Src_Index);

            Target.Length := Target.Length + 1;

            if Target.Length = Source.Length then
               return;
            end if;

         end loop;

         Src_Index := Src_Index + 1;

      end loop;

   end Generic_Assign;


   function Generic_Equal
     (L, R : Hash_Table_Type) return Boolean is

      L_Index, R_Index : Hash_Type;
      L_Node, R_Node   : Node_Access;

      N : Integer'Base;

   begin

      if L.Length /= R.Length then
         return False;
      end if;

      if L.Length = 0 then
         return True;
      end if;

      L_Index := 0;
      R_Index := 0;

      loop
         L_Node := L.Buckets (L_Index);
         exit when L_Node /= Null_Node;
         L_Index := L_Index + 1;
      end loop;

      loop
         R_Node := R.Buckets (R_Index);
         exit when R_Node /= Null_Node;
         R_Index := R_Index + 1;
      end loop;

      N := L.Length;

      loop

         if not Is_Equal (L_Node, R_Node) then
            return False;
         end if;

         N := N - 1;

         if N = 0 then
            return True;
         end if;

         L_Node := Next (L_Node);
         R_Node := Next (R_Node);

         while L_Node = Null_Node loop
            L_Index := L_Index + 1;
            L_Node := L.Buckets (L_Index);
         end loop;

         while R_Node = Null_Node loop
            R_Index := R_Index + 1;
            R_Node := R.Buckets (R_Index);
         end loop;

      end loop;

   end Generic_Equal;


   procedure Clear (Hash_Table : in out Hash_Table_Type) is

      Length : Natural renames Hash_Table.Length;
      Index  : Hash_Type := 0;
      Node   : Node_Access;

   begin

      while Length > 0 loop

         while Hash_Table.Buckets (Index) = Null_Node loop
            Index := Index + 1;
         end loop;

         declare
            Bucket : Node_Access renames Hash_Table.Buckets (Index);
         begin
            loop
               Node := Bucket;
               Bucket := Next (Bucket);
               Length := Length - 1;
               Free (Node);
               exit when Bucket = Null_Node;
            end loop;
         end;

      end loop;

   end Clear;


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

      LB : constant Buckets_Access := Left.Buckets;
      LL : constant Natural := Left.Length;
   begin
      Left.Buckets := Right.Buckets;
      Left.Length := Right.Length;

      Right.Buckets := LB;
      Right.Length := LL;
   end;



   procedure Delete
     (Hash_Table : in out Hash_Table_Type;
      Node       : in out Node_Access) is

      X, Prev : Node_Access;

      L : Natural renames Hash_Table.Length;

   begin

      if Node = Null_Node then
         return;
      end if;

      pragma Assert (L > 0);

      declare

         I : constant Hash_Type := Index (Hash_Table, Node);

         B : Node_Access renames Hash_Table.Buckets (I);
         pragma Assert (B /= Null_Node);

      begin

         if B = Node then

            B := Next (B);
            L := L - 1;

            Free (Node);
            Node := B;

            return;

         end if;

         pragma Assert (L > 1);

         Prev := B;

         loop

            X := Next (Prev);
            pragma Assert (X /= Null_Node);

            exit when X = Node;

            Prev := X;

         end loop;

         Set_Next (Node => Prev, Next => Next (Node));
         L := L - 1;

         Free (Node);
         Node := Next (Prev);

      end;

   end Delete;


--     procedure Delete
--       (Hash_Table : in out Hash_Table_Type;
--        First      : in out Node_Access;
--        Back       : in     Node_Access) is

--        X, N : Node_Access;

--        L : Natural renames Hash_Table.Length;

--     begin

--        if First = Null_Node
--          or else First = Back
--        then
--           return;
--        end if;

--        pragma Assert (L > 0);

--        declare
--           I : constant Positive := Index (Hash_Table, First);
--           B : Node_Access renames Hash_Table.Buckets (I);
--        begin
--           pragma Assert (B /= Null_Node);

--           if B = First then

--              loop
--                 B := Succ (B);
--                 L := L - 1;

--                 Free (First);
--                 First := B;

--                 if First = Back then
--                    return;
--                 end if;

--                 if First = Null_Node then
--                    return;
--                 end if;
--              end loop;

--           end if;

--           pragma Assert (L > 1);

--           N := B;

--           loop
--              X := Succ (N);
--              pragma Assert (X /= Null_Node);

--              exit when X = First;

--              N := X;
--           end loop;

--           loop
--              Set_Succ (Node => N, Succ => Succ (First));
--              L := L - 1;

--              Free (First);
--              First := Succ (N);

--              if First = Back then
--                 return;
--              end if;

--              if First = Null_Node then
--                 return;
--              end if;
--           end loop;
--        end;

--     end Delete;


   procedure Rehash
     (Hash_Table : in out Hash_Table_Type;
      New_Size   : in     Hash_Type) is

      B : Buckets_Access := Hash_Table.Buckets;
      N : constant Natural := Hash_Table.Length;

      Src_Index, Dst_Index : Hash_Type;

   begin

      Hash_Table.Buckets := new Buckets_Type (0 .. New_Size - 1);

      if N = 0 then
         Free (B);
         return;
      end if;

      Hash_Table.Length := 0;

      Src_Index := 0;

      loop

         while B (Src_Index) = Null_Node loop
            Src_Index := Src_Index + 1;
         end loop;

         declare
            Src_Node : Node_Access renames B (Src_Index);
            Dst_Node : Node_Access;
         begin

            loop

               Dst_Node := Src_Node;
               Src_Node := Next (Src_Node);

               begin
                  Dst_Index := Index (Hash_Table, Dst_Node);
               exception
                  when others =>
                     Free (B);  --this will orphan un-rehashed nodes
                     raise;
               end;

               declare
                  Dst_Next : Node_Access renames
                    Hash_Table.Buckets (Dst_Index);
               begin
                  Set_Next (Node => Dst_Node, Next => Dst_Next);
                  Dst_Next := Dst_Node;
               end;

               Hash_Table.Length := Hash_Table.Length + 1;

               exit when Src_Node = Null_Node;

            end loop;

         end;

         if Hash_Table.Length = N then
            Free (B);
            return;
         end if;

         Src_Index := Src_Index + 1;

      end loop;

   end Rehash;


   function Size (Hash_Table : Hash_Table_Type) return Natural is
   begin
      if Hash_Table.Buckets = null then
         return 0;
      end if;

      return Hash_Table.Buckets'Length;
   end;


   procedure Resize
     (Hash_Table : in out Hash_Table_Type;
      Length     : in     Natural) is

      New_Size : Hash_Type;

   begin

      if Length = 0 then
         return;
      end if;

      if Hash_Table.Buckets /= null
        and then Hash_Table.Buckets'Length >= Length
      then
         return;
      end if;

      New_Size := Prime_Numbers.To_Prime (Length);

      if Hash_Table.Buckets /= null
        and then New_Size <= Hash_Table.Buckets'Length
      then
         return;  --?
      end if;

      Rehash (Hash_Table, New_Size);

   end Resize;


   procedure Generic_Iteration (Hash_Table : Hash_Table_Type) is

      N : Integer'Base := Hash_Table.Length;

      Src_Index : Hash_Type;
      Src_Node  : Node_Access;

   begin

      if N = 0 then
         return;
      end if;

      Src_Index := 0;

      loop

         loop

            Src_Node := Hash_Table.Buckets (Src_Index);

            exit when Src_Node /= Null_Node;

            Src_Index := Src_Index + 1;

         end loop;

         loop

            Process (Src_Node);

            N := N - 1;

            if N = 0 then
               return;
            end if;

            Src_Node := Next (Src_Node);

            exit when Src_Node = Null_Node;

         end loop;

         Src_Index := Src_Index + 1;

      end loop;

   end Generic_Iteration;


   function First (Hash_Table : Hash_Table_Type)
     return Node_Access is

      Index : Hash_Type;

   begin

      if Hash_Table.Length = 0 then
         return Null_Node;
      end if;

      Index := 0;

      while Hash_Table.Buckets (Index) = Null_Node loop
         Index := Index + 1;
      end loop;

      return Hash_Table.Buckets (Index);

   end First;


   function Succ
     (Hash_Table : Hash_Table_Type;
      Node       : Node_Access) return Node_Access is

      Result : Node_Access := Next (Node);

   begin

      if Result /= Null_Node then
         return Result;
      end if;

      for I in Index (Hash_Table, Node) + 1 .. Hash_Table.Buckets'Last loop

         Result := Hash_Table.Buckets (I);

         if Result /= Null_Node then
            return Result;
         end if;

      end loop;

      return Null_Node;

   end Succ;


   package body Generic_Keys is

      function Index
        (Hash_Table : Hash_Table_Type;
         Key        : Key_Type) return Hash_Type is
      begin
         return Hash (Key) mod Hash_Table.Buckets'Length;
      end;

      procedure Generic_Conditional_Insert
        (Hash_Table : in out Hash_Table_Type;
         Key        : in     Key_Type;
         Node       :    out Node_Access;
         Success    :    out Boolean) is

         I : constant Hash_Type := Index (Hash_Table, Key);
         B : Node_Access renames Hash_Table.Buckets (I);
         L : Natural renames Hash_Table.Length;

         subtype Length_Subtype is
           Natural range 0 .. Integer'Pred (Natural'Last);

      begin

         if B = Null_Node then

            declare
               N : constant Length_Subtype := L;
            begin
               Node := New_Node (Next => Null_Node);
               Success := True;

               B := Node;
               L := N + 1;
            end;

            return;

         end if;

         Node := B;

         loop

            if Is_Equal_Key (Node, Key) then
               Success := False;
               return;
            end if;

            Node := Next (Node);

            exit when Node = Null_Node;

         end loop;

         declare
            N : constant Length_Subtype := L;
         begin
            Node := New_Node (Next => B);
            Success := True;

            B := Node;
            L := N + 1;
         end;

      end Generic_Conditional_Insert;


      procedure Generic_Unconditional_Insert
        (Hash_Table : in out Hash_Table_Type;
         Key        : in     Key_Type;
         Node       :    out Node_Access) is

         I : constant Hash_Type := Index (Hash_Table, Key);
         B : Node_Access renames Hash_Table.Buckets (I);
         L : Natural renames Hash_Table.Length;

         Prev_Node, Next_Node : Node_Access;

         subtype Length_Subtype is
           Natural range 0 .. Integer'Pred (Natural'Last);

      begin

         if B = Null_Node
           or else Is_Equal_Key (B, Key)
         then

            declare
               N : constant Length_Subtype := L;
            begin
               Node := New_Node (Next => B);

               B := Node;
               L := N + 1;
            end;

            return;

         end if;

         Prev_Node := B;

         loop

            Next_Node := Next (Prev_Node);

            exit when Next_Node = Null_Node;

            exit when Is_Equal_Key (Next_Node, Key);

            Prev_Node := Next_Node;

         end loop;

         declare
            N : constant Length_Subtype := L;
         begin
            Node := New_Node (Next => Next_Node);

            Set_Next (Node => Prev_Node, Next => Node);

            L := N + 1;
         end;

      end Generic_Unconditional_Insert;


      procedure Delete
        (Hash_Table : in out Hash_Table_Type;
         Key        : in     Key_Type) is

         X, Node : Node_Access;

         L : Natural renames Hash_Table.Length;

      begin

         if L = 0 then
            return;
         end if;

         declare

            I : constant Hash_Type := Index (Hash_Table, Key);
            B : Node_Access renames Hash_Table.Buckets (I);

         begin

            if B = Null_Node then
               return;
            end if;

            if Is_Equal_Key (B, Key) then

               loop

                  X := B;

                  B := Next (B);
                  L := L - 1;

                  Free (X);

                  if B = Null_Node then
                     return;
                  end if;

                  if not Is_Equal_Key (B, Key) then
                     return;
                  end if;

               end loop;

            end if;

            Node := B;

            loop

               X := Next (Node);

               if X = Null_Node then
                  return;
               end if;

               exit when Is_Equal_Key (X, Key);

               Node := X;

            end loop;

            loop

               Set_Next (Node => Node, Next => Next (X));
               L := L - 1;

               Free (X);

               X := Next (Node);

               if X = Null_Node then
                  return;
               end if;

               if not Is_Equal_Key (X, Key) then
                  return;
               end if;

            end loop;

         end;

      end Delete;



      function Find
        (Hash_Table : Hash_Table_Type;
         Key        : Key_Type) return Node_Access is

      begin

         if Hash_Table.Length = 0 then
            return Null_Node;
         end if;

         declare
            I : constant Hash_Type := Index (Hash_Table, Key);
            Node : Node_Access := Hash_Table.Buckets (I);
         begin
            while Node /= Null_Node loop
               if Is_Equal_Key (Node, Key) then
                  return Node;
               end if;

               Node := Next (Node);
            end loop;

            return Null_Node;
         end;

      end Find;


      procedure Equal_Range
        (Hash_Table  : in     Hash_Table_Type;
         Key         : in     Key_Type;
         First, Back :    out Node_Access) is

         I : Hash_Type;

      begin

         if Hash_Table.Length = 0 then
            return;
         end if;

         I := Index (Hash_Table, Key);

         First := Hash_Table.Buckets (I);

         loop

            if First = Null_Node then
               Back := Null_Node;
               return;
            end if;

            exit when Is_Equal_Key (First, Key);

            First := Next (First);

         end loop;

         Back := Next (First);

         while Back /= Null_Node
           and then Is_Equal_Key (Back, Key)
         loop
            Back := Next (Back);
         end loop;

      end Equal_Range;


      procedure Generic_Equal_Range
        (Hash_Table : in Hash_Table_Type;
         Key        : in Key_Type) is

         I : Hash_Type;
         Node : Node_Access;

      begin

         if Hash_Table.Length = 0 then
            return;
         end if;

         I := Index (Hash_Table, Key);
         Node := Hash_Table.Buckets (I);

         loop

            if Node = Null_Node then
               return;
            end if;

            exit when Is_Equal_Key (Node, Key);

            Node := Next (Node);

         end loop;

         loop

            Process (Node);

            Node := Next (Node);

            if Node = Null_Node then
               return;
            end if;

            if not Is_Equal_Key (Node, Key) then
               return;
            end if;

         end loop;

      end Generic_Equal_Range;


   end Generic_Keys;


end Charles.Hash_Tables;


