BAGCSBMN.MOD

IMPLEMENTATION MODULE BagCSBMN;
(*==============================================================
    Version  : 1.00  30 Apr 1989  C. Lins
    Compiler : TopSpeed Modula-2
    Code Size: R-  bytes
    Component: Monolithic Structure - Bag
               Character Sequential Bounded Managed Non-Iterator

    INTRODUCTION
    This module supports the abstract data type bag for discrete
    values of CHARs.

    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 CharItems IMPORT
    (*--Type*) Item;

FROM BagEnum IMPORT
    (*--Type*) Exceptions, Operations, ComponentID;

FROM ErrorHandling IMPORT
    (*--Type*) HandlerProc,
    (*--Proc*) NullHandler, Raise, ExitOnError;

    (*-----------------------*)

TYPE  ItemsArray = ARRAY Item OF CARDINAL;
TYPE  BoundedBag = RECORD
        items : ItemsArray;
      END (*-- BoundedBag *);

TYPE  Bag = POINTER TO BoundedBag;


    (*-----------------------*)

VAR   theEmptyBag : ItemsArray; (*-- Predefined bag, initialized to 0 *)

    (*-----------------------*)
    (*--     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;
(*----------------------------*)

PROCEDURE Recreate   (VAR theBag : Bag     (*-- inout *))
                                 : BOOLEAN (*-- out   *);
BEGIN
  IF (theBag = NullBag) THEN
    theBag := Create();
  END (*--if*);
  RETURN (theBag # NIL);
END Recreate;
(*----------------------------*)


    (*---------------------------------*)
    (*--        CONSTRUCTORS         --*)

PROCEDURE Create        ()           : Bag         (*-- out   *);

VAR   newBag : Bag;

BEGIN
  bagError := noerr;
  Allocate(newBag, SIZE(BoundedBag));
  IF (newBag = NullBag) THEN
	RaiseErrIn(create, overflow);
  ELSE
    newBag^.items := theEmptyBag;
  END (*--if*);
  RETURN newBag;
END Create;
(*----------------------------*)

PROCEDURE Destroy       (VAR theBag    : Bag         (*-- inout *));
BEGIN
  Clear(theBag);
  IF (bagError = noerr) THEN
    Deallocate(theBag, SIZE(BoundedBag));
  END (*--if*);
END Destroy;
(*----------------------------*)

PROCEDURE Clear         (VAR theBag    : Bag         (*-- inout *));
BEGIN
  bagError := noerr;
  IF (theBag # NullBag) THEN
    theBag^.items := theEmptyBag;
  ELSE
    RaiseErrIn(clear, undefined);
  END (*--if*);
END Clear;
(*----------------------------*)

PROCEDURE Assign        (    theBag  : Bag         (*-- in    *);
                         VAR toBag   : Bag         (*-- inout *));
BEGIN 
  bagError := noerr;
  IF (theBag # NullBag) THEN
    IF Recreate(toBag) THEN
      toBag^.items := theBag^.items;
    END (*--if*);
  ELSE
    RaiseErrIn(assign, undefined);
  END (*--if*);
END Assign;
(*----------------------------*)

PROCEDURE Include       (    theItem : Item        (*-- in    *);
       	       	         VAR inBag   : Bag         (*-- inout *));
BEGIN
  bagError := noerr;
  IF (inBag # NullBag) THEN
    WITH inBag^ DO
      IF (items[theItem] < MAX(CARDINAL)) THEN
	INC(items[theItem]);
      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 *));
BEGIN
  bagError := noerr;
  IF (fromBag # NullBag) THEN
    WITH fromBag^ DO
      IF (items[theItem] > MIN(CARDINAL)) THEN
	DEC(items[theItem]);
      ELSE
	RaiseErrIn(exclude, notinbag);
      END (*--if*);
    END (*--with*);
  ELSE
    RaiseErrIn(exclude, undefined);
  END (*--if*);
END Exclude;
(*----------------------------*)

PROCEDURE Union         (    left   : Bag         (*-- in    *);
       	       	             right  : Bag         (*-- in    *);
                         VAR toBag  : Bag         (*-- inout *));

VAR   index : Item; (*-- loop index over items *)

BEGIN
  bagError := noerr;
  IF (left # NullBag) & (right # NullBag) THEN
    IF Recreate(toBag) THEN
      WITH toBag^ DO
        FOR index := MIN(Item) TO MAX(Item) DO
          items[index] := left^.items[index] + right^.items[index];
        END (*--for*);
      END (*--with*)
    END (*--if*);
  ELSE
    RaiseErrIn(union, undefined);
  END (*--if*);
END Union;
(*----------------------------*)

PROCEDURE Intersection  (    left   : Bag         (*-- in    *);
       	       	             right  : Bag         (*-- in    *);
                         VAR toBag  : Bag         (*-- inout *));

VAR   index : Item; (*-- loop index over items *)

BEGIN
  bagError := noerr;
  IF (left # NullBag) & (right # NullBag) THEN
    IF Recreate(toBag) THEN
      WITH toBag^ DO
        FOR index := MIN(Item) TO MAX(Item) DO
	  IF (left^.items[index] < right^.items[index]) THEN
            items[index] := left^.items[index];
	  ELSE
            items[index] := right^.items[index];
	  END (*--if*);
        END (*--for*);
       END (*--with*);
    END (*--if*);
  ELSE
    RaiseErrIn(intersection, undefined);
  END (*--if*);
END Intersection;
(*----------------------------*)

PROCEDURE Difference    (    left    : Bag         (*-- in    *);
       	       	             right   : Bag         (*-- in    *);
                         VAR toBag   : Bag         (*-- inout *));

VAR   index : Item; (*-- loop index over items *)

BEGIN
  bagError := noerr;
  IF (left # NullBag) & (right # NullBag) THEN
    IF Recreate(toBag) THEN
      WITH toBag^ DO
        FOR index := MIN(Item) TO MAX(Item) DO
	  IF (right^.items[index] = 0) THEN
	    items[index] := left^.items[index];
	  ELSIF (left^.items[index] > right^.items[index]) THEN
            items[index] := left^.items[index] - right^.items[index];
	  ELSE
	    items[index] := 0;
	  END (*--if*);
        END (*--for*);
      END (*--with*);
    END (*--if*);
  ELSE
    RaiseErrIn(difference, undefined);
  END (*--if*);
END Difference;
(*----------------------------*)

PROCEDURE SymDifference (    left    : Bag         (*-- in    *);
       	       	             right   : Bag         (*-- in    *);
                         VAR toBag   : Bag         (*-- inout *));

VAR   index : Item; (*-- loop index over items *)

BEGIN
  bagError := noerr;
  IF (left # NullBag) & (right # NullBag) THEN
    IF Recreate(toBag) THEN
      WITH toBag^ DO
        FOR index := MIN(Item) TO MAX(Item) DO
	  IF (right^.items[index] = 0) THEN
	    items[index] := left^.items[index];
	  ELSIF (left^.items[index] > right^.items[index]) THEN
            items[index] := left^.items[index] - right^.items[index];
	  ELSE
            items[index] := right^.items[index] - left^.items[index];
	  END (*--if*);
        END (*--for*);
      END (*--with*);
    END (*--if*);
  ELSE
    RaiseErrIn(symdifference, undefined);
  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   *);

VAR   index : Item; (*-- loop index over items *)

BEGIN
  bagError := noerr;
  IF (theBag # NullBag) THEN
    WITH theBag^ DO
      FOR index := MIN(Item) TO MAX(Item) DO
        IF (items[index] # 0) THEN
          RETURN FALSE;
        END (*--if*);
      END (*--for*);
    END (*--with*);
  ELSE
    RaiseErrIn(isempty, undefined);
  END (*--if*);
  RETURN TRUE;
END IsEmpty;
(*----------------------------*)

PROCEDURE IsEqual       (    left      : Bag         (*-- in    *);
       	       	       	     right     : Bag         (*-- in    *))
                                       : BOOLEAN     (*-- out   *);

VAR   index : Item;   (*-- loop index over items *)

BEGIN
  bagError := noerr;
  IF (left # NullBag) & (right # NullBag) THEN
    WITH left^ DO
      FOR index := MIN(Item) TO MAX(Item) DO
        IF (items[index] # right^.items[index]) THEN
          RETURN FALSE;
        END (*--if*);
      END (*--for*);
    END (*--with*);
    RETURN TRUE;
  ELSE
    RaiseErrIn(isequal, undefined);
  END (*--if*);
  RETURN FALSE;
END IsEqual;
(*----------------------------*)

PROCEDURE NumMembers    (    theBag  : Bag         (*-- in    *))
                                     : CARDINAL    (*-- out   *);

VAR   index : Item;     (*-- loop index over items *)
      count : CARDINAL; (*-- working sum of items in the bag *)

BEGIN
  bagError := noerr;
  count    := 0;
  IF (theBag # NullBag) THEN
    WITH theBag^ DO
      FOR index := MIN(Item) TO MAX(Item) DO
        INC(count, items[index]);
      END (*--for*);
    END (*--with*);
  ELSE
    RaiseErrIn(nummembers, undefined);
  END (*--if*);
  RETURN count;
END NumMembers;
(*----------------------------*)

PROCEDURE UniqueMembers (    theBag  : Bag         (*-- in    *))
                                     : CARDINAL    (*-- out   *);

VAR   index : Item;     (*-- loop index over items *)
      count : CARDINAL; (*-- working sum of unique items in the bag *)

BEGIN
  bagError := noerr;
  count    := 0;
  IF (theBag # NullBag) THEN
    WITH theBag^ DO
      FOR index := MIN(Item) TO MAX(Item) DO
	IF (items[index] > 0) THEN
          INC(count);
	END (*--if*);
      END (*--for*);
    END (*--with*);
  ELSE
    RaiseErrIn(uniquemembers, undefined);
  END (*--if*);
  RETURN count;
END UniqueMembers;
(*----------------------------*)

PROCEDURE IsAMember     (    theItem : Item        (*-- in    *);
       	       	             theBag  : Bag         (*-- in    *))
                                     : BOOLEAN     (*-- out   *);
BEGIN
  bagError := noerr;
  IF (theBag # NullBag) THEN
    RETURN theBag^.items[theItem] > 0;
  ELSE
    RaiseErrIn(ismember, undefined);
  END (*--if*);
  RETURN FALSE;
END IsAMember;
(*----------------------------*)

PROCEDURE NumberOf      (    theItem : Item        (*-- in    *);
       	       	             theBag  : Bag         (*-- in    *))
                                     : CARDINAL    (*-- out   *);
BEGIN
  bagError := noerr;
  IF (theBag # NullBag) THEN
    RETURN theBag^.items[theItem];
  ELSE
    RaiseErrIn(numberof, undefined);
  END (*--if*);
  RETURN 0;
END NumberOf;
(*----------------------------*)

PROCEDURE IsSubset      (    left    : Bag         (*-- in    *);
                             right   : Bag         (*-- in    *))
                                     : BOOLEAN     (*-- out   *);

VAR   index : Item; (*-- loop index over items *)

BEGIN
  bagError := noerr;
  IF (left # NullBag) & (right # NullBag) THEN
    WITH left^ DO
      FOR index := MIN(Item) TO MAX(Item) DO
        IF (items[index] > right^.items[index]) THEN
          RETURN FALSE;
        END (*--if*);
      END (*--for*);
    END (*--with*);
    RETURN TRUE;
  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) & ~IsEqual(left, right);
END IsProperSubset;
(*----------------------------*)


(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
(*~~ MODULE INITIALIZATION  ~~*)

VAR   index : Item; (*-- loop index over items *)

BEGIN
  FOR index := MIN(Item) TO MAX(Item) DO
    theEmptyBag[index] := 0;
  END (*--for*);

  FOR bagError := MIN(Exceptions) TO MAX(Exceptions) DO
    handlers[bagError] := ExitOnError;
  END (*--for*);
  handlers[noerr] := NullHandler;
  bagError := noerr;
END BagCSBMN.