Board index » delphi » Math formula routine

Math formula routine

LancePKing <lancepk...@aol.com> wrote in
<19970828230101.TAA14...@ladder02.news.aol.com>...

Quote
> Do you know where I could get a *proven* routine to read a mathematical
> equation from a string and return the value?  I will write one - but I'm
> sure someone has already solved this long ago.

Here is a routine (written by a Frank Fetthauer) that I found in a group
some days ago:

FORMULA has to be a string containing the formular. Variables x y and z are
allowed, as well as the operatins below. Example:
sin(x)*cos(x^y)+exp(cos(x))

Useage:

uses EVALCOMP;

var calc:    EVALVEC ; (evalvec is a pointer to an object befined by
evalcomp)
    FORMULA: string;

begin

FORMULA:='x+y+z';

new (calc,init(FORMULA)); (Building the evaluation tree)

writeln ( calc^.eval1d(7) )     ; (x=7 y=0 z=0; result:  7)
writeln ( calc^.eval2d(7,8) )   ; (x=7 y=8 z=0; result: 15)
writeln ( calc^.eval3d(7,8,9) ) ; (x=7 y=8 z=9; result: 24)

dispose(calc,done); (destroing the evaluation tree)

end.  

Allowed operations:

x <> y ; Logical operations return 1 if true and 0 if false.
x <= y
x >= y
x > y
x < y
x = y
x + y
x - y
x eor y ( exclusive or )
x or y
x * y
x / y
x and y
x mod y
x div y
x ^ y ( power )
x shl y
x shr y
not (x)
sinc (x)
sinh (x)
cosh (x)
tanh (x)
coth (x)
sin (x)
cos (x)
tan (x)
cot (x)
sqrt (x)
sqr (x)
arcsinh (x)
arccosh (x)
arctanh (x)
arccoth (x)
arcsin (x)
arccos (x)
arctan (x)
arccot (x)
heavy (x) ; 1 for positive numbers, 0 else
sgn (x) ; 1 for positive, -1 for negative, 0 for 0
frac (x)
exp (x)
abs (x)
trunc (x)
ln (x)
odd (x)
pred (x)
succ (x)
round (x)
int (x)
fac (x) ; x*(x-1)*(x-2)*...*3*2*1
rnd ; Random number in [0,1]
rnd (x) ; Random number in [0,x]
pi
e

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

Und nun der QUELLCODE:

unit evalcomp;

interface

type fun= function(x,y:real):real;
     evalvec= ^evalobj;
     evalobj= object
              f1,f2:evalvec;
              f1x,f2y:real;
              f3:fun;
              function eval:real;
              function eval1d(x:real):real;
              function eval2d(x,y:real):real;
              function eval3d(x,y,z:real):real;
              constructor init(st:string);
              destructor done;
              end;
var  evalx,evaly,evalz:real;

implementation

var analysetmp:fun;

function search (text,code:string; var pos:integer):boolean;
var i,count:integer;
    flag:boolean;
    newtext:string;
begin
  if length(text)<length(code) then begin search:=false; exit; end;
  flag:=false;
  pos:=length(text)-length(code)+1;
  repeat
    if code=copy(text,pos,length(code))
      then flag:=true
      else dec(pos);
    if flag
      then
       begin
        count:=0;
        for i:= pos+1 to length(text) do
         begin
          if copy(text,i,1) = '(' then inc(count);
          if copy(text,i,1) = ')' then dec(count);
         end;
        if count<>0
         then
          begin
           dec(pos);
           flag:=false;
          end;
       end;
  until (flag=true) or (pos=0);
  search:=flag;
end;

function myid(x,y:real):real;
begin
 myid:=x;
end;

function myunequal(x,y:real):real;
begin
 if x<>y then
  myunequal:=1
 else
  myunequal:=0;
end;

function mylessequal(x,y:real):real;
begin
 if x<=y then
  mylessequal:=1
 else
  mylessequal:=0;
end;

function mygreaterequal(x,y:real):real;
begin
 if x>=y then
  mygreaterequal:=1
 else
  mygreaterequal:=0;
end;

function mygreater(x,y:real):real;
begin
 if x>y then
  mygreater:=1
 else
  mygreater:=0;
end;

function myless(x,y:real):real;
begin
 if x<y then
  myless:=1
 else
  myless:=0;
end;

function myequal(x,y:real):real;
begin
 if x=y then
  myequal:=1
 else
  myequal:=0;
end;

function myadd(x,y:real):real;
begin
  myadd:=x+y;
end;

function mysub(x,y:real):real;
begin
  mysub:=x-y;
end;

function myeor(x,y:real):real;
begin
  myeor:=trunc(x) xor trunc(y);
end;

function myor(x,y:real):real;
begin
  myor:=trunc(x) or trunc(y);
end;

function mymult(x,y:real):real;
begin
  mymult:=x*y;
end;

function mydivid(x,y:real):real;
begin
  mydivid:=x/y;
end;

function myand(x,y:real):real;
begin
  myand:=trunc(x) and trunc(y);
end;

function mymod(x,y:real):real;
begin
  mymod:=trunc(x) mod trunc(y);
end;

function mydiv(x,y:real):real;
begin
  mydiv:=trunc(x) div trunc(y);
end;

function mypower(x,y:real):real;
begin
 if x=0 then
  mypower:=0
 else
  if x>0 then
   mypower:=exp(y*ln(x))
  else
   if trunc(y)<>y  then
    begin
    writeln (' Fehler in x^y ');
    halt;
    end
   else
    if odd(trunc(y))=true then
     mypower:=-exp(y*ln(-x))
    else
     mypower:=exp(y*ln(-x))
end;

function myshl(x,y:real):real;
begin
  myshl:=trunc(x) shl trunc(y);
end;

function myshr(x,y:real):real;
begin
  myshr:=trunc(x) shr trunc(y);
end;

function mynot(x,y:real):real;
begin
  mynot:=not trunc(x);
end;

function mysinc(x,y:real):real;
begin
if x=0 then
 mysinc:=1
else
 mysinc:=sin(x)/x
end;

function mysinh(x,y:real):real;
begin
mysinh:=0.5*(exp(x)-exp(-x))
end;

function mycosh(x,y:real):real;
begin
mycosh:=0.5*(exp(x)+exp(-x))
end;

function mytanh(x,y:real):real;
begin
mytanh:=mysinh(x,0)/mycosh(x,0)
end;

function mycoth(x,y:real):real;
begin
mycoth:=mycosh(x,0)/mysinh(x,0)
end;

function mysin(x,y:real):real;
begin
mysin:=sin(x)
end;

function mycos(x,y:real):real;
begin
mycos:=cos(x)
end;

function mytan(x,y:real):real;
begin
mytan:=sin(x)/cos(x)
end;

function mycot(x,y:real):real;
begin
mycot:=cos(x)/sin(x)
end;

function mysqrt(x,y:real):real;
begin
mysqrt:=sqrt(x)
end;

function mysqr(x,y:real):real;
begin
mysqr:=sqr(x)
end;

function myarcsinh(x,y:real):real;
begin
myarcsinh:=ln(x+sqrt(sqr(x)+1))
end;

function mysgn(x,y:real):real;
begin
if x=0 then
 mysgn:=0
else
 mysgn:=x/abs(x)
end;

function myarccosh(x,y:real):real;
begin
myarccosh:=ln(x+mysgn(x,0)*sqrt(sqr(x)-1))
end;

function myarctanh(x,y:real):real;
begin
myarctanh:=ln((1+x)/(1-x))/2
end;

function myarccoth(x,y:real):real;
begin
myarccoth:=ln((1-x)/(1+x))/2
end;

function myarcsin(x,y:real):real;
begin
if x=1 then
 myarcsin:=pi/2
else
 myarcsin:=arctan(x/sqrt(1-sqr(x)))
end;

function myarccos(x,y:real):real;
begin
myarccos:=pi/2-myarcsin(x,0)
end;

function myarctan(x,y:real):real;
begin
myarctan:=arctan(x);
end;

function myarccot(x,y:real):real;
begin
myarccot:=pi/2-arctan(x)
end;

function myheavy(x,y:real):real;
begin
myheavy:=mygreater(x,0)
end;

function myfrac(x,y:real):real;
begin
myfrac:=frac(x)
end;

function myexp(x,y:real):real;
begin
myexp:=exp(x)
end;

function myabs(x,y:real):real;
begin
myabs:=abs(x)
end;

function mytrunc(x,y:real):real;
begin
mytrunc:=trunc(x)
end;

function myln(x,y:real):real;
begin
myln:=ln(x)
end;

function myodd(x,y:real):real;
begin
if odd(trunc(x)) then
 myodd:=1
else
 myodd:=0;
end;

function mypred(x,y:real):real;
begin
mypred:=pred(trunc(x));
end;

function mysucc(x,y:real):real;
begin
mysucc:=succ(trunc(x));
end;

function myround(x,y:real):real;
begin
myround:=round(x);
end;

function myint(x,y:real):real;
begin
myint:=int(x);
end;

function myfac(x,y:real):real;
var n : integer;
    r : real;
begin
if x<0 then begin writeln(' Fehler in Fakult?t '); halt; end;
if x = 0 then myfac := 1
else
 begin
 r := 1;
 for n := 1 to trunc ( x ) do
  r := r * n;
 myfac:= r;
 end;
end;

function myrnd(x,y:real):real;
begin
myrnd:=random;
end;

function myrandom(x,y:real):real;
begin
myrandom:=random(trunc(x));
end;

function myevalx(x,y:real):real;
begin
myevalx:=evalx;
end;

function myevaly(x,y:real):real;
begin
myevaly:=evaly;
end;

function myevalz(x,y:real):real;
begin
myevalz:=evalz;
end;

procedure analyse (st:string; var st2,st3:string);
label start;
    var pos:integer;
    value:real;
    newterm,term:string;
begin
term:=st;
start:
  if term='' then begin analysetmp:=myid; st2:='0'; st3:=''; exit; end;
  newterm:='';
  for pos:= 1 to length(term) do
    if copy(term,pos,1)<>' ' then newterm:=newterm+copy(term,pos,1);
  term:=newterm;
  if term='' then begin analysetmp:=myid; st2:='0'; st3:=''; exit; end;
  val(term,value,pos);
  if pos=0 then begin
                  analysetmp:=myid;
                  st2:=term;
                  st3:='';
                  exit;
                end;
  if search(term,'<>',pos) then begin
       analysetmp:=myunequal;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+2,length(term)-pos-1);
       exit;
       end;
  if search(term,'<=',pos) then begin
       analysetmp:=mylessequal;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+2,length(term)-pos-1);
       exit;
       end;
  if search(term,'>=',pos) then begin
       analysetmp:=mygreaterequal;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+2,length(term)-pos-1);
       exit;
       end;
  if search(term,'>',pos) then begin
       analysetmp:=mygreater;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'<',pos) then begin
       analysetmp:=myless;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'=',pos) then begin
       analysetmp:=myequal;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'+',pos) then begin
       analysetmp:=myadd;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'-',pos) then begin
       analysetmp:=mysub;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'eor',pos) then begin
       analysetmp:=myeor;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+3,length(term)-pos-2);
       exit;
       end;
  if search(term,'or',pos) then begin
       analysetmp:=myor;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+2,length(term)-pos-1);
       exit;
       end;
  if search(term,'*',pos) then begin
       analysetmp:=mymult;
       st2:=copy(term,1,pos-1);
       st3:=copy(term,pos+1,length(term)-pos);
       exit;
       end;
  if search(term,'/',pos) then begin
       analysetmp:=mydivid;
       st2:=copy(term,1,pos-1);
...

read more »

 

Re:Math formula routine


Quote
lancepk...@aol.com (LancePKing) wrote:
>Do you know where I could get a *proven* routine to read a mathematical
>equation from a string and return the value?  I will write one - but I'm
>sure someone has already solved this long ago.

There are a couple formula-evaluation components available on the
Delphi Super Page.  IIRC, one of them claims to be 40% faster than
compiled code...

Other Threads