cnCalc计算器论坛

 找回密码
 注册
搜索
查看: 3055|回复: 16

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

[复制链接]
发表于 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;

  2. interface

  3. uses
  4.   Math, Classes;

  5. type
  6.   CalcReal = Double;//or Single

  7. const
  8.   sopps   = '+-*/^';

  9. function evaluate(var s0:string):CalcReal;
  10. function evastring(var s0:string):string;

  11. implementation

  12. ////////////////////////////////////////////////////////////////////////////////
  13. //from z_parser
  14. ////////////////////////////////////////////////////////////////////////////////
  15. procedure matchbracket(s0:string;var i:integer);
  16.    var j:integer;
  17. begin
  18.   j := 1;
  19.   repeat inc(i);
  20.     if i>length(s0) then begin s0 := s0+')';dec(j);end;//raise EparserError.Create('missing '')''');
  21.     if s0='(' then inc(j);
  22.     if s0=')' then dec(j);
  23.     if j<0 then begin s0 := '('+s0;inc(j);inc(i);end;  //raise EparserError.Create('missing ''(''');
  24.   until j=0;
  25. end;

  26. function getvalue(s0:string):CalcReal;
  27. begin
  28.        {if s0 = 'w' then Result := form1.Width
  29.   else if s0 = 'h' then Result := form1.Height
  30.   ...
  31.   else if }s0[1] in ['0'..'9','+','-','.'] then Result := strtofloat(s0);
  32. end;


  33. //函数相关
  34. function specialF(p1:integer;s0:string):CalcReal;
  35. var
  36.   operstr,tmpstr: string;
  37.   aa: TStrings;
  38.   bb: array of double;
  39.   tmp,tmp2: integer;
  40. begin
  41.   Randomize;

  42.   operstr := copy(s0,1,p1-1);
  43.   s0 := copy(s0,p1,Length(s0)-p1);
  44.   aa := TStringList.Create;
  45.   aa.Add('');
  46.   tmp2 := 1;
  47.   for tmp := 1 to Length(s0) do case s0[tmp] of
  48.     '(':Inc(tmp2);
  49.     ')':Dec(tmp2);
  50.     ',':if tmp2 = 1 then aa.Add('');
  51.     else if tmp2 = 1 then aa[aa.Count-1] := aa[aa.Count-1]+s0[tmp];
  52.   end;
  53.   ExtractStrings([','],[],PChar(copy(s0,p1+1,length(s0)-p1-1)),aa);
  54.   SetLength(bb,aa.Count);
  55.   for tmp := 0 to aa.Count-1 do begin
  56.     tmpstr := aa[tmp];
  57.     bb[tmp] := evaluate(tmpstr);
  58.   end;

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



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

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

  139.   aa.Free;
  140.   bb := nil;

  141. end;

  142. //简单的计算
  143. function calculate(p1:integer;s0:string):CalcReal;
  144.    var v1,v2:CalcReal;ts:string;
  145. begin
  146.    ts := copy(s0,1,p1-1);
  147.    v1 := evaluate(ts);
  148.    ts := copy(s0,p1+1,length(s0)-p1);
  149.    v2 := evaluate(ts);
  150.    case s0[p1] of
  151.         '+': result := v1+v2;
  152.         '-': result := v1-v2;
  153.         '/': result := v1/v2;
  154.         '*': result := v1*v2;
  155.         '^': result := exp(v2*ln(v1));
  156.    else EparserError.CreateFmt('invalid operation %s',[s0]);
  157.    end;
  158. end;

  159. //查找第一个操作符号
  160. function getfirstopp(tot:integer;s0:string):integer;
  161. var i:integer;
  162. begin
  163.    if tot=0 then tot := length(s0);
  164.    //前面的定义sopps='+-*/^'
  165.    for i := 1 to 5 do begin
  166.          result := pos(sopps,s0);
  167.          //如果找到+-号
  168.          if ((i<3) and (result>0)) then
  169.            if ((result=1) or (pos(s0[result-1],sopps)>0)) then result := 0;
  170.          //如果找到,但是在s0的中间,那么退出,返回运算符号
  171.          if result>0 then if result<tot then exit;
  172.    end;
  173.    //如果找到在tot后,则返回0,即错误的返回
  174.    if result>tot then result := 0;
  175. end;

  176. //把空格和tab,enter清理掉
  177. procedure cleanup(var s0:string);
  178. var i:integer;
  179. begin
  180.   s0 := lowercase(s0);
  181.   i := pos(' ',s0);
  182.   while i>0 do
  183.   begin
  184.     delete(s0,i,1);
  185.     i := pos(' ',s0);
  186.   end;  
  187.   i := pos(#9,s0);
  188.   while i>0 do
  189.   begin
  190.     delete(s0,i,1);
  191.     i := pos(#9,s0);
  192.   end;
  193.   i := pos(#10,s0);
  194.   while i>0 do
  195.   begin
  196.     delete(s0,i,1);
  197.     i := pos(#10,s0);
  198.   end;
  199.   i := pos(#13,s0);
  200.   while i>0 do
  201.   begin
  202.     delete(s0,i,1);
  203.     i := pos(#13,s0);
  204.   end;

  205. end;

  206. //===============主程序的解析计算==============
  207. function evaluate(s0:string):CalcReal;
  208. var
  209.    p1,p2,q1:integer;
  210. begin
  211.    cleanup(s0);
  212.    //如果首行为负号
  213.    if pos('-',s0)=1 then s0 := '0'+s0;
  214.    p1 := pos('(',s0);
  215.    p2 := p1;
  216.    //检查括号是否匹配
  217.    if p2>0 then matchbracket(p2,s0);
  218.    //如果第一个就是'('那么把前后的括号去掉,继续计算;
  219.    if p1=1 then begin
  220.                 if p2=length(s0) then begin
  221.                                       delete(s0,p2,1);
  222.                                       delete(s0,1,1);
  223.                                       result := evaluate(s0);
  224.                                       end
  225.                                  else result := calculate(p2+1,s0);
  226.                 exit;
  227.    end;
  228.    //在第一个不是括号情况下的运算=(普通计算+函数符号计算)
  229.    //取得第一个运算符号
  230.    q1 := getfirstopp(p1,s0);
  231.    //p1=0且q1=0,那么最后的计算值显示
  232.    if (p1=0) and (q1=0) then begin
  233.                      result := getvalue(s0);
  234.                      //result := strtofloat(s0);
  235.                      exit;
  236.    end;
  237.    //运算符号存在
  238.    if q1<>0 then result := calculate(q1,s0)
  239.                //运算符号不存在,但是括号存在
  240.                else if length(s0)>p2 then result := calculate(p2+1,s0)
  241.                                      else result := specialF(p1,s0);


  242. end;
  243.      
  244. //===============字符串的解析计算==============
  245. function evastring(s0:string):string;//hcz edit
  246. const cchar = '|';
  247. var tmp: integer;bl: Boolean;ps: string;
  248. begin
  249.   //if s0[Length(s0)] <> cchar then s0 := s0 + cchar;
  250.   result := '';bl := false;

  251.   for tmp := 1 to length(s0) do if bl then begin
  252.     if s0[tmp] = cchar then begin
  253.       if ps<>'' then Result := Result + FloatToStr(evaluate(ps)) else Result := Result + cchar;
  254.       bl := false;
  255.     end else begin
  256.       ps := ps + s0[tmp];
  257.     end
  258.   end else begin
  259.     if s0[tmp] = cchar then begin
  260.       ps := '';
  261.       bl := true;
  262.     end else begin
  263.       Result := Result + s0[tmp];
  264.     end
  265.   end;

  266.   if bl then begin
  267.     if ps<>'' then Result := Result + FloatToStr(evaluate(ps)) else Result := Result + cchar;
  268.   end;
  269.   
  270. end;
  271. ////////////////////////////////////////////////////////////////////////////////
  272. //z_parser end
  273. ////////////////////////////////////////////////////////////////////////////////
  274. end.
复制代码
 楼主| 发表于 2011-5-27 21:42:49 | 显示全部楼层
修改版的设计上对表达式的要求比原版稍宽松,但目前似乎存在一些问题

另外,那个Ttodo属于物件动作容器的一部分,可以无视,下个版本这块会大改
发表于 2011-5-27 21:51:12 | 显示全部楼层
看见这个标题,我就知道一定是hcz!
发表于 2011-5-27 21:51:35 | 显示全部楼层
要是我的话,delphi可能还没入门。
发表于 2011-5-27 21:52:22 | 显示全部楼层
很好…(虽然我不怎么懂Pascal)
Malical的核心运算代码改天我也放出来(自己写的啊,有点舍不得……)
发表于 2011-5-27 21:52:34 | 显示全部楼层
一定得顶一顶
 楼主| 发表于 2011-5-27 22:09:08 | 显示全部楼层
本帖最后由 hcz 于 2011-5-27 22:12 编辑

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


我公开代码一部分原因也是希望大家能提出宝贵的意见。。对于表达式的格式上,还有对于函数的功能上(尤其是关于3D坐标的定位)
发表于 2011-5-27 22:21:53 | 显示全部楼层
我连2D Direction都不会用
发表于 2011-5-28 19:41:07 | 显示全部楼层
代码被Chrome自动翻译了。
发表于 2011-5-28 19:49:24 | 显示全部楼层
我天真的用Free Pascal编译,结果提示3条错误信息,请问应该使用什么编译器?
发表于 2011-5-28 20:24:48 | 显示全部楼层
应该是Pascal的,建议用Lazarus试试看。
错误信息可能来源:
1.库编译了也没用
2.有一个uses UI;而UI库没有给出。
发表于 2011-5-28 20:40:30 | 显示全部楼层
10# l5h5t7


补充,Free Pascal是《Free Pascal 语言与基础算法》书中所附带的CD中的。
DBank外链:http://dl.dbank.com/c06wpczx3a
发表于 2011-5-28 20:41:02 | 显示全部楼层
10# l5h5t7


补充,Free Pascal是《Free Pascal 语言与基础算法》书中所附带的CD中的。
DBank外链:http://dl.dbank.com/c06wpczx3a
发表于 2011-5-28 21:23:58 | 显示全部楼层
当然是delphi
发表于 2011-5-29 13:06:59 | 显示全部楼层
14# imath


……驴头不对马嘴。
 楼主| 发表于 2011-5-29 16:37:19 | 显示全部楼层
确实是Delphi,如果要用FP得加上{$Mode Delphi}

还有你得把UI库、Ttodo、getvalue调外部内容的部分去掉,然后引用Math库
 楼主| 发表于 2011-5-29 16:49:17 | 显示全部楼层
改了下,大致去掉了,不过要使用还得根据具体的程序调整
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-28 18:23 , Processed in 0.087615 second(s), 22 queries .

Powered by Discuz! X3.4

© 2001-2023 Discuz! Team.

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