xparser.pas

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

   r : Boolean;
begin
     r := MatchFunc('ABS',AResult,n);
     AResult := Abs(AResult);
     DoAbs := r;
end; {doAbs}

(******************************************************************************
*                                  DoArcTan                                   *
******************************************************************************)
function DoArcTan(var AResult : Double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('ARCTAN',AResult,n);
     AResult := ArcTan(AResult);
     DoArcTan := r;
end; {doArcTan}

(******************************************************************************
*                                    DoSqr                                    *
******************************************************************************)
function DoSqr(var AResult : Double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('SQR',AResult,n);
     AResult := Sqr(AResult);
     DoSqr := r;
end; {doSqr}

(******************************************************************************
*                                   DoSqrt                                    *
******************************************************************************)
function DoSqrt(var AResult : Double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('SQRT',AResult,n);
     AResult := Sqrt(AResult);
     DoSqrt := r;
end; {doSqrt}

(******************************************************************************
*                                    DoTan                                    *
******************************************************************************)
function DoTan(var AResult : Double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('TAN',AResult,n);
     if ( cos(Aresult) <> 0 ) then
	AResult := Sin(AResult) / cos(AResult)
     else doErr(n);
     DoTan := r;
end; {doTan}

(******************************************************************************
*                                   DoCoTan                                   *
******************************************************************************)
function DoCoTan(var AResult : Double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('COTAN',AResult,n);
     if ( sin(Aresult) <> 0 ) then
	AResult := cos(AResult) / sin(AResult)
     else doErr(n);
     DoCoTan := r;
end; {doCoTan}

(******************************************************************************
*                                  DoArcSin                                   *
******************************************************************************)
function DoArcSin(var AResult : Double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
     r := MatchFunc('ARCSIN',AResult,n);
	 if (abs(AResult) < 1.0) then
	AResult := arcTan(AResult/sqrt(1-Aresult*Aresult))
     else doErr(n);
     DoArcSin := r;
end; {doArcSin}

(******************************************************************************
*                                  DoArcCos                                   *
******************************************************************************)
function DoArcCos(var AResult : Double; var n : TokenType) : Boolean;
var
   r : Boolean;
begin
	 r := MatchFunc('ARCCOS',AResult,n);
	 if ((AResult <> 0.0) and (Aresult < 1.0)) then
	   AResult := arcTan(sqrt(1-Aresult*Aresult)/Aresult)
    else doErr(n);
    DoArcCos := r;
end; {doArcCos}

(******************************************************************************
*                                   DoFunc                                    *
******************************************************************************)
procedure DoFunc(var AResult : Double; var n : TokenType);
begin
     case Macro [i] of
          's','S' : begin
                         if not(DoSin(AResult,n)) then
                            if not(DoSqr(AResult,n)) then
                               if not(DoSqrt(AResult,n)) then
                            DoErr(n);
                    end;
          'c','C' : begin
                         if not(DoCos(AResult,n)) then
			   if not(DoCoTan(Aresult,n)) then
                            DoErr(n);
                    end;
          'l','L' : begin
                         if not(DoLn(AResult,n)) then
				if not(doLog10(Aresult,n)) then
					if not(doLog2(Aresult,n)) then
                            DoErr(n);
                    end;
          'a','A' : begin
                         if not(DoAbs(AResult,n)) then
                            if not(DoArcTan(AResult,n)) then
				if not(doArcSin(AResult,n)) then
				 	if not(doArcCos(Aresult,n))
                               then DoErr(n);
                    end;
          'e','E' : begin
                         if not(DoExp(AResult,n)) then
				if not(doE(Aresult)) then
                            	 	DoErr(n);
                    end;
	  't','T' : begin
			if not(doTan(Aresult,n)) then
                           if (not doTrunc(Aresult, n)) then
   				doErr(n);
		    end;
	  'p','P' : begin
			if not(doPI(Aresult)) then
				doErr(n);
		    end;
      'r', 'R' : begin
                        if (not(doRandom(Aresult, n))) then
                           if (not doRound(Aresult, n)) then
                              doErr(n);
      end; { 'r' }
      else
         DoErr(n);
     end; {case}
end;

(******************************************************************************
*                                  Primitive                                  *
******************************************************************************)
procedure Primitive(var AResult : Double; var n : TokenType);
begin
   if (n = variable) then begin
      i := m;
      VRec := GetVar(ppText);
      AResult := VRec^.Value;
   end else if (n = Digit) then
      AResult := ReadNumber
   else if (n = Func) then
      DoFunc(AResult,n);
   SkipBlanks(macro, i);
end;

(******************************************************************************
*                                   Level6                                    *
* handle parenthasis                                                          *
******************************************************************************)
procedure Level6(var AResult : Double; var n : TokenType);
begin
   if ((n = Delimiter) and (Macro [i] = '(')) then 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 else
      Primitive(AResult,n);
end; { level6}

(******************************************************************************
*                                   Level5                                    *
******************************************************************************)
procedure Level5(var AResult : Double; var n : TokenType);
var 
   op : Char;
begin
   if (i <= length(macro[i])) then
      op := Macro[i]
   else
      op := '#';
   if (op in ['-','+']) then 
      Inc(i);
   n := GetToken;
   Level6(AResult,n);
   if (op = '-') then 
      AResult := - (AResult);
end; { level5 }

(******************************************************************************
*                                    Sign                                     *
* returns -1 if num < 0, 1 otherwise                                          *
******************************************************************************)
function Sign(Number : Double) : Double;
begin
     if (Number < 0.0) then Sign := -1.0
        else Sign := 1.0;
end; { sign }

(******************************************************************************
*                                   Level4                                    *
******************************************************************************)
procedure Level4(var AResult : Double; var n : TokenType);
var 
   Hold : Double;
begin
   Level5(AResult,n);
   if (n <> Error) then
      if (macro[i] = '^') then begin
         Inc(i);
         n := GetToken;
         Level4(Hold,n);
         if (AResult = 0.0) then
            if (hold = 0.0) then 
               AResult := 1.0
            else 
               AResult := 0.0
         else 
            AResult := Sign(AResult) * Exp(Hold * Ln(Abs(AResult)));
         SkipBlanks(macro, i);
      end;  { case of ^ }
end; {level4}

(******************************************************************************
*                                   Level3                                    *
* handle multiply/divide                                                      *
******************************************************************************)
procedure Level3(var AResult : Double; var n : TokenType);
var 
   Hold : Double;
   op   : Char;
begin
   Level4(AResult,n);
   if (n <> Error) then begin
      SkipBlanks(macro, i);
      While ((Macro[i] in ['*','/','%']) and
             (i <= length(macro))) do begin
         op := Macro[i];
         Inc(i);
         if (i > length(macro)) then begin
            doErr(n);
         end else begin
            n := GetToken;
            Level4(Hold,n);
            if (op = '*') then 
               AResult := AResult * Hold
            else begin
	            if (hold = 0.0) then 
                  doErr(n)
	            else if (op = '/') then 
                  AResult := AResult / Hold
               else 
                  AResult := Trunc(AResult) mod Trunc(Hold);
         end; { legal }
	   end; { while }
         SkipBlanks(macro, i);
      end;
   end; {not error}
end; { level 3 }

(******************************************************************************
*                                   Level2                                    *
* handle add/sub                                                              *
******************************************************************************)
procedure Level2(var AResult : Double; var n : TokenType);
var 
    Hold : Double;
    op   : Char;
begin
   Level3(AResult,n);
   if (n <> Error) then begin
      SkipBlanks(macro, i);
      While ((Macro[i] in ['+','-']) and 
             (i <= length(macro))) do begin
         op := Macro [i];
         inc(i);
         if (i > length(macro)) then begin
            doErr(n);
         end else begin
            n := GetToken;
            Level3(Hold,n);
            if (op = '+') then 
               AResult := AResult + Hold
            else
               AResult := AResult - Hold;
            SkipBlanks(macro, i);
         end; { no probs .. }
      end; {while}
   end; {not error}
end; { level2 }

(******************************************************************************
*                                   Level1                                    *
* handle assign                                                               *
******************************************************************************)
procedure Level1(var AResult : Double; var n : TokenType);
var
    mt   : TokenType;
    j    : Byte;
    mv   : string;
begin
   if (n = variable) then begin
      j := i; {save  i}
      i := m;
      mv := ppText;
      mt := GetToken;
      if ((mt = Delimiter) and (Macro [i] = '=') and (i <=length(Macro)))
      then begin
            Inc(i);
            n := GetToken;
            Level2(AResult,n);
            VRec := GetVar(mv);
            VRec^.Value := AResult;
      end else begin
         i := j; {restore ..}
         level2(AResult,n);
      end; {not a variable = ...}
   end {variable case} else
      Level2(AResult,n);
end; { level 1 }

(******************************************************************************
*                                   GetExpr                                   *
******************************************************************************)
function  GetExpr(const s : string; var valid : Boolean) : double; {$ifdef USE_DLL}export;{$endif}
var
   AResult : Double;
   n       : TokenType;
begin

{$ifdef USE_DLL}
   macro := strPas(s);
{$else}
   macro := s;
{$endif}

   i := 1;
   AResult := 0; {if no result returned}
   n := GetToken;
   if (Not (n in [endExpr,Non])) then
      Level1(AResult,n);
   if ((n <> endExpr) and (i < Length(Macro))) then
      Dec(i);
   GetExpr := AResult;
   if (n = Error) then begin
      Valid := False;
{$ifdef USE_DLL}
      Aresult := errAt;
{$endif}
   end
   else
      Valid := True;
end; {getExpr}

(******************************************************************************)
function Calculate(s:String):double;
begin
    Result:=0;
    s:=Trim(s);
    if Length(s)=0 then Exit;
    try
        IsExprValid:=True;
        Result:=GetExpr(PChar(s),IsExprValid);
        if not IsExprValid then
            MessageBox(0,'无效的表达式','警告',MB_ICONEXCLAMATION);
    except
        on E: Exception do
        begin
            IsExprValid:=False;
            MessageBox(0,PChar(E.Message),'警告',MB_ICONEXCLAMATION);
        end;
    end;
end;

(******************************************************************************
*                                    MAIN                                     *
******************************************************************************)
Initialization
    VarList := TList.Create;

Finalization
    ClearExprVars;
    VarList.Free;

end.