Topspeed_JPI/TS/MODBASE/BIGSETS.MOD

IMPLEMENTATION MODULE BigSets;
(*
 *  REPERTOIRE
 *  Release 1.6
 *  By Charles Bradford and Cole Brecheen
 *  (c) Copyright 1985-1992 PMI
 *  Green Bay, Wisconsin
 *  All rights reserved
 *  (414) 468-6040
 *
 *  $Header:   D:/logfiles/mods/bigsets.mov   1.3   10 Mar 1991 15:25:08   coleb  $
 *
 *
 *  Written and contributed by Wilbur C. Andrews.
 *
 *)


IMPORT ErrorManager;
IMPORT M2Strings;
IMPORT StrEdit;


VAR
  Initialized : BOOLEAN;

  PROCEDURE Init();
    BEGIN
      IF Initialized THEN
        RETURN;
      ELSE
        Initialized := TRUE;
      END;
      ErrorManager.Init();
      M2Strings.Init();
      StrEdit.Init();

      InitSet(DigitSet);
      InitSet(ChSet);
      AppendSet(DigitSet, "{'0'..'9'}");
      AppendSet(ChSet, "{' '..'~'}");
    END Init;


  CONST
    begin = 1;
    Dot = 2;
    Quote = 3;
    statement = 4;
    incomplete = 5;
    end = 7;
    StartSym = '{';
    EndSym = '}';



  PROCEDURE SetStuff(n : CARDINAL; VAR ArrayNo, Index : CARDINAL);
    BEGIN
      IF n=0 THEN
        ArrayNo := 0;
        Index := 0;
      ELSE
        ArrayNo := n DIV BitSetSize;
        Index := n MOD BitSetSize;
      END;
    END SetStuff;

  PROCEDURE InitSet(VAR BSet : ARRAY OF BITSET);
    VAR
      n : CARDINAL;
    BEGIN
      FOR n := 0 TO HIGH(BSet) DO
        BSet[n] := {};
      END;
    END InitSet;

  PROCEDURE AssignSet(Set1 : ARRAY OF BITSET; VAR Set2 : ARRAY OF
      BITSET);
    VAR
      a : CARDINAL;
    BEGIN
      FOR a := 0 TO HIGH(Set1) DO
        Set2[a] := Set1[a];
      END;
    END AssignSet;

  PROCEDURE Check( ArrayNumber, LastBitSet: CARDINAL );
    BEGIN
      IF ArrayNumber > LastBitSet THEN
        ErrorManager.WARN( "Set element out of range");
      END;
    END Check;

  PROCEDURE InclSet(VAR BSet : ARRAY OF BITSET; n : CARDINAL);
    VAR
      ArrayNo, Index : CARDINAL;
    BEGIN
      SetStuff(n, ArrayNo, Index);
      Check( ArrayNo, HIGH(BSet) );
      INCL(BSet[ArrayNo], Index);
    END InclSet;

  PROCEDURE ExclSet(VAR BSet : ARRAY OF BITSET; n : CARDINAL);
    VAR
      ArrayNo, Index : CARDINAL;
    BEGIN
      SetStuff(n, ArrayNo, Index);
      Check( ArrayNo, HIGH(BSet) );
      EXCL(BSet[ArrayNo], Index);
    END ExclSet;

  PROCEDURE InSet(VAR BSet : ARRAY OF BITSET; n : CARDINAL) : BOOLEAN;
    VAR
      ArrayNo, Index : CARDINAL;
      bool : BOOLEAN;
    BEGIN
      SetStuff(n, ArrayNo, Index);
      Check( ArrayNo, HIGH(BSet) );
      bool := Index IN BSet[ArrayNo];
      RETURN bool;
    END InSet;

  PROCEDURE EqualSet(VAR SetOne, SetTwo : ARRAY OF BITSET) : BOOLEAN;
    VAR
      EqualBool : BOOLEAN;
      a : CARDINAL;
    BEGIN
      a := 0;
      EqualBool := TRUE;
      WHILE (a<=HIGH(SetOne)) AND EqualBool DO
        EqualBool := SetOne[a]=SetTwo[a];
        a := a+1;
      END;
      RETURN EqualBool;
    END EqualSet;


  PROCEDURE AppendSet(VAR BSet : ARRAY OF BITSET; st : ARRAY OF CHAR);

  TYPE
    SetStType = ARRAY [0..79] OF CHAR;
    StRecord =
      RECORD
        Item : SetStType;
        type : (card, octal, char);
      END;

    VAR
      ch : CHAR;
      Error, count : CARDINAL;
      CodeSt : SetStType;
      StartSt, EndSt : StRecord;
      EndBool : BOOLEAN;
      message: ARRAY [0..79] OF CHAR;
      dumstr: ARRAY [0..0] OF CHAR;

    PROCEDURE GetCh();
      BEGIN
        IF count<=(M2Strings.Length(CodeSt)-1) THEN
          ch := CodeSt[count];
          INC(count);
        ELSE
          ch := 0C;
        END;
      END GetCh;

    PROCEDURE GetSym();
      BEGIN
        GetCh();
        WHILE ch=' ' DO
          GetCh();
        END;
      END GetSym;

    PROCEDURE StToNum(st : ARRAY OF CHAR; base : CARDINAL) : CARDINAL;
      VAR
        a, c : CARDINAL;
      BEGIN
        c := 0;
        FOR a := 0 TO M2Strings.Length(st)-1 DO
          c := c*base+(ORD(st[a])-ORD('0'));
        END;
        RETURN c;
      END StToNum;

    PROCEDURE AddToSet(VAR BSet : ARRAY OF BITSET);
      VAR
        StartNum, EndNum : CARDINAL;

      PROCEDURE SetNum(st : StRecord) : CARDINAL;
        BEGIN
          CASE st.type OF
            card :
            RETURN StToNum(st.Item,10);
          | octal :
            RETURN StToNum(st.Item,8);
          | char :
            RETURN ORD(st.Item[0]);
          END;
          RETURN 0;
        END SetNum;

      BEGIN
        (* AddToSet *)
        IF M2Strings.Length(EndSt.Item)>0 THEN
          IF M2Strings.Length(StartSt.Item)=0 THEN
            InclSet(BSet, SetNum(EndSt));
          ELSE
            StartNum := SetNum(StartSt);
            EndNum := SetNum(EndSt);
            WHILE StartNum<=EndNum DO
              InclSet(BSet, StartNum);
              INC(StartNum);
            END;
          END;
        END;
        StartSt.Item := 0C;
        EndSt.Item := 0C;
      END AddToSet;

    PROCEDURE AddToNumSt(ch : CHAR; VAR st : ARRAY OF CHAR);
      BEGIN
        StrEdit.Append(st, ch);
      END AddToNumSt;

    PROCEDURE DecodeDot();
      BEGIN
        IF ch='.' THEN
          StartSt := EndSt;
          EndSt.Item := 0C;
        ELSE
          Error := Dot;
          EndBool := TRUE;
        END;
      END DecodeDot;

    PROCEDURE DecodeNum();
      BEGIN
        EndSt.type := card;
        AddToNumSt(ch, EndSt.Item);
        GetCh();
        WHILE (ch>='0') AND (ch<='9') DO
          AddToNumSt(ch, EndSt.Item);
          GetCh();
        END;
        IF CAP(ch)='C' THEN
          EndSt.type := octal;
          GetCh();
        END;
      END DecodeNum;

    PROCEDURE DecodeQuote(QuoteCh : CHAR);
      BEGIN
        EndSt.Item[0] := ch;
        EndSt.Item[1] := 0C;
        EndSt.type := char;
        GetCh();
        IF ch#QuoteCh THEN
          Error := Quote;
          EndBool := TRUE;
        END;
      END DecodeQuote;

    PROCEDURE Statement();
      BEGIN
        (* Statement *)
        StartSt.Item := 0C;
        EndSt.Item := 0C;
        WHILE (NOT EndBool) DO
          IF ch="'" THEN
        (* Character *)
            GetCh();
            DecodeQuote("'");
            GetSym();
          ELSIF ch='"' THEN
        (* Character *)
            GetCh();
            DecodeQuote('"');
            GetSym();
          ELSIF (ch>='0') AND (ch<='9') THEN
        (* CARDINAL OR OCTAL Number *)
            DecodeNum();
            IF ch=' ' THEN
              GetSym();
            END;
          ELSE
            Error := statement;
            EndBool := TRUE;
          END;
          IF ch=0C THEN
            Error := incomplete;
                             (* End of string reached *)
            EndBool := TRUE;
          ELSIF ch=',' THEN
            AddToSet(BSet);
            GetSym();
          ELSIF ch='.' THEN
            GetCh();
            DecodeDot();
            GetSym();
          ELSIF ch=EndSym THEN
            EndBool := TRUE;
          ELSE
            Error := statement;
            EndBool := TRUE;
          END;
        END;
          (* WHILE NOT EndBool *)
      END Statement;

    BEGIN
      (* AppendSet *)
      StrEdit.AssignStr( st, CodeSt );
      EndBool := FALSE;
      Error := 0;
      count := 0;
      ch := ' ';
      GetSym();
      IF ch=StartSym THEN
        GetSym();
        IF ch#EndSym THEN
          Statement();
        END;
      ELSE
        Error := begin;
        EndBool := TRUE;
      END;
      IF (ch=EndSym) AND (Error=0) THEN
        AddToSet(BSet);
      ELSIF Error=0 THEN
        Error := end;
      END;
      IF Error # 0 THEN
        StrEdit.AssignStr( 'Programmer error #', message );
        dumstr[0] := CHR(Error);
        StrEdit.Append( message, dumstr );
        StrEdit.Append( message, 'in AppendSet.' );
        ErrorManager.WARN( message );
      END;
    END AppendSet;

  PROCEDURE InclCh(VAR ChSet : ARRAY OF BITSET; ch : CHAR);
    VAR
      n : CARDINAL;
    BEGIN
      n := ORD(ch);
      InclSet(ChSet, n);
    END InclCh;

  PROCEDURE ExclCh(VAR ChSet : ARRAY OF BITSET; ch : CHAR);
    VAR
      n : CARDINAL;
    BEGIN
      n := ORD(ch);
      ExclSet(ChSet, n);
    END ExclCh;

  PROCEDURE InChSet(VAR ChSet : ARRAY OF BITSET; ch : CHAR) : BOOLEAN;
    VAR
      n : CARDINAL;
      bool : BOOLEAN;
    BEGIN
      n := ORD(ch);
      bool := InSet(ChSet,n);
      RETURN bool;
    END InChSet;

  PROCEDURE InTest(SetSt : ARRAY OF CHAR; TestCh : CHAR) : BOOLEAN;
    VAR
      TestSet : ChSetArray;
    BEGIN
      InitSet(TestSet);
      AppendSet(TestSet, SetSt);
      RETURN InChSet(TestSet,TestCh);
    END InTest;


(* The procedures below assume that SetOne, SetTwo,
   and result are all of equal size.  The compiler's
   range checking option ought to catch violations of
   that assumption, but particular implementations may
   not.  The routines could be rewritten to deal with
   sets of unequal size, but that would take a lot more
   code and would probably be much slower. *)

  PROCEDURE SetUnion( SetOne, SetTwo: ARRAY OF BITSET;
      VAR result: ARRAY OF BITSET );
    VAR
      cnt, last: CARDINAL;
    BEGIN
      InitSet( result );
      last := HIGH( SetOne );
      FOR cnt := 0 TO last DO
        result[cnt] := SetOne[cnt] + SetTwo[cnt];
      END;
    END SetUnion;

  PROCEDURE SetDifference( SetOne, SetTwo: ARRAY OF
      BITSET; VAR result: ARRAY OF BITSET );
    VAR
      cnt, last: CARDINAL;
    BEGIN
      InitSet( result );
      last := HIGH( SetOne );
      FOR cnt := 0 TO last DO
        result[cnt] := SetOne[cnt] - SetTwo[cnt];
      END;
    END SetDifference;

  PROCEDURE SetIntersection( SetOne, SetTwo: ARRAY OF
      BITSET; VAR result: ARRAY OF BITSET );
    VAR
      cnt, last: CARDINAL;
    BEGIN
      InitSet( result );
      last := HIGH( SetOne );
      FOR cnt := 0 TO last DO
        result[cnt] := SetOne[cnt] * SetTwo[cnt];
      END;
    END SetIntersection;

  PROCEDURE SetSymmetricDiff( SetOne, SetTwo: ARRAY OF
      BITSET; VAR result: ARRAY OF BITSET );
    VAR
      cnt, last: CARDINAL;
    BEGIN
      InitSet( result );
      last := HIGH( SetOne );
      FOR cnt := 0 TO last DO
        result[cnt] := SetOne[cnt] / SetTwo[cnt];
      END;
    END SetSymmetricDiff;

BEGIN
  Initialized := FALSE;
  Init();
END BigSets.