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.