hwexpression.pas

另一个简单的公式解释器

unit hwExpression;
{**********************************************************************************************
  表达式解析器
  2002-01-11

  功能：
        解析一个有待于计算的表达式，支持表达式内嵌入函数、变量、引用，支持基本数学运算，支持
        部分Delphi内部数学函数；支持用户自定义的函数。
        对于用户自定义的函数，格式如下：
        function_name ( argument_name [, argument_name ....]) = expression
        支持的数学运算符有：
        + - * / ^ !
  特殊符号含义：
        @         引用标识，指明紧随其后的Token为表达单元、单元格、映射、用户常量、查询结果
                  等值；
        %a        系统内部变量

 **********************************************************************************************
}
interface

uses Classes, Sysutils, Math;

type
  //定义Token类型, 目前的类型有空，数字，括号，操作符，字符串，空格，变量，系统变量
  TTokenType = (ttNone, ttNumeric, ttParenthesis, ttOperation, ttString, ttSpace, ttVariable,
                ttReference, ttSysVariable, ttStringValue);

  //被TExpParser 和TExpNode调用的类，用于将文本剪裁成Token，并创建语法树（syntax tree）。
  TExpToken = class
  private
    FText: string;
    FTokenType: TTokenType;
  public
    property Text: string read FText;
    property TokenType: TTokenType read FTokenType;
  end;

  //分解文本为Token的引擎
  TExpParser = class
  private
    FExpression: string;
    FToken: TList;
    FPos: Integer;
  protected
    procedure Clear;
    function  GetToken(Index: integer): TExpToken;
    procedure SetExpression(const Value: string);
  public
    constructor Create;
    destructor  Destroy; override;

    function ReadFirstToken: TExpToken;
    function ReadNextToken:TExpToken;

    function TokenCount: Integer;
    property Tokens[Index: integer]: TExpToken read GetToken;
    property TokenList: TList read FTokens;
    property Expression: String read FExpresstion write SetExpresstion;
  end;

  //syntax-tree节点。
  TExpNode = class
  private
    FOwner: TObject;
    FParent: TExpNode;
    FChildren: TList;
    FTokens: TList;
    FLevel: Integer;
    FToken: TExpToken;
    FOnEvaluate: TOnEvaluate;
    FOnVariable: TOnVariable;
  protected
    function GetToken(Index: integer): TExpToken;
    function GetChildren(Index: Integer): TExpNode;
    function FindLSOTI: Integer;
    function ParseFunction: Boolean;
    function Evaluate: Double;
    function Variable: Double;
    function ParseVariable: Boolean;
    procedure RemoveSorroundingParenthesis;
    procedure SplitToChildren(TokenIndex: Integer);
    property Children[Index: integer]: TExpNode read GetChildren;
  public
    constructor Create(AOwner: TObject; AParent: TExpNode: Tokens: TList);
    destructor  Destroy: override;
    procedure   Build;
    function TokenCount: Integer;
    function Calculate: Double;
    property Tokens[Index: integer]: TExpToken read GetToken;
    property Parent: TExpNode read FParent;
    property OnEvaluate: TOnEvaluate read FOnEvaluate write FOnEvaluate;
    property OnVariable: TOnVariable read FOnVariable write FOnVariable;
  end;

  TFunction = class
  protected
    FAsString, FName, FHead, FFunction: string;
    FOwner: TObject;
    FArgCount: Integer;
    FArgs: TStringList;
    FValues: array of Double;
  private
    procedure SetAsString(const Value: string);
    procedure EvalArgs(Sender: TObject; Eval: string; Args: array of Double;
      ArgCount: Integer; var Value: Double);
  public
    constructor Create(AOwner: TObject);
    destructor Destroy; override;
    function Call(Values: array of Double): Double;
    property AsString: string read FAsString write SetAsString;
    property Name: string read FName;
    property ArgCount: Integer read FArgCount;
    property Args: TStringList read FArgs;
  end;

  // main component, actually only a wrapper for TExpParser, TExpNode and
  // user input via OnEvaluate event
  //主组件，
  ThwExpression = class(TComponent)
  protected
    FInfo, FText: string;
    FEvaluateOrder: TEvaluateOrder;
    FOnEvaluate: TOnEvaluate;
    FOnVariable: TOnVariable;
    FValue: Double;
    FFunctions: TStringList;
  private
    procedure Compile;
    function GetValue: Double;
    procedure SetInfo(Value: string);
    procedure Evaluate(Eval: string; Args: array of Double; var Value: Double);
    function FindFunction(FuncName: string): TFunction;
    procedure SetFunctions(Value: TStringList);
    procedure Variable(Eval: string; var Value: Double);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Value: Double read GetValue;
  published
    property Text: string read FText write FText;
    property Info: string read FInfo write SetInfo;
    property Functions: TStringList read FFunctions write SetFunctions;
    property EvaluateOrder: TEvaluateOrder read FEvaluateOrder write
      FEvaluateOrder;
    property OnEvaluate: TOnEvaluate read FOnEvaluate write FOnEvaluate;
    property OnVariable: TOnVariable read FOnVariable write FOnVariable;
  end;

implementation

const
  // 目前所支持的数学运算符
  STR_OPERATION = '+-*/^!';
  // 函数参数分隔符
  STR_PARAMDELIMITOR = ',';
  // 合法的变量名字符
  STR_STRING: array[0..1] of string =
  ('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_',
    'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_0123456789');
  //特别含义Token的前导字符。@代表引用，%代表内部变量
  STR_EXTRAPREFIX = '@#%';

//确定操作符类型
function OperParamateres(const Oper: string): Integer;
begin
  if Pos(Oper, '+-*/^') > 0 then
    Result := 2
  else if Oper = '!' then
    Result := 1
  else
    Result := 0;
end;

constructor TExpParser.Create;
begin
  inherited Create;
  FTokens := TList.Create;
end;

destructor TExpParser.Destroy;
begin
  Clear;
  FTokens.Free;
  inherited;
end;

procedure TExpParser.Clear;
begin
  while FTokens.Count > 0 do
  begin
    TExpToken(FTokens[0]).Free;
    FTokens.Delete(0);
  end;
end;

procedure TExpParser.SetExpression(const Value: string);
begin
  FExpression := Trim(Value);
end;

function TExpParser.GetToken(Index: Integer): TExpToken;
begin
  Result := TExpToken(FTokens[Index]);
end;

function TExpParser.ReadFirstToken: TExpToken;
begin
  Clear;
  FPos := 1;
  Result := ReadNextToken;
end;

function GetTokenType(S: string; First: Boolean): TTokenType;
var
  Value: Double;
  P, Error: Integer;
begin
  if (S = '(') or (S = ')') then              //括号
    Result := ttParenthesis
  else if S = STR_PARAMDELIMITOR then         //变量分隔符
    Result := ttParamDelimitor
  else if (S = '[') or (S = ']') then         //变量
    Result := ttVariable
  else if Pos(S, STR_OPERATION) > 0 then      //操作符
    Result := ttOperation
  else if S = '@' then                        //引用
    Result := ttReference
  else if S = '%' then                        //系统内部变量
    Result := ttSysVariable
  else if S = #39 then                        //需要操作的字符串。#39是'号
    Result := ttStringValue
  else
  begin
    Val(S, Value, Error);
    if Error = 0 then
      Result := ttNumeric
    else
    begin
      if First then
        P := Pos(S, STR_STRING[0])
      else
        P := Pos(S, STR_STRING[1]);

      if P > 0 then
        Result := ttString
      else
        Result := ttNone;   //可能是非法字符，即未定义的字符。
    end;
  end;
end;

{读下一个Token}
function TExpParser.ReadNextToken: TExpToken;
var
  Part, Ch: string;
  FirstType, NextType: TTokenType;
  Sci: Boolean;
begin
  Result := nil;
  if FPos > Length(FExpression) then
    Exit;
  Sci := False;

  {取下一个Token中第一个非空格字符}
  Part := '';
  repeat
    Ch := FExpression[FPos];
    Inc(FPos);
  until (Ch <> ' ') or (FPos > Length(FExpression));
  if FPos - 1 > Length(FExpression) then
    Exit;

  {判断该字符属于什么类型，在此时即确定一个Token的类型，以决定对其分解方法}
  FirstType := GetTokenType(Ch, True);
  if FirstType = ttNone then
  begin
    raise
      Exception.CreateFmt('Parse error: illegal character "%s" at position %d.',
      [Ch, FPos - 1]);
    Exit;
  end;

  {如果第一个字符标明Token是括号或者操作符则将该Token添加进Token集合中并返回}
  if FirstType in [ttParenthesis, ttOperation] then
  begin
    Result := TExpToken.Create;
    with Result do
    begin
      FText := Ch;
      FTokenType := FirstType;
    end;
    FTokens.Add(Result);
    Exit;
  end;

  {
   判断是否是变量。如果不是变量则将第一个字符赋值给Part以便于将来合成为完整的Token。
   对于引用、系统内部变量等，都有前导特殊字符。其他的字符串，无论是函数、变量还是数
   字等，都没有特殊标识。字符串用引号标识。

  }
  if FirstType <> ttVariable then
    Part := Ch;
  repeat
    //Ch := FExpression[FPos];
    if FPos <= Length(FExpression) then
      Ch := FExpression[FPos]
    else
      Ch := #0;
    NextType := GetTokenType(Ch, False);

    if (NextType = FirstType) and (FirstType <> ttVariable) or
       ((FirstType = ttVariable) and (NextType <> ttVariable)) or
      ((FirstType = ttString) and (NextType = ttNumeric)) or
      ((FirstType = ttNumeric) and (NextType = ttString) and (Ch = 'E') and
      (Sci = False)) or
      ((FirstType = ttNumeric) and (NextType = ttOperation) and (Ch = '-') and
      (Sci = True)) then
    begin
      Part := Part + Ch;
      if (FirstType = ttNumeric) and (NextType = ttString) and (Ch = 'E') then
        Sci := True;
    end
    else
    begin
      if (FirstType = ttVariable) and (NextType = ttVariable) then
        Inc(FPos);
      Result := TExpToken.Create;
      with Result do
      begin
        FText := Part;
        FTokenType := FirstType;
      end;
      FTokens.Add(Result);
      Exit;
    end;
    Inc(FPos);
  until FPos > Length(FExpression);

  Result := TExpToken.Create;
  with Result do
  begin
    FText := Part;
    FTokenType := FirstType;
  end;
  FTokens.Add(Result);
end;

end.