TEvaluator

Top  Previous  Next

unit Evaluator;

{Math Expression Evaluator,

Main Unit

 

CopyrightŠ 2000, Konstantin Tretyakov

kt_ee@hotmail.com,

http://smartsite.cjb.net}

 

interface

uses Classes, //Needed solely for the TStringList class

    SysUtils, //Needed for the only one 'UpperCase' call and two 'StrToFloat'

    Math,     //Needed for Math fns

    Windows;  //Needed for MessageBox fn

type

   TEvalError=(ERR_NONE, ERR_ZERO_DIVIDE, ERR_OVERFLOW, ERR_INVALID_OP,

   ERR_DBL_POINT, ERR_WRONG_SYNTAX,ERR_WRONG_BRACKETS,

   ERR_EMPTY_STRING,ERR_OTHER);

 

   TDoubleVar=class

       Value:Double;

   end;

 

   TEvaluator=class

       Expression:String;

       Error:TEvalError;

       function SetVariable(VarName:String;Value:Double):Boolean; //returns True if the variable was not created, False: if it's value was changed

       function GetVariable(VarName:String;var Value:Double):Boolean;

       function RemoveVariable(VarName:String):Boolean;  //Returns true if there was anything to remove

       function VariableExists(VarName:String):Boolean;

       function ClearVariables:Boolean; //returns True if there was anyth to clear

       constructor Create;

   private

       function GetResult:Double;

   published

       property Result:Double read GetResult;

   private

       Variables:TStringList;

       function Eval(Expression:String):Double;

       function EvalFormatStr(EvalExpr:String):String;

       function SplitToMonomials(EvalStr:String;Sign1,Sign2:Char):TStringList;

       function GetSplitPos(EvalStr,Sign1,Sign2:String):Integer;

       function CalcMonomial(Monomial:String):Double;

       function CalcMember(Member:String;var Sign:Char):Double;

       function CalcFunction(FunctionID:String;ArgList:TStringList):Double;

       function ExtractNumber(var EvalExpr:String):Double;

       function ExtractValue(var EvalExpr:String):Double;

       function ExtractBrackets(var EvalExpr:String):String;

       function ExtractFunction(var EvalExpr:String;var FuncID:String):TStringList;

   end;

 

const

    PLUS_SIGN = '+';

    MINUS_SIGN = '-';

    MULTIPLY_SIGN = '*';

    DIVIDE_SIGN = '/';

    POWER_SIGN = '^';

    POINT_SIGN = ',';

    POINT_ALTERNATIVE = '.';

    BRACKET_LEFT = '(';

    BRACKET_RIGHT = ')';

    //AMPERSAND = '&';

 

    EvalErrors:array[0..8] of String = ('ERR_NONE', 'ERR_ZERO_DIVIDE',

    'ERR_OVERFLOW', 'ERR_INVALID_OP', 'ERR_DBL_POINT', 'ERR_WRONG_SYNTAX',

    'ERR_WRONG_BRACKETS', 'ERR_EMPTY_STRING','ERR_OTHER');

 

    MessageTitle:String='Message Box';

    MessageOpts:Cardinal=MB_ICONINFORMATION;

 

 

implementation

 

   function Sgn(Number:Double):Integer;Forward;

 

constructor TEvaluator.Create;

begin

    Expression:='';

    Error:=ERR_NONE;

    Variables:=TStringList.Create;

    Variables.Sorted:=True;

    Variables.Duplicates:=dupError;

end;

 

function TEvaluator.SetVariable(VarName:String;Value:Double):Boolean; //returns True if the variable was not created

var

NewValue:TDoubleVar;

Found:Boolean;Index:Integer;

begin

    Found:=Variables.Find(UpperCase(VarName),Index);

    Result:=Found;

    if Found then TDoubleVar(Variables.Objects[Index]).Value:=Value

     else begin

       Index:=Variables.Add(UpperCase(VarName));

       NewValue:=TDoubleVar.Create; NewValue.Value:=Value;

       Variables.Objects[Index]:=NewValue;

    end;

end;

 

 

function TEvaluator.GetVariable(VarName:String;var Value:Double):Boolean;

var Found:Boolean;Index:Integer;

begin

    Found:=Variables.Find(UpperCase(VarName),Index);

    GetVariable:=Found;

    If Found then Value:=TDoubleVar(Variables.Objects[Index]).Value;

end;

 

function TEvaluator.RemoveVariable(VarName:String):Boolean;  //Returns true if there was any to remove

var Found:Boolean;Index:Integer;

begin

    Found:=Variables.Find(UpperCase(VarName),Index);

    RemoveVariable:=Found;

    if Found then begin

       TDoubleVar(Variables.Objects[Index]).Free;

       Variables.Delete(Index);

    end;

 

end;

 

function TEvaluator.VariableExists(VarName:String):Boolean;

var Found:Boolean;Index:Integer;

begin

    Found:=Variables.Find(UpperCase(VarName),Index);

    VariableExists:=Found;

end;

 

function TEvaluator.ClearVariables:Boolean;

var ArrCount:Integer;I:Integer;

begin

    ArrCount:=Variables.Count;

    If ArrCount=0 then ClearVariables:=False else begin

     for I:=0 to ArrCount-1 do begin

         TDoubleVar(Variables.Objects[I]).Free;

     end;

     Variables.Clear;

     ClearVariables:=True;

    end;

end;

 

function TEvaluator.GetResult:Double;

begin

    Error:=ERR_NONE;

    GetResult:=Eval(Expression);

end;

 

function TEvaluator.Eval(Expression:String):Double;

//The Main function - calculates a mathematic expression

var

sEval:String;

MonomList:TStringList;

I:Integer;

dResult:Double;

begin

    dResult:=0;

    //"Normalize" the expression: remove spaces, convert to uppercase, convert all "." to ","

    sEval:=EvalFormatStr(Expression);

    if sEval = '' then begin

       Error:=ERR_EMPTY_STRING;

       Eval:=0; Exit;

    end;

    Randomize;

    //Divide into monomials

    MonomList:=SplitToMonomials(sEval,PLUS_SIGN,MINUS_SIGN);

    //Add each monomial's value (it may be negative) to dResult

    for I:=0 to (MonomList.Count-1) do dResult:=dResult+CalcMonomial(MonomList[I]);

    Eval:=dResult;

end;

 

 

function TEvaluator.CalcMonomial(Monomial:String):Double;

//Calculates a monomial (expression like '+3*4', '-5*6^2', '+(6-67)*3^(5+5)' )

var

MemberList:TStringList;

Sign:Char;

I:Integer;

dResult,TempRes:Double;

begin

  try

   CalcMonomial:=0;

   If Error<>ERR_NONE then Exit;

   dResult:=0;

   MemberList:=SplitToMonomials(Monomial, MULTIPLY_SIGN, DIVIDE_SIGN);

   for I:=0 to (MemberList.Count-1) do begin

       TempRes:=CalcMember(MemberList[I], Sign);

       if Error <> ERR_NONE then Exit;

       case Sign of

          PLUS_SIGN: dResult:= dResult + TempRes;

          MULTIPLY_SIGN: dResult := dResult * TempRes;

          DIVIDE_SIGN: dResult:=dResult / TempRes;

       end;

   end;

   CalcMonomial:=dResult;

  except

        on EZeroDivide do Error:= ERR_ZERO_DIVIDE;

        on EDivByZero do Error:= ERR_ZERO_DIVIDE;

        on EOverflow do Error:= ERR_OVERFLOW;

        else Error:=ERR_OTHER;

  end;

end;

 

function TEvaluator.CalcMember(Member:String;var Sign:Char):Double;

{Calculates an expression (a member), that contains only the operands

higher in proirity than * and /

TODO: It raises an error on X^Y^Z and calculates only X^Y

}

var

   sSign, Op:Char;

   sEval:String;

   HaveMinus:Boolean;

   Num1, Num2, dResult:Double;

begin

   CalcMember:=0;

   if Error <> ERR_NONE then Exit;

   Sign:= PLUS_SIGN; sEval:=Member;

   HaveMinus:=False;dResult:=0;

   //Func:='';

  try

   sSign:=sEval[1];

   //Determine the Sign (or find the Bracket or a function)

   Case sSign of

      PLUS_SIGN, MINUS_SIGN, MULTIPLY_SIGN, DIVIDE_SIGN: begin

          if sSign = MINUS_SIGN then HaveMinus:=True else Sign:= sSign;

          sEval:=Copy(sEval, 2, Length(sEval)-1);

          If Length(sEval)=0 then begin Error:=ERR_WRONG_SYNTAX;Exit;end;

      end;

   end;

   Num1:=ExtractValue(sEval);

   if Error <>ERR_NONE then Exit;

   if Length(sEval) <> 0 then begin

       Op:=sEval[1];

       sEval:=Copy(sEval, 2, Length(sEval)-1);

       Num2:=ExtractValue(sEval);

       Case Op of

           POWER_SIGN: dResult:= Power(Num1,Num2);

           else Error:= ERR_WRONG_SYNTAX;

       end;

   end else dResult:= Num1;

 

   If Length(sEval) <> 0 then Error:=ERR_WRONG_SYNTAX else

   If HaveMinus then CalcMember:=-dResult else CalcMember:= dResult;

  except

   on EOverflow do Error:=ERR_OVERFLOW;

   else Error:=ERR_OTHER;

  end;

end;

 

 

function TEvaluator.ExtractNumber(var EvalExpr:String):Double;

{This is nearly an equivalent of StrToInt,

only here we may know if there was an error

and it also modifies the string by removing the "Extracted" number}

 

//TODO: it doesnt recognize numbers like 10E-15

var

   HavePoint, HaveMinus:Boolean;

   I:Integer;

   TempChar, TempSign:Char;

   sEval, NewNum:String;

begin

   try

    ExtractNumber:=0; HavePoint:=False;HaveMinus:=False;

//Determine whether there is a sign in front of the string

   TempSign:=EvalExpr[1];

   if TempSign = POINT_SIGN then sEval:= '0' + EvalExpr

   else begin

       if not (TempSign in ['0'..'9']) then begin

           sEval:= Copy(EvalExpr, 2, Length(EvalExpr)-1);

           if (TempSign = MINUS_SIGN) then HaveMinus:=True else Error:=ERR_WRONG_SYNTAX;

       end else sEval:= EvalExpr;

   end;

 

   for I:=1 to Length(sEval) do begin

       TempChar:= sEval[I];

       If (TempChar in ['0'..'9']) then NewNum:=NewNum + TempChar

       else begin

           if TempChar = POINT_SIGN then begin

               if HavePoint then begin

               //We have already a point, that's an error

                   Error:=ERR_DBL_POINT;

                   Exit;

               end else begin

                   HavePoint:=True;

                   NewNum:=NewNum + POINT_SIGN;   //We shall use StrToFloat in the end

               end;

           end else Break;

       end;

   end;

   if NewNum = '' then Error:=ERR_WRONG_SYNTAX

   else EvalExpr:= Copy(sEval, Length(NewNum)+1,Length(sEval)-Length(NewNum)); //Cut out the number from the string

   if HaveMinus then ExtractNumber:=-StrToFloat(NewNum) else ExtractNumber:=StrToFloat(NewNum);

  except

   Error:=ERR_OTHER;

  end;

end;

 

 

 

function TEvaluator.ExtractBrackets(var EvalExpr:String):String;

{Gets a String, beginning with a Left Bracket and

returns the expression in this bracket

deletes this expression(with both brackets) from the string}

var

InBracket,I:Integer;

TempChar:Char; RetStr:String;

begin

   //We Suppose that the first sign in the string is BRACKET_LEFT

   InBracket:=1; ExtractBrackets:='';

   try

   for I:=2 to Length(EvalExpr) do begin

       TempChar:= EvalExpr[I];

       Case TempChar of

           BRACKET_LEFT: InBracket:=InBracket+1;

           BRACKET_RIGHT:InBracket:=InBracket-1;

       end;

       if InBracket = 0 then begin

           RetStr:=Copy(EvalExpr,2,I-2);

           EvalExpr:=Copy(EvalExpr,I+1,Length(EvalExpr)-I);

           ExtractBrackets:=RetStr;

           Exit;

       end;

   end;

   Error:= ERR_WRONG_BRACKETS;

   except

   Error:=ERR_OTHER;

   end;

end;

 

 

function TEvaluator.ExtractFunction(var EvalExpr:String;var FuncID:String):TStringList;

{Extract the Function from a Member Expression

Returns Function Argument List}

var

Brac,Pow:Integer;RetList:TStringList;

begin

   RetList:=TStringList.Create;

   Brac:=Pos(BRACKET_LEFT, EvalExpr);

   Pow:=Pos(POWER_SIGN, EvalExpr);

   if (Brac=0) and (Pow=0) then begin

      FuncID:=EvalExpr;

      EvalExpr:='';

   end else if (Brac=0) or ((Pow<>0) and (Pow<Brac)) then begin

      FuncID:=Copy(EvalExpr,1,Pow-1);

      EvalExpr:=Copy(EvalExpr, Pow, Length(EvalExpr)-Pow+1);

   end else begin

      FuncID:=Copy(EvalExpr,1,Brac-1);

      EvalExpr:=Copy(EvalExpr, Brac, Length(EvalExpr)-Brac+1);

      RetList.Add(ExtractBrackets(EvalExpr));

   end;

   ExtractFunction:=RetList;

end;

 

 

function TEvaluator.ExtractValue(var EvalExpr:String):Double;

{Inthe expression of a kind X^Y extracts X and returns the value

where X may be a function call, a value, a constant}

{Helper to CalcMember, the first character in EvalExpr must not be a sign}

var

Func:String;

FuncArgList:TStringList;

begin

    if EvalExpr[1] = BRACKET_LEFT then begin

        ExtractValue:= Eval(ExtractBrackets(EvalExpr));

    end else if EvalExpr[1] in ['0'..'9',POINT_SIGN] then begin

        if EvalExpr[1]=POINT_SIGN then EvalExpr:='0'+EvalExpr;

        ExtractValue:=ExtractNumber(EvalExpr);

    end else begin

        FuncArgList:= ExtractFunction(EvalExpr, Func);

        ExtractValue:= CalcFunction(Func, FuncArgList);

    end;

end;

 

 

function TEvaluator.CalcFunction(FunctionID:String;ArgList:TStringList):Double;

var

Arg:Double;

wH,wMin,wS,wMS,wY,wM,wD:Word;

Done:Boolean;

begin

    CalcFunction:=0; Arg:=0; Done:=False;

   If Error <> ERR_NONE Then Exit;

   try

     //Stupid Part:Check for String functions

     if FunctionID = 'MSGBOX' then begin MessageBox(0,PChar(ArgList[0]),PChar(MessageTitle),MessageOpts); Done:=True;end

     else if FunctionID = 'MSGBOXCALC' then begin MessageBox(0,PChar(FloatToStr(Eval(ArgList[0]))),PChar(MessageTitle),MessageOpts); Done:=True;end

     ;

     //Check for Math Function

     if (ArgList.Count>0) and (Done=False) then begin

      Arg:=Eval(ArgList[0]);

       if FunctionID = 'ABS' then begin CalcFunction:=Abs(Arg); Done:=True; end

       else if FunctionID = 'ATN' then begin CalcFunction:=ArcTan(Arg); Done:=True; end

       else if FunctionID = 'COS' then begin CalcFunction:=Cos(Arg); Done:=True; end

       else if FunctionID = 'COTAN' then begin CalcFunction:=CoTan(Arg); Done:=True; end

       else if FunctionID = 'ARCSIN' then begin CalcFunction:=ArcSin(Arg); Done:=True; end

       else if FunctionID = 'ARCCOS' then begin CalcFunction:=ArcCos(Arg); Done:=True; end

       else if FunctionID = 'HSIN' then begin CalcFunction:=Sinh(Arg); Done:=True; end

       else if FunctionID = 'HCOS' then begin CalcFunction:=Cosh(Arg); Done:=True; end

       else if FunctionID = 'HTAN' then begin CalcFunction:=TanH(Arg); Done:=True; end

       else if FunctionID = 'HARCSIN' then begin CalcFunction:=ArcSinH(Arg); Done:=True; end

       else if FunctionID = 'HARCCOS' then begin CalcFunction:=ArcCosH(Arg); Done:=True; end

       else if FunctionID = 'HARCTAN' then begin CalcFunction:=ArcTanH(Arg); Done:=True; end

       else if FunctionID = 'EXP' then begin CalcFunction:=Exp(Arg); Done:=True; end

       else if FunctionID = 'ROUND' then begin CalcFunction:=Round(Arg); Done:=True; end

       else if FunctionID = 'INT' then begin CalcFunction:=Int(Arg); Done:=True; end

       else if FunctionID = 'FRAC' then begin CalcFunction:=Frac(Arg); Done:=True; end

       else if FunctionID = 'LOG' then begin CalcFunction:=Log10(Arg); Done:=True; end

       else if FunctionID = 'RANDOM' then begin CalcFunction:=Random(Trunc(Arg)); Done:=True; end

       else if FunctionID = 'SGN' then begin CalcFunction:=Sgn(Arg); Done:=True; end

       else if FunctionID = 'SIN' then begin CalcFunction:=Sin(Arg); Done:=True; end

       else if FunctionID = 'SQR' then begin CalcFunction:=Sqrt(Arg); Done:=True; end

       else if FunctionID = 'TAN' then begin CalcFunction:=Tan(Arg); Done:=True; end

 

       else if FunctionID = 'SEC' then begin CalcFunction:=1 / Cos(Arg); Done:=True; end

       else if FunctionID = 'COSEC' then begin CalcFunction:=1 / Sin(Arg); Done:=True; end

 

       else if FunctionID = 'ARCSEC' then begin CalcFunction:=ArcTan(Arg / Sqrt(Arg * Arg - 1)) + Sgn(Arg - 1) * (2 * ArcTan(1)); Done:=True; end

       else if FunctionID = 'ARCCOSEC' then begin CalcFunction:=ArcTan(Arg / Sqrt(Arg * Arg - 1)) + (Sgn(Arg) - 1) * (2 * ArcTan(1)); Done:=True; end

       else if FunctionID = 'ARCCOTAN' then begin CalcFunction:=ArcTan(Arg) + 2 * ArcTan(1); Done:=True; end

 

       else if FunctionID = 'HSEC' then begin CalcFunction:=2 / (Exp(Arg) + Exp(-Arg)); Done:=True; end

       else if FunctionID = 'HCOSEC' then begin CalcFunction:=2 / (Exp(Arg) - Exp(-Arg)); Done:=True; end

       else if FunctionID = 'HCOTAN' then begin CalcFunction:=(Exp(Arg) + Exp(-Arg)) / (Exp(Arg) - Exp(-Arg)); Done:=True; end

       else if FunctionID = 'HARCSEC' then begin CalcFunction:=Log10((Sqrt(-Arg * Arg + 1) + 1) / Arg); Done:=True; end

       else if FunctionID = 'HARCCOSEC' then begin CalcFunction:=Log10((Sgn(Arg) * Sqrt(Arg * Arg + 1) + 1) / Arg); Done:=True; end

       else if FunctionID = 'HARCCOTAN' then begin CalcFunction:=Log10((Arg + 1) / (Arg - 1)) / 2; Done:=True; end;

     end;

       if Done then Exit;

       if FunctionID = 'PI' then CalcFunction:=3.14159265358979

       else if FunctionID = 'E' then CalcFunction:=2.71828182845905

       else if FunctionID = 'ZERO' then CalcFunction:=0

 

     //Not Math functions, but also useful

       //else if FunctionID = 'TIMER' then CalcFunction:=Timer

       else begin

         DecodeDate(Now,wY,wM,wD);

         DecodeTime(Now,wH,wMin,wS,wMS);

         if FunctionID = 'YEAR' then CalcFunction:=wY

         else if FunctionID = 'MONTH' then CalcFunction:=wM

         else if FunctionID = 'DAY' then CalcFunction:=wD

         else if FunctionID = 'WEEKDAY' then CalcFunction:=DayOfWeek(Now)

         else if FunctionID = 'HOUR' then CalcFunction:=wH

         else if FunctionID = 'MINUTE' then CalcFunction:=wMin

         else if FunctionID = 'SECOND' then CalcFunction:=wS

         else if FunctionID = 'MILLISECOND' then CalcFunction:=wMS

 

         else if ((ArgList.Count=0) and GetVariable(FunctionID,Arg)) then CalcFunction:=Arg

         else Error:= ERR_WRONG_SYNTAX;

       end;

   except

       on EOverflow do Error:=ERR_OVERFLOW;

       on EZeroDivide do Error:=ERR_ZERO_DIVIDE;

       on EInvalidOp do Error:=ERR_INVALID_OP;

       else Error:= ERR_OTHER;

   end;

end;

 

 

function TEvaluator.EvalFormatStr(EvalExpr:String):String;

{Removes spaces from an expression, that are not within brackets

and converts letters to uppercase, that are not within brackets}

var

InBracket,I:Integer;

TempChar:Char; RetStr:String;

begin

   InBracket:=0; RetStr:='';EvalFormatStr:='';

   try

   for I:=1 to Length(EvalExpr) do begin

       TempChar:= EvalExpr[I];

       Case TempChar of

           BRACKET_LEFT: InBracket:=InBracket+1;

           BRACKET_RIGHT:InBracket:=InBracket-1;

       end;

       if InBracket = 0 then begin

         if TempChar = POINT_ALTERNATIVE then RetStr:=RetStr+POINT_SIGN

         else if TempChar <> ' ' then RetStr:=RetStr+UpperCase(TempChar);

       end else RetStr:=RetStr+TempChar;

   end;

   if InBracket <> 0 then Error:=ERR_WRONG_BRACKETS;

   EvalFormatStr:=RetStr;

   except

   Error:=ERR_OTHER;

   end;

end;

 

 

function TEvaluator.SplitToMonomials(EvalStr:String;Sign1,Sign2:Char):TStringList;

{Divides the given string in parts using the given sign (1 and 2) parameter

Returns an array where each item is a string

For example SplitToMonomials("2+3*8-4","+","-") returns [2, +3*8, -4]

       and SplitToMonomials("3*2/23","*","/") returns [3, *2, /23]

 

The function also doesn't split brackets so that

     SplitToMonominals("(3+2)*2-3","+","-") will return [(3+2)*2, -3]

}

var

MonomList:TStringList;

sEval,CurMonom:String;

I:Integer;

begin

    MonomList:=TStringList.Create;

    sEval:=EvalStr;

    //Find the first PLUS or MINUS that are not in Bracket

    I:= GetSplitPos(EvalStr, Sign1, Sign2);

    while I > 0 do begin

       {NOT DONE:

       Check for expressions of a kind: "2-3*4+6*-5"

       because we must not split between 6 and 5}

       CurMonom:=Copy(sEval,1,I-1);

       MonomList.Add(CurMonom);

       sEval:=Copy(sEval, I, Length(sEval)-I+1);

       I:= GetSplitPos(sEval, Sign1, Sign2);

    end;

    MonomList.Add(sEval);

    SplitToMonomials:=MonomList;

end;

//+++++++++++++++++++++++++++++++++++

{This is a Helper-func to SplitToMonomials

it returns the position in a string of a Sign(1 or 2)

it doesn't return the signs that are in brackets and the sign on the 1st place}

function TEvaluator.GetSplitPos(EvalStr,Sign1,Sign2:String):Integer;

var

I,InBracket:Integer;

TempChar:String;

begin

   InBracket:=0;

   GetSplitPos:=0;

   for I:=1 To Length(EvalStr) do begin

       TempChar:=EvalStr[I];

       if (TempChar=Sign1) or (TempChar=Sign2) then begin

           If (InBracket=0) And (I>1) then begin

              GetSplitPos:= I;

              Exit;

           end;

       end else if (TempChar=BRACKET_LEFT) then InBracket:=InBracket+1

       else if (TempChar=BRACKET_RIGHT) then begin

            InBracket:=InBracket-1;

            If InBracket<0 then begin

               Error:=ERR_WRONG_BRACKETS;

               Exit;

            end;

       end;

   end;

end;

//+++++++++++++++++++++++++++++++++++

 

function Sgn(Number:Double):Integer;

begin

    if Number>0 then Sgn:=1

    else if Number<0 then Sgn:=-1

    else Sgn:=0;

end;

end.