一个简易的四则运算单元...(15.12.15 BUG更新)

网上找的, 没有作者信息, 只能在这里感谢一下了, 支持标准写法的四则运算

--2015-12-15

　　修改了一个内存泄漏的BUG - Pop方法没有释放申请的内存

unit Base.Calculate;

interface

uses
  System.SysUtils, System.Classes, System.Contnrs, System.Generics.Collections;

type
  TTokenType = (tkNumber, tkAdd, tkSub, tkMul, tkDiv, tkLBracket, tkRBracket);

  TToken = record
    Token: TTokenType;
    DValue: Double;
  end;
  PToken = ^TToken;

/// <summary>
///   解析表达式
/// </summary>
/// <param name="AInExpr">
///   表达式字符串
/// </param>
/// <param name="AInList">
///   解析列表输出
/// </param>
/// <returns>
///   返回值为解析错误的字符串位置(从1开始) 如果返回值为0表示表达式正确
/// </returns>
function ParseExpression(AInExpr: String; AInList: TList<TToken>): Integer;
/// <summary>
///   展开输出值为计算顺序描述字符
/// </summary>
/// <param name="AInList">
///   ParseExpression的输出列表
/// </param>
/// <returns>
///   计算顺序描述字符
/// </returns>
function InsideToSuffix(AInList: TList<TToken>): String;
/// <summary>
///   获得计算结果
/// </summary>
/// <param name="ASuExpr">
///   计算顺序描述字符
/// </param>
/// <returns>
///   计算结果
/// </returns>
function Evaluate(ASuExpr: String): Double;

(*
Demo:

var
  nList: TList<TToken>;
  nErrIndex: Integer;
begin
  nErrIndex := ParseExpression(edtInput.Text, nList);
  if nErrIndex = 0 then
    edtOutput.Test := FloatToStr(Evaluate(InsideToSuffix(nList)))
  else
  begin
    edtInput.SetFocus;
    edtInput.SelStart := nErrIndex - 1;
    edtInput.SelLength := 1;
  end;
end;
*)

implementation

procedure Push(AStack: TStack; AData: String);
begin
  AStack.Push(StrNew(PChar(AData)));
end;

function Pop(AStack: TStack): String;
var
  nP: PChar;
begin
  nP := PChar(AStack.Pop);
  Result := StrPas(nP);
  StrDispose(nP);
end;

function Peek(AStack: TStack): String;
begin
  Result := StrPas(PChar(AStack.Peek));
end;

function IsEmpty(AStack: TStack): Boolean;
begin
  Result := AStack.Count = ;
end;

function CompareSymbol(SymA, SymB: String): Boolean;
begin
  Result := True;
  Case SymA[] of
    '*', '/':
      if SymB[] in ['*', '/'] then
        Result := False;
  end;
end;

function ParseExpression(AInExpr: String; AInList: TList<TToken>): Integer;

  procedure _ListAdd(const AToken: TToken);
  begin
    if AInList <> nil then
      AInList.Add(AToken);
  end;

  procedure _ListClear;
  begin
    if AInList <> nil then
      AInList.Clear;
  end;

var
  nToken: TToken;
  nTemp: String;
  nIsExists: Boolean;
  i, nLen, nBracket: Integer;
  nNextToken: set of TTokenType;
begin
  i := ;
  Result := ;
  nBracket := ;
  nLen := Length(AInExpr);
  nNextToken := [tkNumber, tkLBracket];
  While i <= nLen do
  begin
    Case AInExpr[i] of
      ''..'':
      begin
        nTemp := '';
        nIsExists := False;
        if not (tkNumber in nNextToken) then
        begin
          Result := i;
          _ListClear;
          Break;
        end;
        While i <= nLen do
        begin
          Case AInExpr[i] of
            ''..'':
              nTemp := nTemp + AInExpr[i];
            '.':
              if nIsExists then
              begin
                Result := i;
                i := nLen;
                _ListClear;
                Break;
              end
              else
              begin
                nTemp := nTemp + AInExpr[i];
                nIsExists := True;
              end;
          else
            Dec(i);
            Break;
          end;
          Inc(i);
        end;
        if nTemp[Length(nTemp)] = '.' then
        begin
          Result := i;
          _ListClear;
          Break;
        end;
        nToken.Token := tkNumber;
        nToken.DValue := StrToFloat(nTemp);
        _ListAdd(nToken);
        nNextToken := [tkAdd, tkSub, tkMul, tkDiv, tkRBracket];
      end;
      '+':
      begin
        if not (tkAdd in nNextToken) then
        begin
          Result := i;
          _ListClear;
          Break;
        end;
        nToken.Token := tkAdd;
        _ListAdd(nToken);
        nNextToken := [tkNumber, tkLBracket];
      end;
      '-':
      begin
        if not (tkSub in nNextToken) then
        begin
          Result := i;
          _ListClear;
          Break;
        end;
        nToken.Token := tkSub;
        _ListAdd(nToken);
        nNextToken := [tkNumber, tkLBracket];
      end;
      '*':
      begin
        if not (tkMul in nNextToken) then
        begin
          Result := i;
          _ListClear;
          Break;
        end;
        nToken.Token := tkMul;
        _ListAdd(nToken);
        nNextToken := [tkNumber, tkLBracket];
      end;
      '/':
      begin
        if not (tkDiv in nNextToken) then
        begin
          Result := i;
          _ListClear;
          Break;
        end;
        nToken.Token := tkDiv;
        _ListAdd(nToken);
        nNextToken := [tkNumber, tkLBracket];
      end;
      '(':
      begin
        if not (tkLBracket in nNextToken) then
        begin
          Result := i;
          _ListClear;
          Break;
        end;
        Inc(nBracket);
        nToken.Token := tkLBracket;
        _ListAdd(nToken);
        nNextToken := [tkNumber, tkLBracket];
      end;
      ')':
      begin
        if not (tkRBracket in nNextToken) then
        begin
          Result := i;
          _ListClear;
          Break;
        end;
        Dec(nBracket);
        nToken.Token := tkRBracket;
        _ListAdd(nToken);
        nNextToken := [tkAdd, tkSub, tkMul, tkDiv, tkRBracket];
      end;
      ' ':;
    else
      Result := i;
      _ListClear;
      Break;
    end;
    Inc(i);
  end;
  if nBracket >  then
  begin
    Result := nLen;
    _ListClear;
  end;
end;

function InsideToSuffix(AInList: TList<TToken>): String;
var
  i: Integer;
  nStack: TStack;
  nToken: TToken;
  nTemp, nSymbol: String;
begin
  nTemp := '';
  nStack := TStack.Create;
  for i :=  to AInList.Count -  do
  begin
    nToken := AInList.Items[i];
    Case nToken.Token of
      tkNumber:
        nTemp := nTemp + FloatToStr(nToken.DValue) + ' ';
      tkAdd:
        if not IsEmpty(nStack) then
          if Peek(nStack) = '(' then
            Push(nStack, '+')
          else
          begin
            nSymbol := Pop(nStack);
            nTemp := nTemp + nSymbol + ' ';
            Push(nStack, '+');
          end
        else
          Push(nStack, '+');
      tkSub:
        if not IsEmpty(nStack) then
          if Peek(nStack) = '(' then
            Push(nStack, '-')
          else
          begin
            nSymbol := Pop(nStack);
            nTemp := nTemp + nSymbol + ' ';
            Push(nStack, '-');
          end
        else
          Push(nStack, '-');
      tkMul:
        if not IsEmpty(nStack) then
        begin
          nSymbol := Peek(nStack);
          if nSymbol = '(' then
            Push(nStack, '*')
          else if CompareSymbol('*', nSymbol) then
            Push(nStack, '*')
          else
          begin
            nSymbol := Pop(nStack);
            nTemp := nTemp + nSymbol + ' ';
            Push(nStack, '*');
          end;
        end
        else
          Push(nStack, '*');
      tkDiv:
        if not IsEmpty(nStack) then
        begin
          nSymbol := Peek(nStack);
          if nSymbol = '(' then
            Push(nStack, '/')
          else if CompareSymbol('/', nSymbol) then
            Push(nStack, '/')
          else
          begin
            nSymbol := Pop(nStack);
            nTemp := nTemp + nSymbol + ' ';
            Push(nStack, '/');
          end;
        end
        else
          Push(nStack, '/');
      tkLBracket:
        Push(nStack, '(');
      tkRBracket:
        while nStack.Count >  do
        begin
          nSymbol := Pop(nStack);
          if nSymbol = '(' then
            Break;
          nTemp := nTemp + nSymbol + ' ';
        end;
    end;
  end;
  for i :=  to nStack.Count do
  begin
    nSymbol := Pop(nStack);
    nTemp := nTemp + nSymbol + ' ';
  end;
  nStack.Free;
  Result := Trim(nTemp);
end;

function Evaluate(ASuExpr: String): Double;
var
  nTemp: String;
  nStack: TStack;
  i, nLen: Integer;
  nTempA, nTempB, nResult: Double;
begin
  i := ;
  nLen := Length(ASuExpr);
  nStack := TStack.Create;
  try
    While i <= nLen do
    begin
      Case ASuExpr[i] of
        ''..'':
        begin
          nTemp := '';
          While i <= nLen do
          begin
            if ASuExpr[i] in [''..'', '.'] then
              nTemp := nTemp + ASuExpr[i]
            else
            begin
              Dec(i);
              Break;
            end;
            Inc(i);
          end;
          Push(nStack, nTemp);
        end;
        '+':
        begin
          nTempA := StrToFloat(Pop(nStack));
          nTempB := StrToFloat(Pop(nStack));
          nResult := nTempB + nTempA;
          Push(nStack, FloatToStr(nResult));
        end;
        '-':
        begin
          nTempA := StrToFloat(Pop(nStack));
          nTempB := StrToFloat(Pop(nStack));
          nResult := nTempB - nTempA;
          Push(nStack, FloatToStr(nResult));
        end;
        '*':
        begin
          nTempA := StrToFloat(Pop(nStack));
          nTempB := StrToFloat(Pop(nStack));
          nResult := nTempB * nTempA;
          Push(nStack, FloatToStr(nResult));
        end;
        '/':
        begin
          nTempA := StrToFloat(Pop(nStack));
          nTempB := StrToFloat(Pop(nStack));
          nResult := nTempB / nTempA;
          Push(nStack, FloatToStr(nResult));
        end;
      end;
      Inc(i);
    end;
    Result := StrToFloat(Pop(nStack));
  finally
    nStack.Free;
  end;
end;

end.