unit parser;

{$MODE Delphi}

//**********************************************************
//*** parse some simple FORTRAN/DELPHI math expressions  ***
//**********************************************************

interface

uses classes, sysutils, math;

type
TParseExpression = class(TObject)
  private
    myText: String;
    myValue: Real;
    myError: Boolean;
    myErrorPos: Integer;
    myErrorText: String;
  protected
    procedure SetText(newText: String);
  public
    property text: String read myText write SetText;
    property value: Real read myValue write myValue;
    property error: Boolean read myError;
    property errorPos: Integer read myErrorPos;
    property errorText: String read myErrorText;

    procedure Evaluate(const Definitions: TStringList=nil);
  end;

  function FindLastPlusMinus(s: String; var left, right, symbol:String):Boolean;
  function FindLastTimesOver(s: String; var left, right, symbol:String):Boolean;

implementation

procedure TParseExpression.SetText(newText: String);
begin
  myText:=newText;
  myErrorPos:=0;
  myErrorText:='';
  myError:=false;
end;

function CheckParanthesisCount(s: String):Boolean;
//check if number of "(" matches number of ")".
var
  i: Integer;
  leftParCount, rightParCount: Integer;
begin
  leftParCount:=0;
  rightParCount:=0;
  for i:=1 to length(s) do
  begin
    if s[i]='(' then leftParCount:=leftParCount+1;
    if s[i]=')' then rightParCount:=rightParCount+1;
  end;
  if leftParCount=rightParCount then result:=true else result:=false;
end;

function OuterParanthesis(s: String; var first,last: Integer):Boolean;
//if the whole expression is enclosed by "(...)", the first and last character position inside the paranthesis is given
var
  i: Integer;
  ParCount: Integer;
begin
  i:=1;
  while (s[i]=' ') and (i<=length(s)) do  //leading blanks
    i:=i+1;
  if s[i] <> '(' then //does not start with "("
    result:=false
  else                  //does start with "("
  begin
    i:=i+1;
    first:=i;
    parCount:=1;
    while (ParCount>0) and (i<=length(s)) do
    begin
      if s[i]='(' then ParCount:=ParCount+1;
      if s[i]=')' then ParCount:=ParCount-1;
      i:=i+1;
    end;
    if ParCount>0 then //something went wrong, paranthesis was not closed
      result:=false
    else
    begin        //we start at the character behind the ")" that closed the first "("
      last:=i-2; //the one before the ")"
      while (i<=length(s)) do
      begin
        if s[i]<>' ' then     //tailing blanks are allowed, but nothing else
        begin
          break;
        end;
        i:=i+1;
      end;
      if i<=length(s) then //something else was found behind the ")" that closed the first "("
        result:=false
      else
        result:=true;     //everything is fine
    end;
  end;
end;

function FindLastPlusMinus(s: String; var left, right, symbol:String):Boolean;
//find first and last characters of expressions separated by + or -
//but, be sure that it is not part of a number.
//this is the case if it is preceded by e or E, before that by numbers and dots and before that by no letter.
//examples: 3e+5 is a number
//          a3e+5 is not a sum
//          a*3.e+5 is a product
var
  i, k: Integer;
  ParCount: Integer;
begin
  i:=length(s);
  ParCount:=0;
  symbol:='';
  while i>=1 do
  begin
    if      s[i]=')' then ParCount:=ParCount+1
    else if s[i]='(' then ParCount:=ParCount-1
    else if ParCount=0 then //only operations outside of paranthesis are of interest
    begin
      if (s[i]='+') or (s[i]='-') then
      begin
        if i=1 then
        begin
          symbol:=s[i];
          left:=copy(s,1,i-1);
          right:=copy(s,i+1,length(s)-i);
          break;
        end
        else if (s[i-1]='e') or (s[i-1]='E') then
        begin
          //Alas, this plus or minus may stand in the exponent of a number like 1.3e-6. Check that.
          //We assume it is the case. So, the e should be preceded by numbers and a dot only.
          //Check what is in front of the number.
          k:=i-2;
          while (k>0) do
          begin
            if (s[k]<>'0') and (s[k]<>'1') and (s[k]<>'2') and (s[k]<>'3') and (s[k]<>'4') and
               (s[k]<>'5') and (s[k]<>'6') and (s[k]<>'7') and (s[k]<>'8') and (s[k]<>'9') and
               (s[k]<>'.') then break;
            k:=k-1;
          end;
          if k=0 then //it is part of a number, and this number stands in front.
            break
          else if k=i-2 then //no number occurs before the e. Then, "e" is definitely part of a variable and we found a real plus or minus.
          begin
            symbol:=s[i];
            left:=copy(s,1,i-1);
            right:=copy(s,i+1,length(s)-i);
            break;
          end
          else      //something is before the number before the "e", it is stored in s[k]
          begin
            if ((ord(s[k])>=ord('a')) and (ord(s[k])<=ord('z')))    // s[k] is a small letter
               or ((ord(s[k])>=ord('A')) and (ord(s[k])<=ord('Z'))) // s[k] is a capital letter
               or (s[k]='_') then
            begin
              //Well, the thing before the 'e' is not a number, as some letter or underline comes in front.
              //so, it is part of a variable name, like "var_3e" or something like that.
              symbol:=s[i];
              left:=copy(s,1,i-1);
              right:=copy(s,i+1,length(s)-i);
              break;
            end; //otherwise, it will really be a number and we search for the next plus or minus.
          end;
        end
        else // no 'e' or 'E' in front, so everything is fine.
        begin
          symbol:=s[i];
          left:=copy(s,1,i-1);
          right:=copy(s,i+1,length(s)-i);
          break;
        end;
      end;
    end;
    i:=i-1;
  end;
  if symbol='' then result:=false else result:=true;
end;

function FindLastTimesOver(s: String; var left, right, symbol:String):Boolean;
//find first and last characters of expressions separated by * or /, but not **
var
  i: Integer;
  ParCount: Integer;
  isPower: Boolean;
begin
  i:=length(s);
  ParCount:=0;
  symbol:='';
  while i>=1 do
  begin
    if      s[i]=')' then ParCount:=ParCount+1
    else if s[i]='(' then ParCount:=ParCount-1
    else if ParCount=0 then //only operations outside of paranthesis are of interest
    begin
      if (s[i]='*') or (s[i]='/') then
      begin
        isPower:=false;     //now check if the found * belongs to the power operator **
        if s[i]='*' then
        begin
          if i>1 then
            if s[i-1]='*' then isPower:=true;
          if i<length(s) then
            if s[i+1]='*' then isPower:=true;
        end;
        if isPower=false then  //it does not belong to the power operator, so it is what we were looking for
        begin
          symbol:=s[i];
          left:=copy(s,1,i-1);
          right:=copy(s,i+1,length(s)-i);
          break;
        end;
      end;
    end;
    i:=i-1;
  end;
  if symbol='' then result:=false else result:=true;
end;

function FindLastPower(s: String; var left, right, symbol:String):Boolean;
//find first and last characters of expressions separated **
var
  i: Integer;
  ParCount: Integer;
begin
  i:=length(s);
  ParCount:=0;
  symbol:='';
  while i>=2 do
  begin
    if      s[i]=')' then ParCount:=ParCount+1
    else if s[i]='(' then ParCount:=ParCount-1
    else if ParCount=0 then //only operations outside of paranthesis are of interest
    begin
      if (s[i]='*') and (s[i-1]='*') then
      begin
        symbol:='**';
        left:=copy(s,1,i-2);
        right:=copy(s,i+1,length(s)-i);
        break;
      end;
    end;
    i:=i-1;
  end;
  if symbol='' then result:=false else result:=true;
end;

function FindLastComma(s: String; var left, right, symbol:String):Boolean;
//find first and last characters of expressions separated by ","
var
  i: Integer;
  ParCount: Integer;
begin
  i:=length(s);
  ParCount:=0;
  symbol:='';
  while i>=2 do
  begin
    if      s[i]=')' then ParCount:=ParCount+1
    else if s[i]='(' then ParCount:=ParCount-1
    else if ParCount=0 then //only operations outside of paranthesis are of interest
    begin
      if (s[i]=',')  then
      begin
        symbol:=',';
        left:=copy(s,1,i-1);
        right:=copy(s,i+1,length(s)-i);
        break;
      end;
    end;
    i:=i-1;
  end;
  if symbol='' then result:=false else result:=true;
end;

function FindStandardFunction(s: String; var left, right, symbol:String):Boolean;
var
 s1, sleft, sright, dummy: String;
 i: Integer;
begin
  s1:=trim(s);
  if pos('(',s1)<=0 then
    result:=false
  else
  begin
    sleft:=copy(s1,1,pos('(',s1)-1);
    sleft:=trim(sleft);               //sleft should contain the name of the function
    sright:=copy(s1,pos('(',s1)+1,length(s1));  //sright should become the stuff inside the parantheses
    sright:=trim(sright);
    if sright[length(sright)]=')' then //nothing occurs after the parantheses
    begin
      sright:=copy(sright,1,length(sright)-1);
      if FindLastComma(sright,left,right,dummy) then  //more than one argument
      begin
        if FindLastComma(left,dummy,dummy,dummy) then //more than two arguments, nest the calls
          left:=sleft+'('+left+')';                   //e.g. max(a,b,c) is evaluated as max(max(a,b),c)
      end
      else
      begin
        left:=sright;
        right:='';
      end;

      //now, check which function it is
      symbol:=lowercase(sleft);
      if ((symbol='sin') or (symbol='cos') or (symbol='tan')
         or (symbol='sinh') or (symbol='cosh') or (symbol='tanh')
         or (symbol='exp') or (symbol='log')
         or (symbol='sqrt') or (symbol='abs') or (symbol='theta')) and (right='') then
        result:=true
      else if (symbol='min') or (symbol='max') then
        result:=true
      else
        result:=false;
    end
    else //something occured after the last parantheses
      result:=false;
  end;
end;

procedure PerformOperation(var e: TParseExpression; left, right, symbol: String; const Definitions: TStringList=nil);
//perform a single operation of + - * / **
var
  e1, e2: TParseExpression;
begin
  //first, check if single minus is in front
  if (symbol='-') and (trim(left)='') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=right;
    e1.Evaluate(Definitions);
    e.myValue:=-e1.myValue;
    e.myError:=e1.myError;
    e.myErrorPos:=e1.myErrorPos+length(left)+1;
    e.myErrorText:=e1.myErrorText;
    e1.Free;
  end
  else  //no single minus in front
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    e2:=TParseExpression.Create;
    e2.text:=right;
    e2.Evaluate(Definitions);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=e1.myErrorPos;
      e.myErrorText:=e1.myErrorText;
    end
    else if e2.myError then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=e2.myErrorPos+length(left)+length(symbol);
      e.myErrorText:=e2.errorText;
    end
    else  //both left and right expression gave valid values
    begin
      if symbol='+' then
      begin
        e.myValue:=e1.myValue+e2.myValue;
        e.myError:=false;
        e.myErrorPos:=0;
        e.myErrorText:='';
      end
      else if symbol='-' then
      begin
        e.myValue:=e1.myValue-e2.myValue;
        e.myError:=false;
        e.myErrorPos:=0;
        e.myErrorText:='';
      end
      else if symbol='*' then
      begin
        e.myValue:=e1.myValue*e2.myValue;
        e.myError:=false;
        e.myErrorPos:=0;
        e.myErrorText:='';
      end
      else if symbol='/' then
      begin
        if e2.myValue=0 then
        begin
          e.myValue:=0;
          e.myError:=true;
          e.myErrorPos:=length(left)+1;
          e.myErrorText:='division by 0'
        end
        else
        begin
          e.myValue:=e1.myValue/e2.myValue;
          e.myError:=false;
          e.myErrorPos:=0;
          e.myErrorText:=''
        end;
      end
      else if symbol='**' then
      begin
        if (e2.myValue<0) and not (e2.myValue=round(e2.myValue)) then
        begin
          e.myValue:=0;
          e.myError:=true;
          e.myErrorPos:=length(left)+1;
          e.myErrorText:='raising a negative value to a non-integer power';
        end
        else
        begin
          e.myValue:=power(e1.myValue,e2.myValue);
          e.myError:=false;
          e.myErrorPos:=0;
          e.myErrorText:=''
        end;
      end
    end;
    e1.Free;
    e2.Free;
  end;
end;

procedure PerformFunction(var e: TParseExpression; left, right, symbol: String; const Definitions: TStringList=nil);
//perform a single operation of + - * / **
var
  e1, e2: TParseExpression;
begin
  //first, check if single minus is in front
  if (symbol='sin') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
      e.myErrorText:=e1.myErrorText;
    end
    else
    begin
      e.myValue:=sin(e1.myValue);
      e.myError:=false;
      e.myErrorPos:=0;
      e.myErrorText:='';
    end;
    e1.Free;
  end
  else if (symbol='cos') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
      e.myErrorText:=e1.myErrorText;
    end
    else
    begin
      e.myValue:=cos(e1.myValue);
      e.myError:=false;
      e.myErrorPos:=0;
      e.myErrorText:='';
    end;
    e1.Free;
  end
  else if (symbol='tan') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
      e.myErrorText:=e1.myErrorText;
    end
    else
    begin
      e.myValue:=tan(e1.myValue);
      e.myError:=false;
      e.myErrorPos:=0;
      e.myErrorText:='';
    end;
    e1.Free;
  end
  else if (symbol='sinh') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
      e.myErrorText:=e1.myErrorText;
    end
    else
    begin
      e.myValue:=sinh(e1.myValue);
      e.myError:=false;
      e.myErrorPos:=0;
      e.myErrorText:='';
    end;
    e1.Free;
  end
  else if (symbol='cosh') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
      e.myErrorText:=e1.myErrorText;
    end
    else
    begin
      e.myValue:=cosh(e1.myValue);
      e.myError:=false;
      e.myErrorPos:=0;
      e.myErrorText:='';
    end;
    e1.Free;
  end
  else if (symbol='tanh') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
      e.myErrorText:=e1.myErrorText;
    end
    else
    begin
      e.myValue:=tanh(e1.myValue);
      e.myError:=false;
      e.myErrorPos:=0;
      e.myErrorText:='';
    end;e1.Free;
  end
  else if (symbol='exp') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
      e.myErrorText:=e1.myErrorText;
    end
    else
    begin
      e.myValue:=exp(e1.myValue);
      e.myError:=false;
      e.myErrorPos:=0;
      e.myErrorText:='';
    end;
    e1.Free;
  end
  else if (symbol='log') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    if e1.myValue<=0 then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=1;
      e.myErrorText:='log of non-positive number';
      e1.Free;
    end
    else
    begin
      if e1.myError then
      begin
        e.myValue:=0;
        e.myError:=true;
        e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
        e.myErrorText:=e1.myErrorText;
      end
      else
      begin
        e.myValue:=ln(e1.myValue);
        e.myError:=false;
        e.myErrorPos:=0;
        e.myErrorText:='';
      end;
      e1.Free;
    end;
  end
  else if (symbol='sqrt') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    if e1.myValue<0 then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=1;
      e.myErrorText:='sqrt of negative number';
      e1.Free;
    end
    else
    begin
      if e1.myError then
      begin
        e.myValue:=0;
        e.myError:=true;
        e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
        e.myErrorText:=e1.myErrorText;
      end
      else
      begin
        e.myValue:=sqrt(e1.myValue);
        e.myError:=false;
        e.myErrorPos:=0;
        e.myErrorText:='';
      end;
      e1.Free;
    end;
  end
  else if (symbol='abs') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
      e.myErrorText:=e1.myErrorText;
    end
    else
    begin
      e.myValue:=abs(e1.myValue);
      e.myError:=false;
      e.myErrorPos:=0;
      e.myErrorText:='';
    end;
    e1.Free;
  end
  else if (symbol='theta') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e1.Evaluate(Definitions);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=true;
      e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
      e.myErrorText:=e1.myErrorText;
    end
    else
    begin
      if e1.myValue>0 then e.myValue:=1 else e.myValue:=0;
      e.myError:=false;
      e.myErrorPos:=0;
      e.myErrorText:='';
    end;
    e1.Free;
  end
  else if (symbol='min') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e2:=TParseExpression.Create;
    e2.text:=right;
    e1.Evaluate(Definitions);
    e2.Evaluate(Definitions);
    e.myValue:=min(e1.myValue,e2.myValue);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=e1.myError;
      e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
      e.myErrorText:=e1.myErrorText;
    end
    else if e2.myError then
    begin
      e.myValue:=0;
      e.myError:=e2.myError;
      e.myErrorPos:=e2.myErrorPos+length(symbol)+length(left)+2;
      e.myErrorText:=e2.myErrorText;
    end
    else
    begin
      e.myError:=false;
      e.myErrorPos:=0;
      e.myErrorText:='';
    end;
    e1.Free;
    e2.Free;
  end
  else if (symbol='max') then
  begin
    e1:=TParseExpression.Create;
    e1.text:=left;
    e2:=TParseExpression.Create;
    e2.text:=right;
    e1.Evaluate(Definitions);
    e2.Evaluate(Definitions);
    e.myValue:=max(e1.myValue,e2.myValue);
    if e1.myError then
    begin
      e.myValue:=0;
      e.myError:=e1.myError;
      e.myErrorPos:=e1.myErrorPos+length(symbol)+1;
      e.myErrorText:=e1.myErrorText;
    end
    else if e2.myError then
    begin
      e.myValue:=0;
      e.myError:=e2.myError;
      e.myErrorPos:=e2.myErrorPos+length(symbol)+length(left)+2;
      e.myErrorText:=e2.myErrorText;
    end
    else
    begin
      e.myError:=false;
      e.myErrorPos:=0;
      e.myErrorText:='';
    end;
    e1.Free;
    e2.Free;
  end
  else
  begin
    e.myErrorText:='unable to evaluate this function';
    e.myError:=true;
    e.myErrorPos:=1;
    e.myValue:=0;
  end;
end;

procedure TParseExpression.evaluate(const Definitions: TStringList=nil);
var
  first, last, i, j: Integer;
  left, right, symbol: String;
  e: TParseExpression;
  val: real;
  oldDecimalSeparator: String;
  DefinitionsBefore: TStringList;
begin
  //first, check if numbers of left and right parantheses match
  if CheckParanthesisCount(myText)=false then
  begin
    myValue:=0;
    myErrorPos:=1;
    myErrorText:='paranthesis count';
    myError:=true;
  end

  //second, check if everything is enclosed in one paranthesis.
  //if yes, call "evaluate" on the expression inside the paranthesis.
  else if OuterParanthesis(myText,first,last)=true then
  begin
    e:=TParseExpression.Create;
    e.text:=copy(myText,first,last-first+1);
    e.Evaluate(Definitions);
    myValue:=e.Value;
    myError:=e.Error;
    myErrorPos:=e.errorPos+first-1;
    myErrorText:=e.errorText;
    e.Free;
  end

  //third, check for + and -
  else if FindLastPlusMinus(myText, left, right, symbol)=true then
    performOperation(self,left,right,symbol,definitions)

  //fourth, check for * and /
  else if FindLastTimesOver(myText, left, right, symbol)=true then
    performOperation(self,left,right,symbol,definitions)

  //fifth, check for ** (power)
  else if FindLastPower(myText, left, right, symbol)=true then
    performOperation(self,left,right,symbol,definitions)

  //sixth, check for empty string
  else if trim(myText)='' then
  begin
    myValue:=0;
    myError:=true;
    myErrorPos:=1;
    myErrorText:='empty expression';
  end

  //seventh, check if it is a call of a standard function
  else if FindStandardFunction(myText,left,right,symbol) then
    performFunction(self,left,right,symbol,definitions)

  //eighth, check if it is a real number
  else
  try
    val:=StrToFloat(trim(myText));
    myValue:=val;
    myError:=false;
    myErrorPos:=0;
    myErrorText:='';
  except
    //first, assume nothing helped, cannot be evaluated
    myValue:=0;
    myError:=true;
    myErrorPos:=1;
    myErrorText:='expression cannot be evaluated: '+trim(myText);

    //but, ninth and last, check if it is in the definitions list
    for i:=0 to Definitions.Count-1 do
    begin
      left:=trim(copy(definitions[i],1,pos('=',definitions[i])-1));
      right:=trim(copy(definitions[i],pos('=',definitions[i])+1,length(Definitions[i])));
      if lowercase(left)=lowercase(myText) then //definition found
      begin
        DefinitionsBefore:=TStringList.Create;
        for j:=0 to i-1 do
          DefinitionsBefore.Add(Definitions[j]);
        e:=TParseExpression.Create;
        e.text:=right;
        e.Evaluate(DefinitionsBefore);
        if e.myError then
        begin
          myValue:=0;
          myError:=true;
          myErrorPos:=0;
          myErrorText:='Error in definition of "'+left+'".';
        end
        else
        begin
          myValue:=e.Value;
          myError:=false;
          myErrorPos:=0;
          myErrorText:='';
        end;
        e.Free;
        DefinitionsBefore.Free;
        break;
      end;
    end;
  end;
end;

end.
