qktmathexpression.pas

一个用于解析数学表达式的函数库。支持三角函数、乘方、开放等运算。

unit QKTMathExpression;

interface

uses SysUtils, Types, Math;

Const
  Symbol_Mod='M';  Symbol_Div='D';
  Symbol_Shl='L';  Symbol_Shr='R';
  Symbol_Or='O';   Symbol_Xor='X';
  Symbol_And='A';

implementation

function ConvertExpression(ExpressionString:PChar):PChar; stdcall;
var inputexp:string;
begin
  inputexp:=ExpressionString;
  //convert input expression to recognize expression
  if pos('=', inputexp) = 0 then
    inputexp := inputexp + '='
  else inputexp := Copy(inputexp, 1, Pos('=',inputexp));

  inputexp := UpperCase(inputexp);   //全部转化为大写
  inputexp := StringReplace(inputexp ,' ','', [rfReplaceAll]);   //去掉所有的空格
  inputexp := StringReplace(inputexp ,'MOD', Symbol_Mod,[rfReplaceAll]);
  inputexp := StringReplace(inputexp ,'DIV', Symbol_Div,[rfReplaceAll]);
  inputexp := StringReplace(inputexp ,'AND', Symbol_And,[rfReplaceAll]);
  inputexp := StringReplace(inputexp ,'XOR', Symbol_Xor,[rfReplaceAll]);
  inputexp := StringReplace(inputexp ,'OR', Symbol_Or,[rfReplaceAll]);
  inputexp := StringReplace(inputexp ,'SHL', Symbol_Shl,[rfReplaceAll]);
  inputexp := StringReplace(inputexp ,'SHR', Symbol_Shr,[rfReplaceAll]);
  inputexp := StringReplace(inputexp ,'(-','(0-',[rfReplaceAll]);
  if pos('-', inputexp) = 1 then inputexp:='0' + inputexp;
  Result:=PChar(inputexp);
end;

function ParseExpression(ExpressionString:PChar): extended; stdcall;
var
  nextch:char;
  nextchpos,position:word;
  inputexp:string;
procedure expression(var ev:extended);forward;
procedure readnextch;
begin
  repeat
    if inputexp[position] = '=' then
      nextch := '='
    else
      begin
       inc(nextchpos);
       inc(position);
       nextch:=inputexp[position];
      end;
  until (nextch <> ' ') or eoln;
end;

procedure error(ErrorString:string);
begin
  //MessageDlg('Unknown expression : ' + ErrorString,mterror,[mbok],0);
  //exit;
  raise Exception.Create('Invalid expression : ' + ErrorString);
end;

procedure number(var nv:extended);
var
  radix: longint;
  snv: string;

function BinToInt(value: string): integer;
var
  i,size: integer;
begin   // convert binary number to integer
  result:=0;
  size:=length(value);
  for i:=size downto 1 do
  if copy(value,i,1)='1' then
    result := result + (1 shl (size-i));
end;
begin
  nv:=0;
  snv:='';
  while nextch in ['0'..'9','A'..'F'] do
    begin
//      nv:=10*nv+ord(nextch)-ord('0');
      snv:=snv+nextch;
      readnextch;
    end;
  // parse Hex, Bin
  if snv <> '' then
     if snv[Length(snv)]='B'
        then nv:=BinToInt(Copy(snv,1,Length(snv)-1))
        else if nextch='H' then begin nv:=StrToInt('$'+snv); readnextch; end
                           else nv:=StrToInt(snv);
  if nextch='.' then
    begin
     radix:=10;
     readnextch;
     while nextch in ['0'..'9'] do
       begin
         nv:=nv+(ord(nextch)-ord('0'))/radix;
         radix:=radix*10;
         readnextch;
       end;
    end;
end;

procedure factor(var fv:extended);
Var
  Symbol:string;

  function CalcN(Value:integer):extended;
  var i:integer;
  begin
    Result := 1;
    if Value = 0 then
      Exit
    else
    for i := 1 to Value do
      Result:=Result*i;
  end;

  function ParseFunction(var FunctionSymbol:string):boolean;
  begin
    FunctionSymbol:='';
    while not (nextch in ['0'..'9','.','(',')','+','-','*','/','=']) do
      begin
        FunctionSymbol:=FunctionSymbol+nextch;
        readnextch;
      end;
    if FunctionSymbol='ABS' then Result:=true else
    if FunctionSymbol='SIN' then Result:=true else
    if FunctionSymbol='COS' then Result:=true else
    if FunctionSymbol='TG' then Result:=true else
    if FunctionSymbol='TAN' then Result:=true else
    if FunctionSymbol='ARCSIN' then Result:=true else
    if FunctionSymbol='ARCCOS' then Result:=true else
    if FunctionSymbol='ARCTG' then Result:=true else
    if FunctionSymbol='ARCTAN' then Result:=true else
    if FunctionSymbol='LN' then Result:=true else
    if FunctionSymbol='LG' then Result:=true else
    if FunctionSymbol='EXP' then Result:=true else
    if FunctionSymbol='SQR' then Result:=true else
    if FunctionSymbol='SQRT' then Result:=true else
    if FunctionSymbol='PI' then Result:=true else
    if FunctionSymbol='NOT' then Result:=true else
    if FunctionSymbol='N!' then Result:=true else
    if FunctionSymbol='E' then Result:=true else
       Result:=false;
  end;

begin
  Case nextch of
    '0'..'9' : number(fv);
    '(' : begin
            readnextch;
            expression(fv);
            if nextch=')'
               then readnextch else error(nextch);
          end
    else if ParseFunction(Symbol) then
            if nextch='(' then
               begin
                 readnextch;
                 expression(fv);
                 if Symbol='ABS' then fv:=abs(fv) else
                 if Symbol='SIN' then fv:=sin(fv) else
                 if Symbol='COS' then fv:=cos(fv) else
                 if Symbol='TG' then fv:=tan(fv) else
                 if Symbol='TAN' then fv:=tan(fv) else
                 if Symbol='ARCSIN' then fv:=arcsin(fv) else
                 if Symbol='ARCCOS' then fv:=arccos(fv) else
                 if Symbol='ARCTG' then fv:=arctan(fv) else
                 if Symbol='ARCTAN' then fv:=arctan(fv) else
                 if Symbol='LN' then fv:=ln(fv) else
                 if Symbol='LG' then fv:=ln(fv)/ln(10) else
                 if Symbol='EXP' then fv:=exp(fv) else
                 if Symbol='SQR' then fv:=sqr(fv) else
                 if Symbol='SQRT' then fv:=sqrt(fv) else
                 if Symbol='NOT' then fv:=not(Round(fv)) else
                 if Symbol='N!' then fv:=CalcN(Round(fv)) else
                    error(symbol);
                 if nextch=')' then readnextch else error(nextch);
               end else begin   // parse constant
                          if Symbol='PI' then fv:=3.14159265358979324 else
                          if Symbol='E' then fv:=2.71828182845904523 else error(symbol);
                        end else begin error(Symbol); fv:=1;  end;
  end;
end;

procedure Power_(var pv:extended);
var
  multiop:char;
  fs:extended;
begin
  factor(pv);
  while nextch in ['^'] do
    begin
      multiop := nextch;
      readnextch;
      factor(fs);
      case multiop of
      '^': if pv <> 0.0 then pv:=exp(ln(pv)*fs) else error(multiop);
      end;
    end;
end;

procedure term_(var tv:extended);
var
  multiop: char;
  fs: extended;
begin
  Power_(tv);
  while nextch in ['*','/',Symbol_Mod,Symbol_Div,Symbol_And,Symbol_Shl,Symbol_Shr] do
    begin
      multiop:=nextch;
      readnextch;
      Power_(fs);
      case multiop of
        '*': tv := tv * fs;
        '/': if fs <> 0.0 then tv := tv/fs else error(multiop);
        Symbol_Mod:tv := round(tv) mod round(fs);   // prase mod
        Symbol_Div:tv := round(tv) div round(fs);   // parse div
        Symbol_And:tv := round(tv) and round(fs);   // parse and
        Symbol_Shl:tv := round(tv) shl round(fs);   // parse shl
        Symbol_Shr:tv := round(tv) shr round(fs);   // parse shr
      end;
    end;
end;

procedure expression(var ev:extended);
var
  addop: char;
  fs: extended;
begin
  term_(ev);
  while nextch in ['+', '-', Symbol_Or, Symbol_Xor] do
    begin
      addop := nextch;
      readnextch;
      term_(fs);
      case addop of
        '+': ev := ev + fs;
        '-': ev := ev - fs;
      Symbol_Or: ev := round(ev) or round(fs);     // parse or
      Symbol_Xor: ev := round(ev) xor round(fs);   // parse xor
      end;
    end;
end;
begin
  inputexp := ConvertExpression(ExpressionString);
  if pos('=', inputexp) = 0 then
     inputexp:=ConvertExpression(ExpressionString);

  position := 0;
  while inputexp[position] <> '=' do
    begin
      nextchpos := 0;
      readnextch;
      expression(result);
    end;
end;

{function ParseExpressionToStr(ExpressionString:PChar):PChar; stdcall;
var ES:string;
begin
  ES:=ExpressionString;
  if pos('=',ES)=0
     then ES:=ES+'='
     else ES:=Copy(ES,1,Pos('=',ES));
  ES:=ES+FormatFloat('0.000000000000',ParseExpression(ExpressionString));
  Result:=PChar(ES);
end;

function Version:PChar; stdcall;
begin
  Result:='Calculator Dll Build 2001.10.25 Made By Liu Yang All Rights Reserved';
end;

Exports
  ConvertExpression, ParseExpression, ParseExpressionToStr, Version;}

function ResultOut(ExpressionString:PChar):PChar; stdcall;
var ES:string;
begin
  ES:=FormatFloat('0.00',ParseExpression(ExpressionString));
  Result:=PChar(ES);
end;

end.