ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MISC/EDUCATIO/CATTEST.ZIP/EVAL3.PAS

Pascal/Delphi Source File | 1990-12-19 | 15.0 KB | 454 lines

unit Eval3;
interface
uses Crt,Utility;

PROCEDURE Evaluate(VAR Formula: STRING; { Fomula to evaluate}
                   VAR Value: Real;  { Result of formula }
                   VAR ErrPos: Integer;{ Position of error }
                   VAR ErrMsg: STRING); { Message of error }

implementation

PROCEDURE Evaluate(VAR Formula: STRING; { Fomula to evaluate}
                   VAR Value: Real;  { Result of formula }
                   VAR ErrPos: Integer;{ Position of error }
                   VAR ErrMsg: STRING); { Message of error }
(* COMMENTS
1) modified IV/27/1990-does bracket checking internally
                      -does not allow alphabetic material in equations
                      -reports error kind as well as position
                          1 = brackets not balanced
                          2 = alphabetic in formula
             V/29/1990-uses error message text.
*)

CONST
  Numbers: SET OF Char = ['0'..'9','.'];
  EofLine  = ^M;

VAR
  Position: Integer;    { Current position in formula                     }
  Ch: Char;        { Current character being scanned                 }
  k,
  brkt_counter : Integer;
  Formula_save : string;

{ Procedure NextCh returns the next character in the formula         }
{ The variable Pos contains the position ann Ch the character        }

{ eval.pas }

  { Evaluate an infix expression typed on the command line.  Give no arguments
     to get the help message.  Bruce K. Hillyer.

   This program is written for Microsoft pascal to use the REAL type,
     which seems to avoid answers like 0.999999999999999 when the correct
     answer is 1.

   Note that some versions of Microsoft pascal incorrectly decide that your pc
     has an 8087 or 80287 math coprocessor when in fact it doesn't.  To check
     this, try a simple multiplication.  If  eval 2*3   says 2, rather than 6,
     set the enviornment variable   set NO87=X   in your autoexec.bat file.

   This code is derived in part from the spreadsheet that comes with turbo
     pascal, which contains the following message:

        MICROCALC DEMONSTRATION PROGRAM  Version 1.00A

       This program is hereby donated to the public domain
       for non-commercial use only.  Dot commands are  for
       the program lister: LISTT.PAS  (available with  our
       TURBO TUTOR):    .PA, .CP20, etc...
  }

TYPE
  exprStr   = STRING;

VAR
  retnVl : REAL;
  errLoc : INTEGER;
  i : INTEGER;


{ functions for REAL }
(*
FUNCTION Andrqq(  a : REAL) : REAL;    { round }

FUNCTION Aidrqq(  a : REAL) : REAL;    { trunc }

FUNCTION Srdrqq(  a : REAL) : REAL;    { sqrt }

FUNCTION Sndrqq(  a : REAL) : REAL;    { sin }

FUNCTION Cndrqq(  a : REAL) : REAL;    { cos }

FUNCTION Tndrqq(  a : REAL) : REAL;    { tan }

FUNCTION Asdrqq(  a : REAL) : REAL;    { arcsin }

FUNCTION Acdrqq(  a : REAL) : REAL;    { arccos }

FUNCTION Atdrqq(  a : REAL) : REAL;    { arctan }

FUNCTION Shdrqq(  a : REAL) : REAL;    { sinh }

FUNCTION Chdrqq(  a : REAL) : REAL;    { cosh }

FUNCTION Thdrqq(  a : REAL) : REAL;    { tanh }

FUNCTION Lndrqq(  a : REAL) : REAL;    { ln }

FUNCTION Lddrqq(  a : REAL) : REAL;    { log }

FUNCTION Exdrqq(  a : REAL) : REAL;    { exp }

FUNCTION Pidrqq(  a : REAL;   b : INTEGER) : REAL;  {power}

FUNCTION Prdrqq(  a, b : REAL) : REAL;   { power }

FUNCTION Mddrqq(  a, b : REAL) : REAL;   { mod }

FUNCTION Mndrqq(  a, b : REAL) : REAL;   { min }

FUNCTION Mxdrqq(  a, b : REAL) : REAL;   { max }

PROCEDURE Endxqq;    { halt }
*)

PROCEDURE strToNum(formula : exprStr; start, len : INTEGER;
                   VAR retVal : REAL; VAR errPos : INTEGER);

  VAR
    tempStr : STRING;
    i : INTEGER;
  BEGIN
    tempStr := COPY(formula,start,len);
    WHILE (Length(tempStr) > 0 ) AND (tempStr[1] = ' ') DO
      Delete(tempStr,1,1);
    IF tempStr[1] = '.'
      THEN Insert('0',tempStr,1);
    IF tempStr[1] = '+'
      THEN Delete(tempStr,1,1);
    VAL(tempStr,retVal,errPos);

  END; { strToNum }



PROCEDURE printNum(num : REAL);
  VAR
    pointLoc : INTEGER;
    tempStr : STRING;
    ErrPos : INTEGER;
  BEGIN
    IF (num = Round(num)) AND (num <= 1.0e17) THEN { integer }
      BEGIN
        STR(int(num):1:0,tempStr);
        Writeln(tempStr)
      END
    ELSE IF Abs(num) > 1.0e6
           THEN Writeln(num:24)  { big float }
           ELSE BEGIN
                  Str(Abs(num):1:16,tempStr);
           { the position of the decimal point is one more than the number
               of digits in the absolute value of the integer part }
                  pointLoc := Pos('.',tempStr);
                  IF pointLoc = 0
                    THEN Writeln(output,num:1:0)
                    ELSE BEGIN
                      STR(num:1:(16-pointLoc),tempStr);
(*                      WHILE (Length(tempStr) > pointLoc) AND
                                 (tempStr[Length(tempStr)] = '0') DO{};*)
                       Writeln(output,tempStr)
                      END
             END
  END; { printNum }



(*
PROCEDURE evaluate(formula : exprStr; VAR exprVl: REAL; VAR errPos: INTEGER);
  { evaluate the formula }*)

VAR
  pos : INTEGER;    { current position in formula      }

  function Min(x,y:real):real;
  begin
    if x>y then Min := y else Min := x;
  end;
  function Max(x,y:real):real;
  begin
    if x>y then Max := x else Max := y;
  end;

  PROCEDURE nextCh;
    { get the next character into ch, set pos, <cr> indicates eos }
    BEGIN
      REPEAT
        pos := pos + 1;
               IF pos <= Length(formula)
                 THEN ch := formula[pos]
                               ELSE ch := Chr(0)
      UNTIL ch <> ' '
    END; { nextCh }


  FUNCTION expression : REAL;

    VAR
      e : REAL;

    FUNCTION simpleExpression : REAL;

      VAR
        s : REAL;

      FUNCTION term : REAL;

        VAR
          t,t2 : REAL;

        FUNCTION signedFactor : REAL;

          FUNCTION factor : REAL;

            TYPE
              builtin = (fabs, fround, ftrunc, fsqrt, fsqr, fsin, fcos, ftan,
                         farcsin, farccos, farctan, fsinh, fcosh, ftanh,
                         fln, flog, flog2, fexp, ffact);
              builtinList = ARRAY[builtin] OF STRING;

              CONST
                builtinNames : (*builtinList*)
                               array[builtin] of string =
                               ('abs', 'round', 'trunc', 'sqrt', 'sqr', 'sin', 'cos','tan'
                                ,
                                'arcsin', 'arccos', 'arctan', 'sinh', 'cosh', 'tanh',
                                'ln', 'log', 'log2', 'exp', 'fact');

            VAR
              e,l : INTEGER;       { intermediate variables }
              found : BOOLEAN;
              f : REAL;
              fn : builtin;
              start : INTEGER;

         FUNCTION thisFn(inp : exprStr; pos : INTEGER; fn : builtin)
                       : BOOLEAN;
           { see if the input at location pos contains the fn name }

           VAR
             i : INTEGER;
           BEGIN
             thisFn := TRUE;
             FOR i:=1 TO length(builtinNames[fn]) DO
               IF inp[i+pos-1] <> builtinNames[fn,i]
                 THEN thisFn := FALSE
           END; { thisFn }


              FUNCTION factorial(arg : REAL): REAL;
                BEGIN
                  arg := (*Andrqq*)Round(arg);  { round it to avoid strangeness }
                  IF arg > 170
                    THEN
                      BEGIN
                        Writeln(output,'factorial: Too large argument');
                        exit;
                      END;
                  IF arg < 0
                    THEN
                      BEGIN
                        Writeln(output,'factorial: Negative argument');
                        exit;
                      END;
                  IF arg > 0
                    THEN factorial := arg * factorial(arg-1)
                    ELSE factorial := 1
                END; { factorial }


          FUNCTION log2(  a : REAL) : REAL;
            BEGIN
              log2 := Ln(a) / Ln(2.0)
         END; { log2 }



          BEGIN { factor }
            IF ((ch >= '0') AND (ch <= '9')) OR (ch = '.')
              THEN
                BEGIN
                  start := pos;
                  REPEAT
                    nextCh
                  UNTIL (ch < '0') OR (ch > '9');
                  IF ch = '.'
                    THEN
                      REPEAT
                        nextCh
                      UNTIL (ch < '0') OR (ch > '9');
                  strToNum(formula,start,pos-start,f,errPos)
                END
              ELSE IF ch='('
                     THEN
                       BEGIN
                         nextCh;
                         f := expression;
                         IF ch=')'
                           THEN nextCh
                           ELSE errPos := pos
                       END
                     ELSE
                       BEGIN { parse builtin function }
                         found := false;
(*                         FOR fn := Lower(fn) TO Upper(fn) DO*)
                         for fn := fabs to ffact do
                           IF NOT found
                             THEN
                               BEGIN { check this function name }
                                 l := Length(builtinNames[fn]);
                                 IF thisFn(formula,pos,fn)
                                   THEN
                                     BEGIN { call builtin }
                                       pos := pos + l - 1;
                                       nextCh;
                                       f := factor;
                                       CASE fn OF
                                         fabs:     f := Abs(f);
                                         fround:   f := round(f);
                                         ftrunc:   f := trunc(f);
                                         fsqrt:    f := Sqrt(f);
                                         fsqr:     f := f*f;
                                         fsin:     f := Sin(f);
                                         fcos:     f := Cos(f);
                                         ftan:     f := Sin(f)/Cos(f);
                                      (*   farcsin:  f := Asdrqq(f);
                                         farccos:  f := Acdrqq(f);*)
                                         farctan:  f := ArcTan(f);
                                         (*fsinh :   f := Shdrqq(f);
                                         fcosh :   f := Chdrqq(f);
                                         ftanh :   f := Thdrqq(f);*)
                                         fln :     f := Ln(f);
                                         flog:     f := Ln(f)/2.303;
                                         flog2:    f := log2(f);
                                         fexp:     f := Exp(f);
                                         ffact:    f := factorial(f);
                                       END; { CASE }
                                       found := TRUE;
                                     END; { call builtin }
                               END; { check this function name }
                         IF NOT found
                           THEN errPos := pos;
                       END; { parse builtin function }
              factor := f
          END; { factor }

        BEGIN { signedFactor }
          WHILE ch = ' ' DO
            nextCh;
          IF ch = '-'
            THEN BEGIN
                   nextCh;
                    signedFactor := -factor
                 END
            ELSE IF ch = '+'
                   THEN BEGIN
                          nextCh;
                          signedFactor := factor
                     END
                   ELSE signedFactor := factor
        END; { signedFactor }

      BEGIN { term }
        t := signedFactor;
        WHILE (ch = '^') AND (errPos = 0) DO  {power}
          BEGIN
            nextCh;
            t2 := signedFactor;
            t := exp(t2*ln(t));
          END;
        term := t
      END; { term }

    BEGIN { simpleExpression }
      s := term;
      WHILE ((ch = '*') OR (ch = '/') OR (ch = '\') OR (ch = 'm'))
            AND (errPos = 0) DO
        IF ch = '/'
          THEN BEGIN
                 nextCh;
                     s := s / term
               END
          ELSE IF ch = '*'
                 THEN BEGIN
                        nextCh;
                        s := s * term
                    END
(*                 ELSE IF ch = '\'
                        THEN BEGIN
                               nextCh;
                               s := s mod (term)
                              END *)
                        ELSE IF ch = 'm'
                               THEN
                                 BEGIN
                                   nextCh;
                                   IF ch = 'i'
                                     THEN BEGIN
                                            nextCh;
                                            IF ch = 'n'
                                              THEN BEGIN
                                                     nextCh;
                                                     s := Min(s,(term))
                                                END
                                              ELSE errPos := pos
                                       END
                                     ELSE IF ch = 'a'
                                            THEN BEGIN
                                                   nextCh;
                                                   IF ch = 'x'
                                                     THEN BEGIN
                                                            nextCh;
                                                            s := Max(s,(term))
                                                       END
                                                     ELSE errPos := pos
                                              END
                                            ELSE errPos := pos
                                 END;
      simpleExpression := s
    END; { simpleExpression }

  BEGIN { expression }
    e := simpleExpression;
    WHILE ((ch = '+') OR (ch = '-')) AND (errPos = 0) DO
      IF ch = '-'
        THEN BEGIN
               nextCh;
                   e := e - simpleExpression
                END
                  ELSE BEGIN
                         nextCh;
                         e := e + simpleExpression
                    END;
    expression := e
  END; { expression }


BEGIN { evaluate }

  pos := 0;
  ErrPos := 0;
  nextCh;
  Formula_save := Formula;
  value := expression;
  if pos < Length(Formula) then
  begin
    ErrPos := pos;
    ErrMsg := 'BAD PARSE,->'+Formula_save;
  end
    else ErrMsg := OK_Message;
END; { evaluate }
END.