BillsEditor/CU/ScEvaluate.pas

unit ScEvaluate;

interface

function Evaluate(formula: string; var status,location: integer) : double; overload;
function Evaluate(formula: string):double; overload;

implementation

function Evaluate(formula: string):double;
var
  iStatus: Integer;
  iLocation: Integer;
begin
  Result := Evaluate(formula, iStatus, iLocation);
end;

{================================== EVALUATE ================================}
{ ------------------------------- Declarations ----------------------------- }

const MaxReal = 1.0E+37;       { Maximum real value that we will allow }
      MaxFact = 33;            { 33! = E+37 }
      MaxExpo = 85;            { exp(85) = E+37 }



var   Region,                  { Check if result is defined. eg fact(-1.2) }
      Divzero,                 { Check if a division by zero occured. eg 1/0 }
      Overflow,                { Check if result becomes too large. eg 100! }
      Complex : boolean;       { Check if result is complex. eg sqrt(-1) }


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

{============================================================================}
{================================== EVALUATE ================================}
{ From a VERY VERY OLD Pascal 3.0 Function !
{============================================================================}


{ Initialize boolean flags. }
  procedure Init_Booleans;
  begin
    region:=true;              { Result is initially inside region }
    complex:=false;            { Result is not complex }
    divzero:=false;            { There is no division by zero }
    overflow:=false;           { and no overflow. }
  end;  { Init_Booleans }



{ Check to see if doing an operation on a and b will cause an overflow and
  set the OVERFLOW boolean accordingly }

  procedure CheckOverflow(a,b: real; operation: char);
  begin
    case operation of
      '*':  if abs(a) > 1.0 then overflow:=abs(b) > MaxReal/abs(a);
      '/':  if b <> 0.0 then
            begin
              b:=1/b;
              if abs(a) > 1.0 then overflow:=abs(b) > MaxReal/abs(a)
            end
            else overflow:=true;
      '+':  if b > 0.0 then overflow:=a > (MaxReal - b)
            else overflow:=a < (-MaxReal - b);
      '-':  if b < 0.0 then overflow:=a > (MaxReal + b)
            else overflow:=a < (-MaxReal + b);
      else overflow:=true;                       { Default for bad operation }
    end;  { case }
  end;  { CheckOverflow }


{ ----------------------------------------------------------------------------
   The following functions -- asin,acos,tan,cot,sec,csc,sinh,cosh,tanh,sech,
   csch,coth,fact -- will default to 0.0 if a division by zero occurs, the
   result is complex or undefined, or if an overflow occurs.

   If you are using these functions independently of the Evaluate procedure
   then the procedure Init_Booleans should be called first to reinitialize
   error checking.
---------------------------------------------------------------------------- }


                             { --- Arc Sine --- }

  function Asin(r: real): real;
  begin
    if abs(r) < 1.0 then asin:=arctan(r/sqrt(1-r*r))
    else
      if abs(r) = 1.0 then asin:=(r/abs(r))*pi/2
      else
      begin
        asin:=0.0;
        complex:=true
      end  { else }
  end;  { asin }

                            { --- Arc Cosine --- }

  function Acos(r: real): real;
  begin
    if r = 0.0 then acos:=pi/2
    else
    begin
      if abs(r) < 1.0 then
      begin
        if r < 0.0 then acos:=arctan(sqrt(1-r*r)/r)+pi
        else acos:=arctan(sqrt(1-r*r)/r)
      end
      else
        if abs(r) = 1.0 then
          if r = 1.0 then acos:=0.0
          else acos:=pi
        else
        begin
          acos:=0.0;
          complex:=true
        end
    end
  end;  { acos }

                             { --- Tangent --- }

  function Tan(r: real): real;
  begin
    if cos(r) = 0.0 then
    begin
      tan:=0.0;
      divzero:=true
    end
    else tan:=sin(r)/cos(r)
  end;  { tan }

                            { --- CoTangent --- }

  function Cot(r: real): real;
  begin
    if sin(r) = 0.0 then
    begin
      cot:=0.0;
      divzero:=true
    end
    else cot:=cos(r)/sin(r)
  end;  { cot }

                              { --- Secant --- }

  function Sec(r: real): real;
  begin
    if cos(r) = 0.0 then
    begin
      sec:=0.0;
      divzero:=true
    end
    else sec:=1/cos(r)
  end;  { Sec }

                            { --- CoSecant --- }

  function Csc(r: real): real;
  begin
    if sin(r) = 0.0 then
    begin
      csc:=0.0;
      divzero:=true
    end
    else csc:=1/sin(r)
  end;  { Csc }

                               { --- Sinh --- }

  function Sinh(r: real): real;
  begin
    if abs(r) <= MaxExpo then sinh:=(exp(r)-exp(-r))/2
    else
    begin
      overflow:=true;
      sinh:=0.0
    end
  end;  { Sinh }

                             { --- CoSinh --- }

  function Cosh(r: real): real;
  begin
    if abs(r) <= MaxExpo then cosh:=(exp(r)+exp(-r))/2
    else
    begin
      overflow:=true;
      cosh:=0.0
    end
  end;  { Cosh }

                               { --- Tanh --- }

  function Tanh(r: real): real;
  begin
    if cosh(r) = 0.0 then
    begin
      tanh:=0.0;
      divzero:=true
    end
    else
    begin
      CheckOverflow(sinh(r),cosh(r),'/');
      if not overflow then tanh:=sinh(r)/cosh(r)
      else tanh:=0.0
    end
  end;  { Tanh }

                               { --- Sech --- }

  function Sech(r: real): real;
  begin
    if cosh(r) = 0.0 then
    begin
      sech:=0.0;
      divzero:=true
    end
    else
    begin
      CheckOverflow(1,cosh(r),'/');
      if not overflow then sech:=1/cosh(r)
      else sech:=0.0
    end
  end;  { Sech }

                             { --- CoSech --- }

  function Csch(r: real): real;
  begin
    if sinh(r) = 0.0 then
    begin
      csch:=0.0;
      divzero:=true
    end
    else
    begin
      CheckOverflow(1,sinh(r),'/');
      if not overflow then csch:=1/sinh(r)
      else csch:=0.0
    end
  end;  { Csch }

                             { --- CoTanh --- }

  function Coth(r: real): real;
  begin
    if sinh(r) = 0.0 then
    begin
      coth:=0.0;
      divzero:=true
    end
    else
    begin
      CheckOverflow(cosh(r),sinh(r),'/');
      if not overflow then coth:=cosh(r)/sinh(r)
      else coth:=0.0
    end
  end;  { Coth }

                            { --- Factorial --- }

  function Fact(r:real): real;
  var i: integer;
      resulta: real;
  begin
    if (r < 0.0) or (trunc(r) <> r) then
    begin
      resulta:=0.0;
      region:=false
    end
    else
    begin
      resulta:=1.0;
      if trunc(r) < MaxFact then
        for i:=1 to trunc(r) do
          resulta:=resulta*i
      else
      begin
        overflow:=true;
        resulta:=0.0
      end
    end;
    fact:=resulta
  end;  { Fact }


{ ----------------------------------------------------------------------------
  The function Evaluate is passed a mathematical expression in the form of a
  string (formula) to be evaluated and returns the following:

  If no errors occur during evaluation then:
      Result = evaluated expression
      Status = 0
      Location = 0

  If an error occurs then:
      Result = 0.0
      Status = error type
      Location = location of error in formula

  Error types:
   0: No error occured
   1: Illegal character
   2: Incorrect syntax
   3: Illegal or missing parenthese
   4: Incorrect real format
   5: Illegal function
   6: Result is undefined
   7: Result is too large
   8: Result is complex
   9: Division by zero

---------------------------------------------------------------------------- }
{const
  ErrStr: array[1..9] of string =
   ('无效字符',
    '语法错误',
    '括号不配对',
    '实数的格式部正确',
   );}


function Evaluate(formula: string; var status,location: integer):double;

{ ---- Declaration ---- }

const  numbers: set of char = ['0'..'9'];                 { Digits }
       RightPar: set of char = [')',']','}'];             { Right parentheses }
       LeftPar: set of char = ['(','[','{'];              { Left parentheses }
       alpha: set of char = ['A'..'Z'];                   { Alpha characters }
       operators: set of char = ['+','-','*','/','^'];    { Operators }
       eofline = ^M;

var ch: char;                                            { Current character }
    resulto: real;                                        { Final value }

{ ---- Internal routines ---- }

{ Check to see if an error has occured }
  function Ok: boolean;
  begin
    ok:= region and (not divzero) and (not complex)
         and (not overflow) and (status = 0);
  end;  { Ok }

{ Get the next character in the string and increment the location pointer. }
  procedure NextCh;
  begin
    repeat
      location:=location+1;                              { Increment pointer }
      if location <= length(formula) then ch:=formula[location]
      else ch:=eofline;
      if not (ch in alpha + numbers + LeftPar + RightPar + operators
              + ['%', '.',' ','!',eofline]) then
        status:=1;                                       { Illegal char. }
    until ch <> ' ';                                     { Skip blanks }
  end  { NextCh };


{ ---- Nested functions ---- }


  function Expression: real;
  label quit;
  var e,e_hold: real;
      opr: char;
      Leading_Sign,Nested_Function: boolean;


    function SimpleExpression: real;
    label quit;
    var s,s_hold: real;
        opr: char;


      function Term: real;
      label quit;
      var  t,t_hold: real;


        function SignedFactor: Real;


          function Factor: Real;
          label quit;
          type StandardFunction =
                 (fpi,fabs,fsqrt,fsqr,fln,flog,fexp,ffact,
                  fsinh,fcosh,ftanh,fsech,fcsch,fcoth,
                  fsin,fcos,ftan,fsec,fcsc,fcot,fasin,facos,fatan);

               StandardFunctionList = array[StandardFunction] of string[4];

           const StandardFunctionNames: StandardFunctionList =
                  ('PI','ABS','SQRT','SQR','LNG','LOG','EXP','FACT',
                   'SINH','COSH','TANH','SECH','CSCH','COTH',
                   'SIN','COS','TAN','SEC','CSC','COT','ASIN','ACOS','ATAN');

           var Found: Boolean;
               l: integer;
               F: Real;
               str: string;
               Sf: StandardFunction;
               start,position: integer;

          begin { Function Factor }

          { Exit if error }
            if not ok then begin f:=0.0; goto quit end;

          { Get a real or integer expression }
            if ch in numbers+['.'] then
            begin
              start:=location;
              if ch in numbers then repeat NextCh until not (ch in numbers);
              if ch = '.' then repeat NextCh until not (ch in numbers);

            { Get the E format of a real expression }
              if ch = 'E' then
              begin
                NextCh;
                if ch = 'X' then location:=location - 1      { Skip EXP(...) }
                else
                  if not (ch in numbers + ['+','-']) then status:=4
                  else repeat NextCh until not (ch in numbers);
              end;

            { Check the real format }
              str:=copy(formula,start,location-start);

              { Remove all spaces in str otherwise val will bomb! }
              while pos(' ',str) <> 0 do delete(str,pos(' ',str),1);

              val(str,f,position);
              if position <> 0 then
              begin
                location:=start+position;
                status:=4                            { Incorrect Real format }
              end;

              if Ok and (Ch = '%') then
              begin
                f := f / 100;
                NextCh;
              end;
            end    { end if ch in number }

          { The character is not a digit }
            else
            begin

            { Check for for the beginning of a "sub" expression }
              if ch in LeftPar then
              begin
                NextCh;
                F:=Expression;                       { RECURSION !!! }
                if ok and (ch in RightPar) then      { Check for implicit * }
                begin
                  NextCh;
                  if not (ch in operators+LeftPar+RightPar+['!',eofline]) then
                  begin
                    ch:='*';
                    location:=location-1
                  end;
                end
                else status:=3                         { Illegal parenthese }
              end  { if ch in LeftPar }

            { It should be a function }
              else
              begin
                found:=false;

              { Search for the function among our list }
                for sf:=fpi to fatan do
                  if not found then
                  begin
                    l:=length(StandardFunctionNames[sf]);

                    if copy(formula,location,l)=StandardFunctionNames[sf] then
                    begin
                      location:=location+l-1;
                      NextCh;
                      if sf <> fpi then
                      begin
                        Nested_Function:=true;
                        F:=Factor
                      end;

                    { Assign values according to the function }
                      case sf of
                        fpi:      f:=pi;                  { pi is predefined }
                        fsqr:     if f < 1.0e+19 then f:=sqr(f)
                                  else
                                  begin
                                    f:=0.0;
                                    overflow:=true
                                  end;
                        fabs:     f:=abs(f);
                        fsqrt:    if f < 0.0 then
                                  begin
                                    complex:=true;
                                    f:=0.0
                                  end
                                  else f:=sqrt(f);

                        fsin:     f:=sin(f);
                        fcos:     f:=cos(f);
                        ftan:     f:=tan(f);
                        fasin:    f:=asin(f);
                        facos:    f:=acos(f);
                        fatan:    f:=arctan(f);
                        fsec:     f:=sec(f);
                        fcsc:     f:=csc(f);
                        fcot:     f:=cot(f);

                        fsinh:    f:=sinh(f);
                        fcosh:    f:=cosh(f);
                        ftanh:    f:=tanh(f);
                        fsech:    f:=sech(f);
                        fcsch:    f:=csch(f);
                        fcoth:    f:=coth(f);

                        fexp:     if abs(f) < MaxExpo then f:=exp(f)
                                  else
                                    if f < 0 then f:=0.0
                                    else
                                    begin
                                      overflow:=true;
                                      f:=0.0
                                    end;
                        ffact:    f:=fact(f);
                        fln :     if f < 0.0 then
                                  begin
                                    complex:=true;
                                    f:=0.0
                                  end
                                  else
                                    if f = 0.0 then
                                    begin
                                      overflow:=true;
                                      f:=0.0
                                    end
                                    else f:=ln(f);
                        flog:     if f < 0.0 then
                                  begin
                                    complex:=true;
                                    f:=0.0
                                  end
                                  else
                                    if f = 0.0 then
                                    begin
                                      overflow:=true;
                                      f:=0.0
                                    end
                                    else f:=ln(f)/ln(10);
                      end; { Case }

                      found:=true;
                      Nested_Function:=false;

                    { Check for a trailing factorial symbol }
                      if ch = '!' then
                      begin
                        f:=fact(f);
                        NextCh
                      end

                    end   { If copy = function }
                  end;  { If not found }

              { Check for more errors }
                if (not found) and ok and not (ch in alpha) then
                  status:=2;                                  { Illegal Syntax }
                if (not found) and ok and (ch in alpha) then
                  status:=5;                                { Illegal function }

              end  { Else not ch in LeftPar .. ie. it should be a function }
            end; { else the character is not a digit }

          { Check for a trailing factorial symbol }
            if ok and (not Nested_Function) and (ch = '!') then
            begin
              f:=fact(f);
              NextCh
            end;

          { Assign final value }
     quit:  Factor:=F
          end;  { Factor inside SignedFactor }

        begin  { SignedFactor }
          if ch = '-' then
          begin
            NextCh;
            SignedFactor:= -Factor
          end
          else SignedFactor:=Factor;
        end  { SignedFactor inside Term };


      begin { Term }
        if not ok then begin t:=0.0; goto quit end;          { Exit }

        t:=SignedFactor;
        while ch = '^' do
        begin
          if not ok then begin t:=0.0; goto quit end;        { Exit }

          NextCh;
          t_hold:=SignedFactor;

        { Check for illegal power }
          if ((t < 0.0) and ((t_hold-trunc(t_hold)) <> 0.0)) or (t = 0.0) then
          begin
            t:=0.0;
            complex:=true
          end

        { Power is legal }
          else
          begin
            if t < 0.0 then
            begin
              CheckOverflow(ln(-t),t_hold,'*');
              if not Ok then begin t:=0.0; goto quit end;     { Exit }

              if ln(-t)*t_hold <= MaxExpo then
                case trunc(abs(t_hold)) mod 2 = 0 of
                  true:  t:=exp(ln(-t)*t_hold);
                  false: t:=-exp(ln(-t)*t_hold)
                end
              else
              begin
                t:=0.0;
                overflow:=true
              end
            end  { if t < 0.0 }

            else  { t >= 0.0 }
            begin
              CheckOverflow(ln(t),t_hold,'*');
              if not Ok then begin t:=0.0; goto quit end;     { Exit }

              if ln(t)*t_hold <= MaxExpo then t:=exp(ln(t)*t_hold)
              else
              begin
                t:=0.0;
                overflow:=true
              end
            end  { else t >= 0.0 }
          end  { else not illegal power }
        end;  { while }
  quit: Term:=t;
      end;  { Term inside SimpleExpression }


    begin { SimpleExpression }
      if not ok then begin s:=0.0; goto quit end;                     { Exit }
      s:=term;

    { Check for implicit multiplication and insert missing "*" }
      if ok and (ch in LeftPar + alpha + numbers + ['.']) then
      begin
        ch:='*';
        location:=location-1
      end;

      while ch in ['*','/'] do
      begin
        if not ok then begin s:=0.0; goto quit end;                    { Exit }
        opr:=ch;
        NextCh;

      { Check for implicit multiplication and insert missing "*" }
        if opr in LeftPar + alpha + numbers + ['.'] then
        begin
          opr:='*';
          ch:='(';
          location:=location-1
        end;

        s_hold:=term;
        case opr of
          '*': begin
                 CheckOverflow(s,s_hold,'*');
                 if not overflow then s:=s*s_hold
                 else s:=0.0
               end;
          '/': begin
                 divzero:=s_hold = 0.0;
                 if not divzero then
                 begin
                   CheckOverflow(s,s_hold,'/');
                   if not overflow then s:=s/s_hold
                   else s:=0.0
                 end
                 else s:=0.0
               end
        end;  { Case }

      { Check for implicit multiplication and insert missing "*" }
        if ok and (ch in LeftPar + alpha + numbers + ['.']) then
        begin
          ch:='*';
          location:=location-1
        end
      end;  { while }

    { Assign final value }
quit: SimpleExpression:=s;
    end;  { SimpleExpression inside Expression }


  begin { Expression }
    if not ok then begin e:=0.0; goto quit end;                       { Exit }
    Nested_Function:=false;

    Leading_Sign:= ch = '-';                              { The default is + }
    if ch in ['+','-'] then Nextch;                      { Skip leading sign }
    case Leading_Sign of                              { Set for leading sign }
      true:   e:= -SimpleExpression;
      false:  e:= SimpleExpression
    end;

    while ch in ['+','-'] do
    begin
      if not ok then begin e:=0.0; goto quit end;                     { Exit }
      opr:=ch;
      NextCh;

      e_hold:=SimpleExpression;
      case opr of
        '+': begin
               CheckOverflow(e,e_hold,'+');
               if not overflow then e:=e+e_hold
               else e:=0.0;
             end;
        '-': begin
               CheckOverflow(e,e_hold,'-');
               if not overflow then e:=e-e_hold
               else e:=0.0;
             end;
      end;  { case }
    end;  { while }
  quit: Expression:=e;
  end; { Expression inside Evaluate }

var i:integer;

begin { Evaluate }

{ Initialize }
  for i:=1 to length(formula) do
     formula[i]:=upcase(formula[i]);
  Init_Booleans;
  status:=0;
  location:=0;
  NextCh;

{ Get result }
  resulto:=Expression;

{ Check for final errors }
  if ok then if ch <> eofline then status:=2;             { Incorrect Syntax }

  if not region then status:=6;
  if overflow then status:=7;
  if complex then status:=8;
  if divzero then status:=9;

  if status in [4,6..9] then location:=location-1;
  if status = 0 then location:=0
  else resulto:=0.0;

  Evaluate:=resulto;
end { Evaluate };




end.