language-Modula2-0.1: examples/Modula-2_Libraries/C.-Lins_Modula-2_Software_Component_Library/Vol1/BAGS/BAGSBMI.MOD
IMPLEMENTATION MODULE BagSBMI;
(*==============================================================
Version : 1.00 30 Apr 1989 C. Lins
Compiler : TopSpeed Modula-2
Component: Monolithic Structures - Bag
Sequential Bounded Managed 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 30 Apr 1989 C. Lins
Initial implementation for TopSpeed Modula-2.
(C) Copyright 1989 Charles A. Lins
================================================================*)
FROM JPIStorage IMPORT
(*--Proc*) Allocate, Deallocate;
FROM Items IMPORT
(*--Type*) Item, AssignProc, CompareProc, DisposeProc;
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*) AssignOf, CompareOf, DisposeOf;
(*--------------------*)
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 *));
VAR assignItem : AssignProc; (*-- Item assignment routine, if any *)
BEGIN
assignItem := AssignOf(fromBag^.dataID);
WITH toBag^ DO
WHILE (index <=fromBag^.length) DO
INC(length);
WITH items[length] DO
item := assignItem(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 freeItem : DisposeProc; (*-- Item disposal routine, if any *)
index : CARDINAL; (*-- Loop index over items *)
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
WITH theBag^ DO
freeItem := DisposeOf(dataID);
FOR index := MIN(BagSize) TO length DO
freeItem(items[index].item);
END (*--for*);
length := 0;
END (*--with*);
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 assignItem : AssignProc; (*-- Item assignment routine, if any *)
index : CARDINAL; (*-- Loop index over items *)
BEGIN
bagError := noerr;
IF (theBag # NullBag) THEN
IF Recreate() THEN
WITH theBag^ DO
assignItem := AssignOf(dataID);
FOR index := MIN(BagSize) TO length DO
WITH items[index] DO
toBag^.items[index].item := assignItem(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 *)
assignItem : AssignProc; (*-- Item assignment routine *)
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*);
WITH toBag^ DO
compareItem := CompareOf(dataID);
assignItem := AssignOf(dataID);
END (*--with*);
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 := assignItem(left^.items[leftIndex].item);
count:= left^.items[leftIndex].count;
INC(leftIndex);
ELSIF (order = equal) THEN
item := assignItem(left^.items[leftIndex].item);
count:= left^.items[leftIndex].count +
right^.items[rightIndex].count;
INC(leftIndex);
INC(rightIndex);
ELSE
item := assignItem(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 *)
assignItem : AssignProc; (*-- Item assignment routine *)
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*);
WITH toBag^ DO
compareItem := CompareOf(dataID);
assignItem := AssignOf(dataID);
END (*--with*);
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 := assignItem(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 *)
assignItem : AssignProc; (*-- Item assignment routine *)
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*);
WITH toBag^ DO
compareItem := CompareOf(dataID);
assignItem := AssignOf(dataID);
END (*--with*);
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 := assignItem(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 := assignItem(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 *)
assignItem : AssignProc; (*-- Item assignment routine *)
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*);
WITH toBag^ DO
compareItem := CompareOf(dataID);
assignItem := AssignOf(dataID);
END (*--with*);
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 := assignItem(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 := assignItem(left^.items[leftIndex].item);
count := left^.items[leftIndex].count;
END (*--with*);
INC(leftIndex);
ELSE
WITH items[length] DO
item := assignItem(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 *)
compare : CompareProc; (*-- item comparison routine *)
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.
*)
compare := CompareOf(left^.dataID);
FOR index := MIN(BagSize) TO left^.length DO
IF compare(left^.items[index].item,
right^.items[index].item) # equal 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 BagSBMI.