计算出用字符串表示的数学表达式的值

// built by Liu Yang 2002.1.8

library ExPRession;

uses Dialogs, Math, SysUtils;

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

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;
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;
end.