{
    Expression-Compiler V1.0
    (C) 1990 by Antivivisektion@t-online.de (Update: 3.8.1998)
    Only for non-commercial use.

    DISCLAIMER
    ----------
    WE DO NOT WARANTEE ANYTHING CONCERNING ANY OF THE SOURCES OR FILES
    WHICH MAKE UP THIS MATH PACKAGE. WE ACCEPT NO RESPONSIBILITY FOR
    ANY LOSS OR DAMAGE OF ANY KIND, INCLUDING, BUT NOT LIMITED TO, LOSSES
    OF A PHYSICAL, MENTAL, SOCIAL, FINANCIAL, MARITAL, OR OF WHATEVER
    NATURE, RESULTING FROM THE USE, OR THE PURPORTED USE, OF THIS MATH
    PACKAGE OR ANY OF THE FILES IN THE PACKAGE, FOR ANY PURPOSE WHATSOEVER.
    WE DO NOT EVEN WARANTEE THAT THE FILES WILL NOT KILL YOU.

    YOU USE THIS MATH PACKAGE ENTIRELY AT YOUR OWN RISK, AND YOU SUPPLY
    IT TO YOUR CUSTOMERS, FRIENDS, FAMILY, ACQUAINTANCES, OR ENEMIES,
    ENTIRELY AT YOUR OWN RISK.

    IF THESE TERMS ARE NOT ACCEPTABLE TO YOU, THEN PLEASE DELETE ALL
    THE FILES FROM YOUR DISKS IMMEDIATELY AND PERMANENTLY.

    In this disclaimer, "WE" refers to: Antivivisektion@t-online.de

    (Disclaimer written by The-African-Chief <laa12@cc.keele.ac.uk>)
}

{$A+,B-,D+,E-,F-,I-,L+,N+,O-,R-,S-,V-,M 4048,0,$A0000}
{$DEFINE UNIT}

{$IFDEF UNIT}
Unit Math;
Interface
{$ELSE}
Program Math;
{$ENDIF}
Const
  EndID = '=';
  MaxFunc = 20;
  SymbolStackSize = 100;
  FloatStackSize = 80;
  DataIndexMin = 'A';
  DataIndexMax = 'Z';

{$IFOPT N+}
Type
  Float = {Single} Extended;
Const
  MaxFloat = 3.4E38;
{$ELSE}
Type
  Float = Real;
Const
  MaxFloat = 1.7E38;
{$ENDIF}

Type
  FuncNameTyp = String[7];
  FuncResult = Function (f: Float): Float;
  SymbolTyp = (_Add,_Sub,_Mul,_Div,_Pot,_Neg,_Func,_Var,_Val,_lP,_rP,_End);
  SymbolRec = Record
    Case Symbol: SymbolTyp Of
       _Add: (SymChar: Char);
      _Func: (FuncIndex: Word);
       _Val: (Value: Float);
  End;
  SymbolStackIndex = 1..SymbolStackSize;
  FloatStackIndex = 0..FloatStackSize;
  DataIndex = DataIndexMin..DataIndexMax;

  DataObj = Object
    Data: Array[DataIndex] Of Float;
    SymbolStackPtr: Word;
    SymbolStack: Array[1..SymbolStackSize] Of SymbolRec;
    Constructor Init;
    Procedure PushSymbol (Var Symbol: SymbolRec);
    Procedure Error (Const Msg1,Msg2: String);
    Destructor Done;
  End;

  ParseObj = Object(DataObj)
    ParseIndex: Byte;
    Parse: String;
    ThisChar: Char;
    ThisSymbol: SymbolRec;
    LegalFunc: Word;
    FuncTable: Array[1..MaxFunc] Of Record
      FuncName: FuncNameTyp;
      Evaluate: FuncResult;
    End;
    Procedure AddFunc (Const pName: FuncNameTyp; pResult: FuncResult);
    Constructor Init;
    Procedure NextChar;
    Procedure NextSymbol;
    Procedure Error (Msg1,Msg2: String);
    Destructor Done;
  End;

  Expression = Object(ParseObj)
    MathError: Boolean;
    Constructor Init;
    Procedure EnterTerm;
    Procedure FormatTerm;
    Function FormFloat (f: Float): String;
    Procedure Compile;
    Procedure Term;
    Procedure Summand;
    Procedure Factor;
    Procedure Base;
    Function Evaluate: Float;
    Function EvaluateTerm ({Const} TheTerm: String): Float;
    Procedure PrintResult;
    Procedure Optimize;
    Procedure ShowStack;
    Destructor Done;
  End;

{$IFDEF UNIT}
Implementation
{$ENDIF}

Constructor DataObj.Init;
Var Index: DataIndex;
Begin
  For Index := DataIndexMin To DataIndexMax Do Data[Index] := 0.0;
  SymbolStackPtr := 0;
End;

Procedure DataObj.Error (Const Msg1,Msg2: String);
Begin
  WriteLn ('Parsing error ',Msg1,Msg2);
  Halt;
End;

Procedure ParseObj.Error (Msg1,Msg2: String);
Begin
  WriteLn (Parse);
  If (Copy(Msg1,1,7) <> 'Illegal')
     Then Write ('^':ParseIndex-2)
     Else Write ('^':ParseIndex-1-Length(Msg2));
  WriteLn ('-- syntax error: ',Msg1,Msg2);
  Halt;
End;

Procedure DataObj.PushSymbol (Var Symbol: SymbolRec);
Begin
  Inc(SymbolStackPtr);
  SymbolStack[SymbolStackPtr] := Symbol;
End;

Destructor DataObj.Done;
Begin
  SymbolStackPtr := 0;
End;

Constructor ParseObj.Init;
Begin
  ParseIndex := 1;
  Parse := '';
End;

Procedure ParseObj.NextChar;
Begin
  ThisChar := Parse[ParseIndex];
  Inc(ParseIndex);
End;

Procedure ParseObj.NextSymbol;
Var StrHelp: String[63]; Index: Word;
Begin
  With ThisSymbol Do
  Begin
    Case ThisChar Of
      '+': Begin
             Symbol := _Add;
             SymChar := '+';
             NextChar;
           End;
      '-': Begin
             Symbol := _Sub;
             SymChar := '-';
             NextChar;
           End;
      '*': Begin
             Symbol := _Mul;
             SymChar := '*';
             NextChar;
           End;
      '/': Begin
             Symbol := _Div;
             SymChar := '/';
             NextChar;
           End;
      '^': Begin
             Symbol := _Pot;
             SymChar := '^';
             NextChar;
           End;
      '(': Begin
             Symbol := _lP;
             SymChar := '(';
             NextChar;
           End;
      ')': Begin
             Symbol := _rP;
             SymChar := ')';
             NextChar;
           End;
    EndID: Begin
             Symbol := _End;
             SymChar := EndID;
           End;
 'A'..'Z': Begin
             StrHelp := ThisChar;
             NextChar;
             While (ThisChar >= 'A') And (ThisChar <= 'Z') Do
             Begin
               StrHelp := StrHelp+ThisChar;
               NextChar;
             End;
             If (Length(StrHelp) = 1)
               Then
                 Begin
                   Symbol := _Var;
                   SymChar := StrHelp[1];
                 End
               Else
                 Begin
                   Index := 1;
                   While (Index <= LegalFunc) And
                     (StrHelp <> FuncTable[Index].FuncName) Do
                     Inc(Index);

                   If (Index > LegalFunc)
                      Then Error ('Illegal function call: ',StrHelp);
                   FuncIndex := Index;
                   Symbol := _Func;
                 End;
           End;
  '.',',','0'..'9': Begin
             If (ThisChar = ',') Then ThisChar := '.';
             StrHelp := ThisChar;
             NextChar;
             If (ThisChar = ',') Then ThisChar := '.';
             While (ThisChar = '.') Or
               ((ThisChar >= '0') And (ThisChar <= '9')) Do
             Begin
               StrHelp := StrHelp+ThisChar;
               NextChar;
               If (ThisChar = ',') Then ThisChar := '.';
             End;
             Symbol := _Val;
             Val (StrHelp,Value,Index);
             If (Index > 0)
                Then Error('Illegal float: ',StrHelp);
           End;
    End; { Case }
  End; { With }
End;

Destructor ParseObj.Done;
Begin
End;

{$F+}
Function _ABS (f: Float): Float;
Begin
  _ABS := ABS(f);
End;

Function _SIN (f: Float): Float;
Begin
  _SIN := SIN(f);
End;

Function _COS (f: Float): Float;
Begin
  _COS := COS(f);
End;

Function _TAN (f: Float): Float;
Var x: Float;
Begin
  x := COS(f);
  If (x <> 0)
     Then _TAN := SIN(f) / x
     Else _TAN := MaxFloat;
End;

Function _COT (f: Float): Float;
Var x: Float;
Begin
  x := SIN(f);
  If (x <> 0)
     Then _COT := COS(f) / x
     Else _COT := MaxFloat;
End;

Function _EXP (f: Float): Float;
Begin
  _EXP := EXP(f);
End;

Function _LN (f: Float): Float;
Begin
  If (f <= 0)
     Then Begin _LN := 0; WriteLn('RUNTIME ERROR: ILLEGAL LN() VALUE'); End
     Else _LN := LN(f);
End;

Function _LOG (f: Float): Float;
Const LN10 = 2.30258512496948242;
Begin
  If (f <= 0)
     Then Begin _LOG := 0; WriteLn('RUNTIME ERROR: ILLEGAL LOG() VALUE'); End
     Else _LOG := _LN(f) / LN(10);
End;

Function _LD (f: Float): Float;
Const LN2 = 0.693147182464599609;
Begin
  If (f <= 0)
     Then Begin _LD := 0; WriteLn('RUNTIME ERROR: ILLEGAL LD() VALUE'); End
     Else _LD := _LN(f) / LN(2);
End;

Function _SQRT (f: Float): Float;
Begin
  _SQRT := SQRT(f);
End;

Function _SQR (f: Float): Float;
Begin
  _SQR := SQR(f);
End;

Function _SINH (f: Float): Float;
Begin
  _SINH := 0.5 * (Exp(f)-Exp(-f));
End;

Function _COSH (f: Float): Float;
Begin
  _COSH := 0.5 * (Exp(f)+Exp(-f));
End;

Function _TANH (f: Float): Float;
Begin
  _TANH := _SINH(f) / _COSH(f);
End;

Function _COTH (f: Float): Float;
Begin
  _COTH := _COSH(f) / _SINH(f);
End;

Function _ARSINH (f: Float): Float;
Begin
  _ARSINH := _Ln(f+_Sqrt(_Sqr(f)+1));
End;

Function _ARCOSH (f: Float): Float;
Begin
  If (f >= 1)
     Then _ARCOSH := _Ln(f+_Sqrt(_Sqr(f)-1))
     Else _ARCOSH := MaxFloat;
End;

Function _ARTANH (f: Float): Float;
Begin
  If (Abs(f) < 1)
     Then _ARTANH := _Ln(_Sqrt((1+f)/(1-f)))
     Else _ARTANH := MaxFloat;
End;

Function _ARCOTH (f: Float): Float;
Begin
  If (Abs(f) > 1)
     Then _ARCOTH := _ARTANH(1/f)
     Else _ARCOTH := MaxFloat;
End;
{$F-}

Constructor Expression.Init;
Begin
  DataObj.Init;
  ParseObj.Init;
  LegalFunc := 0;
{ FillChar (FuncTable,SizeOf(FuncTable),0);
} AddFunc ('SIN',_SIN);
  AddFunc ('COS',_COS);
  AddFunc ('TAN',_TAN);
  AddFunc ('EXP',_EXP);
  AddFunc ('LN', _LN);
  AddFunc ('LD', _LD);
  AddFunc ('LOG',_LOG);
  AddFunc ('ABS',_ABS);
  AddFunc ('COT',_COT);
  AddFunc ('SQRT',_SQRT);
  AddFunc ('SQR',_SQR);
  AddFunc ('SINH',_SINH);
  AddFunc ('COSH',_COSH);
  AddFunc ('TANH',_SINH);
  AddFunc ('COTH',_SINH);
  AddFunc ('ARSINH',_ARSINH);
  AddFunc ('ARCOSH',_ARCOSH);
  AddFunc ('ARTANH',_ARTANH);
  AddFunc ('ARCOTH',_ARCOTH);
End;

Procedure ParseObj.AddFunc (Const pName: FuncNameTyp; pResult: FuncResult);
Begin
  If (LegalFunc >= MaxFunc)
     Then Error ('Function table overflow','');
  Inc(LegalFunc);
  With FuncTable[LegalFunc] Do
  Begin
    FuncName := pName;
    @Evaluate := @pResult;
  End;
End;

Destructor Expression.Done;
Begin
  ParseObj.Done;
  DataObj.Done;
End;

Function Expression.Evaluate: Float;
Var
  Index: SymbolStackIndex;
  FloatStackPtr: FloatStackIndex;
  FloatStack: Array[1..FloatStackSize] Of Float;

  Function Pop: Float;
  Begin
    Pop := FloatStack[FloatStackPtr];
    Dec(FloatStackPtr);
  End;

  Procedure Push(Wert: Float);
  Begin
    Inc(FloatStackPtr);
    FloatStack[FloatStackPtr] := Wert;
  End;

  Function RaiseOnZero(f: Float): Float;
  Begin
    If (f = 0)
       Then Begin RaiseOnZero := 1E-20; WriteLn('RUNTIME ERROR: DIV BY ZERO'); RunError(200); End
       Else RaiseOnZero := f;
  End;

Begin
  FloatStackPtr := 0;
  For Index := 1 To SymbolStackPtr Do
  Begin
    With SymbolStack[Index] Do
    Begin
      Case Symbol Of
         _Add: Push (Pop+Pop);
         _Sub: Push (-Pop+Pop);
         _Mul: Push (Pop*Pop);
         _Div: Push ((1/RaiseOnZero(Pop))*Pop);
         _Pot: Push (_Exp(Pop*Ln(Pop)));
         _Neg: Push (-Pop);
         _Var: Push (Data[SymChar]);
         _Val: Push (Value);
        _Func: Push (FuncTable[FuncIndex].Evaluate (Pop));
      End;
    End;
  End;
  Evaluate := Pop;
End;

Function Expression.FormFloat (f: Float): String;
Var s: String;
Begin
  Str(f:0:$FF,s);
  While (Length(s) > 0) And (s[Length(s)] = '0') Do Dec(s[0]);
  If (Length(s) > 0) And (s[Length(s)] = '.') Then Dec(s[0]);
  FormFloat := s;
End;

Procedure Expression.ShowStack;
Var Index: SymbolStackIndex;
Begin
  For Index := 1 To SymbolStackPtr Do
  Begin
    With SymbolStack[Index] Do
    Begin
      Case Symbol Of
        _Func: Write (FuncTable[FuncIndex].FuncName);
         _Val: Write (FormFloat(Value));
          Else Write (SymChar);
      End;
    End;
    Write(' ');
  End;
End;

Procedure Expression.Compile;
Begin
  NextChar;
  NextSymbol;
  Term;
  If (ThisSymbol.Symbol <> _End)
     Then Error('Unexpected end of term','');
End;

Procedure Expression.Term;
Var AddHelp: SymbolRec;
Begin
  If (ThisSymbol.Symbol = _Add) Or (ThisSymbol.Symbol = _Sub)
     Then
       Begin
         AddHelp := ThisSymbol;
         NextSymbol;
         Summand;
         If (AddHelp.Symbol = _Sub)
            Then
              Begin
                AddHelp.Symbol := _Neg;
                AddHelp.SymChar := 'ª';
                PushSymbol (AddHelp);
              End;
       End
     Else Summand;
  While (ThisSymbol.Symbol = _Add) Or (ThisSymbol.Symbol = _Sub) Do
  Begin
    AddHelp := ThisSymbol;
    NextSymbol;
    Summand;
    PushSymbol (AddHelp);
  End;
End;

Procedure Expression.Summand;
Var MulHelp: SymbolRec;
Begin
  Factor;
  While (ThisSymbol.Symbol = _Mul) Or (ThisSymbol.Symbol = _Div) Do
  Begin
    MulHelp := ThisSymbol;
    NextSymbol;
    Factor;
    PushSymbol (MulHelp);
  End;
End;

Procedure Expression.Factor;
Var ExpHelp: SymbolRec;
Begin
  Base;
  ExpHelp := ThisSymbol;
  While (ThisSymbol.Symbol = _Pot) Do
  Begin
    NextSymbol;
    Base;
    PushSymbol (ExpHelp);
  End;
End;

Procedure Expression.Base;
Var FuncHelp: SymbolRec;
Begin
  Case ThisSymbol.Symbol Of
    _Var,_Val: Begin
                 PushSymbol (ThisSymbol);
                 NextSymbol;
               End;
          _lP: Begin
                 NextSymbol;
                 Term;
                 If (ThisSymbol.Symbol = _rP)
                   Then NextSymbol
                   Else Error (') expected','');
               End;
        _Func: Begin
                 FuncHelp := ThisSymbol;
                 NextSymbol;
                 If (ThisSymbol.Symbol = _lP)
                    Then NextSymbol
                    Else {Error('( expected','')};
                 Term;
                 If (ThisSymbol.Symbol = _rP)
                    Then NextSymbol
                    Else If (ThisSymbol.Symbol <> _End) { AutoClose () }
                            Then Error(') expected','');
                 PushSymbol(FuncHelp)
               End;
          Else Error('Base expected','');
  End;
End;

Procedure Expression.EnterTerm;
Begin
  Init;
  Write ('Enter expression: ');
  ReadLn (Parse);
  FormatTerm;
End;

Function Expression.EvaluateTerm ({Const} TheTerm: String): Float;
Begin
  Init;
  Parse := TheTerm;
  FormatTerm;
  Compile;
  EvaluateTerm := Evaluate;
End;

Procedure Expression.FormatTerm;
Var Index1,Index2: Word;
Begin
  Inc(Parse[0]);
  Parse[Length(Parse)] := '=';
  Index1 := 0;
  For Index2 := 1 To Length(Parse) Do
    If (Parse[Index2] <> ' ')
       Then
         Begin
           Inc(Index1);
           Parse[Index1] := UpCase(Parse[Index2]);
         End;
  Parse[0] := Char(Index1);
End;

Procedure Expression.PrintResult;
Begin
  WriteLn (FormFloat(Evaluate));
End;

Procedure Expression.Optimize;
Begin
  { TO-DO! }
End;

{$IFNDEF UNIT}

Var F: Expression;
Begin
  With F Do
  Repeat
    EnterTerm;
    Compile;
    Write(Parse);
    PrintResult;
    ShowStack;
    WriteLn;
  Until FALSE;
{$ENDIF}
End.


         Date: Mon, 03 Aug 1998 22:37:45 +0200
         From: "Antivivisektion e.V." <Antivivisektion@t-online.de>
 Organization: http://Antivivisektion.base.org
   Newsgroups: comp.lang.pascal.borland, de.lang.pascal.misc
      Subject: Re: Input an equation (provides source)
   References: <6pvcn0$lf6$1@news2.saix.net>

AM la Grange wrote:
>
> I would like to readln an equation, for example: 5*9-2/3,
> or whatever, including reserved pascal words for example:
> "sqr","sqrt","cos","sin", etc.
>
> Then I would like to use it in my program in calculating the answer.

Please compile my file MATH.PAS I wrote several years ago:

[Expression-Compiler (OOP/TP55-TP70)]
<http://home.t-online.de/home/Antivivisektion/math.pas>

You may use it like in my example below:

|  Uses Math;
|  Var E: Expression; Term: String; Result: Float;
|  Begin
|    Write('Enter expression: ');
|    ReadLn(Term);
|    Result := E.EvaluateTerm(Term);
|    Write('Result: ',Result:0:20);
|  End.

> If there is a(n) (easy) way of doing this, please let me know...

It's really that easy ;-)

You may also use one-char variables to evaluate complex expressions:

|  Uses Math;
|  Var E: Expression; X: Word;
|  Begin
|    E.Init;
|    E.Parse := '2*X+SIN(X)*TAN(X/8)';
|    E.FormatTerm;
|    E.Compile;
|    For X := 1 To 100 Do
|    Begin
|      E.Data['X'] := X;
|      E.PrintResult; { same as WriteLn(E.FormFloat(E.Evaluate)); }
|    End;
|  End.

The expression may be as complex as you wish,
with 25 build-in var's A-Z (like in basic).

It's even possible to add your own functions at runtime, e.g. RANDOM:

|  Uses Math;
|  Var E: Expression; X: Word;
|
|  {$F+} Function MyFunc (x: Float): Float; {$F-}
|  Begin
|    MyFunc := Random(Round(x));
|  End;
|
|  Begin
|    E.Init; { Insert ADDFUNC after this line }
|    E.AddFunc('RANDOM',MyFunc);
|    { Now you can use RANDOM(...) in your expressions, example: }
|    E.Parse := 'RANDOM(100)';
|    E.FormatTerm;
|    E.Compile;
|    E.PrintResult;
|  End.

The error-handling (simple HALT) has to be worked out...

--
              ---===Coders Against Vivisection===---

A.E.Neumann fuer die Antivivisektion e.V., PO-Box 201, D-53569 Unkel
mailto:Antivivisektion@t-online.de http://Antivivisektion.base.org/

[Animal research is wasteful and misleading]
<http://www.werple.net.au/~antiviv/issue12.htm>