Преобразование строки в математическое выражение и получение результата.

Представляю Вашему вниманию компонент, на вход которого подаётся строка, содержащая математическое выражение, а на выходе результат вычисления этого выражения. При необходимости Вам не составит труда добавить в компонент такие функции как sin,cos,log,tan и т.д. Единственная неприятность, это присутствие глюка. Если ввести строку типа '5* -3', то мы получим ошибку. Я обязательно в ближайшее время постараюсь исправить данный баг.

Совместимость: Delphi 4.x (или выше)

Собственно сам исходничек:

unit MathComponent; 

interface 

uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,math; 


type 
TMathtype=(mtnil,mtoperator,mtlbracket,mtrbracket,mtoperand); 

type 
TMathOperatortype=(monone,moadd,mosub,modiv,momul,mopow); 

type 
pmathchar = ^Tmathchar; 
TMathChar = record 
  case mathtype: Tmathtype of 
   mtoperand:(data:extended); 
   mtoperator:(op:TMathOperatortype); 
end; 

type 
  TMathControl = class(TComponent) 
  private 
   input,output,stack:array of tmathchar; 
   fmathstring:string; 
   function getresult:extended; 
   function calculate(operand1,operand2,operator:Tmathchar):extended; 
   function getoperator(c:char):TMathOperatortype; 
   function getoperand(mid:integer;var len:integer):extended; 
   procedure processstring; 
   procedure convertinfixtopostfix; 
   function isdigit(c:char):boolean; 
   function isoperator(c:char):boolean; 
   function getprecedence(mop:TMathOperatortype):integer; 
  protected 
  published 
   property MathExpression:string read fmathstring write fmathstring; 
   property MathResult:extended read getresult; 
  end; 

procedure Register; 

implementation 

function Tmathcontrol.calculate(operand1,operand2,operator:Tmathchar):extended; 
begin 
result:=0; 
case operator.op of 
  moadd: 
   result:=operand1.data + operand2.data; 
  mosub: 
   result:=operand1.data - operand2.data; 
  momul: 
   result:=operand1.data * operand2.data; 
  modiv: 
   if (operand1.data<>0) and (operand2.data<>0) then 
    result:=operand1.data / operand2.data 
   else 
    result:=0; 
  mopow: result:=power(operand1.data,operand2.data); 
end; 
end; 

function Tmathcontrol.getresult:extended; 
var 
i:integer; 
tmp1,tmp2,tmp3:tmathchar; 
begin 
convertinfixtopostfix; 
setlength(stack,0); 
for i:=0 to length(output)-1 do 
  begin 
   if output[i].mathtype=mtoperand then 
    begin 
     setlength(stack,length(stack)+1); 
     stack[length(stack)-1]:=output[i]; 
    end 
   else if output[i].mathtype=mtoperator then 
    begin 
      tmp1:=stack[length(stack)-1]; 
      tmp2:=stack[length(stack)-2]; 
      setlength(stack,length(stack)-2); 
      tmp3.mathtype:=mtoperand; 
      tmp3.data:=calculate(tmp2,tmp1,output[i]); 
      setlength(stack,length(stack)+1); 
      stack[length(stack)-1]:=tmp3; 
    end; 
  end; 
result:=stack[0].data; 
setlength(stack,0); 
setlength(input,0); 
setlength(output,0); 
end; 

function Tmathcontrol.getoperator(c:char):TMathOperatortype; 
begin 
result:=monone; 
if c='+' then 
  result:=moadd 
else if c='*' then 
  result:=momul 
else if c='/' then 
  result:=modiv 
else if c='-' then 
  result:=mosub 
else if c='^' then 
  result:=mopow; 
end; 

function Tmathcontrol.getoperand(mid:integer;var len:integer):extended; 
var 
i,j:integer; 
tmpnum:string; 
begin 
j:=1; 
for i:=mid to length(fmathstring)-1 do 
  begin 
   if isdigit(fmathstring[i]) then 
    begin 
     if j<=20 then 
      tmpnum:=tmpnum+fmathstring[i]; 
     j:=j+1; 
    end 
   else 
    break; 
  end; 
result:=strtofloat(tmpnum); 
len:=length(tmpnum); 
end; 

procedure Tmathcontrol.processstring; 
var 
i:integer; 
numlen:integer; 
begin 
i:=0; 
numlen:=0; 
setlength(output,0); 
setlength(input,0); 
setlength(stack,0); 
fmathstring:='('+fmathstring+')'; 
setlength(input,length(fmathstring)); 
while i<=length(fmathstring)-1 do 
  begin 
   if fmathstring[i+1]='(' then 
    begin 
     input[i].mathtype:=mtlbracket; 
     i:=i+1; 
    end 
   else if fmathstring[i+1]=')' then 
    begin 
     input[i].mathtype:=mtrbracket; 
     i:=i+1; 
    end 
   else if isoperator(fmathstring[i+1]) then 
    begin 
     input[i].mathtype:=mtoperator; 
     input[i].op:=getoperator(fmathstring[i+1]); 
     i:=i+1; 
    end 
   else if isdigit(fmathstring[i+1]) then 
    begin 
     input[i].mathtype:=mtoperand; 
     input[i].data:=getoperand(i+1,numlen); 
     i:=i+numlen; 
    end; 
  end; 
end; 


function Tmathcontrol.isoperator(c:char):boolean; 
begin 
result:=false; 
if (c='+') or (c='-') or (c='*') or (c='/') or (c='^') then 
  result:=true; 
end; 

function Tmathcontrol.isdigit(c:char):boolean; 
begin 
result:=false; 
if ((integer(c)> 47) and (integer(c)< 58)) or (c='.') then 
  result:=true; 
end; 

function Tmathcontrol.getprecedence(mop:TMathOperatortype):integer; 
begin 
result:=-1; 
case mop of 
  moadd:result:=1; 
  mosub:result:=1; 
  momul:result:=2; 
  modiv:result:=2; 
  mopow:result:=3; 
end; 
end; 

procedure Tmathcontrol.convertinfixtopostfix; 
var 
i,j,prec:integer; 
begin 
processstring; 
for i:=0 to length(input)-1 do 
  begin 
   if input[i].mathtype=mtoperand then 
    begin 
     setlength(output,length(output)+1); 
     output[length(output)-1]:=input[i]; 
    end 
   else if input[i].mathtype=mtlbracket then 
    begin 
     setlength(stack,length(stack)+1); 
     stack[length(stack)-1]:=input[i]; 
    end 
   else if input[i].mathtype=mtoperator then 
    begin 
     prec:=getprecedence(input[i].op); 
     j:=length(stack)-1; 
     if j>=0 then 
      begin 
       while(getprecedence(stack[j].op)>=prec) and (j>=0) do 
        begin 
         setlength(output,length(output)+1); 
         output[length(output)-1]:=stack[j]; 
         setlength(stack,length(stack)-1); 
         j:=j-1; 
        end; 
       setlength(stack,length(stack)+1); 
       stack[length(stack)-1]:=input[i]; 
      end; 
    end 
   else if input[i].mathtype=mtrbracket then 
    begin 
     j:=length(stack)-1; 
     if j>=0 then 
      begin 
       while(stack[j].mathtype<>mtlbracket) and (j>=0) do 
        begin 
         setlength(output,length(output)+1); 
         output[length(output)-1]:=stack[j]; 
         setlength(stack,length(stack)-1); 
         j:=j-1; 
        end; 
       if j>=0 then 
        setlength(stack,length(stack)-1); 
      end; 
    end; 
  end; 
end; 


procedure Register; 
begin 
  RegisterComponents('Samples', [TMathControl]); 
end; 

end. 

1.

Аноним

20 апреля 2006, 09:24:07

Зачем все это? Юзайте msscript activex control.

2.

Аноним

21 мая 2004, 15:33:33

выдает ошибку EAccessViolation на инструкции setlength
что с этим делать?