language-Modula2-0.1: examples/Modula-2_Libraries/C.-Lins_Modula-2_Software_Component_Library/Vol1/SETS/SETSBMI.MOD
(*
12.3 SetSBMI Implementation
*)
IMPLEMENTATION MODULE SetSBMI;
(*==========================================================
Version : 1.00 30 Apr 1989 C. Lins
Compiler : TopSpeed Modula-2 Compiler
Code Size: R- bytes
Component: Monolithic Structures - Set
Sequential Bounded Managed Iterator
INTRODUCTION
This module provides the implementation of the bounded
Set abstraction for generic Items 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,
AccessProc, LoopAccessProc;
FROM ErrorHandling IMPORT
(*--Type*) HandlerProc,
(*--Proc*) Raise, NullHandler, ExitOnError;
FROM Relations IMPORT
(*--Type*) Relation;
FROM SetEnum IMPORT
(*--Type*) Exceptions, Operations, ComponentID;
FROM TypeManager IMPORT
(*--Cons*) NullType,
(*--Type*) TypeID,
(*--Proc*) AssignOf, CompareOf, DisposeOf;
(*--------------------*)
(*
12.3.1 Internal Bounded Set Representation
╟Illustration Here╚
Figure 12.1
Like the internal representations for the bounded stack and string, a bounded set is
represented as a pointer to a record containing an array of items of a variable size. In
addition, the data type ID, physical array size (maximum number of items), and the
current length (number of items currently present in the array). The representation
invariants that must be enforced by the module are:
1. MIN(SizeRange) <= size <= MAX(SizeRange)
2. MIN(SizeRange) <= length <= size
3. items[x] < items[x+1], for all x such that x < length
The third invariant states that elements of the items array must be linearly ordered in
ascending sequence.
*)
TYPE ItemsArray = ARRAY SizeRange OF Item;
TYPE BoundedSet = RECORD
dataID : TypeID; (*-- defined data type *)
size : SizeRange; (*-- defined Set size *)
length : CARDINAL; (*-- current Set length, := 0 *)
items : ItemsArray; (*-- ordered array [1..size] of Item *)
END (*-- BoundedSet *);
TYPE Set = POINTER TO BoundedSet;
(*
12.2.2 Exceptions
To support the exception handling mechanism two variables are needed. The first,
setError, is used to record the exception result from each operation; while handlers is an
array of exception handling procedures indexed by the exception result.
The routines SetError, GetHandler, and SetHandler have been previously described in the
definition module, and their operation should be readily apparent. RaiseErrIn is a local
routine used to set the setError variable and invoke the Raise routine of the
ErrorHandling module.
*)
VAR setError : Exceptions;
VAR handlers : ARRAY Exceptions OF HandlerProc;
(*-----------------------*)
PROCEDURE SetError () : Exceptions (*-- out *);
BEGIN
RETURN setError;
END SetError;
(*--------------------*)
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
setError := theError;
Raise(ComponentID + ModuleID, theRoutine, theError, handlers[theError]);
END RaiseErrIn;
(*--------------------*)
(*
12.3.3 Local Routines
12.3.3.1 CopySubset
Several of the set algorithms require the ability to copy the all remaining items from a
given set to a partially created target set. CopySubset performs this operation by
looping through the fromSet starting from the given index to the end of the fromSet,
copying each item to the target set along the way. If during the copying process the
target set size is insufficient for all of the items from the source set, the overflow
exception is raised and the operation is aborted. (A more efficient implementation for
checking overflow would be to calculate the number of items to copy from the source
(length - fromIndex + 1) and compare this to the number of available positions remaining
in the target (size - length) and if the result is greater then invoke overflow).
12.3.3.2 Recreate
All routines that accept a target set as an inout parameter need to either (1) clear the
existing set of its contents if the set already exists, or (2) create a new, empty set to be
target of the operation. The Recreate routine provides such a capability, returning true if
successful. It should be noted that failure only occurs as a result when the set must be
created.
*)
PROCEDURE CopySubset ( routine : Operations (*-- in *);
fromSet : Set (*-- in *);
index : SizeRange (*-- in *);
VAR toSet : Set (*-- inout *));
VAR assignItem : AssignProc; (*-- Item assignment routine, if any *)
BEGIN
assignItem := AssignOf(fromSet^.dataID);
WITH toSet^ DO
WHILE (index <= fromSet^.length) DO
IF (length < size) THEN
INC(length);
items[length] := assignItem(fromSet^.items[index]);
INC(index);
ELSE
RaiseErrIn(routine, overflow);
RETURN;
END (*--if*);
END (*--while*);
END (*--with*);
END CopySubset;
(*--------------------*)
PROCEDURE Recreate ( theType : TypeID (*-- in *);
theSize : SizeRange (*-- in *);
VAR theSet : Set (*-- inout *))
: BOOLEAN (*-- out *);
BEGIN
IF (theSet # NIL) THEN
Clear(theSet);
theSet^.dataID := theType;
ELSE
theSet := Create(theSize, theType);
END (*--if*);
RETURN (setError = noerr);
END Recreate;
(*--------------------*)
(*
12.3.4 Constructors
Create begins by clearing the setError field under the assumption of a successful result.
The header for the set must then be allocated in a local variable since the function result
cannot be manipulated but only returned. The key to this allocation step is the
calculation of the number of bytes necessary based on the size of an individual item and
the number of items requested. We must not forget the space for storing theSize, the
Type, and the set length. The constant staticSize accomplishes this regardless of the
number and size of these ╥static╙ fields. The calculation is unaffected by changes in the
number or size of these fields that may come about due to future maintenance. If the
bounded set could not be allocated, the overflow exception must be raised, and the NullSet
returned.
At this point, all possibility of failure has been avoided and the bounded set header can be
initialized to its empty state, and the size limit and data type ID can be stored for this
bounded set. Lastly, the new set can be returned to the caller.
*)
PROCEDURE Create ( theSize : SizeRange (*-- in *);
theType : TypeID (*-- in *))
: Set (*-- out *);
CONST staticSize = SIZE(BoundedSet) - SIZE(ItemsArray);
CONST itemSize = SIZE(Item);
VAR newSet : Set;
BEGIN
setError := noerr;
Allocate(newSet, staticSize + itemSize * theSize);
IF (newSet # NIL) THEN
WITH newSet^ DO
size := theSize;
dataID := theType;
length := 0;
END (*--with*);
RETURN newSet;
END (*--if*);
RaiseErrIn(create, overflow);
RETURN NullSet;
END Create;
(*--------------------*)
(*
Destroy takes advantage that Clear sets setError to noerr and raises the undefined set
exception. So if Clear succeeds, Destroy simply releases the allocated set header.
*)
PROCEDURE Destroy (VAR theSet : Set (*-- inout *));
CONST staticSize = SIZE(BoundedSet) - SIZE(ItemsArray);
CONST itemSize = SIZE(Item);
BEGIN
Clear(theSet);
IF (setError = noerr) THEN
Deallocate(theSet, staticSize + itemSize * theSet^.size);
END (*--if*);
END Destroy;
(*--------------------*)
(*
Clear sets setError to noerr and checks for an undefined set raising the undefined set
exception if necessary. After asserting a valid set, the item disposal routine is retrieved
for the set, followed by the deallocation of every item in the set. Once this has been
taken care of, the set length is adjusted to the empty state.
*)
PROCEDURE Clear (VAR theSet : Set (*-- inout *));
VAR freeItem : DisposeProc; (*-- Item disposal routine, if any *)
index : CARDINAL; (*-- Loop index over items *)
BEGIN
setError := noerr;
IF (theSet # NIL) THEN
WITH theSet^ DO
freeItem := DisposeOf(dataID);
FOR index := MIN(SizeRange) TO length DO
freeItem(items[index]);
END (*--for*);
length := 0;
END (*--with*);
ELSE
RaiseErrIn(clear, undefined);
END (*--if*);
END Clear;
(*--------------------*)
(*
Assignment for bounded objects is simpler to implement than their unbounded
counterparts since the opportunity for overflow is restricted to when the target object is
being (re-)created.
If the target object exists and is capable of holding all of the source object's items the
target can be safely cleared and its data type updated appropriately. Otherwise, the
overflow exception is raised and the assignment operation aborted. When the target object
is initially undefined it must be created using the data type and size attributes of the
source object. If overflow does not occur, the actual assignment can commence,
otherwise its suffices to exit as Create has already raised the exception.
The assignment operator cannot be used to copy the whole items array as only a slice of
the array's index range was actually allocated and who knows what other dynamically
allocated objects follow it in memory. Nor can assignment be used to copy individual
items as the data type of those items is unknown; using assignment for dynamically
allocated items would cause structural sharing of items, which is not desired.
*)
PROCEDURE Assign ( theSet : Set (*-- in *);
VAR toSet : Set (*-- inout *));
VAR assignItem : AssignProc; (*-- Item assignment routine, if any *)
index : CARDINAL; (*-- Loop index over items *)
BEGIN
setError := noerr;
IF (theSet # NIL) THEN
WITH theSet^ DO
IF Recreate(dataID, size, toSet) THEN
IF (length <= toSet^.size) THEN
assignItem := AssignOf(dataID);
FOR index := MIN(SizeRange) TO length DO
toSet^.items[index] := assignItem(items[index]);
END (*--for*);
toSet^.length := length;
ELSE
RaiseErrIn(assign, overflow);
END (*--if*);
END (*--if*);
END (*--with*);
ELSE
RaiseErrIn(assign, undefined);
END (*--if*);
END Assign;
(*--------------------*)
(*
Include must add the given item to the set if it is not already a member or to simply exit
if the item is already a member (these semantics are compatible with Modula-2's INCL
operation). We could use the IsAMember selector except the index where the item is not
found is necessary to insert the item in its appropriate position within the ordered array.
Once we have this position, we make room for the new item by shifting all items above
the index position up by one index position in the array. Of course, there must be room
for the new item in the set. Then the new item is inserted into its proper place.
*)
PROCEDURE Include ( theItem : Item (*-- in *);
VAR inSet : Set (*-- 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
setError := noerr;
IF (inSet # NIL) THEN
WITH inSet^ DO
compareItem := CompareOf(dataID);
index := MIN(SizeRange);
LOOP
IF (index > length) THEN
EXIT (*--loop*);
END (*--if*);
itemOrder := compareItem(items[index], theItem);
IF (itemOrder = equal) THEN
RETURN;
ELSIF (itemOrder = greater) THEN
EXIT (*--loop*);
END (*--if*);
INC(index);
END (*--loop*);
IF (length < size) THEN
FOR jndex := length TO index BY -1 DO
items[jndex + 1] := items[jndex];
END (*--for*);
INC(length);
items[index] := theItem;
ELSE
RaiseErrIn(include, overflow);
END (*--if*);
END (*--with*);
ELSE
RaiseErrIn(include, undefined);
END (*--if*);
END Include;
(*--------------------*)
(*
Exclude undoes what Include did to add an item to the set; if the item is found then all
items above it in the array are shifted downward one position and the set length is updated
to reflect removal of the item. If the item is not found the routine simply exits to be
compatible with Modula-2's EXCL operation.
*)
PROCEDURE Exclude ( theItem : Item (*-- in *);
VAR fromSet : Set (*-- inout *));
VAR index : CARDINAL; (*-- Loop index over items *)
compareItem : CompareProc; (*-- Item comparison routine *)
itemOrder : Relation; (*-- Relation between items *)
BEGIN
setError := noerr;
IF (fromSet # NIL) THEN
WITH fromSet^ DO
compareItem := CompareOf(dataID);
index := MIN(SizeRange);
LOOP
IF (index > length) THEN
RETURN;
END (*--if*);
itemOrder := compareItem(items[index], theItem);
IF (itemOrder = equal) THEN
EXIT (*--loop*);
ELSIF (itemOrder = greater) THEN
RETURN;
END (*--if*);
INC(index);
END (*--loop*);
WHILE (index < length) DO
INC(index);
items[index - 1] := items[index];
END (*--while*);
DEC(length);
END (*--with*);
ELSE
RaiseErrIn(exclude, undefined);
END (*--if*);
END Exclude;
(*--------------------*)
(*
Union computes the set containing all members of left and right, e.g.,
x IN toSet iff (x IN left) OR (x IN right).
The algorithm used is a variation on the array merge from Augenstein and Tanenbaum [2,
pg. 414] and the set intersection algorithm presented in Aho, Hopcroft, and Ullman [1,
pg. 117].
The algorithm loops over the items of the left and right sets until the end of either is
reached. On each iteration, the items are compared for the ordering relation between them.
This is used to determine from which set an item is copied to the target set, and which
indexes to advance. In this manner, all items are processed only once and duplicate items
in the target set are avoided. The toSet length is used as the running index for adding the
resulting items of the union.
The last step is to copy the remaining items, if any, from either the left set or the right
set to the destination set.
*)
PROCEDURE Union ( left : Set (*-- in *);
right : Set (*-- in *);
VAR toSet : Set (*-- inout *));
VAR leftIndex : CARDINAL; (*-- Loop index over left set *)
rightIndex : CARDINAL; (*-- Loop index over right set *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
assignItem : AssignProc; (*-- Item assignment routine *)
BEGIN
setError := noerr;
IF (left = NIL) OR (right = NIL) THEN
RaiseErrIn(union, undefined);
RETURN;
ELSIF (left^.dataID # right^.dataID) THEN
RaiseErrIn(union, typeerror);
RETURN;
ELSIF ~Recreate(left^.dataID, left^.size, toSet) THEN
RETURN;
END (*--if*);
WITH toSet^ DO
compareItem := CompareOf(dataID);
assignItem := AssignOf(dataID);
END (*--with*);
leftIndex := MIN(SizeRange);
rightIndex := MIN(SizeRange);
WHILE (leftIndex <= left^.length) & (rightIndex <= right^.length) DO
order := compareItem(left^.items[leftIndex],
right^.items[rightIndex]);
WITH toSet^ DO
IF (length < size) THEN
INC(length);
ELSE
RaiseErrIn(union, overflow);
RETURN;
END (*--if*);
IF (order = less) THEN
items[length] := assignItem(left^.items[leftIndex]);
INC(leftIndex);
ELSIF (order = equal) THEN
items[length] := assignItem(left^.items[leftIndex]);
INC(leftIndex);
INC(rightIndex);
ELSE
items[length] := assignItem(right^.items[rightIndex]);
INC(rightIndex);
END (*--if*);
END (*--with*);
END (*--while*);
IF (leftIndex > left^.length) THEN
CopySubset(union, right, rightIndex, toSet);
ELSIF (rightIndex > right^.length) THEN
CopySubset(union, left, leftIndex, toSet);
END (*--if*);
END Union;
(*--------------------*)
(*
Intersection computes the set containing all members in both left and right sets, e.g.,
x IN toSet iff (x IN left) AND (x IN right).
The algorithm, similar to the set intersection algorithm given in Aho, Hopcroft, and
Ullman [1, pg. 117] for ordered lists, loops over the items of the left and right sets until
the end of either is reached. On each iteration, the items are compared for the ordering
relation between them. Equal items are copied to the target set and both indexes are
advanced, otherwise the index to the smaller item is advanced. In this manner, all items
are processed only once and duplicate items in the target set are avoided. The toSet length
is used as the running index for adding the resulting items of the intersection.
*)
PROCEDURE Intersection ( left : Set (*-- in *);
right : Set (*-- in *);
VAR toSet : Set (*-- inout *));
VAR leftIndex : CARDINAL; (*-- Loop index over left set *)
rightIndex : CARDINAL; (*-- Loop index over right set *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
assignItem : AssignProc; (*-- Item assignment routine *)
BEGIN
setError := noerr;
IF (left = NIL) OR (right = NIL) THEN
RaiseErrIn(intersection, undefined);
RETURN;
ELSIF (left^.dataID # right^.dataID) THEN
RaiseErrIn(intersection, typeerror);
RETURN;
ELSIF ~Recreate(left^.dataID, left^.size, toSet) THEN
RETURN;
END (*--if*);
WITH toSet^ DO
compareItem := CompareOf(dataID);
assignItem := AssignOf(dataID);
END (*--with*);
leftIndex := MIN(SizeRange);
rightIndex := MIN(SizeRange);
WHILE (leftIndex <= left^.length) & (rightIndex < right^.length) DO
order := compareItem(left^.items[leftIndex],
right^.items[rightIndex]);
IF (order = equal) THEN
WITH toSet^ DO
IF (length < size) THEN
INC(length);
items[length] := assignItem(left^.items[leftIndex]);
ELSE
RaiseErrIn(intersection, overflow);
RETURN;
END (*--if*);
END (*--with*);
INC(leftIndex);
INC(rightIndex);
ELSIF (order = less) THEN
INC(leftIndex);
ELSE
INC(rightIndex);
END (*--if*);
END (*--while*);
END Intersection;
(*--------------------*)
(*
Difference computes the set containing all members of the left set that are not members
of the right set, e.g.,
x IN toSet iff (x IN left) & ┬(x IN right)
The algorithm, similar to the above algorithm for intersection, loops over the items of
the left and right sets until the end of either is reached. On each iteration, the items are
compared for the ordering relation between them. Equal items are skipped and both
indexes advanced, otherwise the index to the smaller item is advanced. When the item
from the left set is less than that of the right set we know that it is not present in the
right set and can copy that item over to the target set. The toSet length is used as the
running index for adding the resulting items of the difference. The last step is to copy the
remaining items, if any, from the left set to the destination set.
*)
PROCEDURE Difference ( left : Set (*-- in *);
right : Set (*-- in *);
VAR toSet : Set (*-- inout *));
VAR leftIndex : CARDINAL; (*-- Loop index over left set *)
rightIndex : CARDINAL; (*-- Loop index over right set *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
assignItem : AssignProc; (*-- Item assignment routine *)
BEGIN
setError := noerr;
IF (left = NIL) OR (right = NIL) THEN
RaiseErrIn(difference, undefined);
RETURN;
ELSIF (left^.dataID # right^.dataID) THEN
RaiseErrIn(difference, typeerror);
RETURN;
ELSIF ~Recreate(left^.dataID, left^.size, toSet) THEN
RETURN;
END (*--if*);
WITH toSet^ DO
compareItem := CompareOf(dataID);
assignItem := AssignOf(dataID);
END (*--with*);
leftIndex := MIN(SizeRange);
rightIndex := MIN(SizeRange);
WHILE (leftIndex <= left^.length) & (rightIndex <= right^.length) DO
order := compareItem(left^.items[leftIndex],
right^.items[rightIndex]);
IF (order = equal) THEN
INC(leftIndex);
INC(rightIndex);
ELSIF (order = less) THEN
WITH toSet^ DO
IF (length < size) THEN
INC(length);
items[length] := assignItem(left^.items[leftIndex]);
ELSE
RaiseErrIn(difference, overflow);
RETURN;
END (*--if*);
END (*--with*);
INC(leftIndex);
ELSE
INC(rightIndex);
END (*--if*);
END (*--while*);
CopySubset(difference, left, leftIndex, toSet);
END Difference;
(*--------------------*)
(*
SymDifference computes the set containing all members of the left or right set that are
not members of both sets, e.g.,
x IN toSet iff (x IN left) ¡ (x IN right)
The algorithm, similar to that given above for union and difference, loops over the items
of the left and right sets until the end of either is reached. On each iteration, the items are
compared for the ordering relation between them. Equal items are skipped and both
indexes advanced, otherwise the index to the smaller item is advanced. When the items
between the two sets are unequal we can then copy the smaller of the two items over to
the target set. The toSet length is used as the running index for adding the resulting
items of the symmetric difference. The last step is to copy the remaining items, if any,
from either the left or right set, whichever has items remaining, to the target set.
*)
PROCEDURE SymDifference ( left : Set (*-- in *);
right : Set (*-- in *);
VAR toSet : Set (*-- inout *));
VAR leftIndex : CARDINAL; (*-- Loop index over left set *)
rightIndex : CARDINAL; (*-- Loop index over right set *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
assignItem : AssignProc; (*-- Item assignment routine *)
BEGIN
setError := noerr;
IF (left = NIL) OR (right = NIL) THEN
RaiseErrIn(symdifference, undefined);
RETURN;
ELSIF (left^.dataID # right^.dataID) THEN
RaiseErrIn(symdifference, typeerror);
RETURN;
ELSIF ~Recreate(left^.dataID, left^.size, toSet) THEN
RETURN;
END (*--if*);
WITH toSet^ DO
compareItem := CompareOf(dataID);
assignItem := AssignOf(dataID);
END (*--with*);
leftIndex := MIN(SizeRange);
rightIndex := MIN(SizeRange);
WHILE (leftIndex <= left^.length) & (rightIndex <= right^.length) DO
order := compareItem(left^.items[leftIndex],
right^.items[rightIndex]);
IF (order = equal) THEN
INC(leftIndex);
INC(rightIndex);
ELSE
WITH toSet^ DO
IF (length < size) THEN
INC(length);
ELSE
RaiseErrIn(symdifference, overflow);
RETURN;
END (*--if*);
IF (order = less) THEN
items[length] := assignItem(left^.items[leftIndex]);
INC(leftIndex);
ELSE
items[length] := assignItem(right^.items[rightIndex]);
INC(rightIndex);
END (*--if*);
END (*--with*);
END (*--if*);
END (*--while*);
IF (leftIndex > left^.length) THEN
CopySubset(symdifference, right, rightIndex, toSet);
ELSIF (rightIndex > right^.length) THEN
CopySubset(symdifference, left, leftIndex, toSet);
END (*--if*);
END SymDifference;
(*--------------------*)
(*
12.3.4 Selectors
IsDefined returns true if the given set is non-NIL, which is the simplest test for a defined
set object.
*)
PROCEDURE IsDefined ( theSet : Set (*-- in *))
: BOOLEAN (*-- out *);
BEGIN
RETURN (theSet # NIL);
END IsDefined;
(*--------------------*)
(*
IsEmpty (as always) returns the logical condition as to the state of the set's length,
which if zero indicates an empty set.
*)
PROCEDURE IsEmpty ( theSet : Set (*-- in *))
: BOOLEAN (*-- out *);
BEGIN
setError := noerr;
IF (theSet # NIL) THEN
RETURN (theSet^.length = 0);
END (*--if*);
RaiseErrIn(isempty, undefined);
RETURN TRUE;
END IsEmpty;
(*--------------------*)
(*
Sizeof simply returns the defined size for the given set or a default value for an undefined
set. TypeOf is similar except that it deals with the set's data type ID.
*)
PROCEDURE SizeOf ( theSet : Set (*-- in *))
: CARDINAL (*-- out *);
BEGIN
setError := noerr;
IF (theSet # NIL) THEN
RETURN theSet^.size;
END (*--if*);
RaiseErrIn(sizeof, undefined);
RETURN 0;
END SizeOf;
(*--------------------*)
PROCEDURE TypeOf ( theSet : Set (*-- in *))
: TypeID (*-- out *);
BEGIN
setError := noerr;
IF (theSet # NIL) THEN
RETURN theSet^.dataID;
END (*--if*);
RaiseErrIn(typeof, undefined);
RETURN NullType;
END TypeOf;
(*--------------------*)
(*
IsEqual must return true if the two given sets each contain the same items. After
enforcing the required preconditions, the lengths of the sets are compared in a simple test
for inequality. If the lengths are equal it is possible for the sets to be equal so we loop
over each item of both sets returning false upon encountering the first inequality between
two items. True is returned if the loop completes without finding any mismatched items.
*)
PROCEDURE IsEqual ( left : Set (*-- in *);
right : Set (*-- in *))
: BOOLEAN (*-- out *);
VAR index : CARDINAL; (*-- Loop index over items *)
compare : CompareProc; (*-- item comparison routine *)
BEGIN
setError := noerr;
IF (left # NIL) & (right # NIL) THEN
IF (left^.dataID = right^.dataID) THEN
IF (left^.length = right^.length) THEN
compare := CompareOf(left^.dataID);
FOR index := MIN(SizeRange) TO left^.length DO
IF compare(left^.items[index], right^.items[index]) # equal THEN
RETURN FALSE;
END (*--if*);
END (*--for*);
RETURN TRUE;
END (*--if*);
ELSE
RaiseErrIn(isequal, typeerror);
END (*--if*);
ELSE
RaiseErrIn(isequal, undefined);
END (*--if*);
RETURN FALSE;
END IsEqual;
(*----------------------------*)
(*
NumMembers needs to simply return the current set length or for an undefined set return
zero as it is impossible to have any members in such a set.
*)
PROCEDURE NumMembers ( theSet : Set (*-- in *))
: CARDINAL (*-- out *);
BEGIN
setError := noerr;
IF (theSet # NIL) THEN
RETURN theSet^.length;
END (*--if*);
RaiseErrIn(nummembers, undefined);
RETURN 0;
END NumMembers;
(*----------------------------*)
(*
IsAMember seeks to determine whether the given item is a member of the given set by
scanning each of the items in the set in turn. There are two conditions that could cause
the loop to terminate prior to reaching the last item: (1) the item and a set item match
indicating that the item is a member of the set, and (2) the item is greater than a set item
indicating non-membership since the set items are linearly ordered. If the end of the loop
is reached and we have not exited with a match then by implication the item is not
present.
*)
PROCEDURE IsAMember ( theItem : Item (*-- in *);
theSet : Set (*-- in *))
: BOOLEAN (*-- out *);
VAR index : CARDINAL; (*-- Loop index over items *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
BEGIN
setError := noerr;
IF (theSet # NIL) THEN
WITH theSet^ DO
compareItem := CompareOf(dataID);
FOR index := MIN(SizeRange) TO length DO
IF (theItem = items[index]) THEN
RETURN TRUE;
ELSE
order := compareItem(items[index], 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;
(*----------------------------*)
(*
IsSubset after ensuring that the required preconditions are met, proceeds to loop through
the items of the left and right sets attempting to determine if every member of the left set
is also a member of the right set. Because the items of the array are linearly ordered in
ascending sequence inequality can be determined quicker than with a completely unordered
set implementation. When an item of the left set is less than its counterpart in the right
set we can immediately return false knowing that that item is not present in the right set.
If the left item is greater then we know that we must advance the index into the right set
since the item may yet be found further into the array. When the items are equal both
indexes are advanced. When the end of the loop has been reached without premature exit,
the left set can only be a subset of the right if we have examined beyond the end of the
left set.
*)
PROCEDURE IsSubset ( left : Set (*-- in *);
right : Set (*-- in *))
: BOOLEAN (*-- out *);
VAR leftIndex : CARDINAL; (*-- Loop index over left set *)
rightIndex : CARDINAL; (*-- Loop index over right set *)
compareItem : CompareProc; (*-- Item comparison routine *)
order : Relation; (*-- Ordering relation between items *)
BEGIN
setError := noerr;
IF (left = NIL) OR (right = NIL) THEN
RaiseErrIn(issubset, undefined);
RETURN FALSE;
ELSIF (left^.dataID # right^.dataID) THEN
RaiseErrIn(issubset, typeerror);
RETURN FALSE;
END (*--if*);
compareItem:= CompareOf(left^.dataID);
leftIndex := MIN(SizeRange);
rightIndex := MIN(SizeRange);
WHILE (leftIndex <= left^.length) & (rightIndex <= right^.length) DO
order := compareItem(left^.items[leftIndex],
right^.items[rightIndex]);
IF (order = equal) THEN
INC(leftIndex);
INC(rightIndex);
ELSIF (order = less) THEN
RETURN FALSE;
ELSE
INC(rightIndex);
END (*--if*);
END (*--while*);
RETURN (leftIndex > left^.length);
END IsSubset;
(*----------------------------*)
PROCEDURE IsProperSubset( left : Set (*-- in *);
right : Set (*-- in *))
: BOOLEAN (*-- out *);
BEGIN
RETURN IsSubset(left, right) & (left^.length < right^.length);
END IsProperSubset;
(*----------------------------*)
(*
12.3.6 Iterators
Both iterators are simply loops over each of the items in the given set. LoopOver may
be terminated before reaching the last item in the set if the access procedure returns false.
*)
PROCEDURE LoopOver ( theSet : Set (*-- in *);
process : LoopAccessProc (*-- in *));
VAR index : CARDINAL; (*-- Loop index over items *)
BEGIN
setError := noerr;
IF (theSet # NIL) THEN
WITH theSet^ DO
FOR index := MIN(SizeRange) TO length DO
IF ~process(items[index]) THEN
RETURN;
END (*--if*);
END (*--for*);
END (*--with*);
ELSE
RaiseErrIn(loopover, undefined);
END (*--if*);
END LoopOver;
(*----------------------------*)
PROCEDURE Traverse ( theSet : Set (*-- in *);
process : AccessProc (*-- in *));
VAR index : CARDINAL; (*-- Loop index over items *)
BEGIN
setError := noerr;
IF (theSet # NIL) THEN
WITH theSet^ DO
FOR index := MIN(SizeRange) TO length DO
process(items[index]);
END (*--for*);
END (*--with*);
ELSE
RaiseErrIn(traverse, undefined);
END (*--if*);
END Traverse;
(*----------------------------*)
(*
12.2.7 Module Initialization
In the module initialization the local exception handlers array variables are set to default
handlers (ExitOnError) except for the noerr handler which is given the null handler.
setError is given the value noerr avoiding an undefined state.
*)
BEGIN
FOR setError := MIN(Exceptions) TO MAX(Exceptions) DO
handlers[setError] := ExitOnError;
END (*--for*);
handlers[noerr] := NullHandler;
setError := noerr;
END SetSBMI.
(*
References
[1] A. Aho, J. Hopcroft and J. Ullman, Data Structures and Algorithms, Addison-Wesley,
Reading, MA 1983.
[2] A.M. Tenenbaum and M.J. Augenstein, Data Structures Using Pascal, Prentice-Hall,
Englewood Cliffs, NJ 1981.
*)