language-Modula2-0.1: examples/Modula-2_Libraries/C.-Lins_Modula-2_Software_Component_Library/Vol1/BAGS/BAGSBUI.MOD
IMPLEMENTATION MODULE BagSBUI;
(*==============================================================
Version : 1.00 02 May 1989 C. Lins
Compiler : TopSpeed Modula-2
Component: Monolithic Structures - Bag
Sequential Bounded Unmanaged Iterator
Code Size: R- bytes
INTRODUCTION
This module provides the Bag ADT for generic Items.
Implements a Bag using an ordered array.
REVISION HISTORY
v1.00 02 May 1989 C. Lins
Initial implementation derived from BagSBMI module. The
TypeID is used for retrieval of an Item comparison routine.
(C) Copyright 1989 Charles A. Lins
================================================================*)
FROM JPIStorage IMPORT
(*--Proc*) Allocate, Deallocate;
FROM Items IMPORT
(*--Type*) Item, CompareProc;
FROM ErrorHandling IMPORT
(*--Type*) HandlerProc,
(*--Proc*) Raise, NullHandler, ExitOnError;
FROM Relations IMPORT
(*--Type*) Relation;
FROM BagEnum IMPORT
(*--Type*) Exceptions, Operations, ComponentID;
FROM TypeManager IMPORT
(*--Cons*) NullType,
(*--Type*) TypeID,
(*--Proc*) CompareOf;
(*--------------------*)
TYPE ItemNode = RECORD
item : Item; (*-- the actual value *)
count: CARDINAL; (*-- number of times the value occurs *)
END (*-- ItemNode *);
TYPE ItemsArray = ARRAY BagSize OF ItemNode;
TYPE BoundedBag = RECORD
dataID : TypeID; (*-- defined data type *)
size : BagSize; (*-- defined Bag size *)
length : CARDINAL; (*-- current Bag length, := 0 *)
items : ItemsArray; (*-- ordered array [1..size] of ItemNode *)
END (*-- BoundedBag *);
TYPE Bag = POINTER TO BoundedBag;
(*---------------------------------*)
(*-- EXCEPTIONS --*)
VAR bagError : Exceptions;
VAR handlers : ARRAY Exceptions OF HandlerProc;
(*-----------------------*)
PROCEDURE BagError () : Exceptions (*-- out *);
BEGIN
RETURN bagError;
END BagError;
(*--------------------*)
PROCEDURE GetHandler ( ofError : Exceptions (*-- in *))
: HandlerProc (*-- out *);
BEGIN
RETURN handlers[ofError];
END GetHandler;
(*--------------------*)
PROCEDURE SetHandler ( ofError : Exceptions (*-- in *);
toHandler : HandlerProc (*-- in *));
BEGIN
handlers[ofError] := toHandler;
END SetHandler;
(*--------------------*)
PROCEDURE RaiseErrIn ( theRoutine : Operations (*-- in *);
theError : Exceptions (*-- in *));
BEGIN
bagError := theError;
Raise(ComponentID + ModuleID, theRoutine, theError, handlers[theError]);
END RaiseErrIn;
(*--------------------*)
(*---------------------------------*)
(*-- LOCAL ROUTINES --*)
PROCEDURE CopySubset ( routine : Operations (*-- in *);
fromBag : Bag (*-- in *);
index : BagSize (*-- in *);
VAR toBag : Bag (*-- inout *));
BEGIN
WITH toBag^ DO
WHILE (index <= fromBag^.length) DO
INC(length);
WITH items[length] DO
item := fromBag^.items[index].item;
count := fromBag^.items[index].count;
END (*--with*);
INC(index);
END (*--while*);
END (*--with*);
END CopySubset;
(*--------------------*)
PROCEDURE MinCount ( left : CARDINAL (*-- in *);
right : CARDINAL (*-- in *))
: CARDINAL (*-- out *);
BEGIN
IF (left < right) THEN
RETURN left;
END (*--if*);
RETURN right;
END MinCount;
(*--------------------*)
PROCEDURE Max ( left : CARDINAL (*--in *);
right : CARDINAL (*--in *))
: CARDINAL (*--out *);
BEGIN
IF (left > right) THEN
RETURN left;
END (*--if*);
RETURN right;
END Max;
(*--------------------*)
(*---------------------------------*)
(*-- CONSTRUCTORS --*)
PROCEDURE Create ( theSize : BagSize (*-- in *);
theType : TypeID (*-- in *))
: Bag (*-- out *);
CONST staticSize = SIZE(BoundedBag) - SIZE(ItemsArray);
CONST itemSize = SIZE(ItemNode);
VAR newBag : Bag;
BEGIN
bagError := noerr;
Allocate(newBag, staticSize + itemSize * theSize);
IF (newBag = NullBag) THEN
RaiseErrIn(create, overflow);
ELSE
WITH newBag^ DO
dataID := theType;
size := theSize;
length := 0;
END (*--with*);
END (*--if*);
RETURN newBag;
END Create;
(*--------------------*)
PROCEDURE Destroy (VAR theBag : Bag (*-- inout *));
CONST staticSize = SIZE(BoundedBag) - SIZE(ItemsArray);
CONST itemSize = SIZE(ItemNode);
BEGIN
Clear(theBag);
IF (bagError = noerr) THEN
Deallocate(theBag, staticSize + itemSize * theBag^.size);
END (*--if*);
END Destroy;
(*--------------------*)
PROCEDURE Clear (VAR theBag : Bag (*-- inout *));
VAR index : CARDINAL; (*-- Loop index over items *)
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
theBag^.length := 0;
ELSE
RaiseErrIn(clear, undefined);
END (*--if*);
END Clear;
(*--------------------*)
PROCEDURE Assign ( theBag : Bag (*-- in *);
VAR toBag : Bag (*-- inout *));
PROCEDURE Recreate () : BOOLEAN (*--out *);
BEGIN
IF (toBag = NullBag) THEN
toBag := Create(theBag^.size, theBag^.dataID);
ELSIF (theBag^.length <= toBag^.size) THEN
Clear(toBag);
toBag^.dataID := theBag^.dataID;
ELSE
RaiseErrIn(assign, overflow);
END (*--if*);
RETURN (bagError = noerr);
END Recreate;
(*--------------------*)
VAR index : CARDINAL; (*-- Loop index over items *)
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
IF Recreate() THEN
WITH theBag^ DO
FOR index := MIN(BagSize) TO length DO
WITH items[index] DO
toBag^.items[index].item := item;
toBag^.items[index].count:= count;
END (*--with*);
END (*--for*);
toBag^.length := length;
END (*--with*);
END (*--if*);
ELSE
RaiseErrIn(assign, undefined);
END (*--if*);
END Assign;
(*--------------------*)
PROCEDURE Include ( theItem : Item (*-- in *);
VAR inBag : Bag (*-- inout *));
VAR index : CARDINAL; (*-- Loop index in search for theItem *)
jndex : CARDINAL; (*-- Loop index in shifting items *)
compareItem : CompareProc; (*-- Item comparison routine *)
itemOrder : Relation; (*-- Relation between items *)
BEGIN
bagError := noerr;
IF (inBag # NullBag) THEN
WITH inBag^ DO
compareItem := CompareOf(dataID);
index := MIN(BagSize);
LOOP
IF (index > length) THEN
EXIT (*--loop*);
END (*--if*);
itemOrder := compareItem(items[index].item, theItem);
IF (itemOrder = equal) THEN
INC(items[index].count);
RETURN;
ELSIF (itemOrder = greater) THEN
EXIT (*--loop*);
END (*--if*);
INC(index);
END (*--loop*);
IF (length < size) THEN
(*-- Make room for new item at the current index *)
FOR jndex := length TO index BY -1 DO
items[jndex + 1] := items[jndex];
END (*--for*);
(*-- Insert the new item *)
INC(length);
WITH items[index] DO
item := theItem;
count:= 1;
END (*--with*);
ELSE
RaiseErrIn(include, overflow);
END (*--if*);
END (*--with*);
ELSE
RaiseErrIn(include, undefined);
END (*--if*);
END Include;
(*--------------------*)
PROCEDURE Exclude ( theItem : Item (*-- in *);
VAR fromBag : Bag (*-- inout *));
VAR index : CARDINAL; (*-- Loop index over items *)
jndex : CARDINAL; (*-- Loop index for item deletion *)
compareItem : CompareProc; (*-- Item comparison routine *)
itemOrder : Relation; (*-- Relation between items *)
BEGIN
bagError := noerr;
IF (fromBag # NullBag) THEN
WITH fromBag^ DO
compareItem := CompareOf(dataID);
FOR index := MIN(BagSize) TO length DO
itemOrder := compareItem(items[index].item, theItem);
IF (itemOrder = equal) THEN
IF (items[index].count > 1) THEN
DEC(items[index].count);
ELSE
(*-- Remove the Item at index by shifting all items
-- above index down one position. Then adjust the length
-- to account for the removal of the item. *)
WHILE (jndex < length) DO
INC(jndex);
items[jndex - 1] := items[jndex];
END (*--while*);
DEC(length);
END (*--if*);
RETURN;
ELSIF (itemOrder = greater) THEN
RETURN;
END (*--if*);
END (*--for*);
END (*--with*);
ELSE
RaiseErrIn(exclude, undefined);
END (*--if*);
END Exclude;
(*--------------------*)
PROCEDURE Union ( left : Bag (*-- in *);
right : Bag (*-- in *);
VAR toBag : Bag (*-- inout *));
(*-- Compute the Bag containing all members of left and right.
-- x IN toBag iff (x IN left) OR (x IN right).
-- The toBag length is used as the running index for adding
-- the resulting items of the union.
-- The algorithm used is a variation on the array merge from
-- reference [1], pg. 414. *)
VAR leftIndex : CARDINAL; (*-- Loop index over left bag *)
rightIndex : CARDINAL; (*-- Loop index over right bag *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
BEGIN
bagError := noerr;
IF (left = NullBag) OR (right = NullBag) THEN
RaiseErrIn(union, undefined);
RETURN;
ELSIF (left^.dataID # right^.dataID) THEN
RaiseErrIn(union, typeerror);
RETURN;
END (*--if*);
IF (toBag = NullBag) THEN
WITH left^ DO
IF (length + right^.length > MAX(BagSize)) THEN
RaiseErrIn(union, overflow);
RETURN;
END (*--if*);
toBag := Create(length + right^.length, dataID);
IF (toBag = NullBag) THEN
RETURN;
END (*--if*);
END (*--with*);
ELSIF (left^.length + right^.length > toBag^.size) THEN
RaiseErrIn(union, overflow);
RETURN;
ELSE
Clear(toBag);
toBag^.dataID := left^.dataID;
END (*--if*);
compareItem := CompareOf(toBag^.dataID);
leftIndex := MIN(BagSize);
rightIndex := MIN(BagSize);
WHILE (leftIndex <= left^.length) & (rightIndex <= right^.length) DO
order := compareItem(left^.items[leftIndex].item,
right^.items[rightIndex].item);
WITH toBag^ DO
INC(length);
WITH items[length] DO
IF (order = less) THEN
item := left^.items[leftIndex].item;
count:= left^.items[leftIndex].count;
INC(leftIndex);
ELSIF (order = equal) THEN
item := left^.items[leftIndex].item;
count:= left^.items[leftIndex].count +
right^.items[rightIndex].count;
INC(leftIndex);
INC(rightIndex);
ELSE
item := right^.items[rightIndex].item;
count:= right^.items[rightIndex].count;
INC(rightIndex);
END (*--if*);
END (*--with*);
END (*--with*);
END (*--while*);
(*-- Copy remaining items, if any, from either the left bag or
-- the right bag to the destination bag. *)
IF (leftIndex > left^.length) THEN
CopySubset(union, right, rightIndex, toBag);
ELSIF (rightIndex > right^.length) THEN
CopySubset(union, left, leftIndex, toBag);
END (*--if*);
END Union;
(*--------------------*)
PROCEDURE Intersection ( left : Bag (*-- in *);
right : Bag (*-- in *);
VAR toBag : Bag (*-- inout *));
(*-- Compute the bag containing all members in both left and right.
-- x IN toBag iff (x IN left) AND (x IN right).
-- The toBag length is used as the running index for adding
-- the resulting items of the intersection. The count field for
-- any item added to the destination is the smaller of the two
-- count fields from the source bags. *)
VAR leftIndex : CARDINAL; (*-- Loop index over left bag *)
rightIndex : CARDINAL; (*-- Loop index over right bag *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
largerLength: BagSize; (*-- Larger length of left & right bags *)
BEGIN
bagError := noerr;
IF (left = NullBag) OR (right = NullBag) THEN
RaiseErrIn(intersection, undefined);
RETURN;
ELSIF (left^.dataID # right^.dataID) THEN
RaiseErrIn(intersection, typeerror);
RETURN;
END (*--if*);
largerLength := Max(left^.length, right^.length);
IF (toBag = NullBag) THEN
toBag := Create(largerLength, left^.dataID);
IF (toBag = NullBag) THEN
RETURN;
END (*--if*);
ELSIF (largerLength > toBag^.size) THEN
RaiseErrIn(intersection, overflow);
RETURN;
ELSE
Clear(toBag);
toBag^.dataID := left^.dataID;
END (*--if*);
compareItem := CompareOf(toBag^.dataID);
leftIndex := MIN(BagSize);
rightIndex := MIN(BagSize);
WHILE (leftIndex <= left^.length) & (rightIndex <= right^.length) DO
order := compareItem(left^.items[leftIndex].item,
right^.items[rightIndex].item);
IF (order = equal) THEN
WITH toBag^ DO
INC(length);
WITH items[length] DO
item := left^.items[leftIndex].item;
count:= MinCount(left^.items[leftIndex].count,
right^.items[rightIndex].count);
END (*--with*);
END (*--with*);
INC(leftIndex);
INC(rightIndex);
ELSIF (order = less) THEN
INC(leftIndex);
ELSE
INC(rightIndex);
END (*--if*);
END (*--while*);
END Intersection;
(*--------------------*)
PROCEDURE Difference ( left : Bag (*-- in *);
right : Bag (*-- in *);
VAR toBag : Bag (*-- inout *));
(*-- Compute the bag containing all members of left that are not
-- members of right. x IN toBag iff (x IN left) & ┬(x IN right)
-- If there is no match, then the item is added to the destination
-- bag. If there is a match, a positive difference between the
-- left and right bag counts for the item causes that value to
-- be used as the count for the new item. *)
VAR leftIndex : CARDINAL; (*-- Loop index over left bag *)
rightIndex : CARDINAL; (*-- Loop index over right bag *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
largerLength: BagSize; (*-- Larger length of left & right bags *)
BEGIN
bagError := noerr;
IF (left = NullBag) OR (right = NullBag) THEN
RaiseErrIn(difference, undefined);
RETURN;
ELSIF (left^.dataID # right^.dataID) THEN
RaiseErrIn(difference, typeerror);
RETURN;
END (*--if*);
largerLength := Max(left^.length, right^.length);
IF (toBag = NullBag) THEN
toBag := Create(largerLength, left^.dataID);
IF (toBag = NullBag) THEN
RETURN;
END (*--if*);
ELSIF (largerLength > toBag^.size) THEN
RaiseErrIn(intersection, overflow);
RETURN;
ELSE
Clear(toBag);
toBag^.dataID := left^.dataID;
END (*--if*);
compareItem := CompareOf(toBag^.dataID);
leftIndex := MIN(BagSize);
rightIndex := MIN(BagSize);
WHILE (leftIndex <= left^.length) & (rightIndex <= right^.length) DO
order := compareItem(left^.items[leftIndex].item,
right^.items[rightIndex].item);
IF (order = equal) THEN
IF (left^.items[leftIndex].count >
right^.items[rightIndex].count) THEN
WITH toBag^ DO
INC(length);
WITH items[length] DO
item := left^.items[leftIndex].item;
count := left^.items[leftIndex].count - right^.items[rightIndex].count;
END (*--with*);
END (*--with*);
END (*--if*);
INC(leftIndex);
INC(rightIndex);
ELSIF (order = less) THEN
WITH toBag^ DO
INC(length);
WITH items[length] DO
item := left^.items[leftIndex].item;
count := left^.items[leftIndex].count;
END (*--with*);
END (*--with*);
INC(leftIndex);
ELSE
INC(rightIndex);
END (*--if*);
END (*--while*);
(*-- Copy remaining items, if any, from the left bag to the
-- destination bag. *)
CopySubset(difference, left, leftIndex, toBag);
END Difference;
(*--------------------*)
PROCEDURE SymDifference ( left : Bag (*-- in *);
right : Bag (*-- in *);
VAR toBag : Bag (*-- inout *));
(*-- Compute the Bag containing all members of left or right that
-- are not members of both.
-- x IN toBag iff (x IN left) # (x IN right) *)
VAR leftIndex : CARDINAL; (*-- Loop index over left bag *)
rightIndex : CARDINAL; (*-- Loop index over right bag *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
largerLength: BagSize; (*-- Larger length of left & right bags *)
BEGIN
bagError := noerr;
IF (left = NullBag) OR (right = NullBag) THEN
RaiseErrIn(symdifference, undefined);
RETURN;
ELSIF (left^.dataID # right^.dataID) THEN
RaiseErrIn(symdifference, typeerror);
RETURN;
END (*--if*);
largerLength := Max(left^.length, right^.length);
IF (toBag = NullBag) THEN
toBag := Create(largerLength, left^.dataID);
IF (toBag = NullBag) THEN
RETURN;
END (*--if*);
ELSIF (largerLength > toBag^.size) THEN
RaiseErrIn(symdifference, overflow);
RETURN;
ELSE
Clear(toBag);
toBag^.dataID := left^.dataID;
END (*--if*);
compareItem := CompareOf(toBag^.dataID);
leftIndex := MIN(BagSize);
rightIndex := MIN(BagSize);
WHILE (leftIndex <= left^.length) & (rightIndex <= right^.length) DO
order := compareItem(left^.items[leftIndex].item,
right^.items[rightIndex].item);
IF (order = equal) THEN
IF (left^.items[leftIndex].count >
right^.items[rightIndex].count) THEN
WITH toBag^ DO
INC(length);
WITH items[length] DO
item := left^.items[leftIndex].item;
count := left^.items[leftIndex].count - right^.items[rightIndex].count;
END (*--with*);
END (*--with*);
END (*--if*);
INC(leftIndex);
INC(rightIndex);
ELSE
WITH toBag^ DO
IF (length < size) THEN
INC(length);
ELSE
RaiseErrIn(symdifference, overflow);
RETURN;
END (*--if*);
IF (order = less) THEN
WITH items[length] DO
item := left^.items[leftIndex].item;
count := left^.items[leftIndex].count;
END (*--with*);
INC(leftIndex);
ELSE
WITH items[length] DO
item := right^.items[rightIndex].item;
count := right^.items[rightIndex].count;
END (*--with*);
INC(rightIndex);
END (*--if*);
END (*--with*);
END (*--if*);
END (*--while*);
(*-- Copy remaining items, if any, from either the left set or
-- the right set to the destination set. *)
IF (leftIndex > left^.length) THEN
CopySubset(symdifference, right, rightIndex, toBag);
ELSIF (rightIndex > right^.length) THEN
CopySubset(symdifference, left, leftIndex, toBag);
END (*--if*);
END SymDifference;
(*--------------------*)
(*---------------------------------*)
(*-- SELECTORS --*)
PROCEDURE IsDefined ( theBag : Bag (*-- in *))
: BOOLEAN (*-- out *);
BEGIN
RETURN theBag # NullBag;
END IsDefined;
(*--------------------*)
PROCEDURE IsEmpty ( theBag : Bag (*-- in *))
: BOOLEAN (*-- out *);
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
RETURN (theBag^.length = 0);
END (*--if*);
RaiseErrIn(isempty, undefined);
RETURN TRUE;
END IsEmpty;
(*--------------------*)
PROCEDURE SizeOf ( theBag : Bag (*-- in *))
: CARDINAL (*-- out *);
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
RETURN theBag^.size;
END (*--if*);
RaiseErrIn(sizeof, undefined);
RETURN 0;
END SizeOf;
(*--------------------*)
PROCEDURE TypeOf ( theBag : Bag (*-- in *))
: TypeID (*-- out *);
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
RETURN theBag^.dataID;
END (*--if*);
RaiseErrIn(typeof, undefined);
RETURN NullType;
END TypeOf;
(*--------------------*)
PROCEDURE IsEqual ( left : Bag (*-- in *);
right : Bag (*-- in *))
: BOOLEAN (*-- out *);
VAR index : CARDINAL; (*-- Loop index over items *)
BEGIN
bagError := noerr;
IF (left # NullBag) & (right # NullBag) THEN
IF (left^.dataID = right^.dataID) THEN
IF (left^.length = right^.length) THEN
(*
Scan both Bags looking for the first mismatch (inequality) indicating that the
Bags are unequal. If the FOR loop completes then the Bags must be equal.
*)
FOR index := MIN(BagSize) TO left^.length DO
IF (left^.items[index].item # right^.items[index].item) THEN
RETURN FALSE;
ELSIF (left^.items[index].count # right^.items[index].count) THEN
RETURN FALSE;
END (*--if*);
END (*--for*);
RETURN TRUE;
END (*--if*);
ELSE
RaiseErrIn(isequal, typeerror);
END (*--if*);
ELSE
RaiseErrIn(isequal, undefined);
END (*--if*);
(*-- the Bags must be unequal, either by having different
-- lengths, mismatched types, or an undefined Bag exception. *)
RETURN FALSE;
END IsEqual;
(*----------------------------*)
PROCEDURE NumMembers ( theBag : Bag (*-- in *))
: CARDINAL (*-- out *);
VAR totalCount : CARDINAL;
index : CARDINAL;
BEGIN
bagError := noerr;
totalCount := 0;
IF (theBag # NullBag) THEN
WITH theBag^ DO
FOR index := MIN(BagSize) TO length DO
INC(totalCount, items[index].count);
END (*--for*);
END (*--with*);
ELSE
RaiseErrIn(nummembers, undefined);
END (*--if*);
RETURN totalCount;
END NumMembers;
(*----------------------------*)
PROCEDURE UniqueMembers ( theBag : Bag (*-- in *))
: CARDINAL (*-- out *);
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
RETURN theBag^.length;
END (*--if*);
RaiseErrIn(uniquemembers, undefined);
RETURN 0;
END UniqueMembers;
(*----------------------------*)
PROCEDURE IsAMember ( theItem : Item (*-- in *);
theBag : Bag (*-- in *))
: BOOLEAN (*-- out *);
VAR index : CARDINAL; (*-- Loop index over items *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
WITH theBag^ DO
compareItem := CompareOf(dataID);
FOR index := MIN(BagSize) TO length DO
IF (theItem = items[index].item) THEN
RETURN TRUE;
ELSE
order := compareItem(items[index].item, theItem);
IF (order = greater) THEN
RETURN FALSE;
END (*--if*);
END (*--if*);
END (*--for*);
END (*--with*);
ELSE
RaiseErrIn(ismember, undefined);
END (*--if*);
RETURN FALSE;
END IsAMember;
(*----------------------------*)
PROCEDURE NumberOf ( theItem : Item (*-- in *);
theBag : Bag (*-- in *))
: CARDINAL (*-- out *);
VAR index : CARDINAL; (*-- Loop index over items *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
WITH theBag^ DO
compareItem := CompareOf(dataID);
FOR index := MIN(BagSize) TO length DO
WITH items[index] DO
IF (theItem = item) THEN
RETURN count;
ELSE
order := compareItem(item, theItem);
IF (order = greater) THEN
RETURN 0;
END (*--if*);
END (*--if*);
END (*--with*);
END (*--for*);
END (*--with*);
ELSE
RaiseErrIn(numberof, undefined);
END (*--if*);
RETURN 0;
END NumberOf;
(*----------------------------*)
PROCEDURE IsSubset ( left : Bag (*-- in *);
right : Bag (*-- in *))
: BOOLEAN (*-- out *);
VAR leftIndex : CARDINAL; (*-- Loop index over left bag *)
rightIndex : CARDINAL; (*-- Loop index over right bag *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
BEGIN
bagError := noerr;
IF (left # NullBag) & (right # NullBag) THEN
IF (left^.dataID # right^.dataID) THEN
RaiseErrIn(issubset, typeerror);
ELSE
compareItem:= CompareOf(left^.dataID);
leftIndex := MIN(BagSize);
rightIndex := MIN(BagSize);
WHILE (leftIndex <= left^.length) & (rightIndex <= right^.length) DO
order := compareItem(left^.items[leftIndex].item,
right^.items[rightIndex].item);
IF (order = equal) THEN
IF (left^.items[leftIndex].count >
right^.items[rightIndex].count) THEN
RETURN FALSE;
END (*--if*);
INC(leftIndex);
INC(rightIndex);
ELSIF (order = less) THEN
RETURN FALSE;
ELSE
INC(rightIndex);
END (*--if*);
END (*--while*);
RETURN (leftIndex > left^.length);
END (*--if*);
ELSE
RaiseErrIn(issubset, undefined);
END (*--if*);
RETURN FALSE;
END IsSubset;
(*----------------------------*)
PROCEDURE IsProperSubset( left : Bag (*-- in *);
right : Bag (*-- in *))
: BOOLEAN (*-- out *);
BEGIN
RETURN IsSubset(left, right) & (left^.length < right^.length);
END IsProperSubset;
(*----------------------------*)
(*---------------------------------*)
(*-- ITERATORS --*)
PROCEDURE LoopOver ( theBag : Bag (*-- in *);
process : LoopAccessProc (*-- in *));
VAR index : CARDINAL; (*-- Loop index over items *)
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
WITH theBag^ DO
FOR index := MIN(BagSize) TO length DO
WITH items[index] DO
IF ~process(item, count) THEN
RETURN;
END (*--if*);
END (*--with*);
END (*--for*);
END (*--with*);
ELSE
RaiseErrIn(loopover, undefined);
END (*--if*);
END LoopOver;
(*----------------------------*)
PROCEDURE Traverse ( theBag : Bag (*-- in *);
process : AccessProc (*-- in *));
VAR index : CARDINAL; (*-- Loop index over items *)
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
WITH theBag^ DO
FOR index := MIN(BagSize) TO length DO
WITH items[index] DO
process(item, count);
END (*--with*);
END (*--for*);
END (*--with*);
ELSE
RaiseErrIn(traverse, undefined);
END (*--if*);
END Traverse;
(*----------------------------*)
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
(*~~ MODULE INITIALIZATION ~~*)
BEGIN
FOR bagError := MIN(Exceptions) TO MAX(Exceptions) DO
handlers[bagError] := ExitOnError;
END (*--for*);
handlers[noerr] := NullHandler;
bagError := noerr;
END BagSBUI.