Delphi-一个新算法的表达式求值的函数

發表時間：2007-06-05 13:23:27

IP:219.136.xxx.xxx 訂閱

Delphi-一个新算法的表达式求值的函数
我经过思考，自已做了一个表达式求值的函数，与标准算法不同，这是我闭门造车而成的，目的在于求简单。
一个BUG是小数点0.999999999。。。。。未自动消除为1。时间匆忙，来不及多说，让读者看了再说吧。
另辟溪径也许有利于开拓新思路吧。我这种方法叫逐层去括号法的表达式求值。
更新日期为2007.5.14.我的邮箱是myvbvc@tom.com,QQ:165442523.
程序没有用到递归，只用到循环。
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,StrUtils, Spin;
type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Button1: TButton;
procedure Button1Click(Sender: TObject);

private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function nospace(s:string):string;
begin
result:= stringreplace(s,' ','',[rfReplaceAll]);
end;
function is123(c:char):boolean;
begin
if c in ['0'..'9','.']
then result:=true
else result:=false;
end;
function isminus(s:string;i:integer):boolean ;
var
t:integer;
begin
for t:=i-1 downto 1 do
begin
if s[t]=')' then
begin
result:=false;
break;
end;
if (s[t]='(') and (s[t 1]='-') then
begin
result:=true;
break;
end;
if (not is123(s[t])) and ( not ((s[t]='-') and(s[t-1]='('))) then
begin
result:=false;
break;
end;
end;
end;
function firstJ(s:string):integer ;
var
i,L:integer;
begin
result:=0;
L:=length(s);
for i:=1 to L do
begin
if (s[i]=')') and (not isminus(s,i)) then
begin
result:=i;
break;
end;
end;
end;
function firstC(s:string;firstJ:integer):integer ;
var
t:integer;
begin
for t:=firstJ downto 1 do
begin
if (s[t]='(') and (s[t 1]<>'-') then
begin
result:=t;
break;
end;
end;
end;
function firstsign(s:string):integer ;
var
i:integer;
begin
result:=0;
for i:=1 to length(s) do
if s[i] in [' ','-','*','/'] then
begin
result:=i;
exit;
end;
end;
function firstaddsub(s:string;var sigh:char):integer ;
var
i:integer;
begin
result:=0;
for i:=1 to length(s) do
begin
if s[i]=' ' then
begin
sigh:=' ';
result:=i;
exit;
end;
if (s[i]='-') and (s[i-1]<>'(') then
begin
sigh:='-';
result:=i;
exit;
end;
end;
end;
function firstmultidiv(s:string;var sigh:char):integer ;
var
i:integer;
begin
result:=0;
for i:=1 to length(s) do
begin
if s[i]='*' then
begin
sigh:='*';
result:=i;
exit;
end;
if s[i]='/' then
begin
sigh:='/';
result:=i;
exit;
end;
end;
end;
function firstsignEX(s:string;sigh:char):integer ;
var
i:integer;
begin
result:=0;
for i:=1 to length(s) do
if s[i]=sigh then
begin
result:=i;
exit;
end;
end;
function firstMinussignEX(s:string):integer ;
var
i:integer;
begin
result:=0;
for i:=1 to length(s) do
if (s[i]='-') and (s[i-1]<>'(') then
begin
result:=i;
exit;
end;
end;
function secondsign(s:string):integer ;
var
i,j:integer;
begin
j:=firstsign(s);
for i:=j 1 to length(s) do
if s[i] in [' ','-','*','/'] then
begin
result:=i;
exit;
end;
result:=length(s);
end;
function secondsignEX(s:string;sigh:char):integer ;
var
i,j:integer;
begin
j:=firstsignex(s,sigh);
for i:=j 1 to length(s) do
if s[i] in [' ','-','*','/'] then
begin
result:=i;
exit;
end;
result:=length(s);
end;
function leftnum(s:string;i:integer):double ;
var
t,L:integer;
begin
L:=length(s);
if s[i-1]=')' then
begin
for t:=i-1 downto 1 do
if s[t]='(' then
begin
result:=strtofloat(copy(s,t 1,i-2-t));
exit;
end;
end
else
begin
for t:=i-1 downto 1 do
begin
if not is123(s[t]) then
begin
result:=strtofloat(copy(s,t 1,i-1-t));
exit;
end;
if t=1 then result:=strtofloat(leftstr(s,i-1));
end;
end;

end;
function rightnum(s:string;i:integer):double ;
var
t,L:integer;
begin
L:=length(s);
if s[i 1]='(' then
begin
for t:=i 2 to L do
if s[t]=')' then
begin
result:=strtofloat(copy(s,i 2,t-i-2));
exit;
end;
end
else
begin
for t:=i 1 to L do
begin
if not is123(s[t]) then
begin
result:=strtofloat(copy(s,i 1,t-i-1));
exit;
end;
if t=L then result:=strtofloat(rightstr(s,L-i));
end;
end;
end;
/////////////////////////////////
function leftsigh(s:string;i:integer):integer ;
var
t,L:integer;
begin
L:=length(s);
if s[i-1]=')' then
begin
for t:=i-1 downto 1 do
if s[t]='(' then
begin
result:=t;
exit;
end;
end
else
begin
for t:=i-1 downto 1 do
begin
if not is123(s[t]) then
begin
result:=t 1;
exit;
end;
if t=1 then result:=1;
end;
end;

end;
function rightsigh(s:string;i:integer):integer ;
var
t,L:integer;
begin
L:=length(s);
if s[i 1]='(' then
begin
for t:=i 2 to L do
if s[t]=')' then
begin
result:=t;
exit;
end;
end
else
begin
for t:=i 1 to L do
begin
if not is123(s[t]) then
begin
result:=t-1;
exit;
end;
if t=L then result:=L;
end;
end;
end;
////////////////////////////////////
function nomultidiv(s:string):string ;
var
i,L,le,ri:integer;
j,k:double ;
sigh:char;
begin
while 1=1 do
begin
s:=nospace(s);
result:=s;
L:=length(s);
i:=firstmultidiv(s,sigh);
if (i=0) or (s[i]<>sigh) then exit;
le:=leftsigh(s,i);
j:=leftnum(s,i);
k:=rightnum(s,i);
ri:=rightsigh(s,i);
//if ii if (sigh<>'*') and (sigh<>'/') then break;
if sigh='*' then
if j*k>=0 then
s:=leftstr(s,le-1) floattostr(j*k) rightstr(s,L-ri)
else
s:=leftstr(s,le-1) '(' floattostr(j*k) ')' rightstr(s,L-ri);
if sigh='/' then
if j/k>=0 then
s:=leftstr(s,le-1) floattostr(j/k) rightstr(s,L-ri)
else
s:=leftstr(s,le-1) '(' floattostr(j/k) ')' rightstr(s,L-ri);
end;
result:=s;
end;
function nodiv(s:string):string ;
var
i,L,le,ri:integer;
j,k:double ;
begin
s:=nospace(s);
result:=s;
L:=length(s);
i:=firstsignex(s,'/');
if (i=0) or (s[i]<>'/') then exit;
le:=leftsigh(s,i);
j:=leftnum(s,i);
k:=rightnum(s,i);
ri:=rightsigh(s,i);
if j/k>=0 then
result:=nodiv(leftstr(s,le-1) floattostr(j/k) rightstr(s,L-ri))
else
result:=nodiv(leftstr(s,le-1) '(' floattostr(j/k) ')' rightstr(s,L-ri))
end;
function noaddsub(s:string):string ;
var
i,L,le,ri:integer;
j,k:double ;
sigh:char;
begin
while 1=1 do
begin
s:=nospace(s);
result:=s;
L:=length(s);
i:=firstaddsub(s,sigh);
if (i=0) or (s[i]<>sigh) then exit;
le:=leftsigh(s,i);
j:=leftnum(s,i);
k:=rightnum(s,i);
ri:=rightsigh(s,i);
if (sigh<>' ') and (sigh<>'-') then break;
if sigh=' ' then
if j k>=0 then
s:=leftstr(s,le-1) floattostr(j k) rightstr(s,L-ri)
else
s:=leftstr(s,le-1) '(' floattostr(j k) ')' rightstr(s,L-ri);
if sigh='-' then
if j-k>=0 then
s:=leftstr(s,le-1) floattostr(j-k) rightstr(s,L-ri)
else
s:=leftstr(s,le-1) '(' floattostr(j-k) ')' rightstr(s,L-ri);
end;
result:=s;
end;
function nosub(s:string):string ;
var
i,L,le,ri:integer;
j,k:double ;
begin
s:=nospace(s);
result:=s;
L:=length(s);
i:=firstMinussignEX(s);
if (i=0) or (s[i]<>'-') then exit;
le:=leftsigh(s,i);
j:=leftnum(s,i);
k:=rightnum(s,i);
ri:=rightsigh(s,i);
if j-k>=0 then
result:=nosub(leftstr(s,le-1) floattostr(j-k) rightstr(s,L-ri))
else
result:=nosub(leftstr(s,le-1) '(' floattostr(j-k) ')' rightstr(s,L-ri))
end;
function alltoone(s:string):string ;
begin
s:=nomultidiv(s);
s:=noaddsub(s);
result:=s;
end;

function myexpress(s:string):string;
var
c,j,L:integer;
le,ri,al,substr,s0:string;
tryit:double;
begin
while 1=1 do
begin
s:=nospace(s);
s0:=s;
L:=length(s);
//if (s[1]<>'(') or (s[L]<>')') then
//s:='(' s ')';
//if (s[1]='(') and (s[L]=')') and((s[2]='-') or (isminus(s,L))) then
//s:='(' s ')';
L:=length(s);
j:=firstJ(s);
c:=firstc(s,j);
if j>c then
begin
substr:=copy(s,c 1,j-c-1);
//le:=leftstr(s,c-1);
//ri:= rightstr(s,L-j);
le:=leftstr(s,c-1);
le:=rightstr(le,length(le));
ri:= rightstr(s,L-j);
ri:=leftstr(ri,length(ri));
//showmessage(substr);
al:=alltoone(substr);
//showmessage(le al ri);
s:=le al ri;
end
else
begin
s:=alltoone(s0);
break;
end;
end;
result:=s;
if (result[1]='(') and (result[length(result)]=')') then
result:=copy(result,2,length(result)-2);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit2.Text:=myexpress(edit1.text);
end;

end.

附加檔案：4664f34f9d207_MY__Calculate_OK2.zip