PROGRAM TriLogic;
{
TO DEMONSTRATE THE FUNCTIONING OF TRISTATE LOGICAL REASONING
}
CONST
    Version = '1.0';

TYPE
    LogicState =  (R,O,G);
    CharRep = array[LogicState] of char;
    OperatorRuleTable = array [0..2,0..2] of LogicState;
    OpRep = array [1..10]  of char;
    Str9 = String[9];

CONST
    Flag : charrep = ('R','o','G');
    Op : OpRep = ('!','@','#','$','%','^','&','*','<','>');


VAR
    Operator: array [1..10] of OperatorRuleTable;
    A,B,C,D,E: LogicState;

    StackDEPTH: integer;
    Stack: array[1..64] of LogicState;

    XX,x,y,z: integer;
    KK,k:char;

    inputline: String[80];


procedure FillOp(index:integer; filler: Str9);
      VAR
          state: LogicState;
          khar: char;
begin
    for Y := 0 to 2 do for X := 0 to 2 do
    begin
         khar:=filler[1+x+y*3];
         if khar=flag[R] then state:=R else
         if khar=flag[G] then state:=G else
                              state:=O;
         Operator[index,x,y]:=  state;
    end;
end;

procedure ShowOperatorTable;
begin

    if Length(inputline)<2 then
    begin
        writeln('');
        writeln('Input line is too short');
        writeln('');
        exit;
    end;
           x:=0;
    REPEAT x:=x+1;
    UNTIL (inputline[2]=Op[x]) OR (x=10);
    if (x=10) and (inputline[2]<>Op[x])  then
    begin
        writeln('');
        Writeln(inputline[2],' is not a valid operator');
        writeln('');
    end
    else
    begin
        writeln('');
        Writeln(op[x],'|ROG');
        Writeln('-----');
Write('R|');
Writeln(flag[operator[x,0,0]],flag[operator[x,0,1]],flag[operator[x,0,2]]);
Write('O|');
Writeln(flag[operator[x,1,0]],flag[operator[x,1,1]],flag[operator[x,1,2]]);
write('G|');
Writeln(flag[operator[x,2,0]],flag[operator[x,2,1]],flag[operator[x,2,2]]);
        writeln('');
    end;
end;

procedure FillOperatorTable;
begin
    if Length(inputline)<12 then
    begin
        writeln('');
        writeln('Input line is too short');
        writeln('');
        EXIT;
    end;
           x:=0;
    REPEAT x:=x+1;
    UNTIL (inputline[2]=Op[x]) OR (x=10);
    if (x=10) and (inputline[2]<>Op[x])  then
    begin
        writeln('');
        Writeln(inputline[2],' is not a valid operator');
        writeln('');
    end
    else
    begin
         FillOP(x,copy(inputline,4,9));

    end;

end;

procedure ShowHelpScreen;
begin
     writeln('');
     writeln('             **** TRI-LOGIC On-Line Help  ****');
     writeln('-------------------------------------------------------------');
     writeln('R = red    = False |  -= OPERATORS =-   |      DISPLAY       ');
     writeln('O = orange = Shrug | ! @ # $  ^ & * < > |  Truth Tables by   ');
     writeln('G = green  = True  |--------------------|  [:][operator][cr] ');
     writeln('-------------------|     (COMMENTS)     |--------------------');
     writeln('  STACK FUNCTIONS  | All text inside    |  DEFINE Operators  ');
     writeln(' [.] Print Stk Top | (parentheses) is   |  by following      ');
     writeln(' [2] Duplicate Top | ---> IGNORED.      |  [=][op][space]    ');
     writeln(' [3] Swap Top 2    |--------------------|  with a string of  ');
     writeln(' [,] Dupl, Print   |  this HELP MENU    |  9 tri-logic values');
     writeln(' [-] Pop Stack     |     [?][cr]        |  e.g GOROOOROG[cr] ');
     writeln(' [op] puts item on |  TO EXIT PROGRAM   |--------------------');
     writeln(' [|]  CLEAR stack  |  type [END][cr]    | USE REVERSE POLISH ');
     writeln('-------------------------------------------------------------');
    {writeln('                   |                    |                    ');}
     writeln('');


end;

procedure clearstack;
begin
     for X := 1 to 64 do stack[x]:=O;
end;

procedure pop;
begin
    for x := 1 to 64 do stack[x]:=stack[x+1];
    stack[64]:=O;
end;

procedure push(into: LogicState);
begin
    for x := 64 downto 2 do stack[x]:=stack[x-1];
    stack[1]:=into;
end;

procedure print;
begin
    case stack[1] of
         R: writeln('red');
         O: writeln('orange');
         G: writeln('green');
    end;
    pop;
end;

procedure swap;
var temp: logicstate;
begin
    temp:= stack[1];
    stack[1]:=stack[2];
    stack[2]:=temp;
end;

procedure dup;
begin
    push(stack[1]);
end;


procedure examine(index:integer);
var first,second,result: logicstate;
begin
    second:=stack[1];
    pop;
    first:=stack[1];
    pop;
    result:= operator[index,ord(first),ord(second)];
    push(result);
end;


BEGIN
    FillOp(1,'ROOOOOOOG'); {ABSOLUTELY}
    FillOp(2,'GOROGOROG'); {SIMILAR}
    FillOp(3,'GRGRRRGRG'); {TEST FOR BISTATE}
    FillOp(4,'OROROGOGO'); {TENDENCY}
    FillOp(5,'RROROGOGG'); {REASONABLE CERTAINTY}
    FillOp(6,'ROGOOGGGG'); {OR}
    FillOp(7,'RRRROOROG'); {AND}
    FillOp(8,'ROGOOOGOR'); {NOT BOTH}
    FillOp(9,'OOOOOOOOO'); {USER 1}
    FillOp(10,'OOOOOOOOO');{USER 2}
    STACKDEPTH:=0;
    clearstack;
    writeln('');
    writeln('');
    writeln('     T * R * I * L * O * G * Y ');
    writeln('');
    writeln('TriState Logic Demonstation Program');
    writeln('       placed in Public Domain');
    writeln('         (pd) 1987 J.F. Cuff');
    writeln('             version ',Version);
    writeln('');
    writeln('press ?<cr> for HELP');
    writeln('type END<cr> to EXIT');
    writeln('');
    writeln('');

    REPEAT {until inputline = 'END'}
           Write('? ');
           readln(inputline);
           if inputline<>'END' then
           begin
               K:= INPUTLINE[1];
               case K of
                    ':' : ShowOperatorTable;
                    '=' : FillOperatorTable;
                    '?' : ShowHelpScreen;
               else
                   Xx:=0;
                   REPEAT
                        xX:=Xx+1;
                        Kk:=upcase(inputline[Xx]);
                        case Kk of
                             'R': push(R);
                             'O': push(O);
                             'Y': push(O);
                             'G': push(G);
                             '.': print;
                             ',': begin
                                       dup; print;
                                  end;
                             '(': begin
                                      repeat
                                            xX:=Xx+1;
                                      until ((inputline[Xx]=')')
                                         OR (Xx>=Length(inputline)));
                                  end;
                              '|': clearstack;
                              '2': dup;
                              '3': swap;
                              '-': pop;
                              '!': Examine(1);
                              '@': Examine(2);
                              '#': Examine(3);
                              '$': Examine(4);
                              '%': Examine(5);
                              '^': Examine(6);
                              '&': Examine(7);
                              '*': Examine(8);
                              '<': Examine(9);
                              '>': Examine(10);
                        end;
                   UNTIL (Xx>=Length(inputline)) or (inputline[Xx]='''');
               end; {case-else}
           end;
    UNTIL inputline = 'END';
    writeln('Exiting TRILOGY...');
    writeln('* ad asp*ra ad *stra *');
END.