-- 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;