设为首页收藏本站

cnCalc计算器论坛

 找回密码
 注册
搜索
cnCalc计算器论坛»论坛 › 杂类版块 › 聊天与贴图 › GLPoint的表达式计算内核代码
返回列表 发新帖
查看: 3395|回复: 16

[聊天] 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制作或授权外，建立在本内容上的修改、演绎等均遵循本协议，不得删除、修改条款
  1. unit Calc;

  3. interface

  5. uses
  6.   Math, Classes;

  8. type
  9.   CalcReal = Double;//or Single

  11. const
  12.   sopps   = '+-*/^';

  14. function evaluate(var s0:string):CalcReal;
  15. function evastring(var s0:string):string;

  17. implementation

  19. ////////////////////////////////////////////////////////////////////////////////
  20. //from z_parser
  21. ////////////////////////////////////////////////////////////////////////////////
  22. procedure matchbracket(s0:string;var i:integer);
  23.    var j:integer;
  24. begin
  25.   j := 1;
  26.   repeat inc(i);
  27.     if i>length(s0) then begin s0 := s0+')';dec(j);end;//raise EparserError.Create('missing '')''');
  28.     if s0='(' then inc(j);
  29.     if s0=')' then dec(j);
  30.     if j<0 then begin s0 := '('+s0;inc(j);inc(i);end;  //raise EparserError.Create('missing ''(''');
  31.   until j=0;
  32. end;

  34. function getvalue(s0:string):CalcReal;
  35. begin
  36.        {if s0 = 'w' then Result := form1.Width
  37.   else if s0 = 'h' then Result := form1.Height
  38.   ...
  39.   else if }s0[1] in ['0'..'9','+','-','.'] then Result := strtofloat(s0);
  40. end;


  43. //函数相关
  44. function specialF(p1:integer;s0:string):CalcReal;
  45. var
  46.   operstr,tmpstr: string;
  47.   aa: TStrings;
  48.   bb: array of double;
  49.   tmp,tmp2: integer;
  50. begin
  51.   Randomize;

  53.   operstr := copy(s0,1,p1-1);
  54.   s0 := copy(s0,p1,Length(s0)-p1);
  55.   aa := TStringList.Create;
  56.   aa.Add('');
  57.   tmp2 := 1;
  58.   for tmp := 1 to Length(s0) do case s0[tmp] of
  59.     '(':Inc(tmp2);
  60.     ')':Dec(tmp2);
  61.     ',':if tmp2 = 1 then aa.Add('');
  62.     else if tmp2 = 1 then aa[aa.Count-1] := aa[aa.Count-1]+s0[tmp];
  63.   end;
  64.   ExtractStrings([','],[],PChar(copy(s0,p1+1,length(s0)-p1-1)),aa);
  65.   SetLength(bb,aa.Count);
  66.   for tmp := 0 to aa.Count-1 do begin
  67.     tmpstr := aa[tmp];
  68.     bb[tmp] := evaluate(tmpstr);
  69.   end;

  71.        if operstr = 'max'     then Result := MaxValue(bb)
  72.   else if operstr = 'min'     then Result := MinValue(bb)
  73.   else if operstr = 'sum'     then Result := Sum(bb)
  74.   else if operstr = 'sumsqr'  then Result := SumOfSquares(bb)
  75.   else if operstr = 'std'     then Result := StdDev(bb)
  76.   else if operstr = 'nprm'    then Result := Norm(bb)         
  77.   else if operstr = 'sgn'     then Result := Sign(bb[0])
  78.   else if operstr = 'sin'     then Result := sin(bb[0])
  79.   else if operstr = 'cos'     then Result := cos(bb[0])
  80.   else if operstr = 'tan'     then Result := tan(bb[0])
  81.   else if operstr = 'cot'     then Result := cot(bb[0])
  82.   else if operstr = 'sec'     then Result := sec(bb[0])
  83.   else if operstr = 'csc'     then Result := csc(bb[0])
  84.   else if operstr = 'arcsin'  then Result := ArcSin(bb[0])
  85.   else if operstr = 'arccos'  then Result := ArcCos(bb[0])
  86.   else if operstr = 'arctan'  then begin if Length(bb) > 1 then Result := ArcTan2(bb[0],bb[1]) else Result := ArcTan(bb[0]) end
  87.   else if operstr = 'arccot'  then begin if Length(bb) > 1 then Result := ArcTan2(bb[1],bb[0]) else Result := ArcCot(bb[0]) end
  88.   else if operstr = 'arcsec'  then Result := ArcSec(bb[0])
  89.   else if operstr = 'arccsc'  then Result := ArcCsc(bb[0])
  90.   else if operstr = 'sinh'    then Result := sinh(bb[0])
  91.   else if operstr = 'cosh'    then Result := cosh(bb[0])
  92.   else if operstr = 'tanh'    then Result := tanh(bb[0])
  93.   else if operstr = 'coth'    then Result := coth(bb[0])
  94.   else if operstr = 'sech'    then Result := sech(bb[0])
  95.   else if operstr = 'csch'    then Result := csch(bb[0])
  96.   else if operstr = 'arcsinh' then Result := ArcSinh(bb[0])
  97.   else if operstr = 'arccosh' then Result := ArcCosh(bb[0])
  98.   else if operstr = 'arctanh' then Result := ArcTanh(bb[0])
  99.   else if operstr = 'arccoth' then Result := ArcCoth(bb[0])
  100.   else if operstr = 'arcsech' then Result := ArcSech(bb[0])
  101.   else if operstr = 'arccsch' then Result := ArcCsch(bb[0])
  102.   else if operstr = 'deg'     then Result := RadToDeg(bb[0])
  103.   else if operstr = 'rad'     then Result := DegToRad(bb[0])
  104.   else if operstr = 'hypot'   then Result := Hypot(bb[0],bb[1])
  105.   else if operstr = 'div'     then Result := Round(bb[0]) div Round(bb[1])
  106.   else if operstr = 'mod'     then Result := Round(bb[0]) mod Round(bb[1])
  107.   else if operstr = 'shl'     then Result := Round(bb[0]) shl Round(bb[1])
  108.   else if operstr = 'shr'     then Result := Round(bb[0]) shr Round(bb[1])
  109.   else if operstr = 'log'     then begin if Length(bb) > 1 then Result := ln(bb[0])/ln(bb[1]) else Result := log10(bb[0]) end
  110.   else if operstr = 'lg'      then Result := log10(bb[0])
  111.   else if operstr = 'log2'    then Result := log2(bb[0])
  112.   else if operstr = 'ln'      then Result := ln(bb[0])
  113.   else if operstr = 'exp'     then Result := exp(bb[0])
  114.   else if operstr = 'sqrt'    then Result := sqrt(bb[0])
  115.   else if operstr = 'ceil'    then Result := ceil(bb[0])
  116.   else if operstr = 'floor'   then Result := floor(bb[0])
  117.   else if operstr = 'round'   then begin if Length(bb) > 1 then Result := RoundTo(bb[0],Round(bb[1])) else Result := Round(bb[0]) end
  118.   else if operstr = 'rand'    then Result := random(Round(bb[0]))
  119.   else if operstr = 'random'  then Result := random(Round(bb[0]))
  120.   else if operstr = 'randr'   then Result := bb[0]*random(65536)/65535
  121.   else if operstr = 'randg'   then Result := RandG(bb[0],bb[1])
  122.   else if operstr = 'time'    then Result := ntime[Round(bb[0])]
  123.   else if operstr = 'select'  then Result := bb[Round(bb[0])]         
  124.   else if operstr = 'speed'   then Result := bb[0]*bb[1] + (1-bb[0])*bb[2]
  125.   else if operstr = 'if'      then case Length(bb) of
  126.     1: Result := Ord(bb[0] > 0);
  127.     2: if bb[0] > 0 then Result := bb[1] else Result := 0;
  128.     else if bb[0] > 0 then Result := bb[1] else Result := bb[2];
  129.   end
  130.   else if operstr = 'case'    then begin //a in [c..d] then b
  131.     Result := 0;
  132.     for tmp := 1 to (Length(bb)-1) div 3 do
  133.       if (bb[0] >= bb[tmp*3-2]) and (bb[0] <= bb[tmp*3-1]) then Result := Result + bb[tmp*3];
  134.   end
  135.   else if operstr = 'switch'  then begin //a of b (c) d (e) f...>=
  136.     if Odd(Length(bb)) then begin SetLength(bb,Length(bb)+1);bb[Length(bb)-1] := 0;end;
  137.     if bb[0] < bb[2] then Result := bb[1];
  138.     for tmp := 1 to Length(bb) div 2 - 2 do
  139.       if (bb[0] >= bb[tmp*2]) and (bb[0] < bb[tmp*2+2]) then Result := bb[tmp*2+1];
  140.     if bb[0] >= bb[Length(bb)-2] then Result := bb[Length(bb)-1];
  141.   end
  142.   else if operstr = 'switch2' then begin //a of b (c) d (e) f...>
  143.     if Odd(Length(bb)) then begin SetLength(bb,Length(bb)+1);bb[Length(bb)-1] := 0;end;
  144.     if bb[0] <= bb[2] then Result := bb[1];
  145.     for tmp := 1 to Length(bb) div 2 - 2 do
  146.       if (bb[0] > bb[tmp*2]) and (bb[0] <= bb[tmp*2+2]) then Result := bb[tmp*2+1];
  147.     if bb[0] > bb[Length(bb)-2] then Result := bb[Length(bb)-1];
  148.   end



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

  154.   else Result := rcltodo(obj[Round(bb[0])].now,operstr);

  156.   aa.Free;
  157.   bb := nil;

  159. end;

  161. //简单的计算
  162. function calculate(p1:integer;s0:string):CalcReal;
  163.    var v1,v2:CalcReal;ts:string;
  164. begin
  165.    ts := copy(s0,1,p1-1);
  166.    v1 := evaluate(ts);
  167.    ts := copy(s0,p1+1,length(s0)-p1);
  168.    v2 := evaluate(ts);
  169.    case s0[p1] of
  170.         '+': result := v1+v2;
  171.         '-': result := v1-v2;
  172.         '/': result := v1/v2;
  173.         '*': result := v1*v2;
  174.         '^': result := exp(v2*ln(v1));
  175.    else EparserError.CreateFmt('invalid operation %s',[s0]);
  176.    end;
  177. end;

  179. //查找第一个操作符号
  180. function getfirstopp(tot:integer;s0:string):integer;
  181. var i:integer;
  182. begin
  183.    if tot=0 then tot := length(s0);
  184.    //前面的定义sopps='+-*/^'
  185.    for i := 1 to 5 do begin
  186.          result := pos(sopps,s0);
  187.          //如果找到+-号
  188.          if ((i<3) and (result>0)) then
  189.            if ((result=1) or (pos(s0[result-1],sopps)>0)) then result := 0;
  190.          //如果找到，但是在s0的中间，那么退出，返回运算符号
  191.          if result>0 then if result<tot then exit;
  192.    end;
  193.    //如果找到在tot后，则返回0，即错误的返回
  194.    if result>tot then result := 0;
  195. end;

  197. //把空格和tab,enter清理掉
  198. procedure cleanup(var s0:string);
  199. var i:integer;
  200. begin
  201.   s0 := lowercase(s0);
  202.   i := pos(' ',s0);
  203.   while i>0 do
  204.   begin
  205.     delete(s0,i,1);
  206.     i := pos(' ',s0);
  207.   end;  
  208.   i := pos(#9,s0);
  209.   while i>0 do
  210.   begin
  211.     delete(s0,i,1);
  212.     i := pos(#9,s0);
  213.   end;
  214.   i := pos(#10,s0);
  215.   while i>0 do
  216.   begin
  217.     delete(s0,i,1);
  218.     i := pos(#10,s0);
  219.   end;
  220.   i := pos(#13,s0);
  221.   while i>0 do
  222.   begin
  223.     delete(s0,i,1);
  224.     i := pos(#13,s0);
  225.   end;

  227. end;

  229. //===============主程序的解析计算==============
  230. function evaluate(s0:string):CalcReal;
  231. var
  232.    p1,p2,q1:integer;
  233. begin
  234.    cleanup(s0);
  235.    //如果首行为负号
  236.    if pos('-',s0)=1 then s0 := '0'+s0;
  237.    p1 := pos('(',s0);
  238.    p2 := p1;
  239.    //检查括号是否匹配
  240.    if p2>0 then matchbracket(p2,s0);
  241.    //如果第一个就是'（'那么把前后的括号去掉，继续计算；
  242.    if p1=1 then begin
  243.                 if p2=length(s0) then begin
  244.                                       delete(s0,p2,1);
  245.                                       delete(s0,1,1);
  246.                                       result := evaluate(s0);
  247.                                       end
  248.                                  else result := calculate(p2+1,s0);
  249.                 exit;
  250.    end;
  251.    //在第一个不是括号情况下的运算=（普通计算+函数符号计算）
  252.    //取得第一个运算符号
  253.    q1 := getfirstopp(p1,s0);
  254.    //p1=0且q1=0，那么最后的计算值显示
  255.    if (p1=0) and (q1=0) then begin
  256.                      result := getvalue(s0);
  257.                      //result := strtofloat(s0);
  258.                      exit;
  259.    end;
  260.    //运算符号存在
  261.    if q1<>0 then result := calculate(q1,s0)
  262.                //运算符号不存在，但是括号存在
  263.                else if length(s0)>p2 then result := calculate(p2+1,s0)
  264.                                      else result := specialF(p1,s0);


  267. end;
  268.      
  269. //===============字符串的解析计算==============
  270. function evastring(s0:string):string;//hcz edit
  271. const cchar = '|';
  272. var tmp: integer;bl: Boolean;ps: string;
  273. begin
  274.   //if s0[Length(s0)] <> cchar then s0 := s0 + cchar;
  275.   result := '';bl := false;

  277.   for tmp := 1 to length(s0) do if bl then begin
  278.     if s0[tmp] = cchar then begin
  279.       if ps<>'' then Result := Result + FloatToStr(evaluate(ps)) else Result := Result + cchar;
  280.       bl := false;
  281.     end else begin
  282.       ps := ps + s0[tmp];
  283.     end
  284.   end else begin
  285.     if s0[tmp] = cchar then begin
  286.       ps := '';
  287.       bl := true;
  288.     end else begin
  289.       Result := Result + s0[tmp];
  290.     end
  291.   end;

  293.   if bl then begin
  294.     if ps<>'' then Result := Result + FloatToStr(evaluate(ps)) else Result := Result + cchar;
  295.   end;
  296.   
  297. end;
  298. ////////////////////////////////////////////////////////////////////////////////
  299. //z_parser end
  300. ////////////////////////////////////////////////////////////////////////////////
  301. end.
复制代码
Function, 会员, 计算器, 论坛

相关帖子
回复

使用道具 举报

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 | 显示全部楼层
改了下，大致去掉了，不过要使用还得根据具体的程序调整
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

Archiver|手机版|cnCalc计算器论坛

GMT+8, 2024-11-22 04:44 , Processed in 0.063991 second(s), 23 queries .

Powered by Discuz! X3.4

© 2001-2023 Discuz! Team.

快速回复 返回顶部 返回列表