pexpression.pas

delphi框架可以学习, 写的很好的

unit pExpression;

{$R-}

interface

uses Messages, Windows, SysUtils, Classes, Graphics, Menus, Controls, Forms,
  StdCtrls, Mask ,Grids ,Dialogs;

{ 
  作者:穆龙(delphibbs:delp) 
  声明:本代码为作者学习编写控件之习作,如有雷同,算你倒霉
       本代码作者放弃所有权力,若需引用抄袭篡改,不胜荣幸.
}

type

  TmExpression = class;
  TmFunction = class;

  TmFunctionEvent = function(ParamCount : Integer ;Param : array of Real ;var Value : Real ;var Err: String) : Boolean of object;
  TmExpressionEvent = function(Name : String ;ParamCount : Integer ;Param : array of Real ;var Value : Real ;var Err: String) : Boolean of object;

  TmFunction = class(TCollectionItem)
  private
    vName : String;
    nParamCount : Integer;
    bOnGetValue : TmFunctionEvent;
    fValue : Real;
    //fExpression : TmExpression;
    procedure SetParamCount(Count : Integer);
  public
    function GetDisplayName : String; override;
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
  published
    property Name : String read vName write vName;
    property ParamCount : Integer read nParamCount write SetParamCount;
    property OnGetValue : TmFunctionEvent read bOnGetValue write bOnGetValue;
    property Value : Real read fValue write fValue;
  end;

  TmFunctions = class (TCollection)
  private
    cExpression : TmExpression;
    function GetItem(Index: Integer) : TmFunction;
    procedure SetItem(Index: Integer; Value: TmFunction);
  protected
    procedure Update(Item : TCollectionItem); override;
  public
    { Public declarations }
    constructor Create(Expression : TmExpression);
    function GetOwner : TPersistent; override;
    function Add : TmFunction;
    property Items [Index: Integer]: TmFunction read GetItem write SetItem; default;
  published
  end;

  TmExpression = class(TComponent)
  private
     cFunctions : TmFunctions;
     vExpression : String;
     vErrMsg : String;
     nErrRow,nErrCol : Integer;
     fResult : Real;
     bOnGetValue : TmExpressionEvent;
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function SetValue(Name : String ;Value : Real) : Boolean;
    function GetValue(Name : String ;var Value : Real) : Boolean;
    function Explain(Expression : String) : Boolean; overload;
    function Explain : Boolean; overload;
  published
    { Published declarations }
    property Functions : TmFunctions read cFunctions write cFunctions;
    property Expression : String read vExpression write vExpression;
    property ErrMsg : String read vErrMsg write vErrMsg;
    property ErrRow : Integer read nErrRow write nErrRow;
    property ErrCol : Integer read nErrCol write nErrCol;
    property Result : Real read fResult write fResult;
    property OnGetValue : TmExpressionEvent read bOnGetValue write bOnGetValue;
  end;

procedure Register;

implementation
// Expression

constructor TmExpression.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  cFunctions := TmFunctions.Create(Self);
  vErrMsg := '';
end;

destructor TmExpression.Destroy;
begin
  inherited Destroy;
  cFunctions.Free;
end;

function TmExpression.Explain(Expression : String) : Boolean;
begin
  vExpression := Expression;
  Result := Explain;
end;

function TmExpression.Explain : Boolean;
{
E = A [ \+|- \A]
A = F [ \*|/ \F ]
F = H [ \^ \H | ! ]
H = ( E ) | G
G = [+|-] \N|N.1
N.1 = ???( E , E , E , ...) | ...
N = D [ D ][\.\N]
D = 0..9
}
var
  nLen : Integer;
  nNow : Integer;
  function bE(var fv : Real) : Boolean; forward;

  function bN(var fValue : Real) : Boolean;
  var
     r,r2,r3,f : Real;
  begin
    Result := True;
    r2 := 0;
    while nNow <= nLen do
    begin
      if (Ord(vExpression[nNow]) >= Ord('0')) and (Ord(vExpression[nNow]) <= Ord('9')) then
      begin
        r := Ord(vExpression[nNow]) - Ord('0');
        r2 := r2 * 10 + r;
        nNow := nNow + 1;
        nErrCol := nErrCol + 1;
      end
      else
        Break;
    end;

    if vExpression[nNow] <> '.' then
    begin
      fValue := r2;
      Exit;
    end;
    nNow := nNow + 1;
    nErrCol := nErrCol + 1;

    f := 10;
    r3 := 0;
    while nNow <= nLen do
    begin
      if (Ord(vExpression[nNow]) >= Ord('0')) and (Ord(vExpression[nNow]) <= Ord('9')) then
      begin
        r := Ord(vExpression[nNow]) - Ord('0');
        r3 := r3 + r / f;
        f := f * 10;
        nNow := nNow + 1;
        nErrCol := nErrCol + 1;
      end
      else
        Break;
    end;
    fValue := r2+r3;
  end;

  function bN1(var fValue : Real) : Boolean;
  var
    I : Integer;
    A : String;
    nErr : Integer;
    nCnt : Integer;
    r : Real;
    fParam : array [0 .. 256] of real;
  begin
    Result := True;
    A := Copy(vExpression,nNow,nLen - nNow + 1);
    for I := 0 to cFunctions.Count - 1 do
    begin
      if Pos(cFunctions.Items[i].vName,A) = 1 then
      begin
        nNow := nNow + Length(cFunctions.Items[i].vName);
        nErrCol := nErrCol + Length(cFunctions.Items[i].vName);
        nErr := nErrCol;

        nCnt := 0;
        fParam[0] := 0;
        if vExpression[nNow] = '(' then
        begin
           nNow := nNow + 1;
           nErrCol := nErrCol + 1;

           while nCnt < 256 do
           begin
             if vExpression[nNow] = ')' then
               Break;

             if not bE(r) then
             begin
               Result := False;
               Exit;
             end;
             
             fParam[nCnt] := r;
             nCnt := nCnt + 1;
             if vExpression[nNow] <> ',' then
               Break;
             nNow := nNow + 1;
             nErrCol := nErrCol + 1;
           end;

           if vExpression[nNow] <> ')' then
           begin
             Result := False;
             vErrMsg := '出错在第'+IntToStr(nErr+1)
                     +'个字符,函数"'+cFunctions.Items[i].vName+'"缺少")"。';
             Exit;
           end;

           nNow := nNow + 1;
           nErrCol := nErrCol + 1;
        end;

        if (cFunctions.Items[i].ParamCount > 0) and (nCnt <> cFunctions.Items[i].ParamCount) then
        begin
          Result := False;
          vErrMsg := '出错在第'+IntToStr(nErr+1)
               +'个字符,函数"'+cFunctions.Items[i].vName+'"的参数应该是'
               +IntToStr(cFunctions.Items[i].ParamCount)
               +'个。';
          Exit;
        end;

        if (cFunctions.Items[i].ParamCount = 0) and (nCnt > 0) then
        begin
          Result := False;
          vErrMsg := '出错在第'+IntToStr(nErr+1)
               +'个字符,函数"'+cFunctions.Items[i].vName+'"参数过多。';
          Exit;
        end;

        if Assigned(cFunctions.Items[i].bOnGetValue) then
           Result := cFunctions.Items[i].bOnGetValue(nCnt,fParam,fValue,vErrMsg)
        else
           fValue := cFunctions.Items[i].Value;

        if Assigned(bOnGetValue) then
           Result := bOnGetValue(cFunctions.Items[i].vName,nCnt,fParam,fValue,vErrMsg);

        Exit;
      end;
    end;
    Result := bN(fValue);
  end;

  function bG(var fValue : Real) : Boolean;
  begin
       case vExpression[nNow] of
          '+' :
              begin
                nNow := nNow + 1;
                nErrCol := nErrCol + 1;
                Result := bN1(fValue);
                Exit;
              end;
          '-' :
              begin
                nNow := nNow + 1;
                nErrCol := nErrCol + 1;
                Result := bN1(fValue);
                fValue := -fValue;
                Exit;
              end;
          else
              Result := bN1(fValue);
       end; // case
  end;

  function bH(var fValue : Real) : Boolean;
  begin
    if vExpression[nNow] = '(' then
    begin
      nNow := nNow + 1;
      nErrCol := nErrCol + 1;
      Result := bE(fValue);
      if vExpression[nNow] <> ')' then
      begin
        Result := False;
        vErrMsg := '表达式缺少")"。';
      end;
      nNow := nNow + 1;
      nErrCol := nErrCol + 1;      
    end
    else
      Result := bG(fValue);
  end;

  function bA(var fValue : Real) : Boolean;
  var
    r,r2 : Real;
  begin
    Result := False;
    fValue := 0;
    if bH(r) then
    begin
      while nNow <= nLen do
      begin
        case vExpression[nNow] of
          '*' :
              begin
                nNow := nNow + 1;
                nErrCol := nErrCol + 1;
                if bH(r2) then
                  r := r * r2
                else
                  Exit;
              end;
          '/' :
              begin
                nNow := nNow + 1;
                nErrCol := nErrCol + 1;
                if bH(r2) then
                  r := r / r2
                else
                  Exit;
              end;
          else begin
            Result := True;
            fValue := r;
            Exit;
          end;
        end; // case
      end; // while
      Result := True;
      fValue := r;
    end; // if bH ..
  end;

  function bE(var fv : Real) : Boolean;
  var
    r,r2 : Real;
  begin
    Result := False;
    if bA(r) then
    begin
      while nNow <= nLen do
      begin
        case vExpression[nNow] of
          '+' :
              begin
                nNow := nNow + 1;
                nErrCol := nErrCol + 1;
                if bA(r2) then
                  r := r + r2
                else
                  Exit;
              end;
          '-' :
              begin
                nNow := nNow + 1;
                nErrCol := nErrCol + 1;
                if bA(r2) then
                  r := r - r2
                else
                  Exit;
              end;
          else begin
            Result := True;
            fv := r;
            Exit;
          end;
        end; // case
      end; // while
      Result := True;
      fv := r;
    end; // if bA ..
  end;
begin
  vErrMsg := '';
  nErrRow := 0;
  nErrCol := 0;
  fResult := 0;
  nNow := 1;
  nLen := Length(vExpression);
  Result := bE(fResult);
  if Result and(nNow <= nLen) then
  begin
    Result := False;
    vErrMsg := '出错在第'+IntToStr(nErrCol+1)
               +'个字符,不可识别的保留字"'+vExpression[nNow]+'"。';
  end;
end;

function TmExpression.SetValue(Name : String ;Value : Real) : Boolean;
var
  I : Integer;
begin
  Result := False;   
  for I := 0 to cFunctions.Count - 1 do
  begin
    if cFunctions.Items[i].vName = Name then
    begin
      if not Assigned(cFunctions.Items[i].bOnGetValue) then
      begin
        cFunctions.Items[i].fValue := Value;
        Result := True;
      end;
      Exit;
    end;
  end;
end;

function TmExpression.GetValue(Name : String ;var Value : Real) : Boolean;
var
  I : Integer;
begin
  Result := False;   
  for I := 0 to cFunctions.Count - 1 do
  begin
    if cFunctions.Items[i].vName = Name then
    begin
      if not Assigned(cFunctions.Items[i].bOnGetValue) then
      begin
        Value := cFunctions.Items[i].fValue;
        Result := True;
      end;
      Exit;
    end;
  end;
end;
// Function List

function TmFunctions.GetItem(Index: Integer) : TmFunction;
begin
  Result := TmFunction(inherited GetItem(Index));
end;

procedure TmFunctions.SetItem(Index: Integer; Value: TmFunction);
begin
  inherited SetItem(Index, Value);
end;

function TmFunctions.Add : TmFunction;
begin
  Result := TmFunction(inherited Add);
end;

constructor TmFunctions.Create(Expression: TmExpression);
begin
  inherited Create(TmFunction);
  cExpression := Expression;
end;

procedure TmFunctions.Update(Item: TCollectionItem);
begin
//
end;

function TmFunctions.GetOwner : TPersistent;
begin
  Result := cExpression;
end;

// Function

constructor TmFunction.Create(Collection: TCollection);
begin
  inherited Create(Collection);
//  fExpression := TmFunctions(Collection).fExpression;
end;

destructor TmFunction.Destroy;
begin
  inherited Destroy;
end;

function TmFunction.GetDisplayName : String;
var
   I : Integer;
   vDisplay : String;
begin
  if ParamCount < 0 then
  begin
    Result := vName+'(..)';
    Exit;
  end;

  if ParamCount = 0 then
  begin
    Result := vName;
    Exit;
  end;

  vDisplay := vName+'(';
  for I := 0 to ParamCount - 1 do
  begin
    if I = 0 then
      vDisplay := vDisplay + 'x'
    else
      vDisplay := vDisplay + ',x';
  end;
  Result := vDisplay + ')';
end;

procedure TmFunction.SetParamCount(Count : Integer);
begin
  if Count > 256 then
     nParamCount := 256
  else
     nParamCount := Count;
end;

procedure Register;
begin
  RegisterComponents('Mu Long', [TmExpression]);
end;

end.