File : asgc-setops.adb
-- The Ada Structured Library - A set of container classes and general
-- tools for use with Ada95.
-- Copyright (C) 1998-1999 Corey Minyard (minyard@acm.org)
--
-- This library is free software; you can redistribute it and/or modify it
-- under the terms of the GNU General Public License as published by the
-- Free Software Foundation; either version 2 of the License, or (at your
-- option) any later version.
--
-- This library 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 along
-- with this library; if not, write to the Free Software Foundation, Inc.,
-- 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.
--
package body Asgc.Setops is
function Entry_Count (O : in Object_Class;
Val : in Contained_Type)
return Natural is
Retval : Natural := 0;
Iter : Iterator_Class := New_Iterator(O);
Found : Boolean;
begin
Search(Iter.all, Val, Found);
while (Found = True) loop
Retval := Retval + 1;
Search_Again(Iter.all, Found);
end loop;
Free(Iter);
return Retval;
end Entry_Count;
-- Initialize the destination container. If the destination and a
-- source object are the same object, special work must be done.
-- Otherwise, the destination container is emptied and the contents
-- of the first object are put into it.
procedure Init_Set_Dest (Dest : in Object_Class;
O1, O2 : in Object_Class;
IDest : in Iterator_Class;
I1, I2 : in out Iterator_Class) is
I_Tmp : Iterator_Class;
Is_End : End_Marker;
begin
if (Dest = O1) then
-- The destination an the first object are the same container, so
-- there is nothing to do.
null;
elsif (Dest = O2) then
-- The destination and the second object are the same container.
-- Switch the first and second object so we will add the first
-- object to the second.
I_Tmp := I1;
I1 := I2;
I2 := I_Tmp;
else
-- Clear out the destination.
First(IDest.all, Is_End);
while (Is_End = Not_Past_End) loop
Delete(IDest.all, Is_End);
end loop;
-- Copy all the things from the first container to the destination.
First(I1.all, Is_End);
while (Is_End = Not_Past_End) loop
Add(Dest.all, Get(I1.all));
Next(I1.all, Is_End);
end loop;
end if;
end Init_Set_Dest;
type Object_Ptr is access all Object;
procedure Union (Dest : in Object_Class;
O1, O2 : in Object_Class) is
I1 : Iterator_Class := New_Iterator(O1);
I2 : Iterator_Class := New_Iterator(O2);
IDest : Iterator_Class := New_Iterator(Dest);
Is_End : End_Marker;
Val : Contained_Type;
Found : Boolean;
begin
Init_Set_Dest(Dest, O1, O2, IDest, I1, I2);
-- Now move the second object into the first object.
First(I2.all, Is_End);
while (Is_End = Not_Past_End) loop
Val := Get(I2.all);
Search(Idest.all, Val, Found);
if (not Found) then
Add(Dest.all, Val);
end if;
Next(I2.all, Is_End);
end loop;
Free(I1);
Free(I2);
Free(IDest);
end Union;
procedure Intersection (Dest : in Object_Class;
O1, O2 : in Object_Class) is
I1 : Iterator_Class := New_Iterator(O1);
I2 : Iterator_Class := New_Iterator(O2);
IDest : Iterator_Class := New_Iterator(Dest);
Is_End : End_Marker;
Val : Contained_Type;
Found : Boolean;
begin
Init_Set_Dest(Dest, O1, O2, IDest, I1, I2);
-- Now that we have everything in the first container into the
-- destinaion, scan the destination container, deleting all items
-- that are not in the second container.
First(IDest.all, Is_End);
while (Is_End = Not_Past_End) loop
Val := Get(IDest.all);
Search(I2.all, Val, Found);
if (Found) then
Next(IDest.all, Is_End);
else
Delete(IDest.all, Is_End);
end if;
end loop;
Free(I1);
Free(I2);
Free(IDest);
end Intersection;
procedure Bag_Union (Dest : in Object_Class;
O1, O2 : in Object_Class) is
I1 : Iterator_Class := New_Iterator(O1);
I2 : Iterator_Class := New_Iterator(O2);
IDest : Iterator_Class := New_Iterator(Dest);
Is_End : End_Marker;
Val : Contained_Type;
begin
Init_Set_Dest(Dest, O1, O2, IDest, I1, I2);
-- Now add everything in the second container into the destination.
First(I2.all, Is_End);
while (Is_End = Not_Past_End) loop
Val := Get(I2.all);
Add(Dest.all, Val);
Next(I2.all, Is_End);
end loop;
Free(I1);
Free(I2);
Free(IDest);
end Bag_Union;
procedure Bag_Intersection (Dest : in Object_Class;
O1, O2 : in Object_Class) is
I1 : Iterator_Class := New_Iterator(O1);
I2 : Iterator_Class := New_Iterator(O2);
IDest : Iterator_Class := New_Iterator(Dest);
Is_End : End_Marker;
Val : Contained_Type;
Count1 : Natural;
Count2 : Natural;
Found : Boolean;
Next_Val : Contained_Type;
begin
Init_Set_Dest(Dest, O1, O2, IDest, I1, I2);
-- If an entry is in both containers, add it to the destination.
First(IDest.all, Is_End);
while (Is_End = Not_Past_End) loop
Val := Get(IDest.all);
-- Get the next value, since we may lose this value from the
-- container.
Next(IDest.all, Is_End);
while ((Is_End = Not_Past_End) and then (IDest.all = Val)) loop
Next(IDest.all, Is_End);
end loop;
if (Is_End = Not_Past_End) then
Next_Val := Get(IDest.all);
end if;
-- Find the number of entries in the destination and second source
-- right now.
Count1 := Entry_Count(Dest, Val);
Count2 := Entry_Count(O2, Val);
-- Now delete from the destination to make the count correct,
-- if that is necessary.
if (Count1 > Count2) then
for I in Count2+1 .. Count1 loop
Delete(Dest.all, Val);
end loop;
-- If we deleted values, the iterator will be invalid, so
-- initialize it to reference the saved next value.
if (Is_End = Not_Past_End) then
Search(IDest.all, Next_Val, Found);
end if;
end if;
end loop;
Free(I1);
Free(I2);
Free(IDest);
end Bag_Intersection;
function Is_Subset (O1, O2 : in Object_Class) return Boolean is
I1 : Iterator_Class := New_Iterator(O1);
I2 : Iterator_Class := New_Iterator(O2);
Is_End : End_Marker;
Found : Boolean;
begin
-- For all the members in O1, if any is not found in O2 then return
-- False. If we get through the loop, then O1 is a subset of O2.
First (I1.all, Is_End);
while (Is_End = Not_Past_End) loop
Search(I2.all, Get(I1.all), Found);
if (not Found) then
return False;
end if;
Next(I1.all, Is_End);
end loop;
return True;
end Is_Subset;
function Is_Bag_Subset (O1, O2 : in Object_Class) return Boolean is
I1 : Iterator_Class := New_Iterator(O1);
I2 : Iterator_Class := New_Iterator(O2);
Is_End : End_Marker;
Val : Contained_Type;
Last_Val : Contained_Type;
begin
-- For all the members in O1, if the count is O2 is less than the
-- count in O1 return False. If we get through the loop, then O1 is
-- a bag subset of O2. Since bag hash tables generally keep the same
-- value in sequential locations, we do an optimization to skip a
-- value if it is the same as the last value.
First (I1.all, Is_End);
if (Is_End = Not_Past_End) then
Val := Get(I1.all);
if (Entry_Count(O1, Val) > Entry_Count(O2, Val)) then
return False;
end if;
Last_Val := Val;
while (Is_End = Not_Past_End) loop
Val := Get(I1.all);
if ((Val /= Last_Val)
and then (Entry_Count(O1, Val) > Entry_Count(O2, Val)))
then
return False;
end if;
Next(I1.all, Is_End);
Last_Val := Val;
end loop;
end if;
return True;
end Is_Bag_Subset;
end Asgc.Setops;