------------------------------------------------------------------------------
--                                                                          --
--                         GNAT LIBRARY COMPONENTS                          --
--                                                                          --
--                  ADA.CONTAINERS.INDEFINITE_HASHED_SETS                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--             Copyright (C) 2004 Free Software Foundation, Inc.            --
--                                                                          --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the  contents of the part following the private keyword. --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT 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 GNAT;  see file COPYING.  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.                                      --
--                                                                          --
-- This unit has originally being developed by Matthew J Heaney.            --
------------------------------------------------------------------------------

with Ada.Unchecked_Deallocation;

with Ada.Containers.Hash_Tables.Generic_Operations;
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);

with Ada.Containers.Hash_Tables.Generic_Keys;
pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);

with System;  use type System.Address;

with Ada.Containers.Prime_Numbers;

with Ada.Finalization;  use Ada.Finalization;

package body Ada.Containers.Indefinite_Hashed_Sets is

   type Element_Access is access Element_Type;

   type Node_Type is
      limited record
         Element : Element_Access;
         Next    : Node_Access;
      end record;

   function Hash_Node
     (Node : Node_Access) return Hash_Type;
   pragma Inline (Hash_Node);

   function Hash_Node
     (Node : Node_Access) return Hash_Type is
   begin
      return Hash (Node.Element.all);
   end Hash_Node;

   function Next
     (Node : Node_Access) return Node_Access;
   pragma Inline (Next);

   function Next
     (Node : Node_Access) return Node_Access is
   begin
      return Node.Next;
   end Next;

   procedure Set_Next
     (Node : Node_Access;
      Next : Node_Access);
   pragma Inline (Set_Next);

   procedure Set_Next
     (Node : Node_Access;
      Next : Node_Access) is
   begin
      Node.Next := Next;
   end Set_Next;

   function Equivalent_Keys
     (Key  : Element_Type;
      Node : Node_Access) return Boolean;
   pragma Inline (Equivalent_Keys);

   function Equivalent_Keys
     (Key  : Element_Type;
      Node : Node_Access) return Boolean is
   begin
      return Equivalent_Keys (Key, Node.Element.all);
   end Equivalent_Keys;

   function Copy_Node
     (Source : Node_Access) return Node_Access;
   pragma Inline (Copy_Node);

   function Copy_Node
     (Source : Node_Access) return Node_Access is

      Target : constant Node_Access :=
        new Node_Type'(Element => Source.Element,
                       Next    => null);
   begin
      return Target;
   end Copy_Node;


   procedure Free_Element is
      new Ada.Unchecked_Deallocation (Element_Type, Element_Access);

   procedure Free (X : in out Node_Access);

   procedure Free (X : in out Node_Access) is
      procedure Deallocate is
         new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
   begin
      if X /= null then
         Free_Element (X.Element);
         Deallocate (X);
      end if;
   end Free;

   package HT_Ops is
      new Hash_Tables.Generic_Operations
       (HT_Types          => HT_Types,
        Hash_Table_Type   => Set,
        Null_Node         => null,
        Hash_Node         => Hash_Node,
        Next              => Next,
        Set_Next          => Set_Next,
        Copy_Node         => Copy_Node,
        Free              => Free);

   package Element_Keys is
      new Hash_Tables.Generic_Keys
       (HT_Types  => HT_Types,
        HT_Type   => Set,
        Null_Node => null,
        Next      => Next,
        Set_Next  => Set_Next,
        Key_Type  => Element_Type,
        Hash      => Hash,
        Equivalent_Keys => Equivalent_Keys);


   procedure Adjust (Container : in out Set) renames HT_Ops.Adjust;

   procedure Finalize (Container : in out Set) renames HT_Ops.Finalize;


   function Find_Equal_Key
     (R_Set  : Set;
      L_Node : Node_Access) return Boolean;

   function Find_Equal_Key
     (R_Set  : Set;
      L_Node : Node_Access) return Boolean is

      R_Index : constant Hash_Type :=
        Element_Keys.Index (R_Set, L_Node.Element.all);

      R_Node  : Node_Access := R_Set.Buckets (R_Index);

   begin

      loop

         if R_Node = null then
            return False;
         end if;

         if L_Node.Element.all = R_Node.Element.all then
            return True;
         end if;

         R_Node := Next (R_Node);

      end loop;

   end Find_Equal_Key;

   function Is_Equal is
      new HT_Ops.Generic_Equal (Find_Equal_Key);

   function "=" (Left, Right : Set) return Boolean renames Is_Equal;


   function Length (Container : Set) return Count_Type is
   begin
      return Container.Length;
   end Length;


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


   procedure Clear (Container : in out Set) renames HT_Ops.Clear;


   function Element (Position : Cursor) return Element_Type is
   begin
      return Position.Node.Element.all;
   end Element;


   procedure Query_Element
     (Position : in Cursor;
      Process  : not null access procedure (Element : in Element_Type)) is
   begin
      Process (Position.Node.Element.all);
   end Query_Element;


--  TODO:
--     procedure Replace_Element (Container : in out Set;
--                                Position  : in     Node_Access;
--                                By        : in     Element_Type);

--     procedure Replace_Element (Container : in out Set;
--                                Position  : in     Node_Access;
--                                By        : in     Element_Type) is

--        Node : Node_Access := Position;

--     begin

--        if Equivalent_Keys (Node.Element.all, By) then

--           declare
--              X : Element_Access := Node.Element;
--           begin
--              Node.Element := new Element_Type'(By);
--              --
--              --  NOTE: If there's an exception here, then just
--              --  let it propagate.  We haven't modified the
--              --  state of the container, so there's nothing else
--              --  we need to do.

--              Free_Element (X);
--           end;

--           return;

--        end if;

--        HT_Ops.Delete_Node_Sans_Free (Container, Node);

--        begin
--           Free_Element (Node.Element);
--        exception
--           when others =>
--              Node.Element := null;  --  don't attempt to dealloc X.E again
--              Free (Node);
--              raise;
--        end;

--        begin
--           Node.Element := new Element_Type'(By);
--        exception
--           when others =>
--              Free (Node);
--              raise;
--        end;

--        declare
--           function New_Node (Next : Node_Access) return Node_Access;
--           pragma Inline (New_Node);

--           function New_Node (Next : Node_Access) return Node_Access is
--           begin
--              Node.Next := Next;
--              return Node;
--           end New_Node;

--           procedure Insert is
--              new Element_Keys.Generic_Conditional_Insert (New_Node);

--           Result  : Node_Access;
--           Success : Boolean;
--        begin
--           Insert
--             (HT      => Container,
--              Key     => Node.Element.all,
--              Node    => Result,
--              Success => Success);

--           if not Success then
--              Free (Node);
--              raise Program_Error;
--           end if;

--           pragma Assert (Result = Node);
--        end;

--     end Replace_Element;


--     procedure Replace_Element (Container : in out Set;
--                                Position  : in     Cursor;
--                                By        : in     Element_Type) is
--     begin

--        if Position.Container = null then
--           raise Constraint_Error;
--        end if;

--        if Position.Container /= Set_Access'(Container'Unchecked_Access) then
--           raise Program_Error;
--        end if;

--        Replace_Element (Container, Position.Node, By);

--     end Replace_Element;


   procedure Move (Target : in out Set;
                   Source : in out Set) renames HT_Ops.Move;


   procedure Insert (Container : in out Set;
                     New_Item  : in     Element_Type;
                     Position  :    out Cursor;
                     Inserted  :    out Boolean) is

      function New_Node (Next : Node_Access) return Node_Access;
      pragma Inline (New_Node);

      function New_Node (Next : Node_Access) return Node_Access is
         Element : Element_Access := new Element_Type'(New_Item);
      begin
         return new Node_Type'(Element, Next);
      exception
         when others =>
            Free_Element (Element);
            raise;
      end New_Node;

      procedure Insert is
        new Element_Keys.Generic_Conditional_Insert (New_Node);

   begin

      HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
      Insert (Container, New_Item, Position.Node, Inserted);
      Position.Container := Container'Unchecked_Access;

   end Insert;


   procedure Insert (Container : in out Set;
                     New_Item  : in     Element_Type) is

      Position : Cursor;
      Inserted : Boolean;

   begin

      Insert (Container, New_Item, Position, Inserted);

      if not Inserted then
         raise Constraint_Error;
      end if;

   end Insert;


   procedure Replace (Container : in out Set;
                      New_Item  : in     Element_Type) is

      Node : constant Node_Access :=
        Element_Keys.Find (Container, New_Item);

      X : Element_Access;

   begin

      if Node = null then
         raise Constraint_Error;
      end if;

      X := Node.Element;

      Node.Element := new Element_Type'(New_Item);

      Free_Element (X);

   end Replace;


   procedure Include (Container : in out Set;
                      New_Item  : in     Element_Type) is

      Position : Cursor;
      Inserted : Boolean;

      X : Element_Access;

   begin

      Insert (Container, New_Item, Position, Inserted);

      if not Inserted then

         X := Position.Node.Element;

         Position.Node.Element := new Element_Type'(New_Item);

         Free_Element (X);

      end if;

   end Include;


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

      X : Node_Access;

   begin

      Element_Keys.Delete_Key_Sans_Free (Container, Item, X);

      if X = null then
         raise Constraint_Error;
      end if;

      Free (X);

   end Delete;


   procedure Exclude (Container : in out Set;
                      Item      : in     Element_Type) is

      X : Node_Access;

   begin

      Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
      Free (X);

   end Exclude;


   procedure Delete (Container : in out Set;
                     Position  : in out Cursor) is
   begin

      if Position = No_Element then
         return;
      end if;

      if Position.Container /= Set_Access'(Container'Unchecked_Access) then
         raise Program_Error;
      end if;

      HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
      Free (Position.Node);

      Position.Container := null;

   end Delete;


   procedure Union (Target : in out Set;
                    Source : in     Set) is

      procedure Process (Src_Node : in Node_Access);

      procedure Process (Src_Node : in Node_Access) is

         Src : Element_Type renames Src_Node.Element.all;

         function New_Node (Next : Node_Access) return Node_Access;
         pragma Inline (New_Node);

         function New_Node (Next : Node_Access) return Node_Access is
            Tgt : Element_Access := new Element_Type'(Src);
         begin
            return new Node_Type'(Tgt, Next);
         exception
            when others =>
               Free_Element (Tgt);
               raise;
         end New_Node;

         procedure Insert is
            new Element_Keys.Generic_Conditional_Insert (New_Node);

         Tgt_Node : Node_Access;
         Success  : Boolean;

      begin

         Insert (Target, Src, Tgt_Node, Success);

      end Process;

      procedure Iterate is
         new HT_Ops.Generic_Iteration (Process);

   begin

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

      HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);

      Iterate (Source);

   end Union;


   function Union (Left, Right : Set) return Set is

      Buckets : HT_Types.Buckets_Access;
      Length  : Count_Type;

   begin

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

      if Right.Length = 0 then
         return Left;
      end if;

      if Left.Length = 0 then
         return Right;
      end if;

      declare
         Size : constant Hash_Type :=
           Prime_Numbers.To_Prime (Left.Length + Right.Length);
      begin
         Buckets := new Buckets_Type (0 .. Size - 1);
      end;

      declare
         procedure Process (L_Node : Node_Access);

         procedure Process (L_Node : Node_Access) is
            I : constant Hash_Type :=
              Hash (L_Node.Element.all) mod Buckets'Length;
         begin
            Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
         end Process;

         procedure Iterate is
            new HT_Ops.Generic_Iteration (Process);
      begin
         Iterate (Left);
      exception
         when others =>
            HT_Ops.Free_Hash_Table (Buckets);
            raise;
      end;

      Length := Left.Length;

      declare
         procedure Process (Src_Node : Node_Access);

         procedure Process (Src_Node : Node_Access) is

            Src : Element_Type renames Src_Node.Element.all;

            I : constant Hash_Type :=
              Hash (Src) mod Buckets'Length;

            Tgt_Node : Node_Access := Buckets (I);

         begin

            while Tgt_Node /= null loop

               if Equivalent_Keys (Src, Tgt_Node.Element.all) then
                  return;
               end if;

               Tgt_Node := Next (Tgt_Node);

            end loop;

            declare
               Tgt : Element_Access := new Element_Type'(Src);
            begin
               Buckets (I) := new Node_Type'(Tgt, Buckets (I));
            exception
               when others =>
                  Free_Element (Tgt);
                  raise;
            end;

            Length := Length + 1;

         end Process;

         procedure Iterate is
            new HT_Ops.Generic_Iteration (Process);
      begin
         Iterate (Right);
      exception
         when others =>
            HT_Ops.Free_Hash_Table (Buckets);
            raise;
      end;

      return (Controlled with Buckets, Length);

   end Union;


   function Is_In
     (HT  : Set;
      Key : Node_Access) return Boolean;
   pragma Inline (Is_In);

   function Is_In
     (HT  : Set;
      Key : Node_Access) return Boolean is
   begin
      return Element_Keys.Find (HT, Key.Element.all) /= null;
   end Is_In;


   procedure Intersection (Target : in out Set;
                           Source : in     Set) is

      Tgt_Node : Node_Access;

   begin

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

      if Source.Length = 0 then
         Clear (Target);
         return;
      end if;

      --  TODO: optimize this to use an explicit
      --  loop instead of an active iterator
      --  (similar to how a passive iterator is
      --  implemented).
      --
      --  Another possibility is to test which
      --  set is smaller, and iterate over the
      --  smaller set.

      Tgt_Node := HT_Ops.First (Target);

      while Tgt_Node /= null loop

         if Is_In (Source, Tgt_Node) then

            Tgt_Node := HT_Ops.Next (Target, Tgt_Node);

         else

            declare
               X : Node_Access := Tgt_Node;
            begin
               Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
               HT_Ops.Delete_Node_Sans_Free (Target, X);
               Free (X);
            end;

         end if;

      end loop;

   end Intersection;


   function Intersection (Left, Right : Set) return Set is

      Buckets : HT_Types.Buckets_Access;
      Length  : Count_Type;

   begin

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

      Length := Count_Type'Min (Left.Length, Right.Length);

      if Length = 0 then
         return Empty_Set;
      end if;

      declare
         Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
      begin
         Buckets := new Buckets_Type (0 .. Size - 1);
      end;

      Length := 0;

      declare
         procedure Process (L_Node : Node_Access);

         procedure Process (L_Node : Node_Access) is
         begin
            if Is_In (Right, L_Node) then

               declare
                  I : constant Hash_Type :=
                    Hash (L_Node.Element.all) mod Buckets'Length;
               begin
                  Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
               end;

               Length := Length + 1;

            end if;
         end Process;

         procedure Iterate is
            new HT_Ops.Generic_Iteration (Process);
      begin
         Iterate (Left);
      exception
         when others =>
            HT_Ops.Free_Hash_Table (Buckets);
            raise;
      end;

      return (Controlled with Buckets, Length);

   end Intersection;


   procedure Difference (Target : in out Set;
                         Source : in     Set) is


      Tgt_Node : Node_Access;

   begin

      if Target'Address = Source'Address then
         Clear (Target);
         return;
      end if;

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

      --  TODO: As I noted above, this can be
      --  written in terms of a loop instead as
      --  active-iterator style, sort of like a
      --  passive iterator.

      Tgt_Node := HT_Ops.First (Target);

      while Tgt_Node /= null loop

         if Is_In (Source, Tgt_Node) then

            declare
               X : Node_Access := Tgt_Node;
            begin
               Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
               HT_Ops.Delete_Node_Sans_Free (Target, X);
               Free (X);
            end;

         else

            Tgt_Node := HT_Ops.Next (Target, Tgt_Node);

         end if;

      end loop;

   end Difference;


   function Difference (Left, Right : Set) return Set is

      Buckets : HT_Types.Buckets_Access;
      Length  : Count_Type;

   begin

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

      if Left.Length = 0 then
         return Empty_Set;
      end if;

      if Right.Length = 0 then
         return Left;
      end if;

      declare
         Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
      begin
         Buckets := new Buckets_Type (0 .. Size - 1);
      end;

      Length := 0;

      declare
         procedure Process (L_Node : Node_Access);

         procedure Process (L_Node : Node_Access) is
         begin
            if not Is_In (Right, L_Node) then

               declare
                  I : constant Hash_Type :=
                    Hash (L_Node.Element.all) mod Buckets'Length;
               begin
                  Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
               end;

               Length := Length + 1;

            end if;
         end Process;

         procedure Iterate is
            new HT_Ops.Generic_Iteration (Process);
      begin
         Iterate (Left);
      exception
         when others =>
            HT_Ops.Free_Hash_Table (Buckets);
            raise;
      end;

      return (Controlled with Buckets, Length);

   end Difference;


   procedure Symmetric_Difference (Target : in out Set;
                                   Source : in     Set) is
   begin

      if Target'Address = Source'Address then
         Clear (Target);
         return;
      end if;

      HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);

      if Target.Length = 0 then

         declare
            procedure Process (Src_Node : Node_Access);

            procedure Process (Src_Node : Node_Access) is
               E : Element_Type renames Src_Node.Element.all;
               B : Buckets_Type renames Target.Buckets.all;
               I : constant Hash_Type := Hash (E) mod B'Length;
               N : Count_Type renames Target.Length;
            begin
               declare
                  X : Element_Access := new Element_Type'(E);
               begin
                  B (I) := new Node_Type'(X, B (I));
               exception
                  when others =>
                     Free_Element (X);
                     raise;
               end;

               N := N + 1;
            end Process;

            procedure Iterate is
               new HT_Ops.Generic_Iteration (Process);
         begin
            Iterate (Source);
         end;

      else

         declare
            procedure Process (Src_Node : Node_Access);

            procedure Process (Src_Node : Node_Access) is
               E : Element_Type renames Src_Node.Element.all;
               B : Buckets_Type renames Target.Buckets.all;
               I : constant Hash_Type := Hash (E) mod B'Length;
               N : Count_Type renames Target.Length;
            begin
               if B (I) = null then

                  declare
                     X : Element_Access := new Element_Type'(E);
                  begin
                     B (I) := new Node_Type'(X, null);
                  exception
                     when others =>
                        Free_Element (X);
                        raise;
                  end;

                  N := N + 1;

               elsif Equivalent_Keys (E, B (I).Element.all) then

                  declare
                     X : Node_Access := B (I);
                  begin
                     B (I) := B (I).Next;
                     N := N - 1;
                     Free (X);
                  end;

               else

                  declare
                     Prev : Node_Access := B (I);
                     Curr : Node_Access := Prev.Next;
                  begin
                     while Curr /= null loop
                        if Equivalent_Keys (E, Curr.Element.all) then
                           Prev.Next := Curr.Next;
                           N := N - 1;
                           Free (Curr);
                           return;
                        end if;

                        Prev := Curr;
                        Curr := Prev.Next;
                     end loop;

                     declare
                        X : Element_Access := new Element_Type'(E);
                     begin
                        B (I) := new Node_Type'(X, B (I));
                     exception
                        when others =>
                           Free_Element (X);
                           raise;
                     end;

                     N := N + 1;
                  end;

               end if;
            end Process;

            procedure Iterate is
               new HT_Ops.Generic_Iteration (Process);
         begin
            Iterate (Source);
         end;

      end if;

   end Symmetric_Difference;


   function Symmetric_Difference (Left, Right : Set) return Set is

      Buckets : HT_Types.Buckets_Access;
      Length  : Count_Type;

   begin

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

      if Right.Length = 0 then
         return Left;
      end if;

      if Left.Length = 0 then
         return Right;
      end if;

      declare
         Size : constant Hash_Type :=
           Prime_Numbers.To_Prime (Left.Length + Right.Length);
      begin
         Buckets := new Buckets_Type (0 .. Size - 1);
      end;

      Length := 0;

      declare
         procedure Process (L_Node : Node_Access);

         procedure Process (L_Node : Node_Access) is
         begin
            if not Is_In (Right, L_Node) then
               declare
                  E : Element_Type renames L_Node.Element.all;
                  I : constant Hash_Type := Hash (E) mod Buckets'Length;
               begin

                  declare
                     X : Element_Access := new Element_Type'(E);
                  begin
                     Buckets (I) := new Node_Type'(X, Buckets (I));
                  exception
                     when others =>
                        Free_Element (X);
                        raise;
                  end;

                  Length := Length + 1;
               end;
            end if;
         end Process;

         procedure Iterate is
            new HT_Ops.Generic_Iteration (Process);
      begin
         Iterate (Left);
      exception
         when others =>
            HT_Ops.Free_Hash_Table (Buckets);
            raise;
      end;

      declare
         procedure Process (R_Node : Node_Access);

         procedure Process (R_Node : Node_Access) is
         begin
            if not Is_In (Left, R_Node) then
               declare
                  E : Element_Type renames R_Node.Element.all;
                  I : constant Hash_Type := Hash (E) mod Buckets'Length;
               begin

                  declare
                     X : Element_Access := new Element_Type'(E);
                  begin
                     Buckets (I) := new Node_Type'(X, Buckets (I));
                  exception
                     when others =>
                        Free_Element (X);
                        raise;
                  end;

                  Length := Length + 1;

               end;
            end if;
         end Process;

         procedure Iterate is
            new HT_Ops.Generic_Iteration (Process);
      begin
         Iterate (Right);
      exception
         when others =>
            HT_Ops.Free_Hash_Table (Buckets);
            raise;
      end;

      return (Controlled with Buckets, Length);

   end Symmetric_Difference;


   function Is_Subset (Subset : Set;
                       Of_Set : Set) return Boolean is

      Subset_Node : Node_Access;

   begin

      if Subset'Address = Of_Set'Address then
         return True;
      end if;

      if Subset.Length > Of_Set.Length then
         return False;
      end if;

      --  TODO: rewrite this to loop in the
      --  style of a passive iterator.

      Subset_Node := HT_Ops.First (Subset);

      while Subset_Node /= null loop
         if not Is_In (Of_Set, Subset_Node) then
            return False;
         end if;

         Subset_Node := HT_Ops.Next (Subset, Subset_Node);
      end loop;

      return True;

   end Is_Subset;


   function Overlap (Left, Right : Set) return Boolean is

      Left_Node : Node_Access;

   begin

      if Right.Length = 0 then
         return False;
      end if;

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

      Left_Node := HT_Ops.First (Left);

      while Left_Node /= null loop
         if Is_In (Right, Left_Node) then
            return True;
         end if;

         Left_Node := HT_Ops.Next (Left, Left_Node);
      end loop;

      return False;

   end Overlap;


   function Find (Container : Set;
                  Item      : Element_Type) return Cursor is

      Node : constant Node_Access := Element_Keys.Find (Container, Item);

   begin

      if Node = null then
         return No_Element;
      end if;

      return Cursor'(Container'Unchecked_Access, Node);

   end Find;


   function Contains (Container : Set;
                      Item      : Element_Type) return Boolean is
   begin
      return Find (Container, Item) /= No_Element;
   end Contains;


   function First (Container : Set) return Cursor is
      Node : constant Node_Access := HT_Ops.First (Container);
   begin
      if Node = null then
         return No_Element;
      end if;

      return Cursor'(Container'Unchecked_Access, Node);
   end First;


--     function First_Element (Container : Set) return Element_Type is
--        Node : constant Node_Access := HT_Ops.First (Container);
--     begin
--        return Node.Element;
--     end First_Element;


   function Next (Position : Cursor) return Cursor is
   begin
      if Position.Container = null
        or else Position.Node = null
      then
         return No_Element;
      end if;

      declare
         S : Set renames Position.Container.all;
         Node : constant Node_Access := HT_Ops.Next (S, Position.Node);
      begin
         if Node = null then
            return No_Element;
         end if;

         return Cursor'(Position.Container, Node);
      end;
   end Next;


   procedure Next (Position : in out Cursor) is
   begin
      Position := Next (Position);
   end Next;


   function Has_Element (Position : Cursor) return Boolean is
   begin
      if Position.Container = null then
         return False;
      end if;

      if Position.Node = null then
         return False;
      end if;

      return True;
   end Has_Element;


   function Equivalent_Keys (Left, Right : Cursor)
     return Boolean is
   begin
      return Equivalent_Keys (Left.Node.Element.all, Right.Node.Element.all);
   end Equivalent_Keys;


   function Equivalent_Keys (Left  : Cursor;
                             Right : Element_Type)
    return Boolean is
   begin
      return Equivalent_Keys (Left.Node.Element.all, Right);
   end Equivalent_Keys;


   function Equivalent_Keys (Left  : Element_Type;
                             Right : Cursor)
    return Boolean is
   begin
      return Equivalent_Keys (Left, Right.Node.Element.all);
   end Equivalent_Keys;


   procedure Iterate
     (Container : in Set;
      Process   : not null access procedure (Position : in Cursor)) is

      procedure Process_Node (Node : in Node_Access);
      pragma Inline (Process_Node);

      procedure Process_Node (Node : in Node_Access) is
      begin
         Process (Cursor'(Container'Unchecked_Access, Node));
      end Process_Node;

      procedure Iterate is
         new HT_Ops.Generic_Iteration (Process_Node);
   begin
      Iterate (Container);
   end Iterate;


   function Capacity (Container : Set) return Count_Type
     renames HT_Ops.Capacity;

   procedure Reserve_Capacity
     (Container : in out Set;
      Capacity  : in     Count_Type)
     renames HT_Ops.Ensure_Capacity;


   procedure Write_Node
     (Stream : access Root_Stream_Type'Class;
      Node   : in     Node_Access);
   pragma Inline (Write_Node);

   procedure Write_Node
     (Stream : access Root_Stream_Type'Class;
      Node   : in     Node_Access) is
   begin
      Element_Type'Output (Stream, Node.Element.all);
   end Write_Node;

   procedure Write_Nodes is
      new HT_Ops.Generic_Write (Write_Node);

   procedure Write
     (Stream    : access Root_Stream_Type'Class;
      Container : in     Set) renames Write_Nodes;


   function Read_Node (Stream : access Root_Stream_Type'Class)
     return Node_Access;
   pragma Inline (Read_Node);

   function Read_Node (Stream : access Root_Stream_Type'Class)
     return Node_Access is

      X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
   begin
      return new Node_Type'(X, null);
   exception
      when others =>
         Free_Element (X);
         raise;
   end Read_Node;

   procedure Read_Nodes is
      new HT_Ops.Generic_Read (Read_Node);

   procedure Read
     (Stream    : access Root_Stream_Type'Class;
      Container :    out Set) renames Read_Nodes;


   package body Generic_Keys is

      function Equivalent_Keys (Left  : Cursor;
                                Right : Key_Type)
        return Boolean is
      begin
         return Equivalent_Keys (Right, Left.Node.Element.all);
      end Equivalent_Keys;

      function Equivalent_Keys (Left  : Key_Type;
                                Right : Cursor)
        return Boolean is
      begin
         return Equivalent_Keys (Left, Right.Node.Element.all);
      end Equivalent_Keys;

      function Equivalent_Keys
        (Key  : Key_Type;
         Node : Node_Access) return Boolean;
      pragma Inline (Equivalent_Keys);

      function Equivalent_Keys
        (Key  : Key_Type;
         Node : Node_Access) return Boolean is
      begin
         return Equivalent_Keys (Key, Node.Element.all);
      end Equivalent_Keys;

      package Key_Keys is
         new Hash_Tables.Generic_Keys
          (HT_Types  => HT_Types,
           HT_Type   => Set,
           Null_Node => null,
           Next      => Next,
           Set_Next  => Set_Next,
           Key_Type  => Key_Type,
           Hash      => Hash,
           Equivalent_Keys => Equivalent_Keys);


      function Find (Container : Set;
                     Key       : Key_Type)
         return Cursor is

         Node : constant Node_Access :=
           Key_Keys.Find (Container, Key);

      begin

         if Node = null then
            return No_Element;
         end if;

         return Cursor'(Container'Unchecked_Access, Node);

      end Find;


      function Contains (Container : Set;
                         Key       : Key_Type) return Boolean is
      begin
         return Find (Container, Key) /= No_Element;
      end Contains;


      function Element (Container : Set;
                        Key       : Key_Type)
        return Element_Type is

         Node : constant Node_Access := Key_Keys.Find (Container, Key);
      begin
         return Node.Element.all;
      end Element;


      function Key (Position : Cursor) return Key_Type is
      begin
         return Key (Position.Node.Element.all);
      end Key;


--  TODO:
--        procedure Replace (Container : in out Set;
--                           Key       : in     Key_Type;
--                           New_Item  : in     Element_Type) is

--           Node : constant Node_Access :=
--             Key_Keys.Find (Container, Key);

--        begin

--           if Node = null then
--              raise Constraint_Error;
--           end if;

--           Replace_Element (Container, Node, New_Item);

--        end Replace;


      procedure Delete (Container : in out Set;
                        Key       : in     Key_Type) is

         X : Node_Access;

      begin

         Key_Keys.Delete_Key_Sans_Free (Container, Key, X);

         if X = null then
            raise Constraint_Error;
         end if;

         Free (X);

      end Delete;


      procedure Exclude (Container : in out Set;
                         Key       : in     Key_Type) is

         X : Node_Access;

      begin

         Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
         Free (X);

      end Exclude;


      procedure Checked_Update_Element
        (Container : in out Set;
         Position  : in     Cursor;
         Process   : not null access
           procedure (Element : in out Element_Type)) is

      begin

         if Position.Container = null then
            raise Constraint_Error;
         end if;

         if Position.Container /= Set_Access'(Container'Unchecked_Access) then
            raise Program_Error;
         end if;

         declare
            Old_Key : Key_Type renames Key (Position.Node.Element.all);
         begin
            Process (Position.Node.Element.all);

            if Equivalent_Keys (Old_Key, Position.Node.Element.all) then
               return;
            end if;
         end;

         declare
            function New_Node (Next : Node_Access) return Node_Access;
            pragma Inline (New_Node);

            function New_Node (Next : Node_Access) return Node_Access is
            begin
               Position.Node.Next := Next;
               return Position.Node;
            end New_Node;

            procedure Insert is
               new Key_Keys.Generic_Conditional_Insert (New_Node);

            Result  : Node_Access;
            Success : Boolean;
         begin
            HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);

            Insert
              (HT      => Container,
               Key     => Key (Position.Node.Element.all),
               Node    => Result,
               Success => Success);

            if not Success then
               declare
                  X : Node_Access := Position.Node;
               begin
                  Free (X);
               end;

               raise Program_Error;
            end if;

            pragma Assert (Result = Position.Node);
         end;

      end Checked_Update_Element;

   end Generic_Keys;

end Ada.Containers.Indefinite_Hashed_Sets;