Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/EEV100R1.ZIP/POSTFIX.PAS

Pascal/Delphi Source File | 1992-01-03 | 15.2 KB | 710 lines

Unit PostFix;

{ ------------------------------------------------------------------------
  POSTFIX.PAS
  ------------------------------------------------------------------------

  Version 1.00, Revision 0, December 28, 1991

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

  This unit 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 RPN evaluator does not have its own tokenizer.  Instead, since
  the expression tokens must be separated by spaces, Turbo's own
  ParamStr tokenizer can be fooled into doing the job.  Due to the
  limitations imposed by DOS on the size of the command tail, the
  length of the string to evaluate will be truncated at 120 characters.
  My thanks to PC Techniques magazine for printing a HAX with this
  suggestion in it.

  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.PAS 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 is ended, the procedure DestroyList should
  be called to deallocate the memory taken by these structures.

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

Interface

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}

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

procedure Calculate(MyFormula:string;var MyResult:real;var MyError:boolean);
procedure CalcAndStore(MyFormula:string;StoreID:str20;var MyError:boolean);

Implementation

Uses

  DFStr;

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

function __ParamCount(MyStr:string):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 inc(Count);

  __ParamCount := Count+1;

end; {__ParamCount}

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

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

var

  TempStr : string;
  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;
        inc(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:string;var MyResult:real;var MyError:boolean);

const

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

var

  Index,
  TokenID,
  TokenNum,
  NumTokens : byte;
  CmdTail   : ^Str128;
  Token     : string;
  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);

      val(Token,ValReal,ValError);

      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}
      inc(TokenNum);

    end; {while}

  end
  else
    MyError := true;

  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:string;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}

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

begin {init block}

  {set up linked list to empty state}

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

  {set up the stack}

  STPtr := nil;

end. {unit PostFix}