Betreff: Re: Equation Parser
     Datum: Fri, 04 Sep 1998 02:11:55 -0700
       Von: Yuri Pilipishin <yura@ipm.lviv.ua>
     Firma: JCM Group
        An: newsserv@gu.kiev.ua
     Foren: comp.lang.pascal.delphi.misc


Ben Crain wrote:
> 
> I am new to Delphi, but with some experience in VB.  I want to develop
> an application (in both VB & Delphi, until I decide which is better) in
> which the user enters a mathematical equation, presumably as a string
> (any arbitrary equation, using any of the standard mathematical
> operators : +,*,^, etc, and any of the standard functions: sin, exp,
> etc.).  I need to take that string, convert it to a real function, and
> evaluate it.

Simple, but still useful solution, written originally in Turbo Pascal 3.0 (and
working with any version of Delphi as well). Examples of usage:

 x := ExeFn('2+(x5*y)^2', 1, 4, 0,0);
 ..........

 if not BadFn(Str, ['x', 'y', 't'])
 then s := ExeFn(Str, 3, 7.777, 0, 0)
 else WriteLn('Error in expression');

Please, write me if you need more explanation.

Sincerely,
Yuri Pilipishin



----------------------------------------------------

unit calcfn;
                       { (c) 1991  Yuri Pilipisin }
interface
uses mathfns;

  type charset=set of char;

  function exefn(var f:string; x,y,z,t:real):real;
  function badfn(var f:string; arguments:charset):boolean;

implementation

  type tab=array[1..255]of byte;
  var  stack,stb:tab; oldfn:string; c:real; sp,i:integer;

  procedure set_stb(var f:string);
  begin
    sp:=1;
    for i:=1 to length(f) do
    case f[i] of
     '(': begin stack[sp]:=i;inc(sp)       end;
     ')': begin dec(sp);stb[i]:=stack[sp]  end
    end;
    oldfn:=f
  end;

  function exefn(var f:string; x,y,z,t:real):real;
    
     function calc(p1,p2:byte):real;
       var p:byte;
       function found(ch:char):boolean;
       begin
        p:=p2;
        while not((f[p]=ch)or(p<p1+2)) do
        if f[p]=')' then p:=stb[p] else dec(p);
        found:=(f[p]=ch)
       end;
     begin
        if p1=p2 then case f[p1] of
                     'x':calc:=x;  'y':calc:=y;  'z':calc:=z;  't':calc:=t
                      else calc:=ord(f[p1])-48; end
        else if (stb[p2]=p1)
             and(f[p2]=')' ) then calc:=calc(p1+1,p2-1)
        else if f[p1]=' '    then calc:=calc(p1+1,p2)
        else if f[p2]=' '    then calc:=calc(p1,p2-1)

        else if found('+') then calc:=calc(p1,p-1)+calc(p+1,p2)
        else if found('-') then calc:=calc(p1,p-1)-calc(p+1,p2)
        else if found('*') then calc:=calc(p1,p-1)*calc(p+1,p2)
        else if found('/') then calc:=calc(p1,p-1)/calc(p+1,p2)
        else if found('^') then calc:=power(calc(p1,p-1),calc(p+1,p2))

        else if f[p1] in ['0'..'9']
             then begin  val(copy(f,p1,p2-p1+1),c,i);calc:=c  end
        else case f[p1] of
             's':case f[p1+1] of
                 'i':calc:=sin(calc(p1+3,p2));
                 'h':calc:=sh(calc(p1+2,p2))
                 else calc:=sgn(calc(p1+3,p2)) end;
             'c':case f[p1+2] of
                 's':calc:=cos(calc(p1+3,p2));
                 'g':calc:=ctg(calc(p1+3,p2));
                 'h':calc:=cth(calc(p1+3,p2))
                 else calc:=ch(calc(p1+2,p2))  end;
             't':case f[p1+1] of
                 'g':calc:=tg(calc(p1+2,p2))
                 else calc:=th(calc(p1+2,p2))  end;
             'a':case f[p1+4] of
                 'i':calc:=arcsin(calc(p1+6,p2));
                 'o':calc:=arccos(calc(p1+6,p2));
                 't':calc:=arcctg(calc(p1+6,p2));
                 'g':calc:=arctg(calc(p1+5,p2))
                 else calc:=abs(calc(p1+3,p2))  end;
             '-':calc:=-calc(p1+1,p2);
             'e':calc:=exp(calc(p1+3,p2));
             'l':calc:=ln(calc(p1+2,p2))
             else calc:=pi
             end
     end;

  begin
     if f<>oldfn then set_stb(f);
     exefn:=calc(1,length(f))
  end;

  const
    operators=['+','-','*','/','^'];
    func_num=17;
    func:array [1..func_num] of string[6] =
    ('sin','cos','tg','ctg','sh','ch','th','cth','sgn','abs','-','ln','exp',
     'arcsin','arccos','arcctg','arctg');

  function badfn(var f:string; arguments:charset):boolean;

      function fnok(p1,p2:byte):boolean;
         var p:byte; ok:boolean;
         function operator:boolean;
         begin
          p:=p2;
          while not((f[p] in operators)or(p<p1+2)) do
          if f[p]=')' then p:=stb[p] else dec(p);
          operator:=(f[p] in operators)
         end;
      begin
        if      p1>p2        then fnok:=false
        else if p1=p2        then fnok:=f[p1] in (arguments+['0'..'9'])

        else if (stb[p2]=p1)
            and (f[p2]=')' ) then fnok:=fnok(p1+1,p2-1)
        else if f[p1]=' '    then fnok:=fnok(p1+1,p2)
        else if f[p2]=' '    then fnok:=fnok(p1,p2-1)

        else if operator     then fnok:=fnok(p1,p-1) and fnok(p+1,p2)
        else if f[p1] in ['0'..'9']
             then begin  val(copy(f,p1,p2-p1+1),c,i);fnok:=(i=0) end
        else if copy(f,p1,p2-p1+1)='pi' then fnok:=true

        else begin
          i:=0; ok:=false;
          repeat
           inc(i);
           ok:=func[i]=copy(f,p1,length(func[i]))
          until ok or (i=func_num);
          fnok:=ok and fnok(p1+length(func[i]),p2)
        end

      end;

  begin
    set_stb(f);
    badfn:=(sp<>1)or not fnok(1,length(f))
  end;

end.

-------------------------------------------------------------------

unit mathfns;

interface

  function power(a,b:real):real;
  function tg     (x:real):real;
  function ctg    (x:real):real;
  function sc     (x:real):real;
  function csc    (x:real):real;
  function sh     (x:real):real;
  function ch     (x:real):real;
  function th     (x:real):real;
  function cth    (x:real):real;
  function sch    (x:real):real;
  function csch   (x:real):real;
  function arcsin (x:real):real;
  function arccos (x:real):real;
  function arctg  (x:real):real;
  function arcctg (x:real):real;
  function sgn    (x:real):real;

implementation

  function power(a,b:real):real;
  begin
    if (a>0) and (b>=0) then power:=exp(a*ln(a))
    else if b<0 then power:=1/power(a,-b)
    else if a<0 then
      begin
        if frac(b/2)=0
        then power:= power(-a,b)
        else power:=-power(-a,b)
      end
    else power:=0; {a=0}
  end;

  function arcsin(x:real):real;
  begin
    arcsin:=arctan(x/sqrt(1-sqr(x)))
  end;

  function sgn(x:real):real;
  begin
    if      x>0 then sgn:=1
    else if x<0 then sgn:=-1
    else sgn:=0
  end;

  function tg    (x:real):real; begin  tg:=sin(x)/cos(x)       end;
  function ctg   (x:real):real; begin  ctg:=1/tg(x)            end;
  function sc    (x:real):real; begin  sc:=1/cos(x)            end;
  function csc   (x:real):real; begin  csc:=1/sin(x)           end;
  function sh    (x:real):real; begin  sh:=(exp(x)-exp(-x))/2  end;
  function ch    (x:real):real; begin  ch:=(exp(x)+exp(-x))/2  end;
  function th    (x:real):real; begin  th:=sh(x)/ch(x)         end;
  function cth   (x:real):real; begin  cth:=1/th(x);           end;
  function sch   (x:real):real; begin  sch:=1/ch(x)            end;
  function csch  (x:real):real; begin  csch:=1/sh(x)           end;
  function arctg (x:real):real; begin  arctg:=arctan(x)        end;
  function arcctg(x:real):real; begin  arcctg:=pi/2-arctg(x)   end;
  function arccos(x:real):real; begin  arccos:=pi/2-arcsin(x)  end;

end.