xparser.pas

我自己用的Delphi函数单元 具体说明见打包文件的HELP目录下面

//****************************************************************************
//数学表达式递归分析器 v1.0
//****************************************************************************


//****************************************************************************
//表达式可用函数：
//PI,E,RANDOM(n),TRUNC(n),ROUND(n),EXP(n)
//SIN(n),COS(n),TAN(n),COTAN(n)
//ARCSIN(n),ARCCOS(n),ARCTAN(n)
//LN(n),LOG10(n),LOG2(n)
//ABS(n),SQR(n),SQRT(n)
//
//使用 {$DEFINE USE_DLL}，用于生成DLL
//
//****************************************************************************

unit xParser;

interface

uses Windows,Classes,SysUtils;

{$UNDEF USE_DLL}

   function  Calculate(s:String):double; {$ifdef USE_DLL}export;{$endif}
   function  GetExpr(const s : string; var valid : Boolean) : double; {$ifdef USE_DLL}export;{$endif}
   procedure ClearExprVars; {$ifdef USE_DLL}export;{$endif}

var
   IsExprValid:Boolean = False;

implementation

const
   seperators  : TSysCharSet = [' ', #9, '\', ';', '*', '/', '^','+', '=', '-', '%', ')'];

type
   TokenType= (Delimiter,Non,variable,Digit,endExpr,Error,Func);
   TokenPtr = ^TokenRec;
   TokenRec = Record
        Next : TokenPtr;
        Start,Close : Byte;
   End;

   PValueRec= ^ValueRec;
   ValueRec = Record
        Name : String;
        Value: Double;
   End;

var
   ErrAt  : Byte;
   macro  : string;
   i, m   : byte;
   ppText : string; { holds var of function .. }
   VarList: TList;
   VRec   : PValueRec;

(******************************************************************************)

procedure ClearExprVars; {$IFDEF USE_DLL}export;{$ENDIF}
Var
  i : Integer;
Begin
     for i := 0 to VarList.Count-1 Do Begin
         Dispose( VarList.Items[i] );
         VarList.Items[i] := Nil;
     End;
     VarList.Pack;
End;
function GetVar(AVar:String):PValueRec;
Var
  i : Integer;
Begin
     AVar := UpperCase(AVar);
     Result := Nil;
     for i := 0 to VarList.Count-1 Do
         if ( PValueRec(VarList.Items[i])^.Name = AVar ) Then Begin
            Result := PValueRec(VarList.Items[i]);
            Break;
         End;
     if ( Result = Nil ) Then Begin
        GetMem(Result,sizeof(ValueRec));
        Result^.Name := AVar;
        Result^.Value := 0;
        VarList.Add(Result);
     End;
End;
(******************************************************************************
*                                 skipBlanks                                  *
* skip blanks defined in the seperators variables, and update o               *
******************************************************************************)
procedure skipBlanks(var s : string; var o : byte);
var
   ls : byte;
const
   seperators : TSysCharSet = [' ', #9];
begin
   ls := length(S);
   while((s[o] in seperators) and
         (o <= ls)) do
            inc(o);
end; {skipBlanks}

(******************************************************************************
*                                  makeUpper                                  *
* receive a string, and convert it to upper-case                              *
******************************************************************************)
function makeUpper(s : string) : string;
var
   i : byte;
begin
   for i := 1 to length(s) do
      if (s[i] in ['a' .. 'z']) then
         s[i] := upCase(s[i]);
   makeUpper := s;
end; {makeUpper}

(******************************************************************************
*                                  readWord                                   *
* Return the next word found from the current string, and updates the offset  *
* variable. if mu is true, return the upper case word.                        *
******************************************************************************)
function readWord(var s : string;  var o : byte; mu : boolean;
                  const seperators : TSysCharSet) : string;
var
   v : string;
   ls : byte;
begin
   skipBlanks(s, o);
   v := '';
   ls := length(s);
   while ((not (s[o] in seperators)) and 
          (o <= ls)) do begin
            v := v + s[o];
            inc(o);
   end;
   if (mu) then
      v := makeUpper(v);
   if ((v[length(v)] = #255) and (v <> #255)) then begin
      v := copy(v, 1, length(v) - 1);
      dec(o);
   end;
   readWord := v;
end; {readWord}

(******************************************************************************
*                                    DoErr                                    *
******************************************************************************)
procedure DoErr(var n : TokenType);
begin
   n := Error;
   ErrAt := i; {globl err pos}
end; {doErr}

(******************************************************************************
*                                 doReadWord                                  *
******************************************************************************)
function doReadWord : string;
var
   WordIn : string;
begin
     WordIn := '';
     While (not(Macro [i] in
                      [' ','\',';','*','/','^','+','=','-','%','(',')']))
            and (i <= Length(Macro)) do
     begin
          WordIn := WordIn + UpCase(Macro[i]);
          Inc(i);
     end;
     doReadWord := WordIn;
end; {doreadWord}

(******************************************************************************
*                                 ReadNumber                                  *
******************************************************************************)
function ReadNumber : double;
var 
   Number : double;
   Code   : Integer;
   StrNum : string;
begin
     StrNum := doReadWord;
     if StrNum[1] = '.' then StrNum := '0' + StrNum;
     Val(StrNum,Number,Code);
     if Code <> 0 then Number := 0;
     ReadNumber := Number;
end; {readNumber}

procedure Level1(var AResult : double; var n : TokenType) ; forward;

(******************************************************************************
*                                getFuncOrVar                                 *
******************************************************************************)
procedure getFuncOrVar(var n : tokenType);
begin
   m := i;
   ppText := readWord(macro, m, true, seperators);
   if ((pos('(', ppText) <> 0) or (ppText = 'PI') or (ppText = 'E')) then
      n := func
   else
      n := variable;
end; {getFuncOrVar}

(******************************************************************************
*                                  GetToken                                   *
******************************************************************************)
function GetToken : TokenType;
var 
   n    : TokenType;
begin
     SkipBlanks(macro, i);
     if (Macro[i] in ['+','-','/','*','=','^','%','(',')']) then
                        n := Delimiter
                    else if (Macro[i] in ['0'..'9','.']) then
                        n := Digit
                    else if (Macro[i] = ';') then
                        n := endExpr
                    else if (Macro[i] in ['a'..'z','A'..'Z'])
                        then getFuncOrVar(n)
                    else
                        n := Non;
     GetToken := n;
end; {getToken}

(******************************************************************************
*                                  MatchFunc                                  *
******************************************************************************)
function MatchFunc(Match : string; var AResult : double; var n : TokenType) :
                                                               Boolean;
var
   j : Byte;
begin
     j := i; {restore i if no match}
     if (doReadWord = Match) then begin
        MatchFunc := True;
        skipblanks(macro, i);
        if (Macro [i] <> '(') then DoErr(n)
           else begin
                     Inc(i);
                     n := GetToken;
                     Level1(AResult,n);
                     SkipBlanks(macro, i); {Reach closing parenthasis}
                     if Macro[i] <> ')' then DoErr(n);
                     Inc(i);
                     SkipBlanks(macro, i);
           end;
     end else begin
         MatchFunc := False;
         i := j; {no Func Match, restore}
     end;
end; {matchFunc}

(******************************************************************************
*                                 MatchToken                                  *
******************************************************************************)
function MatchToken(Match : string) : boolean;
var
   j : byte;
begin
	j := i;
	if (doreadWord = match) then MatchToken := True
		else begin
			MatchToken := False;
			i := j;
		end; {else}
end; {matchToken}

(******************************************************************************
*                                    doPI                                     *
******************************************************************************)
function doPI(var r:double) : boolean;
begin
	doPI := matchToken('PI');
	r := pi;
end; {doPI}

(******************************************************************************
*                                     doE                                     *
******************************************************************************)
function doE(var r:double) : boolean;
begin
	doE := matchToken('E');
	r := exp(1.0);
end; {doE}

(******************************************************************************
*                                    DoSin                                    *
******************************************************************************)
function DoSin(var AResult : double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('SIN',AResult,n);
     AResult := sin(AResult);
     DoSin := r;
end; {doSin}

(******************************************************************************
*                                  doRandom                                   *
******************************************************************************)
function doRandom(var Aresult : double; var n : tokenType) : boolean;
var
   r : boolean;
begin
      r := matchFunc('RANDOM', Aresult, n);
      Aresult := 0.0 + random(trunc(Aresult));
      doRandom := r;
end; { doRandom }

(******************************************************************************
*                                   doTrunc                                   *
******************************************************************************)
function doTrunc(var AResult : double; var n : TokenType) : Boolean;
var
   r : boolean;
begin
   r := matchFunc('TRUNC', Aresult, n);
   Aresult := 0.0 + trunc(Aresult);
   doTrunc := r;
end; { doTrunc }

(******************************************************************************
*                                   doRound                                   *
******************************************************************************)
function doRound(var Aresult : double; var n : tokenType) : boolean;
var
   r : boolean;
begin
      r := matchFunc('ROUND', Aresult, n);
      Aresult := 0.0 + round(Aresult);
      doRound := r;
end; { doRound }


(******************************************************************************
*                                    DoExp                                    *
******************************************************************************)
function DoExp(var AResult : double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('EXP',AResult,n);
     AResult := exp(AResult);
     DoExp := r;
end; {doSin}

(******************************************************************************
*                                    DoCos                                    *
******************************************************************************)
function DoCos(var AResult : double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('COS',AResult,n);
     AResult := cos(AResult);
     DoCos := r;
end; {doCos}

(******************************************************************************
*                                    DoLn                                     *
******************************************************************************)
function DoLn(var AResult : Double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('LN',AResult,n);
     if (AResult > 0.0) then AResult := ln(AResult)
        else DoErr(n);
     DoLn := r;
end; {doLn}

(******************************************************************************
*                                   DoLog10                                   *
******************************************************************************)
function DoLog10(var AResult : Double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('LOG10',AResult,n);
     if (AResult > 0.0) then AResult := ln(AResult)/ln(10.0)
        else DoErr(n);
     DoLog10 := r;
end; {doLog10}

(******************************************************************************
*                                   DoLog2                                    *
******************************************************************************)
function DoLog2(var AResult : Double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('LOG2',AResult,n);
     if (AResult > 0.0) then AResult := ln(AResult)/ln(2.0)
        else DoErr(n);
     DoLog2 := r;
end; {doLog2}

(******************************************************************************
*                                    DoAbs                                    *
******************************************************************************)
function DoAbs(var AResult : Double; var n : TokenType) : Boolean;
var