source: cprs/branches/tmg-cprs/CPRS-Chart/uEvaluate.pas@ 834

unit uEvaluate;
//kt and Eddie added entire unit 3/28/10
{
 This unit was created by Josh Code
 and uploaded to Planet Source Code.com
 All changed are noted.
 Reformatting for code appearance applied.

 -----------------------------------------------------------------
 The expression must follow the following rules:
    There can''t be any spaces.
    The only operators supported are: ^,*,/,+,-
    There must be the same number of begin and end brackets.
    Only the round brackets can be used.
    All values must be valid constants.
    A "valid constant," for this program, is defined as a string with:
         - no characters besides "0".."9," up to one ".",
         up to one "-" at the beginning
         - the string must be at least one character in length
         - Exponential sections are not supported, however, the "E" character
         is supported by "StrToFloat."  ie. "3.14E-10" is not supported by this
         program, but it is for Delphi's "StrToFloat" function.
 -----------------------------------------------------------------

 The purpose of the program is to show how to evaluate a string
 The program evaluates an expression contained in a string to a single real number
 using order of operation.
 The program supports powers, multiplication, division, adding, and subtraction.

 You are free to copy and paste this code for educational use.
 If you want it for commercial use, contact me.
 If you find some bugs, contact me.
 If you make any good improvements, contact me.  I'd like to know if the code can be reduced.
 My email address is greijos@hotmail.com.

 A string is evaluated by finding the first simple expression to evaluate using order of operation
 (B.E.D.M.A.S.)
 Each operation is evaluated by looking at the operator character and getting
 the values on the left and right side of it.  These values are found by scanning
 the characters to the left and right of the operator.  After an operation is evaluated,
 the new value is substituted into the string and the next operation will then be evaluated.
 After evaluating all of the operations in the string, a single real number should remain.

}

{$O-}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,Math, StrUtils;


function StringEval(str1: string;var problem: boolean): real;

implementation

function LastIndexOf(ch: char;str1: string): integer;
var c: integer;
begin
  result:=-1; // if the loop doesn't get a match then this is the result
  for c:=Length(str1) downto 1 do begin
    if str1[c]=ch then begin // if the character matches the character in the string
      result:=c;
      break; // don't continue the loop
    end;
  end;
end;

function GetClosingBracket(start1: integer; str1: string;var done: boolean): integer;
var
  x: integer;
  ch: char;
  BCount: integer;
begin
  done:=true;
  result:=0;
  BCount:=1;
  for x:=start1+1 to length(str1) do begin
    ch:=str1[x];
    if (ch=')') or (ch='(') then begin
      case ch of
        '(': inc(BCount);
        ')': dec(BCount);
      end;
      if BCount=0 then begin
        done:=false;
        result:=x;
        break;
      end;
    end;
  end;
end;

function GetHigherBracket(const str1: string;var done,problem: boolean;var start1,end1: integer): string;
var
   pos1,pos2: integer;
begin // problem getting the higherbracket information when str1='(-1)*(-2)'
  result:=''; // initial value
  pos1:=pos('(',str1);
  start1:=pos1-1;
  pos2:=GetClosingBracket(pos1,str1,done);
  inc(pos2);
  end1:=pos2;
  if done then
    result:=str1
  else if (pos1>0) xor (pos2>0) then begin
    ShowMessage('problem with getting brackets out of this string: "'+str1+'"');
    problem:=true;
  end
  // there has to be a match between the number of end and beginning brackets
  else if Pos1>0 then
    result:=copy(str1,pos1+1,pos2-pos1-2)
  else begin // if there was no brackets in the string
    done:=true;
    result:=str1;
  end;
end;

//kt original --> function GetLeftNum(index1: integer;str1: string;var start1: integer; problem: boolean): real;
function GetLeftNum(index1: integer;str1: string;var start1: integer; var problem: boolean): real;
var
   c: integer;
   ch1: char;
   decimaled: boolean; // true after a decimal was added to NumStr
   NumStr: string;
// a string to contain the number in string form until it is comletely copied
begin // get the number left of a certain character by looping down the string
  result:=0;
  if index1=1 then begin
    result:=0;
    exit;
  end;
  NumStr:=''; // initialize string
  Decimaled:=false;
  for c:=index1-1 downto 1 do begin // loop down the string
    ch1:=str1[c];
    if (ch1>='0')and(ch1<='9') then
       NumStr:=ch1+NumStr
    else if ch1='.' then begin
      if Decimaled then begin
        Problem:=true;
        Break;
      end else begin
        NumStr:=ch1+NumStr;
      end;
      Decimaled:=true;
    end else if ch1='-' then begin
      if c>1 then begin // avoid error when referring to a character that doesn't exist
        if (str1[c-1]<'0')or(str1[c-1]>'9') then begin
          // make sure the '-' is not supposed to be a subtraction operator
          NumStr:=NumStr+ch1;
        end;
      end else begin// first character of the string is added
        NumStr:=ch1+NumStr;
      end;
      Break;
    end else Break;
  end;
  start1:=c;
  {  //kt
  if NumStr='' then
    problem:=true
  else
    result:=strtofloat(NumStr);
  }
  if NumStr='' then problem:=true;
  if not problem then begin
    result:=strtofloat(NumStr);
  end;
end;

//kt original --> function GetRightNum(index1: integer;str1: string;var end1: integer;problem: boolean): real;
function GetRightNum(index1: integer;str1: string;var end1: integer; var problem: boolean): real;
var
   c: integer;
   ch1: char;
   decimaled: boolean; // true after a decimal was added to NumStr
   NumStr: string;
// a string to contain the number in string form until it is comletely copied
begin // get the number left of a certain character by looping down the string
  NumStr:=''; // initialize string
  Decimaled:=false;
  for c:=index1+1 to Length(str1) do begin // loop down the string
    ch1:=str1[c];
    if (ch1>='0')and(ch1<='9')or((c=index1+1)and(ch1='-')) then begin
      NumStr:=NumStr+ch1
    end else if ch1='.' then begin
      if Decimaled then begin
        Problem:=true;
        Break;
      end else begin
        NumStr:=NumStr+ch1;
      end;
      Decimaled:=true;
    end else Break;
  end;
  if NumStr='' then problem:=true;
  if not problem then begin
    result:=strtofloat(NumStr);
  end else begin
    result := 0;
  end;
  end1:=c;
  {  //kt
  if NumStr='' then
    problem:=true
  else
    result:=strtofloat(NumStr);
  end1:=c;
  }
end;

procedure SubstituteStr(StartIndex,EndIndex: integer;var str1: string;const SubStr: string);
// substitute a substring into another string, replacing a certain index range
var s1: string;
begin
  s1:='';
  if startindex<>1 then begin
    s1:=copy(str1,1,StartIndex);
  end;
  s1:=s1+SubStr;
  if EndIndex<Length(str1) then begin
    s1:=s1+copy(str1,EndIndex,999);
  end;
  str1:=s1;
end;

procedure StoreOpVals(ChIndex: integer;str1: string; var problem: boolean;var val1,val2: real;var start1,end1: integer);
// store the values left and right of the operation character
begin
  Val1:=GetLeftNum(ChIndex,str1,start1,problem);
  Val2:=GetRightNum(ChIndex,str1,end1,problem);
end;

function StringEval(str1: string;var problem: boolean): real;
var
  pos1,pos2: integer;
  parEval: string;
  parPos1,parPos2: integer;
  stopping: boolean;
  st1,en1: integer; // used for substituing strings
  val1,val2: real; // constant values used to evaluate an operation
  s: string;

  function StorePos(ch: char): integer;
  begin // store the position of the character into pos1 and return it too
    pos1:=pos(ch,str1);
    result:=pos1;
  end;

begin
  stopping:=false;
  while not stopping do begin// loop through the brackets using recursion
   s:=GetHigherBracket(str1,stopping,problem,st1,en1);
   if not (stopping or problem) then // there are still smaller brackets to evaluate
     SubstituteStr(st1,en1,str1,floattostr(StringEval(s,problem)))
   else
     stopping:=true;
  end;
  if problem then begin
    result:=0;
    Exit;
  end;
  // now to actually evaluate something
  //kt added "and (not problem)" below
  while (StorePos('^')>0) and (not problem) do begin// there is an adding operation to evaluate
    StoreOpVals(pos1,str1,problem,val1,val2,st1,en1);
    SubstituteStr(st1,en1,str1,floattostr(power(val1,val2)));
  end;
  while (Pos('*',str1)>0)or(Pos('/',str1)>0) and (not problem) do begin
    pos2:=Pos('*',str1);
    pos1:=Pos('/',str1);
    if (pos1<pos2)and(pos1>1)or(pos2<1) then begin
      StoreOpVals(pos1,str1,problem,val1,val2,st1,en1);
      SubstituteStr(st1,en1,str1,floattostr(val1/val2));
    end else begin
      StoreOpVals(pos2,str1,problem,val1,val2,st1,en1);
      SubstituteStr(st1,en1,str1,floattostr(val1*val2));
    end;
  end;
  while (Pos('+',str1)>0)or(Pos('-',str1)>0) and (not problem) do begin
    pos2:=pos('-',str1);
    if pos2=1 then // ie. str1 = '-4-4'
      pos2:=pos('-',copy(str1,2,999))+1;
    pos1:=Pos('+',str1);
    if pos2=1 then // ie. str1 = '+4-4'
      pos1:=pos('+',copy(str1,2,999))+1;
    if ((pos1<pos2) and (pos1>1) or (pos2<1)) then begin
      StoreOpVals(pos1,str1,problem,val1,val2,st1,en1);
      SubstituteStr(st1,en1,str1,floattostr(val1+val2));
    end else if pos2>1 then begin// don't evaluate something like '-3423'
      StoreOpVals(pos2,str1,problem,val1,val2,st1,en1);
      SubstituteStr(st1,en1,str1,floattostr(val1-val2));
    end else break;
  end;
  if (str1<>'') and not problem then begin  //kt added problem check
    try
      result:=StrToFloat(str1);
    except
      on EConvertError do begin
        result := 0;
        problem := true;
      end;
    end;
  end else begin
    result := 0;
    problem := true;
  end;
end;

{
procedure TForm1.Button1Click(Sender: TObject);
var // Evaluate Expression
  s: string;
  problem: boolean; // used to hold information on a problem
begin
     Problem:=false;
     s:=edit1.text;
     s:=floattostr(StringEval(s,problem));
     if problem then
        edit1.text:='error'
     else
         edit1.text:=s;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin // Expression Guidelines
     // the character, #13, creates a new line.
     ShowMessage('The expression must follow the following rules:'+#13+
                 '   There can''t be any spaces.'+#13+
                 '   The only operators supported are: ^,*,/,+,-'+#13+
                 '   There must be the same number of begin and end brackets.'+#13+
                 '   Only the round brackets can be used.'+#13+
                 '   All values must be valid constants.'+#13+
                 '   A "valid constant," for this program, is defined as a string with:'+#13+
                 '        - no characters besides "0".."9," up to one ".", '+#13+
                 '        up to one "-" at the beginning'+#13+
                 '        - the string must be atleast one character in length'+#13+
                 '        - Exponential sections are not supported, however, the "E" character'+#13+
                 '        is supported by "StrToFloat."  ie. "3.14E-10" is not supported by this program,'+#13+
                 '        but it is for Delphi''s "StrToFloat" function.'
                      );
end;
}
end.