fatexpression.~pas

dede 的源代码 3.10b

{

  TFatExpression by Gasper Kozak, [e-mail]
  component is open-source and is free for any use
  version: 1.01, July 2001

  this is a component used for calculating text-presented expressions
  features
    operations: + - * / ^ !
    parenthesis: ( )
    variables: their values are requested through OnEvaluate event
    user-defined functions in format:
      function_name [ (argument_name [";" argument_name ... ]] "=" expression

  ! parental advisory : bugs included
  if you find any, fix it or let me know

}

unit FatExpression;

interface

uses Classes, Dialogs, Sysutils, Math;

type
  // empty token, numeric, (), +-*/^!, function or variable, ";" character
  TTokenType = (ttNone, ttNumeric, ttParenthesis, ttOperation, ttString, ttParamDelimitor);
  TEvaluateOrder = (eoInternalFirst, eoEventFirst);
  TOnEvaluate = procedure(Sender: TObject; Eval: String; Args: array of Double;
    ArgCount: Integer; var Value: Double; var Done: Boolean) of object;

  // class used by TExpParser and TExpNode for breaking text into 
  // tokens and building a syntax tree
  TExpToken = class
  private
    FText: String;
    FTokenType: TTokenType;
  public
    property Text: String read FText;
    property TokenType: TTokenType read FTokenType;
  end;

  // engine for breaking text into tokens
  TExpParser = class
  protected
    FExpression: String;
    FTokens: TList;
    FPos: Integer;
  private
    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 FExpression write SetExpression;
  end;

  // syntax-tree node. this engine uses a bit upgraded binary-tree
  TExpNode = class
  protected
    FOwner: TObject;
    FParent: TExpNode;
    FChildren: TList;
    FTokens: TList;
    FLevel: Integer;
    FToken: TExpToken;
    FOnEvaluate: TOnEvaluate;
  private
    function GetToken(Index: Integer): TExpToken;
    function GetChildren(Index: Integer): TExpNode;
    function FindLSOTI: Integer; // LSOTI = least significant operation token index
    function ParseFunction: Boolean;
    procedure RemoveSorroundingParenthesis;
    procedure SplitToChildren(TokenIndex: Integer);
    function Evaluate: Double;
    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 Level: Integer read FLevel;
    property OnEvaluate: TOnEvaluate read FOnEvaluate write FOnEvaluate;
  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
  TFatExpression = class(TComponent)
  protected
    FInfo, FText: String;
    FEvaluateOrder: TEvaluateOrder;
    FOnEvaluate: TOnEvaluate;
    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);
  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;
  end;


procedure Register;

implementation

const
  // supported operations
  STR_OPERATION = '+-*/^!';
  // function parameter delimitor
  STR_PARAMDELIMITOR = ';';
  // legal variable name characters
  STR_STRING    : array[0..1] of string =
    ('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_',
     'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_$#@0123456789');


procedure Register;
begin
  RegisterComponents('Additional', [TFatExpression]);
end;



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 Pos(S, STR_OPERATION) > 0 then Result := ttOperation 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;

function TExpParser.ReadNextToken: TExpToken;
var Part, Ch: String;
  FirstType, NextType: TTokenType;
  Sci: Boolean;
begin
  Result := NIL;
  if FPos > Length(FExpression) then Exit;
  Sci := False;

  Part := '';
  repeat
    Ch := FExpression[FPos];
    Inc(FPos);
  until (Ch <> ' ') or (FPos > Length(FExpression));
  if FPos - 1 > Length(FExpression) then Exit;

  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;

  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 := Ch;
  repeat
    Ch := FExpression[FPos];
    NextType := GetTokenType(Ch, False);

    if
        (NextType = FirstType) 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
        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;

function TExpParser.TokenCount: Integer;
begin
  Result := FTokens.Count;
end;




constructor TExpNode.Create(AOwner: TObject; AParent: TExpNode; Tokens: TList);
var I: Integer;
begin
  inherited Create;

  FOwner := AOwner;
  FParent := AParent;
  if FParent = NIL then
    FLevel := 0 else
    FLevel := FParent.Level + 1;

  FTokens := TList.Create;
  I := 0;
  while I < Tokens.Count do begin
    FTokens.Add(Tokens[I]);
    Inc(I);
  end;

  FChildren := TList.Create;

  if Tokens.Count = 1 then
    FToken := Tokens[0];
end;

destructor TExpNode.Destroy;
var Child: TExpNode;
begin
  if Assigned(FChildren) then begin
    while FChildren.Count > 0 do begin
      Child := Children[FChildren.Count - 1];
      FreeAndNil(Child);
      FChildren.Delete(FChildren.Count - 1);
    end;

    FreeAndNil(FChildren);
  end;

  FTokens.Free;
  inherited;
end;

procedure TExpNode.RemoveSorroundingParenthesis;
var First, Last, Lvl, I: Integer;
  Sorrounding: Boolean;
begin
  First := 0;
  Last := TokenCount - 1;
  while Last > First do begin
    if (Tokens[First].TokenType = ttParenthesis) and (Tokens[Last].TokenType = ttParenthesis) and
       (Tokens[First].Text = '(') and (Tokens[Last].Text = ')') then begin

      Lvl := 0;
      I := 0;
      Sorrounding := True;
      repeat
        if (Tokens[I].TokenType = ttParenthesis) and (Tokens[I].Text = '(') then
          Inc(Lvl) else
        if (Tokens[I].TokenType = ttParenthesis) and (Tokens[I].Text = ')') then
          Dec(Lvl);

        if (Lvl = 0) and (I < TokenCount - 1) then begin
          Sorrounding := False;
          Break;
        end;

        Inc(I);
      until I = TokenCount;

      if Sorrounding then begin
        FTokens.Delete(Last);
        FTokens.Delete(First);
      end else
      Exit;
    end else
      Exit;
    
    First := 0;
    Last := TokenCount - 1;
  end;
end;

procedure TExpNode.Build;
var LSOTI: Integer;
begin
  if TokenCount < 2 then
    Exit;
  RemoveSorroundingParenthesis;
  if TokenCount < 2 then
    Exit;

  LSOTI := FindLSOTI;
  if LSOTI < 0 then begin
    if ParseFunction then Exit;
    raise Exception.Create('Compile error: syntax fault.');
    Exit;
  end;
  SplitToChildren(LSOTI);
end;

function TExpNode.ParseFunction: Boolean;
var Func: Boolean;
  I, Delimitor, DelimitorLevel: Integer;
  FChild: TExpNode;
  FList: TList;
begin
  Result := False;
  if TokenCount < 4 then Exit;

  Func := (Tokens[0].TokenType = ttString) and
    (Tokens[1].TokenType = ttParenthesis) and (Tokens[TokenCount - 1].TokenType = ttParenthesis);

  if not Func then Exit;

  FToken := Tokens[0];
  with FTokens do begin
    Delete(TokenCount - 1);
    Delete(1);
  end;

  FList := TList.Create;
  try
    while TokenCount > 1 do begin
      Delimitor := - 1;
      DelimitorLevel := 0;
      for I := 1 to TokenCount - 1 do begin