File : bc-containers-sets.adb


-- Copyright (C) 1994-1999 Grady Booch and Simon Wright.
-- All Rights Reserved.
--
--      This program is free software; you can redistribute it
--      and/or modify it under the terms of the Ada Community
--      License which comes with this Library.
--
--      This program 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 Ada Community License for more details.
--      You should have received a copy of the Ada Community
--      License with this library, in the file named "Ada Community
--      License" or "ACL". If not, contact the author of this library
--      for a copy.
--

-- $Id: bc-containers-sets.adb,v 1.2.2.1 1999/12/05 18:44:12 simon Exp $

with BC.Support.Exceptions;
with System.Address_To_Access_Conversions;

package body BC.Containers.Sets is

  package BSE renames BC.Support.Exceptions;
  procedure Assert
  is new BSE.Assert ("BC.Containers.Sets");

  function Are_Equal (L, R : Set'Class) return Boolean is
    It : Iterator := New_Iterator (L);
  begin
    -- XXX left out the optimisation which checks whether L, R are
    -- identical.
    if Cardinality (L) /= Cardinality (R) then
      return False;
    end if;
    while not Is_Done (It) loop
      if not Exists (R, Current_Item (It)) then
        return False;
      end if;
       Next (It);
    end loop;
    return True;
  end Are_Equal;

  procedure Add (S : in out Set'Class; I : Item) is
    Dummy : Boolean;
  begin
    Add (S, I, Added => Dummy);
  end Add;

  procedure Union (S : in out Set'Class; O : Set'Class) is
    It : Iterator := New_Iterator (O);
  begin
    -- XXX left out the optimisation which checks whether L, R are
    -- identical.
    while not Is_Done (It) loop
      declare
        This_Item : Item renames Current_Item (It);
      begin
        if not Is_Member (S, This_Item) then
          Attach (S, This_Item);
        end if;
      end;
      Next (It);
    end loop;
  end Union;

  procedure Intersection (S : in out Set'Class; O : Set'Class) is
    It : Iterator := New_Iterator (S);
  begin
    -- XXX left out the optimisation which checks whether L, R are
    -- identical.
    while not Is_Done (It) loop
      declare
        This_Item : Item renames Current_Item (It);
      begin
        if not Exists (O, This_Item) then
          Detach (S, This_Item);
        else
          Next (It);
        end if;
      end;
    end loop;
  end Intersection;

  procedure Difference (S : in out Set'Class; O : Set'Class) is
    It : Iterator := New_Iterator (O);
  begin
    -- XXX left out the optimisation which checks whether L, R are
    -- identical.
    while not Is_Done (It) loop
      declare
        This_Item : Item renames Current_Item (It);
      begin
        if Exists (S, This_Item) then
          Detach (S, This_Item);
        end if;
      end;
      Next (It);
    end loop;
  end Difference;

  function Is_Subset (S : Set'Class; O : Set'Class) return Boolean is
    It : Iterator := New_Iterator (S);
  begin
    -- XXX left out the optimisation which checks whether L, R are
    -- identical.
    if Cardinality (S) > Cardinality (O) then
      return False;
    end if;
    while not Is_Done (It) loop
      if not Exists (O, Current_Item (It)) then
        return False;
      end if;
      Next (It);
    end loop;
    return True;
  end Is_Subset;

  function Is_Proper_Subset (S : Set'Class; O : Set'Class) return Boolean is
    It : Iterator := New_Iterator (S);
  begin
    -- XXX left out the optimisation which checks whether L, R are
    -- identical.
    if Cardinality (S) >= Cardinality (O) then
      return False;
    end if;
    while not Is_Done (It) loop
      if not Exists (O, Current_Item (It)) then
        return False;
      end if;
      Next (It);
    end loop;
    return True;
  end Is_Proper_Subset;

  procedure Initialize (It : in out Set_Iterator) is
  begin
    It.Index := 0;
    if Cardinality (It.S.all) = 0 then
      It.Bucket_Index := 0;
    else
      It.Bucket_Index := 1;
      while It.Bucket_Index <= Number_Of_Buckets (It.S.all) loop
        if Length (It.S.all, It.Bucket_Index) > 0 then
          It.Index := 1;
          exit;
        end if;
        It.Bucket_Index := It.Bucket_Index + 1;
      end loop;
    end if;
  end Initialize;

  procedure Reset (It : in out Set_Iterator) is
  begin
    It.Index := 0;
    if Cardinality (It.S.all) = 0 then
      It.Bucket_Index := 0;
    else
      It.Bucket_Index := 1;
      while It.Bucket_Index <= Number_Of_Buckets (It.S.all) loop
        if Length (It.S.all, It.Bucket_Index) > 0 then
          It.Index := 1;
          exit;
        end if;
        It.Bucket_Index := It.Bucket_Index + 1;
      end loop;
    end if;
  end Reset;

  procedure Next (It : in out Set_Iterator) is
  begin
    if It.Bucket_Index <= Number_Of_Buckets (It.S.all) then
      if It.Index < Length (It.S.all, It.Bucket_Index) then
        It.Index := It.Index + 1;
      else
        It.Bucket_Index := It.Bucket_Index + 1;
        It.Index := 0;
        while It.Bucket_Index <= Number_Of_Buckets (It.S.all) loop
          if Length (It.S.all, It.Bucket_Index) > 0 then
            It.Index := 1;
            exit;
          end if;
          It.Bucket_Index := It.Bucket_Index + 1;
        end loop;
      end if;
    end if;
  end Next;

  function Is_Done (It : Set_Iterator) return Boolean is
  begin
    if It.Bucket_Index = 0
       or else It.Bucket_Index > Number_Of_Buckets (It.S.all) then
      return True;
    end if;
    if It.Index <= Length (It.S.all, It.Bucket_Index) then
      return False;
    end if;
    declare
      package Conversions is new System.Address_To_Access_Conversions
         (Set_Iterator'Class);
      P : Conversions.Object_Pointer := Conversions.To_Pointer (It'Address);
    begin
      P.Bucket_Index := P.Bucket_Index + 1;
      P.Index := 0;
      while P.Bucket_Index <= Number_Of_Buckets (P.S.all) loop
        if Length (P.S.all, P.Bucket_Index) > 0 then
          P.Index := 1;
          return False;
        end if;
        P.Bucket_Index := P.Bucket_Index + 1;
      end loop;
    end;
    return True;
  end Is_Done;

  function Current_Item (It : Set_Iterator) return Item is
  begin
    if Is_Done (It) then
      raise BC.Not_Found;
    end if;
    return Item_At (It.S.all, It.Bucket_Index, It.Index).all;
  end Current_Item;

  function Current_Item (It : Set_Iterator) return Item_Ptr is
    -- XXX this should probably not be permitted!
  begin
    if Is_Done (It) then
      raise BC.Not_Found;
    end if;
    return Item_At (It.S.all, It.Bucket_Index, It.Index);
  end Current_Item;

  procedure Delete_Item_At (It : Set_Iterator) is
  begin
    if Is_Done (It) then
      raise BC.Not_Found;
    end if;
    raise BC.Not_Yet_Implemented;
  end Delete_Item_At;

  -- Subprograms to be overridden

  procedure Attach (S : in out Set; I : Item) is
  begin
    raise Should_Have_Been_Overridden;
  end Attach;

  procedure Detach (S : in out Set; I : Item) is
  begin
    raise Should_Have_Been_Overridden;
  end Detach;

  function Number_Of_Buckets (S : Set) return Natural is
  begin
    raise Should_Have_Been_Overridden;
    return 0;
  end Number_Of_Buckets;

  function Length (S : Set; Bucket : Positive) return Natural is
  begin
    raise Should_Have_Been_Overridden;
    return 0;
  end Length;

  function Exists (S : Set; I : Item) return Boolean is
  begin
    raise Should_Have_Been_Overridden;
    return False;
  end Exists;

  function Item_At (S : Set; Bucket, Index : Positive) return Item_Ptr is
  begin
    raise Should_Have_Been_Overridden;
    return null;
  end Item_At;

end BC.Containers.Sets;