OS/2 Shareware BBS: 10 Tools/10-Tools.zip/modu1096.zip/sample/tautology.mod

Text File | 1995-03-29 | 25KB | 936 lines

(****************************************************************)
(*                                *)
(*     (c) copyright 1990 Faculty of Information Technology    *)
(*        Queensland University of Technology        *)
(*                                *)
(*     Permission is granted to use, copy and change this    *)
(*     program as long as the copyright message is left intact    *)
(*                                *)
(****************************************************************)

MODULE Tautology;

IMPORT Storage;
IMPORT Terminal;
IMPORT GenSequenceSupport;
FROM Terminal IMPORT WriteString, WriteLn, Write;

  CONST EOL = 012C;
        nul = 0C;
        bs  = 010C;
        del = 177C;

  TYPE SymbolType = (idSy, andSy, check, evSy, fSy, input, notSy,
            eqSy, orSy, quit, tSy, lPar, rPar, errSy, endSy);

  VAR  errors : BOOLEAN;


  PROCEDURE Error(s : ARRAY OF CHAR);
    VAR i : CARDINAL;
  BEGIN
    (* only give pointer for first call *)
    IF NOT errors THEN
     TermSkip;
     FOR i := 1 TO pos DO Write(' ') END;
      Write('^'); WriteLn;
    END;
    WriteString(s); WriteLn;
    errors := TRUE;
  END Error;

(*******************************************************************)
(* This module contains all the input/output to the console        *)
(* It keeps track of positions in the input for the benefit of the *)
(* procedure Error, and defines the output line type.              *)
(*******************************************************************)

MODULE IOHandler;
IMPORT Terminal, EOL, nul, bs, del,
       WriteString, WriteLn, Write;
EXPORT    GetCh, Line,
    TermSkip, ch, pos, lnMx;

  CONST lnMx = 79;
  TYPE  Line = ARRAY [0..lnMx] OF CHAR;
  VAR   ch   : CHAR;
        pos  : CARDINAL;
    inputLine: Line;
    lineLength: CARDINAL;

  PROCEDURE GetLine;
    VAR index : CARDINAL;
        inChr : CHAR;
  BEGIN
    index := 0;
    Terminal.Read(inChr);
    WHILE (inChr <> EOL) AND (index < lnMx) DO
(*
   new code follows
*)
      inputLine[index] := inChr;
      INC(index);
      Terminal.Read(inChr);
    END;
    inputLine[index] := nul;
    pos := 0;
(*
   UNIX does the echo for us, so delete all this ...

      IF inChr <> bs THEN
        inputLine[index] := inChr;
        Write(inChr);
        INC(index);
      ELSIF index > 0 THEN
        Write(del);
        DEC(index);
      END;
      Terminal.Read(inChr);
    END;
    inputLine[index] := nul;
    WriteLn;
    pos := 0;
*)
  END GetLine;

  PROCEDURE GetCh;
  BEGIN
    IF ch = nul THEN GetLine END;
    ch:=inputLine[pos];
    INC(pos);
  END GetCh;

  PROCEDURE TermSkip;
  (* this procedure corrects alignment of error messages    *)
  BEGIN
    WriteString("     ");
  END TermSkip;

BEGIN
  ch := nul;
  pos := 0;
END IOHandler;

(*******************************************************************)
(* This module provides the symbol table facilities for the system *)
(* and also performs string handling for the lexical scanner.       *)
(* In order to offload the string matching task of the scanner, it *)
(* needs to know about the Symbol type and their representations.  *)
(*******************************************************************)

MODULE SymTab; (******** SYMBOL TABLE *********)
IMPORT    Error, SymbolType;
EXPORT    InitSymTab, InvalidateEntries, DescriptorIndex,
    PushDescriptor, Descriptor, IdRange, Lookup,
    top, eNumber, symtab;

  CONST  maxId = 8;

  TYPE     IdRange = [0..maxId];
     Descriptor = RECORD
            idRep : CHAR;
            valid : BOOLEAN;
            value : BOOLEAN;
            columnPos : CARDINAL;
              END;

  VAR    top    : IdRange;
    topindex: CARDINAL;
    symtab : ARRAY [0..maxId - 1] OF Descriptor;
    strtab : ARRAY [0..47] OF CHAR;

  VAR    eNumber : CARDINAL; (* number of extra columns in header *)

    PROCEDURE Lookup(str : ARRAY OF CHAR;
             VAR sy : SymbolType);

      PROCEDURE compare(index : CARDINAL) : BOOLEAN;
    VAR i : CARDINAL;
      BEGIN (* assert: both arrays have a blank before the end *)
    i := 0;
    WHILE (str[i] = strtab[index]) AND (str[i] <> ' ') DO
      INC(i); INC(index);
    END;
    RETURN (str[i] = strtab[index]);
      END compare;

    BEGIN (* lookup *)
    (* In this case (and quite by accident) the first *)
    (* character of each string is a perfect hash     *)
    (* index for the set of possible word symbols.    *)
      sy := errSy;
      CASE str[0] OF
    'A' : IF compare(0)  THEN sy := andSy END;
      | 'C' : IF compare(4)  THEN sy := check END;
      | 'E' : IF compare(10) THEN sy := evSy  END;
      | 'F' : IF compare(19) THEN sy := fSy   END;
      | 'I' : IF compare(25) THEN sy := input END;
      | 'N' : IF compare(31) THEN sy := notSy END;
      | 'O' : IF compare(35) THEN sy := orSy  END;
      | 'Q' : IF compare(38) THEN sy := quit  END;
      | 'T' : IF compare(43) THEN sy := tSy   END
      ELSE
      END;
    END Lookup;

    PROCEDURE PushDescriptor(ch : CHAR);
    BEGIN
      IF top >= maxId THEN
    Error('Too Many Identifiers');
      ELSE
    WITH symtab[top] DO
      idRep := ch;
      valid := FALSE;
    END;
    INC(top)
      END
    END PushDescriptor;

    PROCEDURE DescriptorIndex(ch : CHAR) : IdRange;
      VAR I : IdRange;
    BEGIN
      FOR I := 0 TO top-1 DO
    IF symtab[I].idRep = ch THEN RETURN I END;
      END; (* if not found then return top *)
      RETURN top;
    END DescriptorIndex;

    PROCEDURE InvalidateEntries;
      VAR I : IdRange;
    BEGIN
      FOR I := 2 TO maxId - 1 DO symtab[I].valid := FALSE END
    END InvalidateEntries;

    PROCEDURE InitSymTab;
    BEGIN
      top := 2;
    END InitSymTab;

BEGIN (* insert static values, these are never changed *)
  WITH symtab[0] DO
    idRep := 'F';
    valid := TRUE;
    value := FALSE;
  END;
  WITH symtab[1] DO
    idRep := 'T';
    valid := TRUE;
    value := TRUE;
  END;
  FOR topindex := 2 TO maxId - 1 DO
    top:=topindex;
    symtab[top].columnPos := top * 2 - 2
  END;
  strtab := 'AND CHECK EVALUATE FALSE INPUT NOT OR QUIT TRUE ';
END SymTab;

(**********************************************************************)
(* Module HeaderHandler creates and manipulates the output formats    *)
(* and lines which are required for the truth tables. These procs.    *)
(* are mainly used by the tree builder procedures.              *)
(* The system builds a line with column markers as soon as the number *)
(* of variables is known. Later analysis of the syntax tree determ-   *)
(* ines how many extra columns are required and trims the line length *)
(**********************************************************************)

MODULE HeaderHandler;

  IMPORT Descriptor, top, symtab, WriteLn, WriteString, Line, lnMx, nul;
  EXPORT InitHeader, TrimLine, WriteHeader, WriteLowEdge,
     blank, InsertInHeader;

  VAR    topEdge, lowEdge, midEdge, blank, header : Line;

  PROCEDURE InsertInHeader(str : ARRAY OF CHAR; col : CARDINAL);
    VAR I : CARDINAL;
  BEGIN
    FOR I := 0 TO HIGH(str) DO header[col + I] := str[I] END
  END InsertInHeader;

  PROCEDURE TrimLine(max : CARDINAL);
  BEGIN
    blank[max]   := nul; header[max]  := nul;
    topEdge[max] := nul; midEdge[max] := nul; lowEdge[max] := nul;
    DEC(max);
    blank[max]   := '|'; header[max]  := '|';
    topEdge[max] := '+'; midEdge[max] := '+'; lowEdge[max] := '+';
  END TrimLine;

  PROCEDURE InitHeader;
    VAR I : CARDINAL;
  BEGIN
    blank[0]   := '|'; header[0] := '|';
    topEdge[0] := '+'; midEdge[0] := '+'; lowEdge[0] := '+';
    FOR I := 1 TO lnMx DO
      blank[I]   := ' '; header[I] := ' ';
      topEdge[I] := '-'; midEdge[I] := '-'; lowEdge[I] := '-'
    END;
    FOR I := 2 TO top - 1 DO
      WITH symtab[I] DO
    header[columnPos] := idRep;
    blank[columnPos]  := '*';
      END;
    END;
    I := 2 * (top -1);
    topEdge[I] := '+'; midEdge[I] := '+'; lowEdge[I] := '+';
    blank[I] := '|'; header[I] := '|';
    FOR I := top * 2 TO lnMx BY 4 DO blank[I] := '*' END;
  END InitHeader;

  PROCEDURE WriteLowEdge;
  BEGIN
    WriteString(lowEdge); WriteLn;
  END WriteLowEdge;

  PROCEDURE WriteHeader;
  BEGIN
    WriteLn;
    WriteString(topEdge); WriteLn;
    WriteString(header);  WriteLn;
    WriteString(midEdge);  WriteLn;
  END WriteHeader;

END HeaderHandler;

(*******************************************************************)
(* This is the lexical scanner. Pretty straightforward. Uses the   *)
(* Symbol Table module to do most of the tricky work. It contains  *)
(* an attribute lexValue for idSy's which is an index into the     *)
(* descriptor table, so that all other attributes may be obtained  *)
(* at tree-building time and at evaluation time.           *)
(*******************************************************************)

  MODULE Scanner;
  IMPORT ch, GetCh, Write, Lookup, top,
     PushDescriptor, DescriptorIndex, IdRange,
     SymbolType, Error, nul;
  EXPORT symbol, lexValue, GetSymbol, InitScanner;

    VAR  symbol : SymbolType;

    VAR lexValue : IdRange;

    PROCEDURE IsAlpha(ch : CHAR) : BOOLEAN;
    BEGIN RETURN (ch >= 'A') AND (ch <= 'Z') END IsAlpha;

    (* The precondition of the GetSymbol procedure is that *)
    (* the current character does not belong to the last   *)
    (* symbol. Note that this does not match the post-     *)
    (* condition in the case that the last symbol was an   *)
    (* endSy symbol. Logically endSy is the string end,    *)
    (* and it is necessary to call InitScanner to start on *)
    (* the scanning of the next string of input symbols.   *)

    PROCEDURE GetSymbol;
      CONST max = 9; (* maximum symbol length + 1 *)
      VAR   old : CHAR;
        str : ARRAY [0..max] OF CHAR;

      PROCEDURE StringRecognize;
    VAR pos : [0..max];
      BEGIN
    pos := 1;
    WHILE IsAlpha(CAP(ch)) AND (pos < max) DO
      str[pos] := CAP(ch); INC(pos); GetCh;
    END;
    str[pos] := ' ';
    Lookup(str,symbol);
    IF (pos = max) OR (symbol = errSy) THEN
      Error('Invalid word');
    END;
      END StringRecognize;

    BEGIN
      WHILE ch = ' ' DO GetCh END;
      IF ch = nul THEN symbol := endSy
      ELSE
    old := ch; GetCh;
    CASE old OF
      '(' : symbol := lPar;
    | ')' : symbol := rPar;
    | '=' : symbol := eqSy;
    | 'a'..'z', 'A'..'Z' :
        IF IsAlpha(CAP(ch)) THEN
          str[0] := CAP(old);
          StringRecognize;
        ELSE (* is isolated alpha. char. *)
          symbol := idSy; old := CAP(old);
          IF DescriptorIndex(old) = top THEN
            PushDescriptor(old)
          END;
          lexValue := DescriptorIndex(old);
        END
    ELSE Error('Invalid character');
    END;
    (* assert : either symbol = endSy or current ch
            is past last of symbol.         *)
      END;
    END GetSymbol;

    PROCEDURE InitScanner;
    BEGIN
      GetCh;
      GetSymbol;
    END InitScanner;

  END Scanner;

(*******************************************************************)
(* This module implements the abstract syntax tree form of the       *)
(* permissible expressions. The tree builder is intertwined with   *)
(* the recursive descent parser.                   *)
(*******************************************************************)

  MODULE TreeSystem;

    IMPORT (* local symbols *)
       SymbolType, Error, errors,
       (* from IOHandler *)
       Write, WriteString, WriteLn, Line,
       (* from HeaderHandler *)
       InitHeader, TrimLine, blank, InsertInHeader,
       WriteHeader, WriteLowEdge,
       (* from Scanner *)
       symbol, lexValue, GetSymbol, InitScanner,
       (* from SymbolTable *)
       symtab, top, IdRange, Descriptor, InitSymTab,
       InvalidateEntries;

    FROM GenSequenceSupport IMPORT
        Sequence, ElemPtr, Ended, InitSequence, DisposeList,
        LinkLeft, LinkRight, InitCursor, GetFirst, GetNext;

    FROM Storage IMPORT ALLOCATE, DEALLOCATE;

    EXPORT Parse, TreeExists, Check, Evaluate;

    TYPE TagType = (conjunction, disjunction, equality,
             negation, atom);

(* The abstract syntax of the tree, in IDL is given by --

    structure Boolexpr root EXPR is
    EXPR ::= conjunction | disjunction | equality
         | negation | atom;
    equality =>           -- lhs "equals" rhs
        asLHS : EXPR,
        asRHS : EXPR,
        lxColumn : CARDINAL; -- pos. of column in truth table
        lxName     : String;    -- column header
    conjunction =>        -- a sequence of ANDs
        asTerms  : seq of EXPR,
        lxName     : String;    -- column header
        lxColumn : CARDINAL;
    disjunction =>        -- a sequence of ORs
        asFactors : seq of EXPR,
        lxName      : String;   -- column header
        lxColumn  : CARDINAL;
    negation =>
        asExp     : EXPR,
        lxName     : String;    -- column header
        lxColumn : CARDINAL;
    atom => lxName    : CHAR,   -- accessed via the descriptor index
        smValue : BOOLEAN;   -- accessed via the descriptor
        lxName    : String;     -- usually not needed
    end. -- of IDL description.
*)
     TYPE String3 = ARRAY[0..2] OF CHAR;
     Expr = POINTER TO Node;
     Node = RECORD
          lxName : String3;
          column : CARDINAL; (* 0 => not allocated *)
          CASE tag : TagType OF
            conjunction, disjunction :
              seq  : Sequence; (* of Expr *)
          | equality :
              lhs, rhs : Expr;
          | negation :
              exp  : Expr;
          | atom : desc : IdRange;
          END;
        END;

    VAR  root : Expr;
    VAR  colSequence : Sequence; (* nodes in column order *)

    PROCEDURE TreeExists() : BOOLEAN;
    BEGIN RETURN root <> NIL END TreeExists;

    PROCEDURE Create(VAR ptr : Expr; t : TagType);
    BEGIN
(*
      ALLOCATE(ptr,SIZE(ptr^));
*)
      NEW(ptr);
      ptr^.tag := t;
      ptr^.lxName := '   ';
      ptr^.column := 0;
    END Create;

    PROCEDURE DisposeTree;

      PROCEDURE Release(p : Expr);
    VAR cursor : ElemPtr;
        next   : Expr;
      BEGIN
    CASE p^.tag OF
      atom :
    | negation :
        Release(p^.exp);
    | equality :
        Release(p^.lhs);
        Release(p^.rhs);
    | conjunction, disjunction :
        InitCursor(p^.seq,cursor);
        WHILE NOT Ended(cursor) DO
          GetNext(cursor,next);
          Release(next);
        END;
        DisposeList(p^.seq);
    END;
(*
        DEALLOCATE(p,SIZE(p^));
*)
        DISPOSE(p);
      END Release;

    BEGIN
      errors := FALSE;
      IF root <> NIL THEN
    Release(root);
    root := NIL;
      END;
      DisposeList(colSequence);
    END DisposeTree;

  (* The key idea of the following procedure is to walk the      *)
  (* syntax tree breadth-first, and then to allocate column      *)
  (* positions in the truth table to the nodes in the reverse      *)
  (* order to that in which they were visited. This ensures that  *)
  (* the value of the subexpression in any column can only depend *)
  (* on the value of other columns to that column's left.         *)

  PROCEDURE AllocateColumns;

      MODULE Queue;

      (*-----------------------------------------------*)
      (* Note that these are dynamic modules, i.e. are *)
      (* nested inside a procedure. When the procedure *)
      (* returns the variables are lost, and when the  *)
      (* procedure is called the init. code is run.    *)
      (*-----------------------------------------------*)

      IMPORT Expr, colSequence, LinkLeft, WriteString;
      EXPORT Push, Next;
      VAR arr : ARRAY[0..15] OF Expr;
      sp, mk : CARDINAL;

    PROCEDURE Push(p : Expr);  (* no overflow check   *)
    BEGIN               (* is made here. Maybe *)
      arr[sp] := p; INC(sp);   (* with a single line  *)
      LinkLeft(colSequence,p); (* input 16 is enough? *)
    END Push;

    PROCEDURE Next(VAR p : Expr);
    BEGIN
      IF mk < sp THEN
        p := arr[mk]; INC(mk);
      ELSE p := NIL
      END
    END Next;

      BEGIN
    sp := 0;
    mk := 0;
      END Queue;

    (*--------------------------------------------------*)
    (* this module generates unique subexpression names *)
    (*--------------------------------------------------*)

      MODULE Names;
      IMPORT String3, WriteString;
      EXPORT PopName;
      VAR  name : String3;

    PROCEDURE PopName(VAR str : String3);
    BEGIN
      str := name;
      name[2] := CHR(ORD(name[2]) + 1);
    END PopName;

      BEGIN
    name := 'ex1';
      END Names;

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

    (* local variables of AllocateColumns. *)
      VAR cursor : ElemPtr;
      n, p     : Expr;

      PROCEDURE InsertNamesAndNumbers;
    VAR crsr : ElemPtr;
        col  : CARDINAL;
        node : Expr;
      BEGIN
    col := top * 2;
    InitCursor(colSequence,crsr);
    WHILE NOT Ended(crsr) DO
      GetNext(crsr,node);
      WITH node^ DO
        IF lxName[0] = ' ' THEN (* is unnamed *)
          PopName(lxName);
        END;
        (* and in any case ... *)
        InsertInHeader(lxName,col-1);
        column := col; INC(col,4);
      END;
    END;
    TrimLine(col-1);
      END InsertNamesAndNumbers;

    BEGIN (* allocate columns *)
      InitSequence(colSequence);
      Push(root); root^.lxName := 'res';
      Next(n); (* queue discipline gives breadth first search *)
      WHILE n <> NIL DO
    WITH n^ DO
      CASE tag OF
        equality : (* always push lhs & rhs *)
          Push(rhs); Push(lhs);
          rhs^.lxName := 'rhs'; lhs^.lxName := 'lhs';
      | conjunction, disjunction :
          InitCursor(seq,cursor);
          WHILE NOT Ended(cursor) DO
        GetNext(cursor,p); (* don't push atoms *)
        IF p^.tag <> atom THEN Push(p) ELSE END;
          END;
      | negation :
          IF exp^.tag <> atom THEN Push(exp) ELSE END;
      | atom : (* nothing *)
      END;
    END;
    Next(n);
      END;
      (* nodes are in breadth-first order in colSeq. *)
      InsertNamesAndNumbers;
    END AllocateColumns;

     PROCEDURE WriteTree(p : Expr);
      VAR exp     : Expr;
      cursor : ElemPtr;
      op     : ARRAY [0..4] OF CHAR;
    BEGIN
      CASE p^.tag OF
    atom : Write(symtab[p^.desc].idRep);
      | negation : WriteString('not ');
           WriteTree(p^.exp);
      | equality : WriteTree(p^.lhs);
           WriteString(' = ');
           WriteTree(p^.rhs);
      | conjunction, disjunction :
           IF p^.tag = disjunction
             THEN op := ' or ';
             ELSE op := ' and '
           END;
           Write('(');
           GetFirst(p^.seq,cursor,exp);
           WriteTree(exp);
           WHILE NOT Ended(cursor) DO
             WriteString(op);
             GetNext(cursor,exp);
             WriteTree(exp)
           END;
           Write(')');
      END; (* case *)
    END WriteTree;

    PROCEDURE WalkSubTree(p : Expr);
      VAR exp     : Expr;
      cursor : ElemPtr;
      op     : ARRAY [0..4] OF CHAR;

      PROCEDURE WriteName(p : Expr);
      BEGIN
    IF p^.lxName[0] = ' ' THEN WalkSubTree(p);
    ELSE WriteString(p^.lxName);
    END;
      END WriteName;

    BEGIN
      CASE p^.tag OF
    atom : Write(symtab[p^.desc].idRep);
      | negation : WriteString('not ');
           WriteName(p^.exp);
      | equality : WriteName(p^.lhs);
           WriteString(' = ');
           WriteName(p^.rhs);
      | conjunction, disjunction :
           IF p^.tag = disjunction
             THEN op := ' or ';
             ELSE op := ' and '
           END;
           Write('(');
           GetFirst(p^.seq,cursor,exp);
           WriteName(exp);
           WHILE NOT Ended(cursor) DO
             WriteString(op);
             GetNext(cursor,exp);
             WriteName(exp);
           END;
           Write(')');
      END;
    END WalkSubTree;

    PROCEDURE WriteLegend;
      VAR curs : ElemPtr;
      node : Expr;
    BEGIN
      WriteLn;
      WriteTree(root);
      WriteLn;
      WriteString('Legend --'); WriteLn;
      InitCursor(colSequence,curs);
      WHILE NOT Ended(curs) DO
    GetNext(curs,node); Write(' ');
    WriteString(node^.lxName);
    WriteString(' == ');
    WalkSubTree(node);
    WriteLn;
      END;
    END WriteLegend;

    (* level-0 variables for use by Evaluate and Check *)
    VAR  values   : Line;
     constRep : ARRAY BOOLEAN OF CHAR;

    PROCEDURE NodeValue(p : Expr) : BOOLEAN;
      VAR node     : Expr;
      cursor : ElemPtr;
      result : BOOLEAN;

          PROCEDURE PromptInput(d : IdRange) : BOOLEAN;
        VAR v : CHAR;
          BEGIN (* assert: value is not valid *)
        WITH symtab[d] DO
          REPEAT (* until valid *)
            Write(idRep); Write('?'); Write(' ');
            InitScanner;
            CASE symbol OF
              tSy  : valid := TRUE; value := TRUE;
            | fSy  : valid := TRUE; value := FALSE;
            | idSy : valid := symtab[lexValue].valid;
                 value := symtab[lexValue].value;
            ELSE (* nothing *)
            END;
          UNTIL valid;
          values[columnPos] := constRep[value];
          RETURN value;
        END (* with *)
          END PromptInput;

(* Body of NodeValue appears on the following page  *)
(* It is the main tree evaluation routine, and is   *)
(* called once by Evaluate, and repeatedly by Check *)
     BEGIN (* NodeValue *)
      WITH p^ DO
    CASE tag OF
      atom       : IF symtab[desc].valid THEN
               result := symtab[desc].value
             ELSE result := PromptInput(desc);
             END;
    | negation : result := NOT NodeValue(exp);
    | equality : result := NodeValue(lhs) = NodeValue(rhs);
    | conjunction :
        GetFirst(seq,cursor,node);
        result := NodeValue(node);
        WHILE NOT Ended(cursor) AND result DO
          GetNext(cursor,node);
          result := NodeValue(node);
        END; (* short circuit evaluation ! *)
    | disjunction :
        GetFirst(seq,cursor,node);
        result := NodeValue(node);
        WHILE NOT Ended(cursor) AND NOT result DO
          GetNext(cursor,node);
          result := NodeValue(node);
        END;
    END; (* case *)
    IF column <> 0 THEN values[column] := constRep[result] END;
    RETURN result;
      END (* with *)
    END NodeValue;

    PROCEDURE Evaluate;
      VAR dummy : BOOLEAN;
    BEGIN
      InvalidateEntries; values := blank;
      dummy := NodeValue(root);
      WriteHeader;
      WriteString(values); WriteLn;
      WriteLowEdge;
      WriteLegend;
    END Evaluate;

    PROCEDURE Check;
      VAR dummy : BOOLEAN;
      pos    : IdRange;
      trick : RECORD CASE (* no tag *) : BOOLEAN OF
            TRUE  : bits : BITSET;
          | FALSE : card : CARDINAL;
          END END; (* case and record *)
    BEGIN
      trick.bits := BITSET{}; (* i.e. all false *)
      WriteHeader;
      WHILE NOT(top IN trick.bits) DO (* always do once at least *)
    values := blank;
    FOR pos := 2 TO top-1 DO      (* never if no variables ! *)
      WITH symtab[top + 1 - pos] DO     (* bit reverse order *)
        value := pos IN trick.bits;
        valid := TRUE;
        values[columnPos] := constRep[value];
      END;
    END;
    dummy := NodeValue(root);
    WriteString(values); WriteLn;
    INC(trick.card,4);
      END;
      WriteLowEdge; WriteLegend;
    END Check;

(*************************************************************)
(* Classical recursive descent parser. Procedures are nested *)
(* within each other so that no difficulty with "forward"    *)
(* arises even in mplementations which use a single pass.    *)
(*************************************************************)


    PROCEDURE Parse;
      VAR p : Expr;

      PROCEDURE SimpleExpr(VAR r : Expr);
    VAR t : Expr;

    PROCEDURE Term(VAR r : Expr);
      VAR f : Expr;

      PROCEDURE Factor(VAR r : Expr);
      BEGIN
        CASE symbol OF
          idSy :
        Create(r,atom);
        r^.desc := lexValue;
        GetSymbol;
        | fSy :
        Create(r,atom);
        r^.desc := 0;
        GetSymbol;
        | tSy :
        Create(r,atom);
        r^.desc := 1;
        GetSymbol;
        | notSy :
        Create(r,negation);
        GetSymbol;
        Factor(r^.exp);
        | lPar :
        GetSymbol;
        SimpleExpr(r);
        IF symbol = rPar THEN GetSymbol
        ELSE Error('Missing ")"')
        END;
        ELSE Error('Expected name or expression');
        END
        END Factor;

    BEGIN (* term *)
      Factor(f);
      IF symbol = andSy THEN
        Create(r,conjunction);
        InitSequence(r^.seq);
        LinkLeft(r^.seq,f);
        WHILE symbol = andSy DO
          GetSymbol;
          Factor(f);
          LinkRight(r^.seq,f);
        END;
      ELSE r := f;
      END;
    END Term;

       BEGIN (* simple expression *)
    Term(t);
    IF symbol = orSy THEN
      Create(r,disjunction);
      InitSequence(r^.seq);
      LinkLeft(r^.seq,t);
      WHILE symbol = orSy DO
        GetSymbol;
        Term(t);
        LinkRight(r^.seq,t);
      END;
    ELSE r := t;
    END;
      END SimpleExpr;

    BEGIN (* parse *)
      WriteString("EXPR : ");
      DisposeTree;
      InitSymTab;
      InitScanner;
      IF symbol = endSy THEN InitScanner END; (* 1 retry only *)
      SimpleExpr(p);
      IF symbol = eqSy THEN
    Create(root,equality); GetSymbol;
    SimpleExpr(root^.rhs); root^.lhs := p;
      ELSE root := p;
      END;
      IF symbol <> endSy THEN
    Error('Extra symbols followed expression end.');
    REPEAT GetSymbol UNTIL symbol = endSy;
      END;
      IF errors THEN root := NIL
      ELSE
    InitHeader;
    AllocateColumns;
      END;
    END Parse;

  BEGIN (* initialization of module TreeSystem *)
    root := NIL;
    errors := FALSE;
    InitSequence(colSequence);
    constRep[TRUE] := '1'; constRep[FALSE] := '0';
  END TreeSystem;

(*******************************************************************)

(*******************************************************************)
(******************** Mainline code follows ************************)
(*******************************************************************)
BEGIN (* mainline *)
  LOOP
    WriteLn;
    WriteString('OK > ');
    InitScanner;
    CASE symbol OF
      quit  : EXIT;
    | evSy  : IF TreeExists() THEN Evaluate
          ELSE Error('No valid expression exists')
          END;
    | check : IF TreeExists() THEN Check
          ELSE Error('No valid expression exists')
          END;
    | input : Parse;
    ELSE Error('Input, evaluate, check or quit')
    END;
  END; (* loop *)
END Tautology.

(*******************************************************************)
(*******************************************************************)
(*******************************************************************)