home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / EDUCATIN / K-CHING.LBR / TRILOGY.PZS / TRILOGY.PAS
Pascal/Delphi Source File  |  2000-06-30  |  8KB  |  264 lines
  1. PROGRAM TriLogic;
  2. {
  3. TO DEMONSTRATE THE FUNCTIONING OF TRISTATE LOGICAL REASONING
  4. }
  5. CONST
  6.     Version = '1.0';
  7.  
  8. TYPE
  9.     LogicState =  (R,O,G);
  10.     CharRep = array[LogicState] of char;
  11.     OperatorRuleTable = array [0..2,0..2] of LogicState;
  12.     OpRep = array [1..10]  of char;
  13.     Str9 = String[9];
  14.  
  15. CONST
  16.     Flag : charrep = ('R','o','G');
  17.     Op : OpRep = ('!','@','#','$','%','^','&','*','<','>');
  18.  
  19.  
  20. VAR
  21.     Operator: array [1..10] of OperatorRuleTable;
  22.     A,B,C,D,E: LogicState;
  23.  
  24.     StackDEPTH: integer;
  25.     Stack: array[1..64] of LogicState;
  26.  
  27.     XX,x,y,z: integer;
  28.     KK,k:char;
  29.  
  30.     inputline: String[80];
  31.  
  32.  
  33. procedure FillOp(index:integer; filler: Str9);
  34.       VAR
  35.           state: LogicState;
  36.           khar: char;
  37. begin
  38.     for Y := 0 to 2 do for X := 0 to 2 do
  39.     begin
  40.          khar:=filler[1+x+y*3];
  41.          if khar=flag[R] then state:=R else
  42.          if khar=flag[G] then state:=G else
  43.                               state:=O;
  44.          Operator[index,x,y]:=  state;
  45.     end;
  46. end;
  47.  
  48. procedure ShowOperatorTable;
  49. begin
  50.  
  51.     if Length(inputline)<2 then
  52.     begin
  53.         writeln('');
  54.         writeln('Input line is too short');
  55.         writeln('');
  56.         exit;
  57.     end;
  58.            x:=0;
  59.     REPEAT x:=x+1;
  60.     UNTIL (inputline[2]=Op[x]) OR (x=10);
  61.     if (x=10) and (inputline[2]<>Op[x])  then
  62.     begin
  63.         writeln('');
  64.         Writeln(inputline[2],' is not a valid operator');
  65.         writeln('');
  66.     end
  67.     else
  68.     begin
  69.         writeln('');
  70.         Writeln(op[x],'|ROG');
  71.         Writeln('-----');
  72. Write('R|');
  73. Writeln(flag[operator[x,0,0]],flag[operator[x,0,1]],flag[operator[x,0,2]]);
  74. Write('O|');
  75. Writeln(flag[operator[x,1,0]],flag[operator[x,1,1]],flag[operator[x,1,2]]);
  76. write('G|');
  77. Writeln(flag[operator[x,2,0]],flag[operator[x,2,1]],flag[operator[x,2,2]]);
  78.         writeln('');
  79.     end;
  80. end;
  81.  
  82. procedure FillOperatorTable;
  83. begin
  84.     if Length(inputline)<12 then
  85.     begin
  86.         writeln('');
  87.         writeln('Input line is too short');
  88.         writeln('');
  89.         EXIT;
  90.     end;
  91.            x:=0;
  92.     REPEAT x:=x+1;
  93.     UNTIL (inputline[2]=Op[x]) OR (x=10);
  94.     if (x=10) and (inputline[2]<>Op[x])  then
  95.     begin
  96.         writeln('');
  97.         Writeln(inputline[2],' is not a valid operator');
  98.         writeln('');
  99.     end
  100.     else
  101.     begin
  102.          FillOP(x,copy(inputline,4,9));
  103.  
  104.     end;
  105.  
  106. end;
  107.  
  108. procedure ShowHelpScreen;
  109. begin
  110.      writeln('');
  111.      writeln('             **** TRI-LOGIC On-Line Help  ****');
  112.      writeln('-------------------------------------------------------------');
  113.      writeln('R = red    = False |  -= OPERATORS =-   |      DISPLAY       ');
  114.      writeln('O = orange = Shrug | ! @ # $  ^ & * < > |  Truth Tables by   ');
  115.      writeln('G = green  = True  |--------------------|  [:][operator][cr] ');
  116.      writeln('-------------------|     (COMMENTS)     |--------------------');
  117.      writeln('  STACK FUNCTIONS  | All text inside    |  DEFINE Operators  ');
  118.      writeln(' [.] Print Stk Top | (parentheses) is   |  by following      ');
  119.      writeln(' [2] Duplicate Top | ---> IGNORED.      |  [=][op][space]    ');
  120.      writeln(' [3] Swap Top 2    |--------------------|  with a string of  ');
  121.      writeln(' [,] Dupl, Print   |  this HELP MENU    |  9 tri-logic values');
  122.      writeln(' [-] Pop Stack     |     [?][cr]        |  e.g GOROOOROG[cr] ');
  123.      writeln(' [op] puts item on |  TO EXIT PROGRAM   |--------------------');
  124.      writeln(' [|]  CLEAR stack  |  type [END][cr]    | USE REVERSE POLISH ');
  125.      writeln('-------------------------------------------------------------');
  126.     {writeln('                   |                    |                    ');}
  127.      writeln('');
  128.  
  129.  
  130. end;
  131.  
  132. procedure clearstack;
  133. begin
  134.      for X := 1 to 64 do stack[x]:=O;
  135. end;
  136.  
  137. procedure pop;
  138. begin
  139.     for x := 1 to 64 do stack[x]:=stack[x+1];
  140.     stack[64]:=O;
  141. end;
  142.  
  143. procedure push(into: LogicState);
  144. begin
  145.     for x := 64 downto 2 do stack[x]:=stack[x-1];
  146.     stack[1]:=into;
  147. end;
  148.  
  149. procedure print;
  150. begin
  151.     case stack[1] of
  152.          R: writeln('red');
  153.          O: writeln('orange');
  154.          G: writeln('green');
  155.     end;
  156.     pop;
  157. end;
  158.  
  159. procedure swap;
  160. var temp: logicstate;
  161. begin
  162.     temp:= stack[1];
  163.     stack[1]:=stack[2];
  164.     stack[2]:=temp;
  165. end;
  166.  
  167. procedure dup;
  168. begin
  169.     push(stack[1]);
  170. end;
  171.  
  172.  
  173. procedure examine(index:integer);
  174. var first,second,result: logicstate;
  175. begin
  176.     second:=stack[1];
  177.     pop;
  178.     first:=stack[1];
  179.     pop;
  180.     result:= operator[index,ord(first),ord(second)];
  181.     push(result);
  182. end;
  183.  
  184.  
  185. BEGIN
  186.     FillOp(1,'ROOOOOOOG'); {ABSOLUTELY}
  187.     FillOp(2,'GOROGOROG'); {SIMILAR}
  188.     FillOp(3,'GRGRRRGRG'); {TEST FOR BISTATE}
  189.     FillOp(4,'OROROGOGO'); {TENDENCY}
  190.     FillOp(5,'RROROGOGG'); {REASONABLE CERTAINTY}
  191.     FillOp(6,'ROGOOGGGG'); {OR}
  192.     FillOp(7,'RRRROOROG'); {AND}
  193.     FillOp(8,'ROGOOOGOR'); {NOT BOTH}
  194.     FillOp(9,'OOOOOOOOO'); {USER 1}
  195.     FillOp(10,'OOOOOOOOO');{USER 2}
  196.     STACKDEPTH:=0;
  197.     clearstack;
  198.     writeln('');
  199.     writeln('');
  200.     writeln('     T * R * I * L * O * G * Y ');
  201.     writeln('');
  202.     writeln('TriState Logic Demonstation Program');
  203.     writeln('       placed in Public Domain');
  204.     writeln('         (pd) 1987 J.F. Cuff');
  205.     writeln('             version ',Version);
  206.     writeln('');
  207.     writeln('press ?<cr> for HELP');
  208.     writeln('type END<cr> to EXIT');
  209.     writeln('');
  210.     writeln('');
  211.  
  212.     REPEAT {until inputline = 'END'}
  213.            Write('? ');
  214.            readln(inputline);
  215.            if inputline<>'END' then
  216.            begin
  217.                K:= INPUTLINE[1];
  218.                case K of
  219.                     ':' : ShowOperatorTable;
  220.                     '=' : FillOperatorTable;
  221.                     '?' : ShowHelpScreen;
  222.                else
  223.                    Xx:=0;
  224.                    REPEAT
  225.                         xX:=Xx+1;
  226.                         Kk:=upcase(inputline[Xx]);
  227.                         case Kk of
  228.                              'R': push(R);
  229.                              'O': push(O);
  230.                              'Y': push(O);
  231.                              'G': push(G);
  232.                              '.': print;
  233.                              ',': begin
  234.                                        dup; print;
  235.                                   end;
  236.                              '(': begin
  237.                                       repeat
  238.                                             xX:=Xx+1;
  239.                                       until ((inputline[Xx]=')')
  240.                                          OR (Xx>=Length(inputline)));
  241.                                   end;
  242.                               '|': clearstack;
  243.                               '2': dup;
  244.                               '3': swap;
  245.                               '-': pop;
  246.                               '!': Examine(1);
  247.                               '@': Examine(2);
  248.                               '#': Examine(3);
  249.                               '$': Examine(4);
  250.                               '%': Examine(5);
  251.                               '^': Examine(6);
  252.                               '&': Examine(7);
  253.                               '*': Examine(8);
  254.                               '<': Examine(9);
  255.                               '>': Examine(10);
  256.                         end;
  257.                    UNTIL (Xx>=Length(inputline)) or (inputline[Xx]='''');
  258.                end; {case-else}
  259.            end;
  260.     UNTIL inputline = 'END';
  261.     writeln('Exiting TRILOGY...');
  262.     writeln('* ad asp*ra ad *stra *');
  263. END.
  264.