delphi计算表达式的值

unit m;

interface

uses
Windows, Messages, Math, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
const
Symbol_Mod = 'M';
Symbol_Div = 'D';
Symbol_Shl = 'L';
Symbol_Shr = 'R';
Symbol_Or = 'O';
Symbol_Xor = 'X';
Symbol_And = 'A';
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

function ConvertExpression(ExpressionString: PChar): PChar;
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;
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('无法识别的语法  : ' + 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;
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;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit1.Text:=ConvertExpression(pchar(Edit1.text));
  Edit2.Text:=floattostr(ParseExpression(Pchar(Edit1.text)));
end;

end.