Power-Programmierung/CD1.mdf/pascal/library/dos/math/eev/postfix.inc

Text File | 1992-02-02 | 17.0 KB | 749 lines

{ ------------------------------------------------------------------------
  POSTFIX.INC
  ------------------------------------------------------------------------

  Version 1.00, Revision 1, 02/02/92 -- added TP3 RPN support   TP3.0, 5.5, 6.0
  Version 1.00, Revision 0, 12/28/91 -- original release        TP5.5, 6.0

  Written by: David J. Firth
              5665-A2 Parkville St.
              Columbus, OH 43229

  This file provides a complete reverse polish notation (RPN) expression
  evaluator.  Each part of the RPN expression needs to be separated by a
  space.  The evaluator supports the following functions:

  + - * / PI ABS ARCTAN COS EXP LN SQR SQRT

  The evaluator package includes routines to read and write values
  to and from variables.  Variables should be 20 or characters or
  less in length.  During expression evaluation, any unrecognized
  string of characters will be assumed to be a variable.

  Two procedures are provided for expression evaluation, Calculate and
  CalcAndStore.  Calculate will evaluate the expression and return the
  result to the caller.  CalcAndStore will evaluate the expression and
  store the result in a variable.

  POSTFIX.INC has two major data structures allocated on the heap.
  The first is a stack, used for the processing of RPN expressions.
  The other is a linked list used to store variables.  Before the
  application program uses an evaluator function, InitializeEE must
  be called to initialize the data structures.  Before the
  application program is ended, the procedure DestroyList should
  be called to deallocate the memory taken by these structures.

  API description:

  procedure InitializeEE;                            Init data structures

  procedure StoreVariable(VariableID:str20;          Put variable in LL
                          MyValue:real);

  procedure ReadVariable(VariableID:str20;           Get variable from LL
                         var MyValue:real;
                         var MyError:boolean);

  procedure DestroyList;                             Close data structures

  procedure Calculate(MyFormula:AnyStr;              Evaluate RPN expression
                      var MyResult:real;
                      var MyError:boolean);

  procedure CalcAndStore(MyFormula:AnyStr;           Evaluate/store RPN expr
                         StoreID:str20;
                         var MyError:boolean);

  ------------------------------------------------------------------------

  Differences between V1.00R0 and V1.00R1:

  All files and functions in Expression Evaluator Tools V1.00R0 exist
  in V1.00R1 with the following modifications:

  1. V1.00R1 is written to include Turbo Pascal V3.0 by adding POSTFIX.INC,
     DFSTR.INC, and TESTP3.PAS.

  Changes to the evaluator code in POSTFIX.INC (POSTFIX.PAS is unchanged):

  2. Code to test for '+' and '-' has been added to the part of Calculate
     that identifies a token as a valid number.  TP3.0's Val routine will
     evaluate '+' and '-' as 0.  TP5.5 sees '+' and '-' as non-numeric.
  3. A new procedure, InitializeEE, must be called prior to using the
     expression evaluator.  InitializeEE performs the function that the
     unit initialization code block performs in the TP5.5/TP6.0 version.
  4. All references to Dec and Inc are now Succ and Pred.
  5. All string types are now declared with sizes.
  6. All references to the 255 byte string type are now AnyStr (declared
     in DFSTR.INC).

  ------------------------------------------------------------------------ }

type

  Str20 = string[20];                 {store variable IDs this way to conserve}
  Str128 = string[128];

  VariablePtr = ^VariableType;        {for dynamic allocation of records }

  VariableType = record
    ID    : Str20;                    {the id of the variable, with @s   }
    Value : real;                     {the current value of the variable }
    Next  : VariablePtr;              {hook to next record in linked list}
  end; {VariableType}

  StackItemPtr = ^StackItemType;      {for dynamic allocation of records }

  StackItemType = record
    Value : real;                     {the value to be "operated" upon   }
    Next  : StackItemPtr;             {hook to next record in linked list}
  end; {StackItemType}

var

  HPtr,                               {head of variable list       }
  TPtr,                               {tail of variable list       }
  SPtr  : VariablePtr;                {used to search variable list}

  STPtr : StackItemPtr;               {the top of the stack}

{ ------------------------------------------------------------------------ }

function __ParamCount(MyStr:AnyStr):byte;

{this routine is a work-alike of Turbo's own ParamCount function. this
 routine requires my DFStr unit to operate.}

var

  Count,
  Index  : byte;

begin

  MyStr := __RemWhiteStr(MyStr,_Leading);
  MyStr := __RemWhiteStr(MyStr,_Trailing);

  Count := 0;
  for Index := 1 to length(MyStr) do
    if MyStr[Index]=' ' then
      Count := succ(Count);

  __ParamCount := Count+1;

end; {__ParamCount}

{ ------------------------------------------------------------------------ }

function __ParamStr(Index:byte;MyStr:AnyStr):AnyStr;

var

  TempStr : AnyStr;
  I,
  J,
  P,
  Count   : byte;
  Spaces  : array[0..256] of byte;

begin

  TempStr := '';

  fillchar(Spaces,sizeof(Spaces),0);

  Count := __ParamCount(MyStr);

  if (Index<=Count) AND (Index>0) then begin

    MyStr := __RemWhiteStr(MyStr,_Leading);
    MyStr := __RemWhiteStr(MyStr,_Trailing);

    MyStr := ' ' + MyStr + ' ';

    {load Spaces}
    J := 0;
    for I := 1 to length(MyStr) do begin
      if MyStr[I] = ' ' then begin
        Spaces[J] := I;
        J := succ(J);
      end;
    end; {for}

    {get the parameter}
    TempStr := copy(MyStr,Spaces[Index-1]+1,Spaces[Index]-Spaces[Index-1]-1);

  end;

  __ParamStr := TempStr;

end; {__ParamStr}

{ ------------------------------------------------------------------------ }

procedure Pop(var MyValue:real;var MyError:boolean);

var

  TempPtr : StackItemPtr;

begin

  if STPtr=nil then begin
    {tried to pop empty stack -- error!}
    MyValue := 0;
    MyError := true;
  end
  else begin
    {get value}
    MyValue := STPtr^.Value;
    MyError := false;
    {dispose of the record at the top of the stack}
    TempPtr := STPtr;
    STPtr := STPtr^.Next;
    dispose(TempPtr);
  end; {if-else}

end; {Pop}

{ ------------------------------------------------------------------------ }

procedure Push(MyValue:real);

var

  TempPtr : StackItemPtr;

begin

  {create record on heap for value}
  new(TempPtr);
  TempPtr^.Value := MyValue;

  {attach new record as top of stack}
  TempPtr^.Next := STPtr;
  STPtr := TempPtr;

end; {Push}

{ ------------------------------------------------------------------------ }

procedure DestroyStack(MyPtr:StackItemPtr);

begin

  if MyPtr^.Next<>nil then
    DestroyStack(MyPtr^.Next);

  dispose(MyPtr);

end; {DestroyStack}

{ ------------------------------------------------------------------------ }

procedure GetPointerTo(VariableID:str20;var MPtr:VariablePtr);

var

  Done : boolean;
  XPtr : VariablePtr;

begin

  MPtr := nil;
  XPtr := HPtr;

  Done := false;
  while (not Done) do begin

    if XPtr^.ID=VariableID then
      MPtr := XPtr;

    if XPtr^.Next=nil then
      Done := true
    else
      XPtr := XPtr^.Next;

  end; {while}

end; {GetPointerTo}

{ ------------------------------------------------------------------------ }

procedure ReadVariable(VariableID:str20;var MyValue:real;var MyError:boolean);

var

  MPtr : VariablePtr;

begin

  MyError := false;
  MyValue := 0;

  GetPointerTo(VariableID,MPtr);

  if MPtr<>nil then begin
    MyValue := MPtr^.Value
  end
  else begin
    MyError := true;
  end;

end; {ReadVariable}

{ ------------------------------------------------------------------------ }

procedure StoreVariable(VariableID:str20;MyValue:real);

var

  WorkingRec : VariableType;

begin

  fillchar(WorkingRec,sizeof(WorkingRec),0);
  WorkingRec.ID := VariableID;
  WorkingRec.Value := MyValue;

  If HPtr = nil then begin

    {this is the first record added to the list}

    New(HPtr);                                {allocate 1st record in LL }
    TPtr := HPtr;                             {init tail (= head)        }
    TPtr^ := WorkingRec;                      {add new record as head    }
    TPtr^.Next := nil;                        {set the next link for tail}

  end
  else begin

    GetPointerTo(VariableID,SPtr);

    if SPtr <> nil then begin

      {the list exists and so does the variable -- modify value}

      SPtr^.Value := MyValue;

    end
    else begin

      {the list exists, but the variable doesn't -- add it}

      New(SPtr);                          {allocate new record for LL }
      SPtr^ := WorkingRec;                {put info in new LL record  }
      TPtr^.Next := SPtr;                 {add new record as tail     }
      SPtr^.Next := nil;                  {set the new link for tail  }
      TPtr := SPtr;                       {point tail to new record   }

    end; {if-else}

  end;

end; {StoreVariable}

{ ------------------------------------------------------------------------- }

Procedure DestroyFieldList(TempPtr:VariablePtr);

{ This procedure recursively destroys a linked list }

Begin

  If TempPtr^.Next <> nil then
    DestroyFieldList(TempPtr^.Next);

  Dispose(TempPtr);

End;

{ ------------------------------------------------------------------------ }

procedure DestroyList;

begin

  if HPtr <> Nil then
    DestroyFieldList(HPtr);

  HPtr := nil;
  TPtr := nil;
  SPtr := nil;

  if STPtr<>nil then
    DestroyStack(STPtr);

  STPtr := nil;

end; {DestroyList}

{ ------------------------------------------------------------------------ }

procedure DoAdd(var MyError:boolean);

var

  A,B : real;

begin

  Pop(A,MyError);
  if not MyError then begin
    Pop(B,MyError);
    if not MyError then Push(A+B)
  end;

end; {DoAdd}

{ ------------------------------------------------------------------------ }

procedure DoSub(var MyError:boolean);

var

  A,B : real;

begin

  Pop(A,MyError);
  if not MyError then begin
    Pop(B,MyError);
    if not MyError then Push(B-A)
  end;

end; {DoSub}

{ ------------------------------------------------------------------------ }

procedure DoMul(var MyError:boolean);

var

  A,B : real;

begin

  Pop(A,MyError);
  if not MyError then begin
    Pop(B,MyError);
    if not MyError then Push(A*B)
  end;

end; {DoMul}

{ ------------------------------------------------------------------------ }

procedure DoPI(var MyError:boolean);

begin

  MyError := false;
  Push(3.1415927);

end; {DoPI}

{ ------------------------------------------------------------------------ }

procedure DoABS(var MyError:boolean);

var

  A : real;

begin

  Pop(A,MyError);
  if not MyError then begin
    Push(abs(A))
  end;

end; {DoABS}

{ ------------------------------------------------------------------------ }

procedure DoATAN(var MyError:boolean);

{this function works in radians}

var

  A : real;

begin

  Pop(A,MyError);
  if not MyError then begin
    Push(arctan(A));
  end;

end; {DoATAN}

{ ------------------------------------------------------------------------ }

procedure DoCOS(var MyError:boolean);

{this function works in radians}

var

  A : real;

begin

  Pop(A,MyError);
  if not MyError then begin
    Push(cos(A));
  end;

end; {DoCOS}

{ ------------------------------------------------------------------------ }

procedure DoEXP(var MyError:boolean);

var

  A : real;

begin

  Pop(A,MyError);
  if not MyError then begin
    Push(exp(A));
  end;

end; {DoEXP}

{ ------------------------------------------------------------------------ }

procedure DoLN(var MyError:boolean);

var

  A : real;

begin

  Pop(A,MyError);
  if not MyError then begin
    Push(ln(A));
  end;

end; {DoLN}

{ ------------------------------------------------------------------------ }

procedure DoSQR(var MyError:boolean);

var

  A : real;

begin

  Pop(A,MyError);
  if not MyError then begin
    Push(A*A);
  end;

end; {DoSQR}

{ ------------------------------------------------------------------------ }

procedure DoSQRT(var MyError:boolean);

var

  A : real;

begin

  Pop(A,MyError);
  if not MyError then begin
    Push(sqrt(A));
  end;

end; {DoSQRT}

{ ------------------------------------------------------------------------ }

procedure DoDiv(var MyError:boolean);

var

  A,B : real;

begin

  Pop(A,MyError);
  if not MyError then begin
    Pop(B,MyError);
    if not MyError then Push(B/A)
  end;

end; {DoDiv}

{ ------------------------------------------------------------------------ }

procedure Calculate(MyFormula:AnyStr;var MyResult:real;var MyError:boolean);

const

  {MyFunctions is the lookup table for valid EE operators}

  NumFunctions = 12;
  MyFunctions : array[1..NumFunctions] of AnyStr = ('+',
                                                    '-',
                                                    '*',
                                                    '/',
                                                    'PI',
                                                    'ABS',
                                                    'ARCTAN',
                                                    'COS',
                                                    'EXP',
                                                    'LN',
                                                    'SQR',
                                                    'SQRT');

var

  Index,
  TokenID,
  TokenNum,
  NumTokens : byte;
  CmdTail   : ^Str128;
  Token     : AnyStr;
  ValError  : integer;
  ValReal   : real;
  VarStr    : Str20;

begin

  {set up error condition}
  MyError := false;
  MyResult := 0;

  NumTokens := __ParamCount(MyFormula);

  if NumTokens>0 then begin

    TokenNum := 1;
    while (TokenNum<=NumTokens) AND (not MyError) do begin

      Token := __ParamStr(TokenNum,MyFormula);

      { In TP5.5, trying to obtain the value of '+' or '-' will generate
        an error.  In TP3.0, the same function will return a valid number
        with a value of zero.  This fix will check for '+' and '-' first. }

      if (Token='+') OR (Token='-') then begin
        {manually force POSTFIX to skip number evaluation}
        ValError := 1;
      end
      else begin
        {process the token just like previous version of POSTFIX}
        val(Token,ValReal,ValError);
      end; {if-else}

      if ValError=0 then begin

       {token is a valid number - push onto stack}
        Push(ValReal);

      end
      else begin

        {token wasn't a number, is it an operator?}

        {convert to all caps}
        for Index := 1 to length(Token) do
          Token[Index] := upcase(Token[Index]);

        {search valid functions}
        TokenID := 0;
        for Index := 1 to NumFunctions do
          if MyFunctions[Index]=Token then TokenID := Index;

        case TokenID of
          0: begin
               {search valid variables for Token}
               VarStr := copy(Token,1,20);
               ReadVariable(VarStr,ValReal,MyError);
               if not MyError then
                 {push variable's value onto stack}
                 Push(ValReal);
             end; {0}
          1: DoAdd(MyError);
          2: DoSub(MyError);
          3: DoMul(MyError);
          4: DoDiv(MyError);
          5: DoPI(MyError);
          6: DoABS(MyError);
          7: DoATAN(MyError);
          8: DoCOS(MyError);
          9: DoEXP(MyError);
         10: DoLN(MyError);
         11: DoSQR(MyError);
         12: DoSQRT(MyError);
        end; {case}

      end; {if-else}

      {point to next token}
      TokenNum := succ(TokenNum);

    end; {while}

  end
  else begin
    MyError := true;
  end;

  if not MyError then
    {the result of the evaluator is on the stack}
    Pop(MyResult,MyError)
  else
    {problem -- destroy stack}
    if STPtr<>nil then DestroyStack(STPtr);

end; {Calculate}

{ ------------------------------------------------------------------------ }

procedure CalcAndStore(MyFormula:AnyStr;StoreID:str20;var MyError:boolean);

var

  MyResult : real;

begin

  {call calculate to evaluate the expression}
  Calculate(MyFormula,MyResult,MyError);

  {store the result in a variable}
  if not MyError then
    StoreVariable(StoreID,MyResult);

end; {Calculate}

{ ------------------------------------------------------------------------ }

procedure InitializeEE;

begin {init block}

  {set up linked list to empty state}

  HPtr := nil;
  TPtr := nil;
  SPtr := nil;

  {set up the stack}

  STPtr := nil;

end; {InitializeEE}