home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / miscpas / eval.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-01-02  |  11.6 KB  |  369 lines
  1.  
  2. { eval.pas }
  3.  
  4. PROGRAM evalexpr(input,output);
  5.   { Evaluate an infix expression typed on the command line.  Give no arguments
  6.      to get the help message.  Bruce K. Hillyer.
  7.  
  8.    This program is written for Microsoft pascal to use the REAL8 type,
  9.      which seems to avoid answers like 0.999999999999999 when the correct
  10.      answer is 1.
  11.  
  12.    Note that some versions of Microsoft pascal incorrectly decide that your pc
  13.      has an 8087 or 80287 math coprocessor when in fact it doesn't.  To check
  14.      this, try a simple multiplication.  If  eval 2*3   says 2, rather than 6,
  15.      set the enviornment variable   set NO87=X   in your autoexec.bat file.
  16.  
  17.    This code is derived in part from the spreadsheet that comes with turbo 
  18.      pascal, which contains the following message: 
  19.  
  20.         MICROCALC DEMONSTRATION PROGRAM  Version 1.00A
  21.  
  22.        This program is hereby donated to the public domain
  23.        for non-commercial use only.  Dot commands are  for
  24.        the program lister: LISTT.PAS  (available with  our
  25.        TURBO TUTOR):    .PA, .CP20, etc...
  26.   }
  27.  
  28. TYPE
  29.   exprStr   = LSTRING(80);
  30.  
  31. VAR
  32.   cmdTail : ADS OF LSTRING(80);
  33.   Cesxqq [EXTERN] : WORD;
  34.  
  35.   retnVl : REAL8;
  36.   errLoc : INTEGER;
  37.   i : INTEGER;
  38.  
  39.  
  40. { functions for REAL8 }
  41. FUNCTION Andrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { round }
  42. FUNCTION Aidrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { trunc }
  43. FUNCTION Srdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { sqrt }
  44. FUNCTION Sndrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { sin }
  45. FUNCTION Cndrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { cos }
  46. FUNCTION Tndrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { tan }
  47. FUNCTION Asdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { arcsin }
  48. FUNCTION Acdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { arccos }
  49. FUNCTION Atdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { arctan }
  50. FUNCTION Shdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { sinh }
  51. FUNCTION Chdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { cosh }
  52. FUNCTION Thdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { tanh }
  53. FUNCTION Lndrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { ln }
  54. FUNCTION Lddrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { log }
  55. FUNCTION Exdrqq(CONSTS a : REAL8) : REAL8; EXTERN;  { exp }
  56. FUNCTION Pidrqq(CONSTS a : REAL8; CONSTS b : INTEGER4) : REAL8; EXTERN;{power}
  57. FUNCTION Prdrqq(CONSTS a, b : REAL8) : REAL8; EXTERN; { power }
  58. FUNCTION Mddrqq(CONSTS a, b : REAL8) : REAL8; EXTERN; { mod }
  59. FUNCTION Mndrqq(CONSTS a, b : REAL8) : REAL8; EXTERN; { min }
  60. FUNCTION Mxdrqq(CONSTS a, b : REAL8) : REAL8; EXTERN; { max }
  61.  
  62. PROCEDURE Endxqq; EXTERN;  { halt }
  63.  
  64.  
  65. PROCEDURE strToNum(formula : exprStr; start, len : INTEGER;
  66.            VAR retVal : REAL8; VAR errPos : INTEGER);
  67.   VAR
  68.     tempStr : LSTRING(80);
  69.     i : INTEGER;
  70.   BEGIN
  71.     FOR i:=1 TO len DO
  72.       tempStr[i] := formula[start+i-1];
  73.     tempStr.Len := Wrd(len);
  74.     WHILE (tempStr.Len > 0) AND (tempStr[1] = ' ') DO
  75.       Delete(tempStr,1,1);
  76.     IF tempStr[1] = '.' THEN Insert('0',tempStr,1);
  77.     IF tempStr[1] = '+' THEN Delete(tempStr,1,1);
  78.     IF NOT Decode(tempStr,retVal) THEN errPos := start
  79.   END; { strToNum }
  80.  
  81.  
  82.  
  83. PROCEDURE printNum(num : REAL8);
  84.   VAR
  85.     pointLoc : INTEGER;
  86.     tempStr : LSTRING(40);
  87.   BEGIN
  88.     IF (num = Andrqq(num)) AND (num <= 1.0e17) THEN { integer }
  89.       BEGIN IF NOT Encode(tempStr,num:1:0) THEN Writeln(output,'output bug ');
  90.               tempStr.Len := Wrd(Ord(tempStr.Len) - 1);  { no point }
  91.         Writeln(output,tempStr)
  92.       END
  93.     ELSE IF Abs(num) > 1.0e6 THEN Writeln(output,num:24)  { big float }
  94.     ELSE BEGIN IF NOT Encode(tempStr,Abs(num):1:16) THEN
  95.              Write(output,'output bug  ');
  96.            { the position of the decimal point is one more than the number
  97.                 of digits in the absolute value of the integer part }
  98.            pointLoc := Positn('.',tempStr,1);
  99.                IF pointLoc = 0
  100.              THEN Writeln(output,num:1:0)
  101.              ELSE BEGIN IF NOT Encode(tempStr,num:1:(16-pointLoc)) THEN
  102.                   Write(output,'output bug  ');
  103.                 WHILE (Ord(tempStr.Len) > pointLoc) AND
  104.                    (tempStr[Ord(tempStr.Len)] = '0') DO
  105.                   tempStr.Len := Wrd(Ord(tempStr.Len) - 1);
  106.                 IF tempStr[Ord(tempStr.Len)] = '.' THEN
  107.                   tempStr.Len := Wrd(Ord(tempStr.Len) - 1);
  108.                 Writeln(output,tempStr)
  109.               END
  110.          END
  111.   END; { printNum }
  112.  
  113.  
  114.  
  115. PROCEDURE evaluate(formula : exprStr; VAR exprVl: REAL8; VAR errPos: INTEGER);
  116.   { evaluate the formula }
  117.  
  118. VAR
  119.   pos : INTEGER;    { current position in formula      }
  120.   ch : CHAR;        { Current character being scanned  }
  121.  
  122.   PROCEDURE nextCh;
  123.     { get the next character into ch, set pos, <cr> indicates eos }
  124.     BEGIN REPEAT pos := pos + 1;
  125.              IF pos <= Ord(formula.Len) THEN ch := formula[pos]
  126.                              ELSE ch := Chr(0)
  127.       UNTIL ch <> ' '
  128.     END; { nextCh }
  129.  
  130.  
  131.   FUNCTION expression : REAL8;
  132.     VAR
  133.       e : REAL8;
  134.  
  135.     FUNCTION simpleExpression : REAL8;
  136.       VAR
  137.         s : REAL8;
  138.  
  139.       FUNCTION term : REAL8;
  140.         VAR
  141.           t,t2 : REAL8;
  142.  
  143.         FUNCTION signedFactor : REAL8;
  144.  
  145.           FUNCTION factor : REAL8;
  146.             TYPE
  147.               builtin = (fabs, fround, ftrunc, fsqrt, fsqr, fsin, fcos, ftan,
  148.                    farcsin, farccos, farctan, fsinh, fcosh, ftanh,
  149.              fln, flog, flog2, fexp, ffact);
  150.               builtinList = ARRAY[builtin] OF LSTRING(6);
  151.  
  152.             CONST
  153.               builtinNames = builtinList
  154.                 ('abs', 'round', 'trunc', 'sqrt', 'sqr', 'sin', 'cos','tan',
  155.                    'arcsin', 'arccos', 'arctan', 'sinh', 'cosh', 'tanh',
  156.            'ln', 'log', 'log2', 'exp', 'fact');
  157.             VAR
  158.               e,l : INTEGER;       { intermediate variables }
  159.               found : BOOLEAN;
  160.               f : REAL8;
  161.               fn : builtin;
  162.               start : INTEGER;
  163.  
  164.          FUNCTION thisFn(inp : exprStr; pos : INTEGER; fn : builtin)
  165.                       : BOOLEAN;
  166.            { see if the input at location pos contains the fn name }
  167.            VAR
  168.              i : INTEGER;
  169.            BEGIN
  170.              thisFn := TRUE;
  171.          FOR i:=1 TO Ord(builtinNames[fn].Len) DO
  172.            IF inp[i+pos-1] <> builtinNames[fn,i] THEN thisFn := FALSE
  173.            END; { thisFn }
  174.  
  175.  
  176.               FUNCTION factorial(arg : REAL8): REAL8;
  177.                 BEGIN
  178.           arg := Andrqq(arg);  { round it to avoid strangeness }
  179.           IF arg > 170 THEN 
  180.             BEGIN Writeln(output,'factorial: Too large argument');
  181.                   Endxqq
  182.             END;
  183.           IF arg < 0 THEN 
  184.             BEGIN Writeln(output,'factorial: Negative argument');
  185.                   Endxqq
  186.             END;
  187.           IF arg > 0 THEN factorial := arg * factorial(arg-1)
  188.                    ELSE factorial := 1
  189.                 END; { factorial }
  190.  
  191.  
  192.           FUNCTION log2(CONSTS a : REAL8) : REAL8;
  193.             BEGIN
  194.           log2 := Lndrqq(a) / Lndrqq(2.0)
  195.         END; { log2 }
  196.  
  197.  
  198.  
  199.           BEGIN { factor }
  200.             IF ((ch >= '0') AND (ch <= '9')) OR (ch = '.') THEN
  201.               BEGIN start := pos;
  202.                   REPEAT nextCh UNTIL (ch < '0') OR (ch > '9'); 
  203.             IF ch = '.' THEN
  204.               REPEAT nextCh UNTIL (ch < '0') OR (ch > '9');
  205.             IF (ch='E') OR (ch='e') THEN
  206.               BEGIN nextCh;
  207.                   REPEAT nextCh UNTIL (ch < '0') OR (ch > '9')
  208.               END;
  209.             strToNum(formula,start,pos-start,f,errPos)
  210.               END
  211.         ELSE IF ch='(' THEN
  212.               BEGIN nextCh;
  213.                   f := expression;
  214.             IF ch=')' THEN nextCh
  215.                       ELSE errPos := pos
  216.               END
  217.         ELSE
  218.               BEGIN { parse builtin function }
  219.                 found := false;
  220.                 FOR fn := Lower(fn) TO Upper(fn) DO
  221.                 IF NOT found THEN
  222.                 BEGIN { check this function name }
  223.                   l := Ord(builtinNames[fn].Len);
  224.           IF thisFn(formula,pos,fn) THEN
  225.                     BEGIN { call builtin }
  226.                       pos := pos + l - 1;
  227.               nextCh;
  228.                       f := factor;
  229.                       CASE fn OF
  230.                         fabs:     f:=Abs(f);
  231.             fround:   f:=Andrqq(f);
  232.                         ftrunc:   f:=Aidrqq(f);
  233.             fsqrt:    f:=Srdrqq(f);
  234.                         fsqr:     f:=f*f;
  235.                         fsin:     f:=Sndrqq(f);
  236.                         fcos:     f:=Cndrqq(f);
  237.                         ftan:     f:=Tndrqq(f);
  238.                         farcsin:  f:=Asdrqq(f);
  239.                         farccos:  f:=Acdrqq(f);
  240.                         farctan:  f:=Atdrqq(f);
  241.                         fsinh :   f:=Shdrqq(f);
  242.                         fcosh :   f:=Chdrqq(f);
  243.                         ftanh :   f:=Thdrqq(f);
  244.                         fln :     f:=Lndrqq(f);
  245.                         flog:     f:=Lddrqq(f);
  246.             flog2:    f:=log2(f);
  247.                         fexp:     f:=Exdrqq(f);
  248.                         ffact:    f:=factorial(f);
  249.                       END; { CASE }
  250.                       found := TRUE;
  251.                     END; { call builtin }
  252.                 END; { check this function name }
  253.                 IF NOT found THEN errPos := pos;
  254.               END; { parse builtin function }
  255.               factor := f
  256.           END; { factor }
  257.  
  258.         BEGIN { signedFactor }
  259.       WHILE ch = ' ' DO nextCh;
  260.           IF ch = '-' THEN BEGIN nextCh;
  261.                    signedFactor := -factor
  262.                END
  263.           ELSE IF ch = '+' THEN BEGIN nextCh;
  264.                         signedFactor := factor
  265.                END
  266.       ELSE signedFactor := factor
  267.         END; { signedFactor }
  268.  
  269.       BEGIN { term }
  270.         t := signedFactor;
  271.         WHILE (ch = '^') AND (errPos = 0) DO
  272.           BEGIN nextCh;
  273.           t2 := signedFactor;
  274.         { check if t2 is integer by rounding }
  275.         IF t2 = Andrqq(t2) THEN t := Pidrqq(t,Round4(t2))
  276.                    ELSE t := Prdrqq(t,t2)
  277.           END;
  278.         term := t
  279.       END; { term }
  280.  
  281.     BEGIN { simpleExpression }
  282.       s := term;
  283.       WHILE ((ch = '*') OR (ch = '/') OR (ch = '\') OR (ch = 'm'))
  284.             AND (errPos = 0) DO
  285.         IF ch = '/' THEN BEGIN nextCh;
  286.                    s := s / term
  287.              END
  288.         ELSE IF ch = '*' THEN BEGIN nextCh;
  289.                     s := s * term
  290.                   END
  291.         ELSE IF ch = '\' THEN BEGIN nextCh;
  292.                     s := Mddrqq(s,(term))
  293.                   END
  294.         ELSE IF ch = 'm' THEN
  295.       BEGIN nextCh;
  296.         IF ch = 'i'
  297.           THEN BEGIN nextCh;
  298.                    IF ch = 'n' THEN BEGIN nextCh;
  299.                                  s := Mndrqq(s,(term))
  300.                           END
  301.                               ELSE errPos := pos
  302.                END
  303.         ELSE IF ch = 'a'
  304.           THEN BEGIN nextCh;
  305.                    IF ch = 'x' THEN BEGIN nextCh;
  306.                                  s := Mxdrqq(s,(term))
  307.                           END
  308.                               ELSE errPos := pos
  309.                END
  310.         ELSE errPos := pos
  311.       END;
  312.       simpleExpression := s
  313.     END; { simpleExpression }
  314.  
  315.   BEGIN { expression }
  316.     e := simpleExpression;
  317.     WHILE ((ch = '+') OR (ch = '-')) AND (errPos = 0) DO
  318.       IF ch = '-' THEN BEGIN nextCh;
  319.                  e := e - simpleExpression
  320.                END
  321.                   ELSE BEGIN nextCh;
  322.                  e := e + simpleExpression
  323.                END;
  324.     expression := e
  325.   END; { expression }
  326.  
  327.  
  328. BEGIN { evaluate }
  329.   { first lower case the string }
  330.   FOR pos:=1 TO Ord(formula.Len) DO
  331.     IF (formula[pos] >= 'A') AND (formula[pos] <= 'Z') THEN
  332.       formula[pos] := Chr(Ord(formula[pos]) + Ord('a') - Ord('A'));
  333.  
  334.   pos := 0;
  335.   errPos := 0;
  336.   nextCh;
  337.   exprVl := expression;
  338.   IF ch <> Chr(0) THEN errPos := pos
  339. END; { evaluate }
  340.  
  341.  
  342.  
  343. BEGIN { main }
  344.   cmdTail.S := Cesxqq;
  345.   cmdTail.R := 128;
  346.   IF cmdTail^.Len = 0 THEN
  347.     BEGIN Writeln(output,
  348.             'Infix expressions using:  +  -  *  /  \  ^  (  )  max  min');
  349.           Writeln(output,' unary prefix operators:  +  -  abs  round  trunc',
  350.                '  sqrt  sqr  sin  cos  tan');
  351.       Writeln(output,'                          arcsin  arccos  arctan',
  352.                '  sinh  cosh  tanh');
  353.       Writeln(output,'                          ln  log  log2  exp',
  354.                '  fact');
  355.     END
  356.   ELSE IF cmdTail^ = ' who' THEN
  357.     Writeln(output,'adapted from Turbo Pascal spreadsheet, Bruce K. Hillyer')
  358.   ELSE
  359.     BEGIN evaluate(cmdTail^,retnVl,errLoc);
  360.            IF errLoc > 0
  361.         THEN BEGIN Write(output,'      ');  { pass the 'C>eval' }
  362.                      FOR i:=1 TO errLoc-1 DO
  363.              Write(output,' ');
  364.                Writeln(output,'^----- error')
  365.                END
  366.         ELSE printNum(retnVl)
  367.     END
  368. END.
  369.