File : bc-containers-bags.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-bags.adb,v 1.2.2.1 1999/12/03 20:53:26 simon Exp $
with BC.Support.Exceptions;
with System.Address_To_Access_Conversions;
package body BC.Containers.Bags is
package BSE renames BC.Support.Exceptions;
procedure Assert
is new BSE.Assert ("BC.Containers.Bags");
function Are_Equal (L, R : Bag'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;
if Count (L, Current_Item (It)) /= Count (R, Current_Item (It)) then
return False;
end if;
Next (It);
end loop;
return True;
end Are_Equal;
procedure Add (B : in out Bag'Class; I : Item) is
Dummy : Boolean;
begin
Add (B, I, Added => Dummy);
end Add;
procedure Union (B : in out Bag'Class; O : Bag'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);
This_Count : Positive := Count (O, This_Item);
begin
if not Is_Member (B, This_Item) then
Attach (B, This_Item, This_Count);
else
Set_Value (B, This_Item, Count (B, This_Item) + This_Count);
end if;
end;
Next (It);
end loop;
end Union;
procedure Intersection (B : in out Bag'Class; O : Bag'Class) is
It : Iterator := New_Iterator (B);
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);
B_Count : Positive := Count (B, This_Item);
begin
if not Exists (O, This_Item) then
Detach (B, This_Item);
else
declare
O_Count : Positive := Count (O, This_Item);
begin
if B_Count > O_Count then
Set_Value (B, This_Item, O_Count);
end if;
end;
Next (It);
end if;
end;
end loop;
end Intersection;
procedure Difference (B : in out Bag'Class; O : Bag'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 (B, This_Item) then
declare
B_Count : Positive := Count (B, This_Item);
O_Count : Positive := Count (O, This_Item);
begin
if B_Count <= O_Count then
Detach (B, This_Item);
else
Set_Value (B, This_Item, B_Count - O_Count);
end if;
end;
end if;
end;
Next (It);
end loop;
end Difference;
function Total_Size (B : Bag'Class) return Natural is
It : Iterator := New_Iterator (B);
Result : Natural := 0;
begin
while not Is_Done (It) loop
Result := Result + Count (B, Current_Item (It));
Next (It);
end loop;
return Result;
end Total_Size;
function Is_Subset (B : Bag'Class; O : Bag'Class) return Boolean is
It : Iterator := New_Iterator (B);
begin
-- XXX left out the optimisation which checks whether L, R are
-- identical.
if Cardinality (B) > Cardinality (O) then
return False;
end if;
while not Is_Done (It) loop
declare
This_Item : Item := Current_Item (It);
begin
-- why don't I just do "or else Count (B, This_Item) > Count (O,
-- This_Item)"? .. because it triggered a compiler bug in GNAT
-- 3.11p (or was it 3.11b2?)
if not Exists (O, This_Item) then
return False;
else
declare
B_Count : Positive := Count (B, This_Item);
O_Count : Positive := Count (O, This_Item);
begin
if B_Count > O_Count then
return False;
end if;
end;
end if;
end;
Next (It);
end loop;
return True;
end Is_Subset;
function Is_Proper_Subset (B : Bag'Class; O : Bag'Class) return Boolean is
It : Iterator := New_Iterator (B);
Is_Proper : Boolean := False;
begin
-- XXX left out the optimisation which checks whether L, R are
-- identical.
if Cardinality (B) > Cardinality (O) then
return False;
end if;
while not Is_Done (It) loop
declare
This_Item : Item renames Current_Item (It);
begin
if not Exists (O, This_Item) then
return False;
else
declare
B_Count : Positive := Count (B, This_Item);
O_Count : Positive := Count (O, This_Item);
begin
if B_Count > O_Count then
return False;
elsif B_Count < O_Count then
Is_Proper := True;
end if;
end;
end if;
end;
Next (It);
end loop;
return Is_Proper or else Cardinality (B) < Cardinality (O);
end Is_Proper_Subset;
-- Subprograms to be overridden
procedure Attach (B : in out Bag; I : Item; C : Positive) is
begin
raise Should_Have_Been_Overridden;
end Attach;
procedure Detach (B : in out Bag; I : Item) is
begin
raise Should_Have_Been_Overridden;
end Detach;
procedure Set_Value (B : in out Bag; I : Item; C : Positive) is
begin
raise Should_Have_Been_Overridden;
end Set_Value;
function Multiplicity (B : Bag'Class) return Natural is
It : Iterator := New_Iterator (B);
Result : Natural := 0;
begin
while not Is_Done (It) loop
Result := Result + Count (B, Current_Item (It));
Next (It);
end loop;
return Result;
end Multiplicity;
function Number_Of_Buckets (B : Bag) return Natural is
begin
raise Should_Have_Been_Overridden;
return 0;
end Number_Of_Buckets;
function Length (B : Bag; Bucket : Positive) return Natural is
begin
raise Should_Have_Been_Overridden;
return 0;
end Length;
function Exists (B : Bag; I : Item) return Boolean is
begin
raise Should_Have_Been_Overridden;
return False;
end Exists;
function Value_Of (B : Bag; I : Item) return Positive is
begin
raise Should_Have_Been_Overridden;
return 1;
end Value_Of;
function Item_At (B : Bag; Bucket, Index : Positive) return Item_Ptr is
begin
raise Should_Have_Been_Overridden;
return null;
end Item_At;
function Value_At (B : Bag; Bucket, Index : Positive) return Positive is
begin
raise Should_Have_Been_Overridden;
return 1;
end Value_At;
-- Iterators
procedure Initialize (It : in out Bag_Iterator) is
begin
It.Index := 0;
if Cardinality (It.B.all) = 0 then
It.Bucket_Index := 0;
else
It.Bucket_Index := 1;
while It.Bucket_Index <= Number_Of_Buckets (It.B.all) loop
if Length (It.B.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 Bag_Iterator) is
begin
It.Index := 0;
if Cardinality (It.B.all) = 0 then
It.Bucket_Index := 0;
else
It.Bucket_Index := 1;
while It.Bucket_Index <= Number_Of_Buckets (It.B.all) loop
if Length (It.B.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 Bag_Iterator) is
begin
if It.Bucket_Index <= Number_Of_Buckets (It.B.all) then
if It.Index < Length (It.B.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.B.all) loop
if Length (It.B.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 : Bag_Iterator) return Boolean is
begin
if It.Bucket_Index = 0
or else It.Bucket_Index > Number_Of_Buckets (It.B.all) then
return True;
end if;
if It.Index <= Length (It.B.all, It.Bucket_Index) then
return False;
end if;
declare
package Conversions is new System.Address_To_Access_Conversions
(Bag_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.B.all) loop
if Length (P.B.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 : Bag_Iterator) return Item is
begin
if Is_Done (It) then
raise BC.Not_Found;
end if;
return Item_At (It.B.all, It.Bucket_Index, It.Index).all;
end Current_Item;
function Current_Item (It : Bag_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.B.all, It.Bucket_Index, It.Index);
end Current_Item;
procedure Delete_Item_At (It : Bag_Iterator) is
begin
if Is_Done (It) then
raise BC.Not_Found;
end if;
raise BC.Not_Yet_Implemented;
end Delete_Item_At;
end BC.Containers.Bags;