stexpr.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StExpr.pas 4.03                             *}
{*********************************************************}
{* SysTools: Expression evaluator component              *}
{*********************************************************}

{$I StDefine.inc}

unit StExpr;

interface

uses
  Windows,
  Classes, Controls, Messages, StdCtrls, SysUtils,
  {$IFDEF UseMathUnit} Math, {$ENDIF}
  StBase, StConst, StMath;

type
  {TStFloat = Double;}  {TStFloat is defined in StBase}
  {.Z+}
  PStFloat = ^TStFloat;
  {.Z-}

type
  {user-defined functions with up to 3 parameters}
  TStFunction0Param =
    function : TStFloat;
  TStFunction1Param =
    function(Value1 : TStFloat) : TStFloat;
  TStFunction2Param =
    function(Value1, Value2 : TStFloat) : TStFloat;
  TStFunction3Param =
    function(Value1, Value2, Value3 : TStFloat) : TStFloat;

  {user-defined methods with up to 3 parameters}
  TStMethod0Param =
    function : TStFloat
    of object;
  TStMethod1Param =
    function(Value1 : TStFloat) : TStFloat
    of object;
  TStMethod2Param =
    function(Value1, Value2 : TStFloat) : TStFloat
    of object;
  TStMethod3Param =
    function(Value1, Value2, Value3 : TStFloat) : TStFloat
    of object;

  TStGetIdentValueEvent =
    procedure(Sender : TObject; const Identifier : AnsiString; var Value : TStFloat)
    of object;

  {.Z+}
  {tokens}
  TStToken = (
    ssStart, ssInIdent, ssInNum, ssInSign, ssInExp, ssEol, ssNum, ssIdent,
    ssLPar, ssRPar, ssComma, ssPlus, ssMinus, ssTimes, ssDiv, ssEqual, ssPower);

const
  {Note: see Initialization section!}
  StExprOperators : array[ssLPar..ssPower] of Char = '(),+-*/=^';
{$IFNDEF VERSION4}
var
  ListSeparator : AnsiChar;
{$ENDIF VERSION4}
  {.Z-}

type
  TStExpression = class(TStComponent)
  {.Z+}
  protected {private}
    {property variables}
    FAllowEqual      : Boolean;
    FLastError       : Integer;
    FErrorPos        : Integer;
    FExpression      : AnsiString;

    {event variables}
    FOnAddIdentifier : TNotifyEvent;
    FOnGetIdentValue : TStGetIdentValueEvent;

    {internal variables}
    eBusyFlag        : Boolean;
    eCurChar         : Char;
    eExprPos         : Integer;
    eIdentList       : TList;
    eStack           : TList;
    eToken           : TStToken;
    eTokenStr        : AnsiString;
    lhs, rhs         : TStFloat;

    {property methods}
    function GetAsInteger : Integer;
    function GetAsString : AnsiString;

    {ident list routines}
    function FindIdent(Name : AnsiString) : Integer;

    {stack routines}
    procedure StackClear;
    function StackCount : Integer;
    procedure StackPush(const Value : TStFloat);
    function StackPeek : TStFloat;
    function StackPop : TStFloat;
    function StackEmpty : Boolean;

    procedure DoOnAddIdentifier;
    procedure GetBase;
      {-base: unsigned_num | (expression) | sign factor | func_call }
    procedure GetExpression;
      {-expression: term | expression+term | expression-term implemented as loop}
    procedure GetFactor;
      {-factor: base | base^factor}
    procedure GetFunction;
      {-func_call: identifier | identifier(params)}
    procedure GetParams(N : Integer);
      {-params: expression | params,expression}
    procedure GetTerm;
      {-term: factor | term*factor | term/factor implemented as loop}
    procedure GetToken;
      {-return the next token string in eTokenStr and type in eToken}
    function PopOperand : TStFloat;
      {-remove top operand value from stack}
    procedure RaiseExprError(Code : LongInt; Column : Integer);
      {-generate an expression exception}

  public
    constructor Create(AOwner : TComponent);
      override;
    destructor Destroy;
      override;
  {.Z-}

    function AnalyzeExpression : TStFloat;
    procedure AddConstant(const Name : AnsiString; Value : TStFloat);
    procedure AddFunction0Param(const Name : AnsiString; FunctionAddr : TStFunction0Param);
    procedure AddFunction1Param(const Name : AnsiString; FunctionAddr : TStFunction1Param);
    procedure AddFunction2Param(const Name : AnsiString; FunctionAddr : TStFunction2Param);
    procedure AddFunction3Param(const Name : AnsiString; FunctionAddr : TStFunction3Param);
    procedure AddInternalFunctions;
    procedure AddMethod0Param(const Name : AnsiString; MethodAddr : TStMethod0Param);
    procedure AddMethod1Param(const Name : AnsiString; MethodAddr : TStMethod1Param);
    procedure AddMethod2Param(const Name : AnsiString; MethodAddr : TStMethod2Param);
    procedure AddMethod3Param(const Name : AnsiString; MethodAddr : TStMethod3Param);
    procedure AddVariable(const Name : AnsiString; VariableAddr : PStFloat);
    procedure ClearIdentifiers;
    procedure GetIdentList(S : TStrings);
    procedure RemoveIdentifier(const Name : AnsiString);

    {public properties}
    property AsInteger : Integer
      read GetAsInteger;
    property AsFloat : TStFloat
      read AnalyzeExpression;
    property AsString : AnsiString
      read GetAsString;
    property ErrorPosition : Integer
      read FErrorPos;
    property Expression : AnsiString
      read FExpression write FExpression;
    property LastError : Integer
      read FLastError;

  published
    property AllowEqual : Boolean
      read FAllowEqual write FAllowEqual default True;

    property OnAddIdentifier : TNotifyEvent
      read FOnAddIdentifier write FOnAddIdentifier;
    property OnGetIdentValue : TStGetIdentValueEvent
      read FOnGetIdentValue write FOnGetIdentValue;
  end;


type
  TStExprErrorEvent =
    procedure(Sender : TObject; ErrorNumber : LongInt; const ErrorStr : AnsiString)
    of object;

type
  TStExpressionEdit = class(TStBaseEdit)
  {.Z+}
  protected {private}
    {property variables}
    FAutoEval : Boolean;
    FExpr     : TStExpression;
    FOnError  : TStExprErrorEvent;

    {property methods}
    function GetOnAddIdentifier : TNotifyEvent;
    function GetOnGetIdentValue : TStGetIdentValueEvent;
    procedure SetOnAddIdentifier(Value : TNotifyEvent);
    procedure SetOnGetIdentValue(Value : TStGetIdentValueEvent);

    {VCL control methods}
    procedure CMExit(var Msg : TMessage);
      message CM_EXIT;
    procedure DoEvaluate;
  {.Z-}

  protected
    procedure KeyPress(var Key: Char);
      override;

  public
    constructor Create(AOwner : TComponent);
      override;
    destructor Destroy;
      override;

    function Evaluate : TStFloat;

    property Expr : TStExpression
      read FExpr;

  published
    property AutoEval : Boolean
      read FAutoEval write FAutoEval default False;

    property OnAddIdentifier : TNotifyEvent
      read GetOnAddIdentifier write SetOnAddIdentifier;
    property OnError : TStExprErrorEvent
      read FOnError write FOnError;
    property OnGetIdentValue : TStGetIdentValueEvent
      read GetOnGetIdentValue write SetOnGetIdentValue;
  end;

function AnalyzeExpr(const Expr : AnsiString) : Double;
  {-Compute the arithmetic expression Expr and return the result}

procedure TpVal(const S : AnsiString; var V : Extended; var Code : Integer);
{
Evaluate string as a floating point number, emulates Borlandish Pascal's
Val() intrinsic
}


implementation

const
  Alpha = ['A'..'Z', 'a'..'z', '_'];
  { Numeric = ['0'..'9', '.']; }
  AlphaNumeric = Alpha + ['0'..'9'];
var
  {Note: see Initialization section!}
  Numeric: set of char;

type
  PStIdentRec = ^TStIdentRec;
  {a double-variant record - wow - confusing maybe, but it saves space}
  TStIdentRec = record
    Name     : AnsiString;
    Kind     : (ikConstant, ikVariable, ikFunction, ikMethod);
    case Byte of
      0 : (Value : TStFloat);
      1 : (VarAddr : PStFloat);
      2 : (PCount : Integer;
           case Byte of
             0 : (Func0Addr : TStFunction0Param);
             1 : (Func1Addr : TStFunction1Param);
             2 : (Func2Addr : TStFunction2Param);
             3 : (Func3Addr : TStFunction3Param);
             4 : (Meth0Addr : TStMethod0Param);
             5 : (Meth1Addr : TStMethod1Param);
             6 : (Meth2Addr : TStMethod2Param);
             7 : (Meth3Addr : TStMethod3Param);
          )
  end;


{routine for backward compatibility}

function AnalyzeExpr(const Expr : AnsiString) : Double;
begin
  with TStExpression.Create(nil) do
    try
      Expression := Expr;
      Result := AnalyzeExpression;
    finally
      Free;
    end;
end;


{*** function definitions ***}

function _Abs(Value : TStFloat) : TStFloat; far;
begin
  Result := Abs(Value);
end;

function _ArcTan(Value : TStFloat) : TStFloat; far;
begin
  Result := ArcTan(Value);
end;

function _Cos(Value : TStFloat) : TStFloat; far;
begin
  Result := Cos(Value);
end;

function _Exp(Value : TStFloat) : TStFloat; far;
begin
  Result := Exp(Value);
end;

function _Frac(Value : TStFloat) : TStFloat; far;
begin
  Result := Frac(Value);
end;

function _Int(Value : TStFloat) : TStFloat; far;
begin
  Result := Int(Value);
end;

function _Trunc(Value : TStFloat) : TStFloat; far;
begin
  Result := Trunc(Value);
end;

function _Ln(Value : TStFloat) : TStFloat; far;
begin
  Result := Ln(Value);
end;

function _Pi : TStFloat; far;
begin
  Result := Pi;
end;

function _Round(Value : TStFloat) : TStFloat; far;
begin
  Result := Round(Value);
end;

function _Sin(Value : TStFloat) : TStFloat; far;
begin
  Result := Sin(Value);
end;

function _Sqr(Value : TStFloat) : TStFloat; far;
begin
  Result := Sqr(Value);
end;

function _Sqrt(Value : TStFloat) : TStFloat; far;
begin
  Result := Sqrt(Value);
end;

{$IFDEF UseMathUnit}
function _ArcCos(Value : TStFloat) : TStFloat; far;
begin
  Result := ArcCos(Value);
end;

function _ArcSin(Value : TStFloat) : TStFloat; far;
begin
  Result := ArcSin(Value);
end;

function _ArcTan2(Value1, Value2 : TStFloat) : TStFloat; far;
begin
  Result := ArcTan2(Value1, Value2);
end;

function _Tan(Value : TStFloat) : TStFloat; far;
begin
  Result := Tan(Value);
end;

function _Cotan(Value : TStFloat) : TStFloat; far;
begin
  Result := CoTan(Value);
end;

function _Hypot(Value1, Value2 : TStFloat) : TStFloat; far;
begin
  Result := Hypot(Value1, Value2);
end;

function _Cosh(Value : TStFloat) : TStFloat; far;
begin
  Result := Cosh(Value);
end;

function _Sinh(Value : TStFloat) : TStFloat; far;
begin
  Result := Sinh(Value);
end;

function _Tanh(Value : TStFloat) : TStFloat; far;
begin
  Result := Tanh(Value);
end;

function _ArcCosh(Value : TStFloat) : TStFloat; far;
begin
  Result := ArcCosh(Value);
end;

function _ArcSinh(Value : TStFloat) : TStFloat; far;
begin
  Result := ArcSinh(Value);
end;

function _ArcTanh(Value : TStFloat) : TStFloat; far;
begin
  Result := ArcTanh(Value);
end;

function _Lnxp1(Value : TStFloat) : TStFloat; far;
begin
  Result := Lnxp1(Value);
end;

function _Log10(Value : TStFloat) : TStFloat; far;
begin
  Result := Log10(Value);
end;

function _Log2(Value : TStFloat) : TStFloat; far;
begin
  Result := Log2(Value);
end;

function _LogN(Value1, Value2 : TStFloat) : TStFloat; far;
begin
  Result := LogN(Value1, Value2);
end;

function _Ceil(Value : TStFloat) : TStFloat; far;
begin
  Result := Ceil(Value);
end;

function _Floor(Value : TStFloat) : TStFloat; far;
begin
  Result := Floor(Value);
end;
{$ENDIF}


{*** TStExpression ***}

procedure TStExpression.AddConstant(const Name : AnsiString; Value : TStFloat);
var
  IR : PStIdentRec;
begin
  if FindIdent(Name) > -1 then
    RaiseExprError(stscExprDupIdent, 0);

  New(IR);
  IR^.Name := LowerCase(Name);
  IR^.Kind := ikConstant;
  IR^.Value := Value;
  eIdentList.Add(IR);

  DoOnAddIdentifier;
end;

procedure TStExpression.AddFunction0Param(const Name : AnsiString;
          FunctionAddr : TStFunction0Param);
var
  IR : PStIdentRec;
begin
  if FindIdent(Name) > -1 then
    RaiseExprError(stscExprDupIdent, 0);

  New(IR);
  IR^.Name := LowerCase(Name);
  IR^.PCount := 0;
  IR^.Kind := ikFunction;
  IR^.Func0Addr := FunctionAddr;
  eIdentList.Add(IR);

  DoOnAddIdentifier;
end;

procedure TStExpression.AddFunction1Param(const Name : AnsiString;
          FunctionAddr : TStFunction1Param);
var
  IR : PStIdentRec;
begin
  if FindIdent(Name) > -1 then
    RaiseExprError(stscExprDupIdent, 0);

  New(IR);
  IR^.Name := LowerCase(Name);
  IR^.PCount := 1;
  IR^.Kind := ikFunction;
  IR^.Func1Addr := FunctionAddr;
  eIdentList.Add(IR);

  DoOnAddIdentifier;
end;

procedure TStExpression.AddFunction2Param(const Name : AnsiString;
          FunctionAddr : TStFunction2Param);
var
  IR : PStIdentRec;
begin
  if FindIdent(Name) > -1 then
    RaiseExprError(stscExprDupIdent, 0);

  New(IR);
  IR^.Name := LowerCase(Name);
  IR^.PCount := 2;
  IR^.Kind := ikFunction;
  IR^.Func2Addr := FunctionAddr;
  eIdentList.Add(IR);

  DoOnAddIdentifier;
end;

procedure TStExpression.AddFunction3Param(const Name : AnsiString;
          FunctionAddr : TStFunction3Param);
var
  IR : PStIdentRec;
begin