论坛 › 聊天与贴图 › GLPoint的表达式计算内核代码

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

GLPoint的表达式计算内核代码

本帖最后由 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 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 of
    '(':Inc(tmp2);
    ')':Dec(tmp2);
    ',':if tmp2 = 1 then aa.Add('');
    else if tmp2 = 1 then aa := aa+s0;
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;
    bb := 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)
else if operstr = 'sin'   then Result := sin(bb)
else if operstr = 'cos'   then Result := cos(bb)
else if operstr = 'tan'   then Result := tan(bb)
else if operstr = 'cot'   then Result := cot(bb)
else if operstr = 'sec'   then Result := sec(bb)
else if operstr = 'csc'   then Result := csc(bb)
else if operstr = 'arcsin'then Result := ArcSin(bb)
else if operstr = 'arccos'then Result := ArcCos(bb)
else if operstr = 'arctan'then begin if Length(bb) > 1 then Result := ArcTan2(bb,bb) else Result := ArcTan(bb) end
else if operstr = 'arccot'then begin if Length(bb) > 1 then Result := ArcTan2(bb,bb) else Result := ArcCot(bb) end
else if operstr = 'arcsec'then Result := ArcSec(bb)
else if operstr = 'arccsc'then Result := ArcCsc(bb)
else if operstr = 'sinh'    then Result := sinh(bb)
else if operstr = 'cosh'    then Result := cosh(bb)
else if operstr = 'tanh'    then Result := tanh(bb)
else if operstr = 'coth'    then Result := coth(bb)
else if operstr = 'sech'    then Result := sech(bb)
else if operstr = 'csch'    then Result := csch(bb)
else if operstr = 'arcsinh' then Result := ArcSinh(bb)
else if operstr = 'arccosh' then Result := ArcCosh(bb)
else if operstr = 'arctanh' then Result := ArcTanh(bb)
else if operstr = 'arccoth' then Result := ArcCoth(bb)
else if operstr = 'arcsech' then Result := ArcSech(bb)
else if operstr = 'arccsch' then Result := ArcCsch(bb)
else if operstr = 'deg'   then Result := RadToDeg(bb)
else if operstr = 'rad'   then Result := DegToRad(bb)
else if operstr = 'hypot'   then Result := Hypot(bb,bb)
else if operstr = 'div'   then Result := Round(bb) div Round(bb)
else if operstr = 'mod'   then Result := Round(bb) mod Round(bb)
else if operstr = 'shl'   then Result := Round(bb) shl Round(bb)
else if operstr = 'shr'   then Result := Round(bb) shr Round(bb)
else if operstr = 'log'   then begin if Length(bb) > 1 then Result := ln(bb)/ln(bb) else Result := log10(bb) end
else if operstr = 'lg'      then Result := log10(bb)
else if operstr = 'log2'    then Result := log2(bb)
else if operstr = 'ln'      then Result := ln(bb)
else if operstr = 'exp'   then Result := exp(bb)
else if operstr = 'sqrt'    then Result := sqrt(bb)
else if operstr = 'ceil'    then Result := ceil(bb)
else if operstr = 'floor'   then Result := floor(bb)
else if operstr = 'round'   then begin if Length(bb) > 1 then Result := RoundTo(bb,Round(bb)) else Result := Round(bb) end
else if operstr = 'rand'    then Result := random(Round(bb))
else if operstr = 'random'then Result := random(Round(bb))
else if operstr = 'randr'   then Result := bb*random(65536)/65535
else if operstr = 'randg'   then Result := RandG(bb,bb)
else if operstr = 'time'    then Result := ntime)]
else if operstr = 'select'then Result := bb)]         
else if operstr = 'speed'   then Result := bb*bb + (1-bb)*bb
else if operstr = 'if'      then case Length(bb) of
    1: Result := Ord(bb > 0);
    2: if bb > 0 then Result := bb else Result := 0;
    else if bb > 0 then Result := bb else Result := bb;
end
else if operstr = 'case'    then begin //a in then b
    Result := 0;
    for tmp := 1 to (Length(bb)-1) div 3 do
      if (bb >= bb) and (bb <= bb) then Result := Result + bb;
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 := 0;end;
    if bb < bb then Result := bb;
    for tmp := 1 to Length(bb) div 2 - 2 do
      if (bb >= bb) and (bb < bb) then Result := bb;
    if bb >= bb then Result := bb;
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 := 0;end;
    if bb <= bb then Result := bb;
    for tmp := 1 to Length(bb) div 2 - 2 do
      if (bb > bb) and (bb <= bb) then Result := bb;
    if bb > bb then Result := bb;
end



{这里可以添加新的函数}

else Result := rcltodo(obj)].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 of
      '+': result := v1+v2;
      '-': result := v1-v2;
      '/': result := v1/v2;
      '*': result := v1*v2;
      '^': result := exp(v2*ln(v1));
   else EparserError.CreateFmt('invalid operation %s',);
   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,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 <> cchar then s0 := s0 + cchar;
result := '';bl := false;

for tmp := 1 to length(s0) do if bl then begin
    if s0 = cchar then begin
      if ps<>'' then Result := Result + FloatToStr(evaluate(ps)) else Result := Result + cchar;
      bl := false;
    end else begin
      ps := ps + s0;
    end
end else begin
    if s0 = cchar then begin
      ps := '';
      bl := true;
    end else begin
      Result := Result + s0;
    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的表达式计算内核代码