------------------------------------------------------------------------------
--                                                                          --
--                   AI-302 Reference Implementation                        --
--                                                                          --
--              Copyright (C) 2003-2004 Matthew J Heaney                    --
--                                                                          --
-- The AI-302 Reference Implementation ("AI-302") 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.  AI-302 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       --
-- AI-302;  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.                                       --
--                                                                          --
-- The AI-302 Reference Implementation is maintained by Matthew J Heaney.   --
--                                                                          --
-- mailto:matthewjheaney@earthlink.net                                      --
-- http://home.earthlink.net/~matthewjheaney/index.html                     --
-- http://charles.tigris.org/                                               --
--                                                                          --
------------------------------------------------------------------------------

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

package body Ada.Containers.Hash_Tables.Generic_Operations is

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

   procedure Free_Hash_Table (Buckets : in out Buckets_Access) is

      Node : Node_Access;

   begin

      if Buckets = null then
         return;
      end if;

      for I in Buckets'Range loop

         while Buckets (I) /= null loop

            Node := Buckets (I);

            Buckets (I) := Next (Node);

            Free (Node);

         end loop;

      end loop;

      Free (Buckets);

   end Free_Hash_Table;


   function Index
     (Buckets : Buckets_Type;
      Node    : Node_Access) return Hash_Type is
   begin
      return Hash_Node (Node) mod Buckets'Length;
   end Index;


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


   procedure Adjust (HT : in out Hash_Table_Type) is

      Src_Buckets : constant Buckets_Access := HT.Buckets;

      N : constant Count_Type := HT.Length;

      Src_Node, Dst_Prev : Node_Access;

   begin

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

      if N = 0 then
         return;
      end if;

      HT.Buckets := new Buckets_Type (Src_Buckets'Range);
      --
      --  NOTE:
      --  I suppose we have to duplicate the Size (Src), too, in order
      --  to guarantee that
      --    Dst := Src;
      --    Dst = Src is true
      --  The only quirk is that we depend on the hash value of a dst key
      --  to be the same as the src key from which it was copied.
      --  If we relax the requirement that the hash value must be the
      --  same, then of course we can't guarantee that following
      --  assignment that Dst = Src is true.
      --  END NOTE.

      for Src_Index in Src_Buckets'Range loop

         Src_Node := Src_Buckets (Src_Index);

         if Src_Node /= null then  -- I wish Ada had a continue ...

            declare
               Dst_Node : constant Node_Access := Copy_Node (Src_Node);

               --   See note above.
               pragma Assert (Index (HT, Dst_Node) = Src_Index);
            begin
               HT.Buckets (Src_Index) := Dst_Node;
               HT.Length := HT.Length + 1;

               Dst_Prev := Dst_Node;
            end;

            Src_Node := Next (Src_Node);

            while Src_Node /= null loop

               declare
                  Dst_Node : constant Node_Access := Copy_Node (Src_Node);

                  --  See note above.
                  pragma Assert (Index (HT, Dst_Node) = Src_Index);
               begin
                  Set_Next (Node => Dst_Prev, Next => Dst_Node);
                  HT.Length := HT.Length + 1;

                  Dst_Prev := Dst_Node;
               end;

               Src_Node := Next (Src_Node);

            end loop;

         end if;

      end loop;

      pragma Assert (HT.Length = N);

   end Adjust;


   procedure Finalize (HT : in out Hash_Table_Type) is
   begin
      Clear (HT);
      Free (HT.Buckets);
   end Finalize;


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

      L_Index : Hash_Type;
      L_Node  : Node_Access;

      N : Count_Type;

   begin

      if L'Address = R'Address then
         return True;
      end if;

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

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

      L_Index := 0;

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

      N := L.Length;

      loop

         if not Find (HT => R, Key => L_Node) then
            return False;
         end if;

         N := N - 1;

         L_Node := Next (L_Node);

         if L_Node = null then

            if N = 0 then
               return True;
            end if;

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

         end if;

      end loop;

   end Generic_Equal;


   procedure Clear (HT : in out Hash_Table_Type) is
      I : Hash_Type;
      X : Node_Access;
   begin

      if HT.Busy > 0 then
         raise Program_Error;
      end if;

      I := 0;

      while HT.Length > 0 loop

         while HT.Buckets (I) = null loop
            I := I + 1;
         end loop;

         declare
            B : Node_Access renames HT.Buckets (I);
         begin
            loop
               X := B;
               B := Next (B);

               HT.Length := HT.Length - 1;

               Free (X);

               exit when B = null;
            end loop;
         end;

      end loop;

   end Clear;


   procedure Move (Target, Source : in out Hash_Table_Type) is
   begin

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

      if Source.Busy > 0 then
         raise Program_Error;
      end if;

      Clear (Target);

      --  Free (Target.Buckets);
      --  NOTE: instead of deallocating this array, let's just give
      --  it to the Source.  This will save him the trouble of
      --  having to immediately reallocate another buckets array.

      declare
         Buckets : constant Buckets_Access := Target.Buckets;
      begin
         Target.Buckets := Source.Buckets;
         Source.Buckets := Buckets;
      end;

      Target.Length := Source.Length;
      Source.Length := 0;

   end Move;


   function Capacity (HT : Hash_Table_Type)
      return Count_Type is
   begin
      if HT.Buckets = null then
         return 0;
      end if;

      return HT.Buckets'Length;
   end Capacity;


   procedure Reserve_Capacity
     (HT : in out Hash_Table_Type;
      N  : in     Count_Type) is

      NN : Hash_Type;

   begin

      if HT.Buckets = null then

         if N > 0 then
            NN := Prime_Numbers.To_Prime (N);
            HT.Buckets := new Buckets_Type (0 .. NN - 1);
         end if;

         return;

      end if;

      if HT.Length = 0 then

         if N = 0 then
            Free (HT.Buckets);
            return;
         end if;

         if N = HT.Buckets'Length then
            return;
         end if;

         NN := Prime_Numbers.To_Prime (N);

         if NN = HT.Buckets'Length then
            return;
         end if;

         declare
            X : Buckets_Access := HT.Buckets;
         begin
            HT.Buckets := new Buckets_Type (0 .. NN - 1);
            Free (X);
         end;

         return;

      end if;

      if N = HT.Buckets'Length then
         return;
      end if;

      if N < HT.Buckets'Length then

         if HT.Length >= HT.Buckets'Length then
            return;
         end if;

         NN := Prime_Numbers.To_Prime (HT.Length);

         if NN >= HT.Buckets'Length then
            return;
         end if;

      else

         NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length));

         if NN = HT.Buckets'Length then -- can't expand any more
            return;
         end if;

      end if;

      if HT.Busy > 0 then
         raise Program_Error;
      end if;

      Rehash :
      declare
         Dst_Buckets : Buckets_Access :=
           new Buckets_Type (0 .. NN - 1);

         Src_Buckets : Buckets_Access := HT.Buckets;

         L : Count_Type renames HT.Length;
         LL : constant Count_Type := L;
      begin
         --  we might want to change this to iter from 1 .. L instead
         --
         for Src_Index in Src_Buckets'Range loop

            declare
               Src_Bucket : Node_Access renames Src_Buckets (Src_Index);
            begin

               while Src_Bucket /= null loop

                  declare
                     Src_Node : constant Node_Access := Src_Bucket;

                     Dst_Index : constant Hash_Type :=
                       Index (Dst_Buckets.all, Src_Node);

                     Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index);
                  begin
                     Src_Bucket := Next (Src_Node);

                     Set_Next (Src_Node, Dst_Bucket);

                     Dst_Bucket := Src_Node;
                  end;

                  pragma Assert (L > 0);
                  L := L - 1;

               end loop;

            exception
               when others =>

                  --  I don't think we can deallocate the nodes,
                  --  because they may be designated by outstanding
                  --  iterators.  Which means they're now lost...
                  --
                  --                 for J in NB'Range loop
                  --
                  --                    declare
                  --                       Dst : Node_Access renames NB (J);
                  --                       X   : Node_Access;
                  --                    begin
                  --                       while Dst /= null loop
                  --                          X := Dst;
                  --                          Dst := Succ (Dst);
                  --                          Free (X);
                  --                       end loop;
                  --                    end;
                  --
                  --                 end loop;

                  --  NOTE: 15 Apr 2005
                  --  What I'll do instead is go ahead and deallocate the
                  --  nodes, since we now vet the cursors, and because we
                  --  modify the state of a node enough to detect mischief.
                  --  ENDNOTE.

                  for Dst_Index in Dst_Buckets'Range loop
                     declare
                        B : Node_Access renames Dst_Buckets (Dst_Index);
                        X : Node_Access;
                     begin
                        while B /= null loop
                           X := B;
                           B := Next (X);
                           Free (X);
                        end loop;
                     end;
                  end loop;

                  Free (Dst_Buckets);

                  raise Program_Error;

            end;

            --  exit when L = 0;
            --  need to bother?

         end loop;

         pragma Assert (L = 0);

         HT.Buckets := Dst_Buckets;
         HT.Length := LL;

         Free (Src_Buckets);
      end Rehash;

   end Reserve_Capacity;


   procedure Delete_Node_Sans_Free
     (HT : in out Hash_Table_Type;
      X  : in     Node_Access) is

      pragma Assert (X /= null);

      I : Hash_Type;
      Prev, Curr : Node_Access;

   begin

      if HT.Length = 0 then
         raise Program_Error;
      end if;

      I := Index (HT, X);

      Prev := HT.Buckets (I);

      if Prev = null then
         raise Program_Error;
      end if;

      if Prev = X then
         HT.Buckets (I) := Next (Prev);
         HT.Length := HT.Length - 1;
         return;
      end if;

      if HT.Length = 1 then
         raise Program_Error;
      end if;

      loop

         Curr := Next (Prev);

         if Curr = null then
            raise Program_Error;
         end if;

         if Curr = X then
            Set_Next (Node => Prev, Next => Next (Curr));
            HT.Length := HT.Length - 1;
            return;
         end if;

         Prev := Curr;

      end loop;

   end Delete_Node_Sans_Free;


   function First (HT : Hash_Table_Type)
     return Node_Access is

      I : Hash_Type;

   begin

      if HT.Length = 0 then
         return null;
      end if;

      I := HT.Buckets'First;

      loop

         if HT.Buckets (I) /= null then
            return HT.Buckets (I);
         end if;

         I := I + 1;

      end loop;

   end First;


   function Next (HT   : Hash_Table_Type;
                  Node : Node_Access)
     return Node_Access is

      Result : Node_Access := Next (Node);

   begin

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

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

         Result := HT.Buckets (I);

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

      end loop;

      return null;

   end Next;


   procedure Generic_Iteration (HT : in Hash_Table_Type) is

      Node : Node_Access;

   begin

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

      for I in HT.Buckets'Range loop

         Node := HT.Buckets (I);

         while Node /= null loop
            Process (Node);
            Node := Next (Node);
         end loop;

      end loop;

   end Generic_Iteration;


   procedure Generic_Write
     (Stream : access Root_Stream_Type'Class;
      HT     : in     Hash_Table_Type) is

      M : Count_Type'Base;
      X : Node_Access;

   begin

      if HT.Buckets = null then
         Hash_Type'Write (Stream, 0);
      else
         Hash_Type'Write (Stream, HT.Buckets'Last);
      end if;

      Count_Type'Base'Write (Stream, HT.Length);

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

      for I in HT.Buckets'Range loop

         X := HT.Buckets (I);

         if X /= null then

            M := 1;

            loop

               X := Next (X);

               exit when X = null;

               M := M + 1;

            end loop;

            Hash_Type'Write (Stream, I);
            Count_Type'Base'Write (Stream, M);

            X := HT.Buckets (I);

            for J in Count_Type range 1 .. M loop

               Write (Stream, X);
               X := Next (X);

            end loop;

            pragma Assert (X = null);

         end if;

      end loop;

   end Generic_Write;



   procedure Generic_Read
     (Stream : access Root_Stream_Type'Class;
      HT     :    out Hash_Table_Type) is

      X, Y : Node_Access;

      Last, I : Hash_Type;
      N, M    : Count_Type'Base;

   begin

      Clear (HT);

      Hash_Type'Read (Stream, Last);

      Count_Type'Base'Read (Stream, N);
      pragma Assert (N >= 0);

      if N = 0 then
         return;
      end if;

--    NOTE: this won't work, since the loop below assumes that
--    the buckets array length is preserved.
--        if HT.Buckets = null
--          or else HT.Buckets'Length < N
--        then
--           Free (HT.Buckets);
--           --  TODO: alloc To_Prime (N) or Last elems?
--           HT.Buckets := new Buckets_Type (0 .. Last);
--        end if;
--    so for now:

      if HT.Buckets = null
        or else HT.Buckets'Last /= Last
      then
         Free (HT.Buckets);
         HT.Buckets := new Buckets_Type (0 .. Last);
      end if;

      loop

         Hash_Type'Read (Stream, I);
         pragma Assert (I in HT.Buckets'Range);
         pragma Assert (HT.Buckets (I) = null);

         Count_Type'Base'Read (Stream, M);
         pragma Assert (M >= 1);
         pragma Assert (M <= N);

         HT.Buckets (I) := New_Node (Stream);
         pragma Assert (HT.Buckets (I) /= null);
         pragma Assert (Next (HT.Buckets (I)) = null);

         Y := HT.Buckets (I);

         HT.Length := HT.Length + 1;

         for J in Count_Type range 2 .. M loop

            X := New_Node (Stream);
            pragma Assert (X /= null);
            pragma Assert (Next (X) = null);

            Set_Next (Node => Y, Next => X);
            Y := X;

            HT.Length := HT.Length + 1;

         end loop;

         N := N - M;

         exit when N = 0;

      end loop;

   end Generic_Read;


end Ada.Containers.Hash_Tables.Generic_Operations;


