GLPoint的表达式计算内核代码

hcz · 发表于 2011-5-27 21:33:26

本帖最后由 hcz 于 2011-5-29 16:47 编辑

5/29修改，去除与其它GLPoint所用库的关联

本文件改编自Zlib代码的一部分，遵守协议：http://www.gzip.org/zlib/zlib_license.html
除此以外：
-本内容允许fxesms论坛会员查看、使用、研究、修改等
-本内容及修改、演绎等（非商业的计算器程序除外）仅限fxesms论坛会员内部流通
-除由hcz制作或授权外，建立在本内容上的修改、演绎等均遵循本协议，不得删除、修改条款

unit Calc;
interface
uses
Math, Classes;
type
CalcReal = Double;//or Single
const
sopps = '+-*/^';
function evaluate(var s0:string):CalcReal;
function evastring(var s0:string):string;
implementation
////////////////////////////////////////////////////////////////////////////////
//from z_parser
////////////////////////////////////////////////////////////////////////////////
procedure matchbracket(s0:string;var i:integer);
var j:integer;
begin
j := 1;
repeat inc(i);
if i>length(s0) then begin s0 := s0+')';dec(j);end;//raise EparserError.Create('missing '')''');
if s0='(' then inc(j);
if s0=')' then dec(j);
if j<0 then begin s0 := '('+s0;inc(j);inc(i);end; //raise EparserError.Create('missing ''(''');
until j=0;
end;
function getvalue(s0:string):CalcReal;
begin
{if s0 = 'w' then Result := form1.Width
else if s0 = 'h' then Result := form1.Height
...
else if }s0[1] in ['0'..'9','+','-','.'] then Result := strtofloat(s0);
end;
//函数相关
function specialF(p1:integer;s0:string):CalcReal;
var
operstr,tmpstr: string;
aa: TStrings;
bb: array of double;
tmp,tmp2: integer;
begin
Randomize;
operstr := copy(s0,1,p1-1);
s0 := copy(s0,p1,Length(s0)-p1);
aa := TStringList.Create;
aa.Add('');
tmp2 := 1;
for tmp := 1 to Length(s0) do case s0[tmp] of
'(':Inc(tmp2);
')':Dec(tmp2);
',':if tmp2 = 1 then aa.Add('');
else if tmp2 = 1 then aa[aa.Count-1] := aa[aa.Count-1]+s0[tmp];
end;
ExtractStrings([','],[],PChar(copy(s0,p1+1,length(s0)-p1-1)),aa);
SetLength(bb,aa.Count);
for tmp := 0 to aa.Count-1 do begin
tmpstr := aa[tmp];
bb[tmp] := evaluate(tmpstr);
end;
if operstr = 'max' then Result := MaxValue(bb)
else if operstr = 'min' then Result := MinValue(bb)
else if operstr = 'sum' then Result := Sum(bb)
else if operstr = 'sumsqr' then Result := SumOfSquares(bb)
else if operstr = 'std' then Result := StdDev(bb)
else if operstr = 'nprm' then Result := Norm(bb)
else if operstr = 'sgn' then Result := Sign(bb[0])
else if operstr = 'sin' then Result := sin(bb[0])
else if operstr = 'cos' then Result := cos(bb[0])
else if operstr = 'tan' then Result := tan(bb[0])
else if operstr = 'cot' then Result := cot(bb[0])
else if operstr = 'sec' then Result := sec(bb[0])
else if operstr = 'csc' then Result := csc(bb[0])
else if operstr = 'arcsin' then Result := ArcSin(bb[0])
else if operstr = 'arccos' then Result := ArcCos(bb[0])
else if operstr = 'arctan' then begin if Length(bb) > 1 then Result := ArcTan2(bb[0],bb[1]) else Result := ArcTan(bb[0]) end
else if operstr = 'arccot' then begin if Length(bb) > 1 then Result := ArcTan2(bb[1],bb[0]) else Result := ArcCot(bb[0]) end
else if operstr = 'arcsec' then Result := ArcSec(bb[0])
else if operstr = 'arccsc' then Result := ArcCsc(bb[0])
else if operstr = 'sinh' then Result := sinh(bb[0])
else if operstr = 'cosh' then Result := cosh(bb[0])
else if operstr = 'tanh' then Result := tanh(bb[0])
else if operstr = 'coth' then Result := coth(bb[0])
else if operstr = 'sech' then Result := sech(bb[0])
else if operstr = 'csch' then Result := csch(bb[0])
else if operstr = 'arcsinh' then Result := ArcSinh(bb[0])
else if operstr = 'arccosh' then Result := ArcCosh(bb[0])
else if operstr = 'arctanh' then Result := ArcTanh(bb[0])
else if operstr = 'arccoth' then Result := ArcCoth(bb[0])
else if operstr = 'arcsech' then Result := ArcSech(bb[0])
else if operstr = 'arccsch' then Result := ArcCsch(bb[0])
else if operstr = 'deg' then Result := RadToDeg(bb[0])
else if operstr = 'rad' then Result := DegToRad(bb[0])
else if operstr = 'hypot' then Result := Hypot(bb[0],bb[1])
else if operstr = 'div' then Result := Round(bb[0]) div Round(bb[1])
else if operstr = 'mod' then Result := Round(bb[0]) mod Round(bb[1])
else if operstr = 'shl' then Result := Round(bb[0]) shl Round(bb[1])
else if operstr = 'shr' then Result := Round(bb[0]) shr Round(bb[1])
else if operstr = 'log' then begin if Length(bb) > 1 then Result := ln(bb[0])/ln(bb[1]) else Result := log10(bb[0]) end
else if operstr = 'lg' then Result := log10(bb[0])
else if operstr = 'log2' then Result := log2(bb[0])
else if operstr = 'ln' then Result := ln(bb[0])
else if operstr = 'exp' then Result := exp(bb[0])
else if operstr = 'sqrt' then Result := sqrt(bb[0])
else if operstr = 'ceil' then Result := ceil(bb[0])
else if operstr = 'floor' then Result := floor(bb[0])
else if operstr = 'round' then begin if Length(bb) > 1 then Result := RoundTo(bb[0],Round(bb[1])) else Result := Round(bb[0]) end
else if operstr = 'rand' then Result := random(Round(bb[0]))
else if operstr = 'random' then Result := random(Round(bb[0]))
else if operstr = 'randr' then Result := bb[0]*random(65536)/65535
else if operstr = 'randg' then Result := RandG(bb[0],bb[1])
else if operstr = 'time' then Result := ntime[Round(bb[0])]
else if operstr = 'select' then Result := bb[Round(bb[0])]
else if operstr = 'speed' then Result := bb[0]*bb[1] + (1-bb[0])*bb[2]
else if operstr = 'if' then case Length(bb) of
1: Result := Ord(bb[0] > 0);
2: if bb[0] > 0 then Result := bb[1] else Result := 0;
else if bb[0] > 0 then Result := bb[1] else Result := bb[2];
end
else if operstr = 'case' then begin //a in [c..d] then b
Result := 0;
for tmp := 1 to (Length(bb)-1) div 3 do
if (bb[0] >= bb[tmp*3-2]) and (bb[0] <= bb[tmp*3-1]) then Result := Result + bb[tmp*3];
end
else if operstr = 'switch' then begin //a of b (c) d (e) f...>=
if Odd(Length(bb)) then begin SetLength(bb,Length(bb)+1);bb[Length(bb)-1] := 0;end;
if bb[0] < bb[2] then Result := bb[1];
for tmp := 1 to Length(bb) div 2 - 2 do
if (bb[0] >= bb[tmp*2]) and (bb[0] < bb[tmp*2+2]) then Result := bb[tmp*2+1];
if bb[0] >= bb[Length(bb)-2] then Result := bb[Length(bb)-1];
end
else if operstr = 'switch2' then begin //a of b (c) d (e) f...>
if Odd(Length(bb)) then begin SetLength(bb,Length(bb)+1);bb[Length(bb)-1] := 0;end;
if bb[0] <= bb[2] then Result := bb[1];
for tmp := 1 to Length(bb) div 2 - 2 do
if (bb[0] > bb[tmp*2]) and (bb[0] <= bb[tmp*2+2]) then Result := bb[tmp*2+1];
if bb[0] > bb[Length(bb)-2] then Result := bb[Length(bb)-1];
end
{这里可以添加新的函数}
else Result := rcltodo(obj[Round(bb[0])].now,operstr);
aa.Free;
bb := nil;
end;
//简单的计算
function calculate(p1:integer;s0:string):CalcReal;
var v1,v2:CalcReal;ts:string;
begin
ts := copy(s0,1,p1-1);
v1 := evaluate(ts);
ts := copy(s0,p1+1,length(s0)-p1);
v2 := evaluate(ts);
case s0[p1] of
'+': result := v1+v2;
'-': result := v1-v2;
'/': result := v1/v2;
'*': result := v1*v2;
'^': result := exp(v2*ln(v1));
else EparserError.CreateFmt('invalid operation %s',[s0]);
end;
end;
//查找第一个操作符号
function getfirstopp(tot:integer;s0:string):integer;
var i:integer;
begin
if tot=0 then tot := length(s0);
//前面的定义sopps='+-*/^'
for i := 1 to 5 do begin
result := pos(sopps,s0);
//如果找到+-号
if ((i<3) and (result>0)) then
if ((result=1) or (pos(s0[result-1],sopps)>0)) then result := 0;
//如果找到，但是在s0的中间，那么退出，返回运算符号
if result>0 then if result<tot then exit;
end;
//如果找到在tot后，则返回0，即错误的返回
if result>tot then result := 0;
end;
//把空格和tab,enter清理掉
procedure cleanup(var s0:string);
var i:integer;
begin
s0 := lowercase(s0);
i := pos(' ',s0);
while i>0 do
begin
delete(s0,i,1);
i := pos(' ',s0);
end;
i := pos(#9,s0);
while i>0 do
begin
delete(s0,i,1);
i := pos(#9,s0);
end;
i := pos(#10,s0);
while i>0 do
begin
delete(s0,i,1);
i := pos(#10,s0);
end;
i := pos(#13,s0);
while i>0 do
begin
delete(s0,i,1);
i := pos(#13,s0);
end;
end;
//===============主程序的解析计算==============
function evaluate(s0:string):CalcReal;
var
p1,p2,q1:integer;
begin
cleanup(s0);
//如果首行为负号
if pos('-',s0)=1 then s0 := '0'+s0;
p1 := pos('(',s0);
p2 := p1;
//检查括号是否匹配
if p2>0 then matchbracket(p2,s0);
//如果第一个就是'（'那么把前后的括号去掉，继续计算；
if p1=1 then begin
if p2=length(s0) then begin
delete(s0,p2,1);
delete(s0,1,1);
result := evaluate(s0);
end
else result := calculate(p2+1,s0);
exit;
end;
//在第一个不是括号情况下的运算=（普通计算+函数符号计算）
//取得第一个运算符号
q1 := getfirstopp(p1,s0);
//p1=0且q1=0，那么最后的计算值显示
if (p1=0) and (q1=0) then begin
result := getvalue(s0);
//result := strtofloat(s0);
exit;
end;
//运算符号存在
if q1<>0 then result := calculate(q1,s0)
//运算符号不存在，但是括号存在
else if length(s0)>p2 then result := calculate(p2+1,s0)
else result := specialF(p1,s0);
end;
//===============字符串的解析计算==============
function evastring(s0:string):string;//hcz edit
const cchar = '|';
var tmp: integer;bl: Boolean;ps: string;
begin
//if s0[Length(s0)] <> cchar then s0 := s0 + cchar;
result := '';bl := false;
for tmp := 1 to length(s0) do if bl then begin
if s0[tmp] = cchar then begin
if ps<>'' then Result := Result + FloatToStr(evaluate(ps)) else Result := Result + cchar;
bl := false;
end else begin
ps := ps + s0[tmp];
end
end else begin
if s0[tmp] = cchar then begin
ps := '';
bl := true;
end else begin
Result := Result + s0[tmp];
end
end;
if bl then begin
if ps<>'' then Result := Result + FloatToStr(evaluate(ps)) else Result := Result + cchar;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//z_parser end
////////////////////////////////////////////////////////////////////////////////
end.

复制代码

hcz · 发表于 2011-5-27 21:42:49

修改版的设计上对表达式的要求比原版稍宽松，但目前似乎存在一些问题

另外，那个Ttodo属于物件动作容器的一部分，可以无视，下个版本这块会大改

imath · 发表于 2011-5-27 21:51:12

看见这个标题，我就知道一定是hcz！

imath · 发表于 2011-5-27 21:51:35

要是我的话，delphi可能还没入门。

diameter · 发表于 2011-5-27 21:52:22

很好…（虽然我不怎么懂Pascal）
Malical的核心运算代码改天我也放出来（自己写的啊，有点舍不得……）

imath · 发表于 2011-5-27 21:52:34

一定得顶一顶

hcz · 发表于 2011-5-27 22:09:08

本帖最后由 hcz 于 2011-5-27 22:12 编辑

其实这段代码还不太可靠，抄的、改的、加的不怎么协调（有些是违例的，如直接调form1），一些部分得完全重写

我公开代码一部分原因也是希望大家能提出宝贵的意见。。对于表达式的格式上，还有对于函数的功能上（尤其是关于3D坐标的定位）

imath · 发表于 2011-5-27 22:21:53

我连2D Direction都不会用

l5h5t7 · 发表于 2011-5-28 19:41:07

代码被Chrome自动翻译了。

l5h5t7 · 发表于 2011-5-28 19:49:24

我天真的用Free Pascal编译，结果提示3条错误信息，请问应该使用什么编译器？

zhj · 发表于 2011-5-28 20:24:48

应该是Pascal的，建议用Lazarus试试看。
错误信息可能来源：
1.库编译了也没用
2.有一个uses UI;而UI库没有给出。

l5h5t7 · 发表于 2011-5-28 20:40:30

10# l5h5t7

补充，Free Pascal是《Free Pascal 语言与基础算法》书中所附带的CD中的。
DBank外链：http://dl.dbank.com/c06wpczx3a

l5h5t7 · 发表于 2011-5-28 20:41:02

10# l5h5t7

补充，Free Pascal是《Free Pascal 语言与基础算法》书中所附带的CD中的。
DBank外链：http://dl.dbank.com/c06wpczx3a

imath · 发表于 2011-5-28 21:23:58

当然是delphi

l5h5t7 · 发表于 2011-5-29 13:06:59

14# imath

……驴头不对马嘴。

hcz · 发表于 2011-5-29 16:37:19

确实是Delphi，如果要用FP得加上{$Mode Delphi}

还有你得把UI库、Ttodo、getvalue调外部内容的部分去掉，然后引用Math库

hcz · 发表于 2011-5-29 16:49:17

改了下，大致去掉了，不过要使用还得根据具体的程序调整

账号		自动登录	找回密码
密码			注册

[聊天] GLPoint的表达式计算内核代码

相关帖子