出自：http://wagesys.googlecode.com/svn-history/r2/trunk/Source/MathParserUnit.pas
////////////////////////////////////////////////////////////////////////////////// 模块: 表达式解析器// 创建时间:2003-10-19 作者:mrlong 版本:2.0//// 支持 Delphi XE 的版本////说明:// 类:TMathParser//-----------------------------------------------------------------------------// TokenType : 0 :运算符// 1 :函数// 2 :普通变量 {} 已变为说明符// 3 :费用表变量 []// 4 :工程表变量 {}// 5 :普通数字 212//-----------------------------------------------------------------------------// 如果拥有者是TmlBudgetFile对象,则在解析时可通过域控制器搜索变量//-----------------------------------------------------------------------------//关键方法// 解析表达式// 参数: expression 表达式 ;Awrong 非法字符串// function Parse(expression: string;Awrong:String=''): extended;// 返回值:解析是否成功// property ParserError : Boolean read fParserError ;// 可用的方法名// property FunctionName : TStrings read GetfunctionNames;//// 修改:// 1.增加一个方法: jw()小数据进位,取整 By Mrlong 2004-9-26// 2.增加一个方法: Round2(value), 取两位 Round3(value), 取三位 Round4(value), 取四位// 3.修改了 MaxFuncNameLen 函数名称的位数5 改为 10// 4.fCount : integer; 是目的是怎么处理??// 5.语法增强:// ()表示代码的集合 [(t1;t2;t3).sc_rgf] = [t1.sc_rgf] + [t2.sc_rgf] + [t3.sc_rgf]//// 6.增加 Round0(), Round1(), Round5(),Round6() 的 函数 2005-12-5//// 7.在对表达式来说,有可能不是直接要计算出值,而是只显示表达式的内容// 如 费用表内的计算表达式说明时要用到// 修改内容:// line:1110 增加 '['的条件// line: 997 去掉部分不要的代码为了加快速度//// 8.处理不采用 [] 作为变量的作法,这样加快录入的速度 2006-11-15////// 9.我增加了if()的方法 格式 if(条件,真,假) 2007-3-1 V3.0.5// 处理方式: 放在Parse 方法前处理掉单独处理,在生成键表后,Parse前处理,// 所以生成键表过程中if()是方法,到了parse就不是方法了.//// 10.更改了，在去掉<>,与{}时，没有去掉<> 2007-9-18 ver=3.1.6// 11.修改 GetExpressVar() 方法内Value取出值后必须初期化,否则第二次有问题 ver=3.1.9 2007-10-23// 12.修改了第10条<>处理引起的if([!rcj_dy]>[rcj_ysj],0,12);时,>给去掉了.产生计算出错 ver=3.1.9 2007-10-29// 13.修改支持Delphi XE 版本 作者 :龙仕云 2011-7-2//////////////////////////////////////////////////////////////////////////////////////unit MathParserUnit;interfaceuses Windows, SysUtils, Messages, Classes, Controls, math ;type TParseErrorEvent = procedure(Sender : TObject; ParseError : Integer) of object; //取出变量的地方,回调方法 // 引用表时 myMathPaser.Parse(@DoGetValueByCode); TOnGetValueByCodeEvent = procedure(ACode:string; var AValue:string; var AFound:Boolean) of object;//定义ExpressParse中的常量const ParserStackSize = 30; MaxFuncNameLen = 10; // 5 by mrlong 有方法名大于5个字符的 ExpLimit = 11356; SqrLimit = 1E2466; MaxExpLen = 4; TotalErrors = 10; ErrParserStack = 1; ErrBadRange = 2; ErrExpression = 3; ErrOperator = 4; ErrOpenParen = 5; ErrOpCloseParen = 6; ErrInvalidNum = 7; //引用自身或循环传递出错 Erruseselfloop = 8; //单位描述错误 Errindanweimask = 9; //变量描述错误 Errinvardefine = 10; //表达式不能为空 ErrEmpty = 11; //Add : Mrlongtype ErrorRange = 0..TotalErrors; TokenTypes = (Plus, Minus, Times, Divide, Expo, OParen, CParen, Num, Func, EOL, Bad, ERR, Modu); TokenRec = record State : Byte; case Byte of 0 : (Value : Extended); 2 : (FuncName : String[MaxFuncNameLen]); end; { TokenRec } PExpressLink = ^TExpressLink; TExpressLink = record Tokenname : String; TokenType : Word; ExpressNext : pExpressLink; end; //定义检查链表 PCheckLink = ^TCheckLink; TCheckLink = record VarName : String; VNext : PCheckLink; end;type TMathParser = class(TObject) private fInput : string; fLeftInput : String; fOnParseError : TParseErrorEvent; fOnGetValueByCode : TOnGetValueByCodeEvent; // add by mrlong fhasvar : Boolean ; //= True 表示有变量 如 [f2.g3] ,主要用到对变量的解析中 fhasVariableChar : Boolean; //=True 表示变量要采用[] 来注明的 // end add protected CurrToken : TokenRec; VaruseError : Word; MathError : Boolean; ExpressError : Boolean; DescribeError : Boolean; Stack : array[1..ParserStackSize] of TokenRec; StackTop : 0..ParserStackSize; TokenError : ErrorRange; TokenLen : Word; TokenType : TokenTypes; CheckHead : PCheckLink; fCount: integer; fFunctionCaption : TStringList; fFunctionName : TStringList; function GotoState(Production : Word) : Word; function IsFunc(S : String) : Boolean; function IsVar(var Value : Extended) : Boolean; function NextToken : TokenTypes; function DeleteSpace(InputExpress: String): String; function CreateExpressLink(OrignalExpress : String) : PExpressLink; function IsFunction(s: String; d: String) : Boolean; function IsConstVar(s: String) : Boolean; function IsNum(s: String) :Boolean; function CreateExpress( ExpressHead : PExpressLink ) : String; procedure DeleteExpressLink(ExpressHead : PExpressLink); //取出数字 function GetExpressVar(ExpressHead : PExpressLink) : PExpressLink; procedure GetVarByCode(ACode:string;var Value:Extended;var Found:Boolean); //下面的方法只用于取出字符串 function GetExpressStrVar(ExpressHead : PExpressLink) : PExpressLink; procedure GetStrVarByCode(ACode:string;var Value:string;var Found:Boolean); //check procedure CheckLinkAdd(VarName : String); function CompareLink(ExpressHead : PExpressLink) : Boolean; procedure DeleteCheckLink(CheckHead : PCheckLink); procedure Deletethevarname; // procedure Push(Token : TokenRec); procedure Pop(var Token : TokenRec); procedure Reduce(Reduction : Word); procedure Shift(State : Word); function Parse : Boolean;overload; function ParseIfExp(AStr:String):Boolean; // 1.2&23 的情况 function ParseNum(AStr:String;var AValue:Extended):Boolean; //处理一个没有变量的表达式 如 2*3+1 function ExpressParse(Express : String; varname : String; CheckHead : PCheckLink ) :Boolean; overload; public Position : Word; ParseError : Boolean; ParseValue : Extended; Constructor Create(); destructor Destroy; override; procedure Parse(ABackFun:TOnGetValueByCodeEvent); overload; // // 解析出表达式的内容,但不计算出最后的结果 // AExp : 为原始值的内容,如成功则返回为最后的内容 // 返回值 : = True 表示成功 // procedure ParseExpression(var AExp:String); published property OnParseError : TParseErrorEvent read FOnParseError write FOnParseError; property OnGetValueByCode : TOnGetValueByCodeEvent read fOnGetValueByCode write fOnGetValueByCode; property ParseString : string read FInput write FInput; property ParseLeftString : String read FLeftInput write FLeftInput; //目的是为了处理死 property FunctionCaption : TStringList read fFunctionCaption; property FunctionName : TStringList read fFunctionName; property Count: integer read fCount write fCount; property hasVariableChar : Boolean read fhasVariableChar write fhasVariableChar; end;implementationfunction Round2(aValue: extended; aDigit: integer): extended;begin aValue := aValue + 0.0000000001; if aDigit > 14 then result := RoundTo(aValue,-14) else result := RoundTo(aValue,-aDigit);end;function isEqual(Avalue,Bvalue:Extended):boolean;begin if abs(Avalue-Bvalue)<0.00000001 then result := true else result := false;end;{ TMathParser }constructor TMathParser.Create();begin { defaults } FInput := ''; fCount := 0; CheckHead := nil; fFunctionCaption := TStringList.Create; fFunctionName := TStringList.Create; fhasVariableChar := True; //写入方法说明 fFunctionCaption.Add('abs(B)=B的绝对值 '); fFunctionCaption.Add('atan(B) '); fFunctionCaption.Add('cos(D) = D的余弦值,D以度为单位'); fFunctionCaption.Add('tan(D) = D的正切值,D以度为单位'); fFunctionCaption.Add('cot(D) = D的余切值,D以度为单位'); fFunctionCaption.Add('exp(B) = B的指数 '); fFunctionCaption.Add('ln(B) = B的自然对数 '); fFunctionCaption.Add('round(B)= 四舍五入取整 '); fFunctionCaption.Add('sin(D) = D的正弦值,D以度为单位'); fFunctionCaption.Add('sqrt(B) = B的开方 '); fFunctionCaption.Add('sqr(B) = B的平方 '); fFunctionCaption.Add('sqr3(B) = B的三次方 '); fFunctionCaption.Add('trunc(B) '); fFunctionCaption.Add('xsqz(B) = B向上取整 '); fFunctionCaption.Add('jw(B) = 小数点进位取整'); fFunctionCaption.Add('r0(B)= 四舍五入取0位 '); fFunctionCaption.Add('r1(B)= 四舍五入取1位 '); fFunctionCaption.Add('r2(B)= 四舍五入取2位 '); fFunctionCaption.Add('r3(B)= 四舍五入取3位 '); fFunctionCaption.Add('r4(B)= 四舍五入取4位 '); fFunctionCaption.Add('r5(B)= 四舍五入取5位 '); fFunctionCaption.Add('r6(B)= 四舍五入取6位 '); fFunctionCaption.Add('if(B)= 条件取值,B 条件,真,假 , 例如 if(1>2,1,2)'+#13#10 + '其中 >,=,!=,>= 分别表示大于,等于,不等于,大于等于。 '+#13#10+ ' & 为并且;| 为或者 '+#13#10 + '例如: if(1.2>[v.y1_a]&1.5>[v.y1_a],2.3,0)'+#13#10 + ' 意思就是 [v.y1_a]的值在1.2与1.5之间,则返回值=2.3,否则=0。 ' ); fFunctionName.Add('abs()'); fFunctionName.Add('atan()'); fFunctionName.Add('cos()'); fFunctionName.Add('tan()'); fFunctionName.Add('cot()'); fFunctionName.Add('exp()'); fFunctionName.Add('ln()'); fFunctionName.Add('round()'); fFunctionName.Add('sin()'); fFunctionName.Add('sqrt()'); fFunctionName.Add('sqr()'); fFunctionName.Add('sqr3()'); fFunctionName.Add('trunc()'); fFunctionName.Add('rxqz()'); fFunctionName.Add('jw()'); fFunctionName.Add('r0()'); fFunctionName.Add('r1()'); fFunctionName.Add('r2()'); fFunctionName.Add('r3()'); fFunctionName.Add('r4()'); fFunctionName.Add('r5()'); fFunctionName.Add('r6()'); fFunctionName.Add('if()');end;function TMathParser.GotoState(Production : Word) : Word;var State : Word;begin GotoState := 0; // add by mrlong State := Stack[StackTop].State; if (Production <= 3) then begin case State of 0 : GotoState := 1; 9 : GotoState := 19; 20 : GotoState := 28; end; { case } end else if Production <= 6 then begin case State of 0, 9, 20 : GotoState := 2; 12 : GotoState := 21; 13 : GotoState := 22; end; { case } end else if (Production <= 8) or (Production = 100) then begin case State of 0, 9, 12, 13, 20 : GotoState := 3; 14 : GotoState := 23; 15 : GotoState := 24; 16 : GotoState := 25; 40 : GotoState := 80; end; { case } end else if Production <= 10 then begin case State of 0, 9, 12..16, 20, 40 : GotoState := 4; end; { case } end else if Production <= 12 then begin case State of 0, 9, 12..16, 20, 40 : GotoState := 6; 5 : GotoState := 17; end; { case } end else begin case State of 0, 5, 9, 12..16, 20, 40 : GotoState := 8; end; { case } end;end; { GotoState }function TMathParser.IsFunc(S : String) : Boolean;var P, SLen : Word; FuncName : string;begin P := Position; FuncName := ''; while (P <= Length(FInput)) and CharInSet(FInput[P], ['A'..'Z', 'a'..'z', '0'..'9', '_']) do begin FuncName := FuncName + FInput[P]; Inc(P); end; { while } if Uppercase(FuncName) = S then begin SLen := Length(S); // FuncName 是有长度的,但录入的内容没有长度 CurrToken.FuncName := ShortString(UpperCase(Copy(FInput, Position, SLen))); Inc(Position, SLen); IsFunc := True; end { if } else IsFunc := False;end;{ IsFunc }function TMathParser.IsVar(var Value : Extended) : Boolean;var VarName : string; VarFound : Boolean;begin VarFound := False; VarName := ''; while (Position <= Length(FInput)) and (AnsiChar(FInput[Position]) in ['A'..'Z', 'a'..'z', '0'..'9', '_', #127..#255, '[', ']','@','#']) do begin VarName := VarName + FInput[Position]; Inc(Position); end; { while } IsVar := VarFound;end; { IsVar }function TMathParser.NextToken : TokenTypes;var NumString : String[80]; TLen, NumLen : Word; Check : Integer; Ch: Char; Decimal : Boolean;begin while (Position <= Length(FInput)) and (FInput[Position] = ' ') do Inc(Position); TokenLen := Position; if Position > Length(FInput) then begin NextToken := EOL; TokenLen := 0; Exit; end; { if } Ch := UpCase(FInput[Position]); if AnsiChar(Ch) in ['!'] then begin NextToken := ERR; TokenLen := 0; Exit; end; { if } NextToken := EOL; // add by mrlong 2008-5-26 if AnsiChar(Ch) in ['0'..'9', '.'] then begin NumString := ''; TLen := Position; Decimal := False; while (TLen <= Length(FInput)) and ((AnsiChar(FInput[TLen]) in ['0'..'9']) or ((FInput[TLen] = '.') and (not Decimal))) do begin NumString := NumString + ShortString(FInput[TLen]); if Ch = '.' then Decimal := True; Inc(TLen); end; { while } if (TLen = 2) and (Ch = '.') then begin NextToken := BAD; TokenLen := 0; Exit; end; { if } if (TLen <= Length(FInput)) and (UpCase(FInput[TLen]) = 'E') then begin NumString := NumString + 'E'; Inc(TLen); if AnsiChar(FInput[TLen]) in ['+', '-'] then begin NumString := NumString + ShortString(FInput[TLen]); Inc(TLen); end; { if } NumLen := 1; while (TLen <= Length(FInput)) and (AnsiChar(FInput[TLen]) in ['0'..'9']) and (NumLen <= MaxExpLen) do begin NumString := NumString + ShortString(FInput[TLen]); Inc(NumLen); Inc(TLen); end; { while } end; { if } if NumString[1] = '.' then NumString := '0' + NumString; Val(string(NumString), CurrToken.Value, Check); if Check <> 0 then begin MathError := True; TokenError := ErrInvalidNum; Inc(Position, Pred(Check)); end { if } else begin NextToken := NUM; Inc(Position, System.Length(NumString)); TokenLen := Position - TokenLen; end; { else } Exit; end { if } else if CharInSet(Ch,['A'..'Z', 'a'..'z', #127..#255, '[',']']) then begin if IsFunc('ABS') or IsFunc('ATAN') or IsFunc('COS') or IsFunc('TAN') or isFunc('COT') or IsFunc('EXP') or IsFunc('LN') or IsFunc('ROUND') or IsFunc('SIN') or IsFunc('SQRT') or IsFunc('SQR') or IsFunc('SQR3') or IsFunc('TRUNC') or IsFunc('XSQZ') or IsFunc('JW') or isFunc('R0') or IsFunc('R1') or IsFunc('R2') or IsFunc('R3') or IsFunc('R4') or IsFunc('R5') or IsFunc('R6') then begin NextToken := FUNC; TokenLen := Position - TokenLen; Exit; end; { if } if IsFunc('MOD') then begin NextToken := MODU; TokenLen := Position - TokenLen; Exit; end; { if } if IsVar(CurrToken.Value) //是变量,取出值 then begin NextToken := NUM; TokenLen := Position - TokenLen; Exit; end { if } else begin NextToken := BAD; TokenLen := 0; Exit; end; { else } end { if } else begin case Ch of '+' : NextToken := PLUS; '-' : NextToken := MINUS; '*' : NextToken := TIMES; '/' : NextToken := DIVIDE; '^' : NextToken := EXPO; '(' : NextToken := OPAREN; ')' : NextToken := CPAREN; else begin NextToken := BAD; TokenLen := 0; Exit; end; { case else } end; { case } Inc(Position); TokenLen := Position - TokenLen; Exit; end; { else if }end; { NextToken }procedure TMathParser.Pop(var Token : TokenRec);begin Token := Stack[StackTop]; Dec(StackTop);end; { Pop }procedure TMathParser.Push(Token : TokenRec);begin if StackTop = ParserStackSize then TokenError := ErrParserStack else begin Inc(StackTop); Stack[StackTop] := Token; end; { else }end; { Push }function TMathParser.Parse : Boolean;var FirstToken : TokenRec; Accepted : Boolean;begin Position := 1; StackTop := 0; TokenError := 0; MathError := False; ParseError := False; Accepted := False; FirstToken.State := 0; FirstToken.Value := 0; Push(FirstToken); TokenType := NextToken; repeat case Stack[StackTop].State of 0, 9, 12..16, 20, 40 : begin if TokenType = NUM then Shift(10) else if TokenType = FUNC then Shift(11) else if TokenType = MINUS then Shift(5) else if TokenType = OPAREN then Shift(9) else if TokenType = ERR then begin MathError := True; Accepted := True; end { else if } else begin TokenError := ErrExpression; Dec(Position, TokenLen); end; { else } end; { case of } 1 : begin if TokenType = EOL then Accepted := True else if TokenType = PLUS then Shift(12) else if TokenType = MINUS then Shift(13) else begin TokenError := ErrOperator; Dec(Position, TokenLen); end; { else } end; { case of } 2 : begin if TokenType = TIMES then Shift(14) else if TokenType = DIVIDE then Shift(15) else Reduce(3); end; { case of } 3 : begin if TokenType = MODU then Shift(40) else Reduce(6); end; { case of } 4 : begin if TokenType = EXPO then Shift(16) else Reduce(8); end; { case of } 5 : begin if TokenType = NUM then Shift(10) else if TokenType = FUNC then Shift(11) else if TokenType = OPAREN then Shift(9) else begin TokenError := ErrExpression; Dec(Position, TokenLen); end; { else } end; { case of } 6 : Reduce(10); 7 : Reduce(13); 8 : Reduce(12); 10 : Reduce(15); 11 : begin if TokenType = OPAREN then Shift(20) else begin TokenError := ErrOpenParen; Dec(Position, TokenLen); end; { else } end; { case of } 17 : Reduce(9); 18 : raise Exception.Create('Bad token state'); 19 : begin if TokenType = PLUS then Shift(12) else if TokenType = MINUS then Shift(13) else if TokenType = CPAREN then Shift(27) else begin TokenError := ErrOpCloseParen; Dec(Position, TokenLen); end; end; { case of } 21 : begin if TokenType = TIMES then Shift(14) else if TokenType = DIVIDE then Shift(15) else Reduce(1); end; { case of } 22 : begin if TokenType = TIMES then Shift(14) else if TokenType = DIVIDE then Shift(15) else Reduce(2); end; { case of } 23 : Reduce(4); 24 : Reduce(5); 25 : Reduce(7); 26 : Reduce(11); 27 : Reduce(14); 28 : begin if TokenType = PLUS then Shift(12) else if TokenType = MINUS then Shift(13) else if TokenType = CPAREN then Shift(29) else begin TokenError := ErrOpCloseParen; Dec(Position, TokenLen); end; { else } end; { case of } 29 : Reduce(16); 80 : Reduce(100); end; { case } until Accepted or (TokenError <> 0); if TokenError <> 0 then begin if TokenError = ErrBadRange then Dec(Position, TokenLen); if Assigned(FOnParseError) then FOnParseError(Self, TokenError); end; { if } if MathError or (TokenError <> 0) or ExpressError or DescribeError then begin ParseError := True; if Assigned(FOnParseError) then FOnParseError(Self, TokenError); ParseValue := 0; Result := False; //Exit; end else begin ParseError := False; ParseValue := Stack[StackTop].Value; Result := True; end;end; { Parse }procedure TMathParser.Reduce(Reduction : Word);{ Completes a reduction }var Token1, Token2 : TokenRec;begin case Reduction of 1 : begin Pop(Token1); Pop(Token2); Pop(Token2); CurrToken.Value := Token1.Value + Token2.Value; end; 2 : begin Pop(Token1); Pop(Token2); Pop(Token2); CurrToken.Value := Token2.Value - Token1.Value; end; 4 : begin Pop(Token1); Pop(Token2); Pop(Token2); CurrToken.Value := Token1.Value * Token2.Value; end; 5 : begin Pop(Token1); Pop(Token2); Pop(Token2); if Token1.Value = 0 then MathError := True else CurrToken.Value := Token2.Value / Token1.Value; end; { MOD operator } 100 : begin Pop(Token1); Pop(Token2); Pop(Token2); if Token1.Value = 0 then MathError := True else CurrToken.Value := Round(Token2.Value) mod Round(Token1.Value); end; 7 : begin Pop(Token1); Pop(Token2); Pop(Token2); if Token2.Value <= 0 then MathError := True else if (Token1.Value * Ln(Token2.Value) < -ExpLimit) or (Token1.Value * Ln(Token2.Value) > ExpLimit) then MathError := True else CurrToken.Value := Exp(Token1.Value * Ln(Token2.Value)); end; 9 : begin Pop(Token1); Pop(Token2); CurrToken.Value := -Token1.Value; end; 11 : raise Exception.Create('Invalid reduction'); 13 : raise Exception.Create('Invalid reduction'); 14 : begin Pop(Token1); Pop(CurrToken); Pop(Token1); end; 16 : begin Pop(Token1); Pop(CurrToken); Pop(Token1); Pop(Token1); // begin add by mrlong if UpperCase(string(Token1.FuncName))='R0' then begin Currtoken.Value := Round2(CurrToken.Value,0); end else if CompareText(string(Token1.FuncName),'R1')=0 then begin Currtoken.Value := Round2(CurrToken.Value,1); end else if CompareText(string(Token1.FuncName),'R2')=0 then //进位 begin Currtoken.Value := Round2(CurrToken.Value,2); end else if CompareText(string(Token1.FuncName),'R3')=0 then begin Currtoken.Value := Round2(CurrToken.Value,3); end else if CompareText(string(Token1.FuncName),'R4')=0 then begin CurrToken.Value := Round2(CurrToken.Value,4); end else if CompareText(string(Token1.FuncName),'R5')=0 then begin Currtoken.Value := Round2(CurrToken.Value,5); end else if CompareText(string(Token1.FuncName),'R6')=0 then begin Currtoken.Value := Round2(CurrToken.Value,6); end // // if 的处理方法放到了 CreateExpress 方法处理 // else if CompareText(string(Token1.FuncName),'ABS')=0 then CurrToken.Value := Abs(CurrToken.Value) else if CompareText(string(Token1.FuncName),'ATAN')=0 then CurrToken.Value := ArcTan(CurrToken.Value) else if CompareText(string(Token1.FuncName),'COS')=0 then begin if (CurrToken.Value < -9E18) or (CurrToken.Value > 9E18) then MathError := True else CurrToken.Value := Cos((CurrToken.Value/180)*PI); //角度改为弧度 end {...if Token1.FuncName = 'SIN' } else if CompareText(string(Token1.FuncName),'TAN')=0 then begin if (CurrToken.Value < -9E18) or (CurrToken.Value > 9E18) then MathError := True else CurrToken.Value := tan((CurrToken.Value/180)*PI) end {...if Token1.FuncName = 'TAN' } else if CompareText(string(Token1.FuncName),'COT')=0 then begin if (CurrToken.Value < -9E18) or (CurrToken.Value > 9E18) then MathError := True else CurrToken.Value := cot((CurrToken.Value/180)*PI) end else if CompareText(string(Token1.FuncName),'EXP')=0 then begin if (CurrToken.Value < -ExpLimit) or (CurrToken.Value > ExpLimit) then MathError := True else CurrToken.Value := Exp(CurrToken.Value); end else if CompareText(string(Token1.FuncName),'XSQZ')=0 then begin if (CurrToken.Value < -1E9) or (CurrToken.Value > 1E9) then MathError := True else CurrToken.Value := ceil(CurrToken.Value); end else if CompareText(string(Token1.FuncName),'LN')=0 then begin if CurrToken.Value <= 0 then MathError := True else CurrToken.Value := Ln(CurrToken.Value); end else if CompareText(string(Token1.FuncName),'ROUND')=0 then begin if (CurrToken.Value < -1E9) or (CurrToken.Value > 1E9) then MathError := True else CurrToken.Value := Round(CurrToken.Value); end else if CompareText(string(Token1.FuncName),'SIN')=0 then begin if (CurrToken.Value < -9E18) or (CurrToken.Value > 9E18) then MathError := True else CurrToken.Value := Sin((CurrToken.Value/180)*PI); end {...if Token1.FuncName = 'SIN' } else if CompareText(string(Token1.FuncName),'SQRT')=0 then begin if CurrToken.Value < 0 then MathError := True else CurrToken.Value := Sqrt(CurrToken.Value); end else if CompareText(string(Token1.FuncName),'SQR')=0 then begin if (CurrToken.Value < -SQRLIMIT) or (CurrToken.Value > SQRLIMIT) then MathError := True else CurrToken.Value := Sqr(CurrToken.Value); end else if CompareText(string(Token1.FuncName),'SQR3')=0 then begin if (CurrToken.Value < -SQRLIMIT) or (CurrToken.Value > SQRLIMIT) then MathError := True else CurrToken.Value := Sqr(CurrToken.Value)*CurrToken.Value; //三次方 end else if CompareText(string(Token1.FuncName),'TRUNC')=0 then begin if (CurrToken.Value < -1E9) or (CurrToken.Value > 1E9) then MathError := True else CurrToken.Value := Trunc(CurrToken.Value); end else if CompareText(string(Token1.FuncName),'JW')=0 then begin if Abs(CurrToken.Value) > Int(Abs(CurrToken.Value ) + 0.000000001) then begin if CurrToken.Value > 0 then CurrToken.Value := Int(CurrToken.Value) + 1 else if CurrToken.Value < 0 then CurrToken.Value := (Int(Abs(CurrToken.Value)) + 1)*-1 else CurrToken.Value := 0; end; end; end; 3, 6, 8, 10, 12, 15 : Pop(CurrToken); end; { case } CurrToken.State := GotoState(Reduction); Push(CurrToken);end; { Reduce }procedure TMathParser.Shift(State : Word);begin CurrToken.State := State; Push(CurrToken); TokenType := NextToken;end; { Shift }{扩展功能}function TMathParser.DeleteSpace(InputExpress: String) : String;var Flags : TReplaceFlags;begin DescribeError := False; //1.替换%和‰ Flags := [rfReplaceAll]; //先查找，要快很多，毕竟公式里%不多 if Pos('%',InputExpress) > 0 then InputExpress := StringReplace(InputExpress,'%','*(0.01)',Flags); if Pos('‰',InputExpress) > 0 then InputExpress := StringReplace(InputExpress,'‰','*(0.001)',Flags); Result:= InputExpress;end;//处理原始表达式function TMathParser.CreateExpressLink(OrignalExpress : String) : PExpressLink;var head : PExpressLink; //键头 p,pnext : PExpressLink; ESLen : Word; Eposition: Word; STemp : String; ch : Char; tp : Word; hadif : Boolean; //= True 表示正在处理 if 的方法begin fhasvar := False; //add by mrlong hadif := False; ESLen := Length(OrignalExpress); Eposition := 1; p := nil; head := nil; while (Eposition <= EsLen) do begin ch := OrignalExpress[Eposition]; case ch of '(',')','+','-','*','/' : //基本语法 begin if head = nil then begin New(head); head^.Tokenname := ''; head^.Tokenname := head^.Tokenname + OrignalExpress[Eposition]; head^.TokenType := 0; head^.ExpressNext := nil; p := head; inc(Eposition); end else begin New(pnext); pnext^.Tokenname := ''; pnext^.Tokenname := pnext^.Tokenname + OrignalExpress[Eposition]; pnext^.TokenType := 0; pnext^.ExpressNext := nil; p^.ExpressNext := pnext; p := pnext; inc(Eposition); if (ch=')') and hadif then hadif := False; //不是 if 了 end; end; '[' : //变量 begin STemp := ''; inc(Eposition); repeat STemp := STemp + OrignalExpress[Eposition]; inc(Eposition); until AnsiChar(OrignalExpress[Eposition]) in [']']; //STemp 可能要进行二次的分析出来,可能有 [(t1;t2;t3).sc_rgf] 的变量,这变量要从这取出来 //还是到我们的底层类内进行,我认为在底层类内更全面点,有助于对 // 最后处理成 [t1.sc_rgf] + [t2.sc_rgf] + [t3.sc_rgf]; inc(Eposition); fhasvar := True; //add by mrlong //说明有变量,要进行变量的替换 if head = nil then begin New(head); head^.Tokenname := STemp; head^.TokenType := 4; head^.ExpressNext := nil; p := head; end else begin New(pnext); pnext^.Tokenname := STemp; pnext^.TokenType := 4; pnext^.ExpressNext := nil; p^.ExpressNext := pnext; p := pnext; end; end; '{' : //变量注释,当常量,只要是在表达式不计算只是解释时用的 begin STemp := ''; inc(Eposition); repeat STemp := STemp + OrignalExpress[Eposition]; inc(Eposition); until AnsiChar(OrignalExpress[Eposition]) in ['}']; inc(Eposition); if head = nil then begin //New(head); //head^.Tokenname := format('{%s}',[STemp]); //head^.TokenType := 5; //head^.ExpressNext := nil; //p := head; end else begin //New(pnext); //pnext^.Tokenname := format('{%s}',[STemp]); //pnext^.TokenType := 5; //pnext^.ExpressNext := nil; //p^.ExpressNext := pnext; //p := pnext; end; end; else //begin if hadif and (AnsiChar(ch) in ['>','!','=',',','&','|']) then begin New(pnext); pnext^.Tokenname := ch; pnext^.TokenType := 5; //做为常量 pnext^.ExpressNext := nil; p^.ExpressNext := pnext; p := pnext; inc(Eposition); end else begin // may be function,var,const var,num STemp := ''; repeat STemp := STemp + OrignalExpress[Eposition]; inc(Eposition); // upate 增加 [ 的字符串条件 2006-1-16 until ( AnsiChar(OrignalExpress[Eposition]) in ['(',')','+','-','*','/','[','{']) or (Eposition > ESLen)or ( hadif and ( AnsiChar(OrignalExpress[Eposition]) in ['>','!','=',',','&','|'])); if IsFunction(Stemp,'IF') then begin hadif := True; //下面的内容是if方法 tp := 1; end else if IsFunction(STemp,'ABS') or IsFunction(STemp,'ATAN') or IsFunction(STemp,'COS') or IsFunction(STemp,'TAN') or IsFunction(STemp,'COT') or IsFunction(STemp,'EXP') or IsFunction(STemp,'LN') or IsFunction(STemp,'ROUND') or IsFunction(STemp,'SIN') or IsFunction(STemp,'SQRT') or IsFunction(STemp,'SQR') or IsFunction(STemp,'SQR3') or IsFunction(STemp,'TRUNC') or IsFunction(STemp,'XSQZ') or IsFunction(Stemp,'JW') or IsFunction(Stemp,'R0') or IsFunction(Stemp,'R1') or IsFunction(Stemp,'R2') or IsFunction(Stemp,'R3') or IsFunction(Stemp,'R4') or IsFunction(Stemp,'R5') or IsFunction(Stemp,'R6') then tp := 1 else begin if IsNum(STemp) then tp := 5 else begin tp := 2; if not fhasVariableChar then //如不采用[]注明时(工程量内用),说明这个就是变量 fhasvar := True; end; end; if head = nil then begin New(head); //工程量计算式不支持 Q*.1*.1 if (tp = 5) and (STemp[1] = '.') then STemp := '0' + STemp; head^.Tokenname := STemp; head^.TokenType := tp; head^.ExpressNext := nil; p := head; end else begin New(pnext); //工程量计算式不支持 Q*.1*.1 if (tp = 5) and (STemp[1] = '.') then STemp := '0' + STemp; pnext^.Tokenname := STemp; pnext^.TokenType := tp; pnext^.ExpressNext := nil; p^.ExpressNext := pnext; p := pnext; end; end; end; end; Result:= head;end;function TMathParser.IsNum(s: String) :Boolean;var ESLen : Word; pos : Word; ch : Char; i : Integer;begin ESLen := Length(s); pos := 1;i := 0; while pos <= ESLen do begin ch := s[pos]; if not (AnsiChar(ch) in ['0'..'9','.'] )then i := i + 1; inc(pos); end; if i = 0 then IsNum := True else IsNum := False;end;function TMathParser.IsConstVar(s: String) : Boolean;begin IsConstVar := False;end;function TMathParser.IsFunction(s: String; d: String) : Boolean;begin if UpperCase(s) = d then IsFunction := True else IsFunction := False;end;//将键表变成一个字符串function TMathParser.CreateExpress( ExpressHead : PExpressLink ) : String;var p : PExpressLink; STemp : String; myStr : String; myValue : Array[0..2] of String; //表达式,真值,假值 myv : Extended;begin STemp := ''; p := ExpressHead; while p <> nil do begin // //1.if 方法 // if (CompareText(p.Tokenname,'if') = 0) and Assigned(p^.ExpressNext) then begin myStr := ''; p := p^.ExpressNext; // ( p := p^.ExpressNext; // while (p<>nil) and (p^.Tokenname <> ')') do begin myStr := myStr + p^.Tokenname; // 是if() 的内容 p := p^.ExpressNext; end; //先将值分到数据内 myValue[0] myVlaue[1] myVlaue[2] // 条件 真值 假值 if Pos(',',myStr)>0 then begin myValue[0] := Copy(myStr,1,Pos(',',myStr)-1); myStr := Copy(myStr,Pos(',',myStr)+1,maxint); if Pos(',',myStr)>0 then begin myValue[1] := Copy(myStr,1,Pos(',',myStr)-1); myValue[2] := Copy(myStr,Pos(',',myStr)+1,maxint); end else begin STemp := STemp + myStr; if not Assigned(p) then break; p := p^.ExpressNext; Continue; end; end else begin STemp := STemp + myStr; if not Assigned(p) then break; p := p^.ExpressNext; Continue; end; // // 解释正则表达式 12>5&4<5 的情况 // if ParseIfExp(myValue[0]) then begin if ParseNum(myValue[1],myv) then Stemp := STemp + floattostr(myv) else Exit; end else begin if ParseNum(myValue[2],myv) then Stemp := STemp + floattostr(myv) else Exit; end; if not Assigned(p) then break; p := p^.ExpressNext; end else begin STemp := STemp + p^.Tokenname; p := p^.ExpressNext; end; end; Result := STemp;end;//删除键表procedure TMathParser.DeleteExpressLink(ExpressHead : PExpressLink);var p,p1 : PExpressLink;begin p:= ExpressHead; if p <> nil then begin while p^.ExpressNext <> nil do begin p1:= p^.ExpressNext; Dispose(p); p := p1; end; Dispose(p); end;end;//----------------------------// Express:表达式// VarName : 非法字符集//-----------------------------function TMathParser.ExpressParse(Express : String; varname : String; CheckHead : PCheckLink ) :Boolean;var Head : PExpressLink;begin ParseError := False; Head := CreateExpressLink(DeleteSpace(Express)); // // 现在不处理这个 2007-3-1 //CheckLinkAdd(varname); //非法字符 // if CompareLink(Head) then VaruseError := VaruseError + 1; Head := GetExpressVar(Head); //换算变量 ParseString := CreateExpress(Head);//替换成纯数字表达式的字符串,或处理特殊的方法 DeleteExpressLink(Head); //删除键表 if (ParseString <> '') and not ParseError then begin Result := Parse end else begin if Assigned(FOnParseError) then FOnParseError(Self, ErrEmpty); ParseError := True; ParseValue := 0; Result := False; end;end;//变量换算function TMathParser.GetExpressVar(ExpressHead : PExpressLink) : PExpressLink;var phead,nodepre,nodethis : PExpressLink; Value : Extended; ValFound: Boolean;begin ExpressError := False; phead := ExpressHead; if (VaruseError = 0) and (ExpressError = False) and (phead <> nil) then begin nodethis := phead; Value := 0.0; repeat case nodethis^.TokenType of 4: //费用表变量[] 2=普通变量 begin GetVarByCode(nodethis^.Tokenname,Value,ValFound); if ValFound then begin nodethis^.TokenType := 5; nodethis^.Tokenname := floattostr(Value); end else begin ExpressError := True; break; end; end; 2: begin // // 只有 fhasVariableChar = False 才处理 2 // // 可能if(1=2,3,4), 是 1=2,3,4就是变量,这时会增加查找的过程过多 // if not fhasVariableChar then begin GetVarByCode(nodethis^.Tokenname,Value,ValFound); if ValFound then begin nodethis^.TokenType := 5; nodethis^.Tokenname := floattostr(Value); end else nodethis^.TokenType := 5; //如没有找到,则当前是常量处理了. 2007-4-2 end; end; end; // end case nodepre := nodethis; nodethis := nodepre^.ExpressNext; Value := 0.0; until (nodethis = nil) or (VaruseError <> 0) or ExpressError; end; // end if if (VaruseError = 0) and (ExpressError = False) then Result := ExpressHead else begin if Assigned(FOnParseError) then FOnParseError(Self, Erruseselfloop); DeleteExpressLink(phead); Result := nil; end;end;procedure TMathParser.Deletethevarname;var p,p1 : PCheckLink;begin p1 := nil; p:= CheckHead; if p <> nil then begin if p^.VNext = nil then begin Dispose(p); CheckHead := nil; end else begin while p^.VNext <> nil do begin p1:= p ; // Dispose(p); p := p1^.VNext; //Dispose(p1); //add by mrlong 为什么这?? end; if Assigned(p1) then p1^.VNext := nil; Dispose(p); end; end;end;procedure TMathParser.CheckLinkAdd(VarName : String);var node,pnode : PCheckLink;begin if CheckHead = nil then begin New(node); node^.VarName := VarName; node^.VNext := nil; CheckHead := node; end else begin pnode := CheckHead; while pnode^.VNext <> nil do pnode := pnode^.VNext; New(node); node^.VarName := VarName; node^.VNext := nil; pnode^.VNext := node; end;end;function TMathParser.CompareLink(ExpressHead : PExpressLink) : Boolean;var EHead : PExpressLink; CHead : PCheckLink; num : Word;begin num := 0; EHead := ExpressHead; if EHead <> nil then begin repeat if (EHead^.TokenType = 3) or (EHead^.TokenType = 4) then begin CHead := CheckHead; if CHead <> nil then begin repeat if CHead^.VarName = EHead^.Tokenname then num := num +1; CHead := CHead^.VNext; until CHead = nil; end; end; EHead := EHead^.ExpressNext; until EHead = nil; end; if num = 0 then Result := False else Result := True;end;procedure TMathParser.DeleteCheckLink(CheckHead : PCheckLink);var p,p1 : PCheckLink;begin p:= CheckHead; if p <> nil then begin repeat p1 := p^.VNext; Dispose(p); p := p1; until p = nil; end;end;destructor TMathParser.Destroy;begin fFunctionCaption.Free; fFunctionName.Free; inherited;end;procedure TMathParser.Parse(ABackFun: TOnGetValueByCodeEvent);begin fOnGetValueByCode := ABackFun; VaruseError := 0; ExpressParse(ParseString,ParseLeftString,CheckHead) ; DeleteCheckLink(CheckHead); //清空键表 CheckHead := nil;end;procedure TMathParser.ParseExpression(var AExp:String);var Head,p : PExpressLink; MyStr : String;begin VaruseError := 0; Head := CreateExpressLink(AExp); CheckLinkAdd(''); //非法字符,无非法字符 if CompareLink(Head) then VaruseError := VaruseError + 1; if fhasvar then Head := GetExpressStrVar(Head);//GetExpressVar(Head); //换算变量 if (VaruseError = 0 ) and (ExpressError = False) then begin //将键表转化为字符串 p := Head; MyStr := ''; while p <> nil do begin MyStr := MyStr + p^.Tokenname; p := p^.ExpressNext; end; AExp := MyStr end; DeleteExpressLink(Head); //删除键表 Deletethevarname;end;function TMathParser.ParseIfExp(AStr: String): Boolean;type pMyStrRec = ^TmyStrRec; TmyStrRec = record fStr : String; end;var i,c : integer; myList : TList; myand : Boolean; //如=True 表示 and关系,否则是 or 关系 myPstr : pMyStrRec; myStr : String; myExp : array[0..2] of String; myChar : Char; myb : Boolean; myiback : Boolean; // = True 则不处理 myv1,myv2 : Extended;begin//// & 表示并且 | 表示或者//// 说明,只能全部是 & 或全部是 |//// >= 时怎么处理,////// Result := False; myList := TList.Create; try myand := Pos('&',AStr) > 0; if myand then myChar := '&' else myChar := '|'; myiback := False; for i:=1 to Length(AStr) do begin if myiback then begin myiback := False; Continue; end; if (AStr[i] = myChar) or (AnsiChar(AStr[i]) in ['>','=','!']) then // @ 为< begin new(myPstr); myPstr^.fStr := myStr; myList.Add(myPstr); mystr := ''; //增加操作符 if (AnsiChar(AStr[i]) in ['>','=']) then begin new(myPstr);myPstr^.fStr := AStr[i]; myList.Add(myPstr); if (AStr[i] = '>') and ((i+1)<Length(AStr)) and (AStr[i+1]='=') then begin myPstr^.fStr := '>='; //这时的i 要跳一格 myiback := True; //下一个i不处理 end; end else if (AnsiChar(AStr[i]) in ['!']) and ((i+1)<Length(AStr)) and (AStr[i+1]='=') then begin new(myPstr);myPstr^.fStr := '!='; myList.Add(myPstr); myiback := True; //与上面一样 end; end else mystr := mystr + AStr[i]; end; if mystr <> '' then begin new(myPstr); myPstr^.fStr := mystr; myList.Add(myPstr); end; // // 三个一比较 // c := myList.Count div 3; if c = 0 then Exit; for i:=0 to c -1 do begin myPstr := myList.Items[i*3+0]; myExp[0] := myPstr^.fStr; myPstr := myList.Items[i*3+1]; myExp[1] := myPstr^.fStr; myPstr := myList.Items[i*3+2]; myExp[2] := myPstr^.fStr; // myExp[0],myExp[2] 有可能是表达式 if not ParseNum(myExp[0],myv1) then Exit; if not ParseNum(myExp[2],myv2) then Exit; myb := False; //大于值 if myExp[1] = '>' then myb := myv1 > myv2 else if myExp[1] = '=' then myb := isEqual(myv1,myv2) else if myExp[1] = '!=' then myb := myv1 <> myv2 else if myExp[1] = '>=' then myb := myv1 >= myv2; if myb and not myand then begin Result := True; Exit; end else if not myb and myand then begin Exit; end; end; //myand =True 的情况 运行完成,发现没有 false ,则返回 True if myand then Result := True; finally for i:=0 to myList.Count -1 do begin myPstr := myList.Items[i]; Dispose(myPstr); end; myList.Free; end;end;function TMathParser.ParseNum(AStr: String;var AValue:Extended): Boolean;var myStr : String;begin AValue := 0; Result := True; myStr := ParseString; ParseString := AStr; try if ParseString <> '' then begin if Parse then begin AValue := ParseValue; Result := True; end else begin ParseError := True; Result := False; end end finally ParseString := myStr; end;end;procedure TMathParser.GetStrVarByCode(ACode: string; var Value: string; var Found: Boolean);var myStr : string; myFound : Boolean;begin Found := False; //这地方是取出变量来 if Assigned(fOnGetValueByCode) then begin myFound := False; fOnGetValueByCode(ACode,myStr,myFound); if myFound then begin Found := True; Value := myStr; end; end;end;procedure TMathParser.GetVarByCode(ACode: string; var Value: Extended; var Found: Boolean);var myStr : string; myFound : Boolean;begin Found := False; myFound:= False; GetStrVarByCode(ACode,myStr,myFound); if myFound then begin Found := myFound; Value := StrToFloatDef(myStr,0); end;end;function TMathParser.GetExpressStrVar( ExpressHead: PExpressLink): PExpressLink;var phead,nodepre,nodethis : PExpressLink; Value : string; ValFound: Boolean;begin ExpressError := False; phead := ExpressHead; if (VaruseError = 0) and (ExpressError = False) and (phead <> nil) then begin nodethis := phead; Value := ''; repeat case nodethis^.TokenType of 4: //费用表变量[] 2=普通变量 begin GetStrVarByCode(nodethis^.Tokenname,Value,ValFound); if ValFound then begin nodethis^.TokenType := 5; nodethis^.Tokenname := Value; end else begin ExpressError := True; break; end; end; 2: begin // // 只有 fhasVariableChar = False 才处理 2 // // 可能if(1=2,3,4), 是 1=2,3,4就是变量,这时会增加查找的过程过多 // if not fhasVariableChar then begin GetStrVarByCode(nodethis^.Tokenname,Value,ValFound); if ValFound then begin nodethis^.TokenType := 5; nodethis^.Tokenname := Value; end else nodethis^.TokenType := 5; //如没有找到,则当前是常量处理了. 2007-4-2 end; end; end; // end case nodepre := nodethis; nodethis := nodepre^.ExpressNext; Value := ''; until (nodethis = nil) or (VaruseError <> 0) or ExpressError; end; // end if if (VaruseError = 0) and (ExpressError = False) then Result := ExpressHead else begin if Assigned(FOnParseError) then FOnParseError(Self, Erruseselfloop); DeleteExpressLink(phead); Result := nil; end;end;end.
