计算表达式

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.