diff --git a/Plotter.cfg b/Plotter.cfg new file mode 100644 index 0000000..d42bcd6 --- /dev/null +++ b/Plotter.cfg @@ -0,0 +1,35 @@ +-$A8 +-$B- +-$C+ +-$D+ +-$E- +-$F- +-$G+ +-$H+ +-$I+ +-$J- +-$K- +-$L+ +-$M- +-$N+ +-$O+ +-$P+ +-$Q- +-$R- +-$S- +-$T- +-$U- +-$V+ +-$W- +-$X+ +-$YD +-$Z1 +-cg +-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +-H+ +-W+ +-M +-$M16384,1048576 +-K$00400000 +-LE"c:\program files (x86)\delphi6\Projects\Bpl" +-LN"c:\program files (x86)\delphi6\Projects\Bpl" diff --git a/Plotter.dof b/Plotter.dof new file mode 100644 index 0000000..18a993c --- /dev/null +++ b/Plotter.dof @@ -0,0 +1,87 @@ +[FileVersion] +Version=6.0 +[Compiler] +A=8 +B=0 +C=1 +D=1 +E=0 +F=0 +G=1 +H=1 +I=1 +J=0 +K=0 +L=1 +M=0 +N=1 +O=1 +P=1 +Q=0 +R=0 +S=0 +T=0 +U=0 +V=1 +W=0 +X=1 +Y=1 +Z=1 +ShowHints=1 +ShowWarnings=1 +UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; +[Linker] +MapFile=0 +OutputObjs=0 +ConsoleApp=1 +DebugInfo=0 +RemoteSymbols=0 +MinStackSize=16384 +MaxStackSize=1048576 +ImageBase=4194304 +ExeDescription= +[Directories] +OutputDir= +UnitOutputDir= +PackageDLLOutputDir= +PackageDCPOutputDir= +SearchPath= +Packages= +Conditionals= +DebugSourceDirs= +UsePackages=0 +[Parameters] +RunParams= +HostApplication= +Launcher= +UseLauncher=0 +DebugCWD= +[Language] +ActiveLang= +ProjectLang= +RootDir= +[Version Info] +IncludeVerInfo=0 +AutoIncBuild=0 +MajorVer=1 +MinorVer=0 +Release=0 +Build=0 +Debug=0 +PreRelease=0 +Special=0 +Private=0 +DLL=0 +Locale=1031 +CodePage=1252 +[Version Info Keys] +CompanyName= +FileDescription= +FileVersion=1.0.0.0 +InternalName= +LegalCopyright= +LegalTrademarks= +OriginalFilename= +ProductName= +ProductVersion=1.0.0.0 +Comments= diff --git a/Plotter.dpr b/Plotter.dpr new file mode 100644 index 0000000..89f597b --- /dev/null +++ b/Plotter.dpr @@ -0,0 +1,14 @@ +program Plotter; + +uses + Forms, + fgraph in 'fgraph.pas' {fGraph}, + graph in 'graph.pas'; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TfGraph, formGraph); + Application.Run; +end. diff --git a/Plotter.res b/Plotter.res new file mode 100644 index 0000000..b111060 Binary files /dev/null and b/Plotter.res differ diff --git a/fgraph.dfm b/fgraph.dfm new file mode 100644 index 0000000..418195c --- /dev/null +++ b/fgraph.dfm @@ -0,0 +1,174 @@ +object fGraph: TfGraph + Left = 216 + Top = 178 + BorderStyle = bsNone + Caption = 'fGraph' + ClientHeight = 514 + ClientWidth = 699 + Color = clSkyBlue + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'MS Sans Serif' + Font.Style = [] + OldCreateOrder = False + Position = poScreenCenter + OnCreate = FormCreate + OnMouseWheelDown = FormMouseWheelDown + OnMouseWheelUp = FormMouseWheelUp + OnPaint = FormPaint + OnResize = FormResize + PixelsPerInch = 96 + TextHeight = 13 + object ptop: TPanel + Left = 0 + Top = 0 + Width = 699 + Height = 33 + Align = alTop + BevelOuter = bvNone + Color = clSkyBlue + TabOrder = 0 + DesignSize = ( + 699 + 33) + object lheader: TLabel + Left = 0 + Top = 0 + Width = 699 + Height = 33 + Align = alClient + Alignment = taCenter + Caption = 'Plotter Graph' + Font.Charset = ANSI_CHARSET + Font.Color = clGreen + Font.Height = -24 + Font.Name = 'Comic Sans MS' + Font.Style = [] + ParentFont = False + end + object lexit: TLabel + Left = 674 + Top = 8 + Width = 25 + Height = 41 + Anchors = [akTop, akRight] + AutoSize = False + Caption = 'X' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'Comic Sans MS' + Font.Style = [] + ParentFont = False + OnMouseDown = lexitMouseDown + OnMouseMove = lexitMouseMove + OnMouseLeave = lexitMouseLeave + end + object lmax: TLabel + Left = 658 + Top = 0 + Width = 15 + Height = 41 + Anchors = [akTop, akRight] + AutoSize = False + Caption = '^' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'Comic Sans MS' + Font.Style = [] + ParentFont = False + OnMouseDown = lmaxMouseDown + OnMouseMove = lmaxMouseMove + OnMouseLeave = lmaxMouseLeave + end + end + object pleft: TPanel + Left = 0 + Top = 33 + Width = 41 + Height = 440 + Align = alLeft + BevelOuter = bvNone + Color = clSkyBlue + TabOrder = 1 + end + object pbottom: TPanel + Left = 0 + Top = 473 + Width = 699 + Height = 41 + Align = alBottom + BevelOuter = bvNone + Color = clSkyBlue + TabOrder = 2 + object Edit1: TEdit + Left = 32 + Top = 8 + Width = 217 + Height = 21 + TabOrder = 0 + Text = 'x^2 + x^3' + end + object Button1: TButton + Left = 256 + Top = 8 + Width = 75 + Height = 25 + Caption = 'Evaluate' + TabOrder = 1 + OnClick = Button1Click + end + end + object pright: TPanel + Left = 657 + Top = 33 + Width = 42 + Height = 440 + Align = alRight + BevelOuter = bvNone + Color = clSkyBlue + TabOrder = 3 + DesignSize = ( + 42 + 440) + object lmin: TLabel + Left = 8 + Top = -12 + Width = 26 + Height = 25 + Alignment = taRightJustify + Anchors = [akTop, akRight] + AutoSize = False + Caption = '_' + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -19 + Font.Name = 'Comic Sans MS' + Font.Style = [] + ParentFont = False + OnClick = lminClick + OnMouseMove = lminMouseMove + OnMouseLeave = lminMouseLeave + end + end + object pmiddle: TPanel + Left = 41 + Top = 33 + Width = 616 + Height = 440 + Align = alClient + BevelOuter = bvNone + Color = clWhite + TabOrder = 4 + object iGraph: TImage + Left = 0 + Top = 0 + Width = 616 + Height = 440 + Align = alClient + OnClick = iGraphClick + end + end +end diff --git a/fgraph.pas b/fgraph.pas new file mode 100644 index 0000000..15638a6 --- /dev/null +++ b/fgraph.pas @@ -0,0 +1,246 @@ +unit fgraph; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs, ExtCtrls, StdCtrls, graph; + +type + TfGraph = class(TForm) + ptop: TPanel; + pleft: TPanel; + pbottom: TPanel; + pright: TPanel; + pmiddle: TPanel; + iGraph: TImage; + lheader: TLabel; + lexit: TLabel; + lmax: TLabel; + lmin: TLabel; + Edit1: TEdit; + Button1: TButton; + procedure lexitMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure lexitMouseLeave(Sender: TObject); + procedure lexitMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure lmaxMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure lmaxMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure lmaxMouseLeave(Sender: TObject); + procedure FormPaint(Sender: TObject); + procedure FormResize(Sender: TObject); + procedure FormCreate(Sender: TObject); + procedure lminMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); + procedure lminMouseLeave(Sender: TObject); + procedure lminClick(Sender: TObject); + procedure iGraphClick(Sender: TObject); + procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); + procedure Button1Click(Sender: TObject); + private + { Private-Deklarationen } + public + { Public-Deklarationen } + graph:TGraph; + end; + +var + formGraph: TfGraph; + +implementation + +{$R *.dfm} + +procedure TfGraph.lexitMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); +begin + + lexit.Font.Color:=clred; + +end; + +procedure TfGraph.lexitMouseLeave(Sender: TObject); +begin + + lexit.Font.Color:=clblack; + +end; + +procedure TfGraph.lexitMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + + Application.Terminate; + +end; + +procedure TfGraph.lmaxMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + + if formGraph.WindowState=wsmaximized then formGraph.WindowState:=wsnormal else formGraph.WindowState:=wsmaximized; + + graph.drawAchsis; + +end; + +procedure TfGraph.lmaxMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); +begin + + lmax.Font.Color:=clred; + +end; + +procedure TfGraph.lmaxMouseLeave(Sender: TObject); +begin + + lmax.Font.Color:=clblack; + +end; + +procedure TfGraph.FormPaint(Sender: TObject); +var rgn: HRGN; +begin + + if windowstate=wsmaximized then + begin + rgn := CreateRoundRectRgn(0,// x-coordinate of the region's upper-left corner + 0, // y-coordinate of the region's upper-left corner + ClientWidth, // x-coordinate of the region's lower-right corner + ClientHeight, // y-coordinate of the region's lower-right corner + 0, // height of ellipse for rounded corners + 0); // width of ellipse for rounded corners + SetWindowRgn(Handle, rgn, True); + end else + begin + rgn := CreateRoundRectRgn(0,// x-coordinate of the region's upper-left corner + 0, // y-coordinate of the region's upper-left corner + ClientWidth, // x-coordinate of the region's lower-right corner + ClientHeight, // y-coordinate of the region's lower-right corner + 25, // height of ellipse for rounded corners + 25); // width of ellipse for rounded corners + SetWindowRgn(Handle, rgn, True); + end; + + rgn := CreateRoundRectRgn(0,// x-coordinate of the region's upper-left corner + 0, // y-coordinate of the region's upper-left corner + pmiddle.Width, // x-coordinate of the region's lower-right corner + pmiddle.Height, // y-coordinate of the region's lower-right corner + 25, // height of ellipse for rounded corners + 25); // width of ellipse for rounded corners + SetWindowRgn(pmiddle.Handle, rgn, True); + +end; + +procedure TfGraph.FormResize(Sender: TObject); +var rgn: HRGN; +begin + + if windowstate=wsmaximized then + begin + rgn := CreateRoundRectRgn(0,// x-coordinate of the region's upper-left corner + 0, // y-coordinate of the region's upper-left corner + ClientWidth, // x-coordinate of the region's lower-right corner + ClientHeight, // y-coordinate of the region's lower-right corner + 0, // height of ellipse for rounded corners + 0); // width of ellipse for rounded corners + SetWindowRgn(Handle, rgn, True); + end else + begin + rgn := CreateRoundRectRgn(0,// x-coordinate of the region's upper-left corner + 0, // y-coordinate of the region's upper-left corner + ClientWidth, // x-coordinate of the region's lower-right corner + ClientHeight, // y-coordinate of the region's lower-right corner + 25, // height of ellipse for rounded corners + 25); // width of ellipse for rounded corners + SetWindowRgn(Handle, rgn, True); + end; + +end; + +procedure TfGraph.FormCreate(Sender: TObject); +var rgn: HRGN; +begin + + rgn := CreateRoundRectRgn(0,// x-coordinate of the region's upper-left corner + 0, // y-coordinate of the region's upper-left corner + ClientWidth, // x-coordinate of the region's lower-right corner + ClientHeight, // y-coordinate of the region's lower-right corner + 25, // height of ellipse for rounded corners + 25); // width of ellipse for rounded corners + SetWindowRgn(Handle, rgn, True); + + graph:=TGraph.create; + + graph.init(50,50,iGraph); + +end; + +procedure TfGraph.lminMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); +begin + + lmin.Font.Color:=clred; + +end; + +procedure TfGraph.lminMouseLeave(Sender: TObject); +begin + + lmin.Font.Color:=clblack; + +end; + +procedure TfGraph.lminClick(Sender: TObject); +begin + + Application.Minimize; + +end; + +procedure TfGraph.iGraphClick(Sender: TObject); +var point:TPoint; +begin + + getcursorpos(point); + + graph.drawAchsis(point.x-formGraph.left-pleft.width,screen.Height-point.y-(screen.Height-formgraph.Height-formgraph.Top)-(formgraph.pbottom.Height)); + +end; + +procedure TfGraph.FormMouseWheelDown(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); +begin + + graph.ZeichenAbstandX:=graph.ZeichenAbstandX-1; + graph.ZeichenAbstandY:=graph.ZeichenAbstandY-1; + graph.drawAchsis; + +end; + +procedure TfGraph.FormMouseWheelUp(Sender: TObject; Shift: TShiftState; + MousePos: TPoint; var Handled: Boolean); +begin + + graph.ZeichenAbstandX:=graph.ZeichenAbstandX+1; + graph.ZeichenAbstandY:=graph.ZeichenAbstandY+1; + graph.drawAchsis; + +end; + +procedure TfGraph.Button1Click(Sender: TObject); +begin + + graph.drawFunction(edit1.Text); + +end; + +end. + diff --git a/graph.pas b/graph.pas new file mode 100644 index 0000000..2833e01 --- /dev/null +++ b/graph.pas @@ -0,0 +1,138 @@ +unit graph; + +interface + +uses windows, ExtCtrls, sysutils, parser, graphics, dialogs; + +type TGraph = class + public + Ursprung:TPoint; + Bild:TImage; + ZeichenAbstandX:integer; + ZeichenAbstandY:integer; + ZeichenSchrittX:integer; + ZeichenSchrittY:integer; + + procedure drawAchsis; overload; + procedure drawAchsis(Ursprungx,Ursprungy:integer); overload; + procedure init(Ursprungx,Ursprungy:integer;pBild:TImage); + procedure leereBild; + procedure drawPoint(x,y:integer); + procedure drawFunction(formalstr:string); +end; + +implementation + +procedure TGraph.drawFunction(formalstr:string); +var Expression:IExpr1V; + i:extended; +begin + + expression:=compileStr1V(formalstr); + if Expression.getErrInfo.ErrPos > 0 then messagedlg(Expression.getErrStr,mtwarning, [MBok],0) else + begin + i:=-(Bild.Width div ZeichenAbstandX); + repeat + try + drawPoint(round(i*ZeichenAbstandX),round(expression.eval(i)*ZeichenAbstandX)); + except + end; + i:=i+0.001; + until i >=(Bild.Width div ZeichenAbstandX); + end; + +end; + +procedure TGraph.drawPoint(x,y:integer); +begin + + Bild.Canvas.Pixels[Ursprung.X+x,Ursprung.Y-y]:=clred; + +end; + +procedure TGraph.init(Ursprungx,Ursprungy:integer;pBild:TImage); +begin + + Bild:=pBild; + + Ursprung.x:=Ursprungx; + Ursprung.y:=bild.Height-ursprungy; + + ZeichenAbstandX:=50; + ZeichenAbstandY:=50; + ZeichenSchrittX:=1; + ZeichenSchrittY:=1; + + drawAchsis; + +end; + +procedure TGraph.drawAchsis; +var i:integer; +begin + + if ZeichenAbstandX<5 then ZeichenAbstandX:=5; + if ZeichenAbstandY<5 then ZeichenAbstandY:=5; + + leereBild; + + //Linie X: + Bild.Canvas.MoveTo(0,ursprung.Y); + Bild.Canvas.LineTo(bild.Width,ursprung.y); + + //Line Y: + Bild.Canvas.MoveTo(ursprung.x,0); + Bild.Canvas.LineTo(ursprung.x,bild.height); + + // Abschnitte X positiv + for i:=1 to (Bild.Width div ZeichenAbstandX) do + begin + Bild.Canvas.MoveTo(Ursprung.x+(ZeichenAbstandX*i),Ursprung.y+3); + Bild.Canvas.LineTo(Ursprung.x+(ZeichenAbstandX*i),Ursprung.y-3); + Bild.Canvas.TextOut(Ursprung.x+(ZeichenAbstandX*i)-3,Ursprung.y+6,inttostr(ZeichenSchrittY*i)); + end; + + // Abschnitte X negativ + for i:=1 to (Bild.Width div ZeichenAbstandX) do + begin + Bild.Canvas.MoveTo(Ursprung.x-(ZeichenAbstandX*i),Ursprung.y+3); + Bild.Canvas.LineTo(Ursprung.x-(ZeichenAbstandX*i),Ursprung.y-3); + Bild.Canvas.TextOut(Ursprung.x-(ZeichenAbstandX*i)-3,Ursprung.y+6,inttostr(ZeichenSchrittY*i)); + end; + + // Abschnitte Y negativ + for i:=1 to (Bild.height div ZeichenAbstandY) do + begin + Bild.Canvas.MoveTo(Ursprung.x+3,Ursprung.Y+(ZeichenAbstandY*i)); + Bild.Canvas.LineTo(Ursprung.x-4,Ursprung.Y+(ZeichenAbstandY*i)); + Bild.Canvas.TextOut(Ursprung.x-(length(inttostr(ZeichenSchrittY*i))*6)-5,Ursprung.y+(ZeichenAbstandy*i)-4,inttostr(ZeichenSchrittY*i)); + end; + + // Abschnitte Y positiv + for i:=1 to (Bild.height div ZeichenAbstandY) do + begin + Bild.Canvas.MoveTo(Ursprung.x+3,Ursprung.Y-(ZeichenAbstandY*i)); + Bild.Canvas.LineTo(Ursprung.x-4,Ursprung.Y-(ZeichenAbstandY*i)); + Bild.Canvas.TextOut(Ursprung.x-(length(inttostr(ZeichenSchrittY*i))*6)-5,Ursprung.y-(ZeichenAbstandy*i)-4,inttostr(ZeichenSchrittY*i)); + end; + +end; + +procedure Tgraph.leereBild; +begin + + Bild.picture:=nil; + +end; + +procedure TGraph.drawAchsis(Ursprungx,Ursprungy:integer); +begin + + Ursprung.x:=Ursprungx; + Ursprung.y:=bild.Height-ursprungy; + + drawAchsis; + +end; + +end. diff --git a/parser.pas b/parser.pas new file mode 100644 index 0000000..a5bc26f --- /dev/null +++ b/parser.pas @@ -0,0 +1,1677 @@ +(* +// Information / License /////////////////////////////////////////////////////// + + Originally written in March 2005 by tyberis (aka delfiphan) + Original version can be downloaded here: + http://www.tyberis.com/download/tyParser.pas + + * This unit can be copied/used/modified without permission by the author. + Credits appreciated but not required (give credit to "tyberis") + * Code comes with no warranties whatsoever. + * Do not alter/remove/separate this information/license from the unit! + + Version 1.2.2 + +//////////////////////////////////////////////////////////////////////////////// +*) + +{ +- Description ------------------------------------------------------------------ + +What it does / How it works: +tyParser is a parser for mathematical expressions. It can be used to evaluate +string expressions like "x + 1/2". +The parser takes a mathematical expression as a string and creates a bytecode. +This bytecode can be evaluated very efficiently. To further highten the speed +of the evaluation, the bytecode can be compiled to machine code. + +Performance: +The tyParser compiler will create an (almost autonomous) function which can be +run like a regular delphi function. This guarantees top performance! + +Safety/Usage: +For easy and safe usage, see examples 1-3. The interface wrapper will take care +of all problems that might arise when using the parser/compiler directly but +will introduce some overhead. +If you need top performance you can use the parser or compiler directly. Please +note that the functions generated directly by the compiler are potentially +unsafe when used incorrectly. +1. Make sure that you always pass the correct number of arguments with the + correct type. +2. Make sure that you free all functions that you create (using FreeFunc). +See examples 4-7 to find out how to use the parser/compiler directly. + +- Examples A - using the interface wrapper (safe but with additional overhead) - +uses ..., tyParser; + +Var + sinc: IExpr1V; + sinexp: IExpr2V; + Sum_abc: IExprR; + Args: array[0..2] of Extended; + Result: Extended; +begin + // EXAMPLE 1 + sinc := compileStr1V('sin(x)/x'); + Result := sinc.Eval(1.0); + + // EXAMPLE 2 + sinexp := compileStr2V('sin(x)*exp(y)'); + Result := sinexp.Eval(2.0, 3.0); + + // EXAMPLE 3 + Sum_abc := compileStrR('a+b+c',['a','b','c']); + Args[0] := 1.0; // a = 1.0 + Args[1] := 2.0; // b = 2.0 + Args[2] := 3.0; // c = 3.0 + Result := Sum_abc.Eval(Args) + + // All functions are freed automatically when out of scope +end; + +- Examples B - direct usage, top performance but potentially unsafe ------------ +uses ..., tyParser; + +Var + SinC : ExprFunc1V; // Function(const x : Extended): Extended; + SinExp : ExprFunc2V; // Function(const x,y : Extended): Extended; + Sum_abc: ExprFuncR; // Function(var Args): Extended; + Expr : Expression; + Result : Extended; + Args: array[0..2] of Extended; +begin +// Examples with compiling +// ----------------------- + + // EXAMPLE 4 -- 1 Variable Example (pass by value) + // ----------------------------------------------- + SinC := CompileExpr(ParseExpr('sin(x)/x',['x']),tyPass1V); // parse and compile expression + Result := SinC(1.0); // evaluate the Expression + FreeFunc(@SinC); // Free Function + ShowMessage('Result = '+floattostr(Result)); + + // EXAMPLE 5 -- 2 Variables Example (pass by value) + // ------------------------------------------------ + SinExp := CompileExpr(ParseExpr('sin(x)*exp(y)',['x','y']),tyPass2V); // parse and compile expression + Result := SinExp(2.0,3.0); // evaluate the Expression + FreeFunc(@SinExp); // Free Function + ShowMessage('Result = '+floattostr(Result)); + + // EXAMPLE 6 -- 3 Variables Example (pass by reference) + // ---------------------------------------------------- + Sum_abc := CompileExpr(ParseExpr('a+b+c',['a','b','c'])); // parse and compile expression + Args[0] := 1.0; // a = 1.0 + Args[1] := 2.0; // b = 2.0 + Args[2] := 3.0; // c = 3.0 + Result := Sum_abc(Args); // evaluate the Expression + FreeFunc(@Sum_abc); // Free Function + ShowMessage('Result = '+floattostr(Result)); + +// EXAMPLE 7 -- Evaluate without compiling (evaluate from bytecode) +// ---------------------------------------------------------------- + Expr := ParseExpr('sin(x*2*pi/maxX)*cos(y*2*pi/maxY)/2+0.5',['x','y','maxX','maxY']); + if Expr.Error then + begin + ShowMessage('Syntax error!'); + exit; + end; + Result := EvalExpr(Expr,[2,3,200,100]); // x=2, y=3, maxX=200, maxY=100 +end; + +- List of internal functions --------------------------------------------------- + abs,sin,cos,tan,cot,arcsin,arccos,arctan,arccot,ln,log,lb,exp,sqrt,sqr,round, + trunc,frac,heaviside,sign + +- Constants -------------------------------------------------------------------- + pi,e + +- Operators -------------------------------------------------------------------- + +,-,/,*,^ + +Note: x^y^z = x^(y^z) +} + +{$define ErrCode} // Generate detailed syntax error messages? (ErrCode, ErrPos) + // Disable for faster compilation (10%-20% faster) +{$define MultDefaultOp} // Multiplication as default operator? (Allow expressions like "2x") + +{$booleval off} +{$warnings off} +{$ifdef VER170} + {$inline auto} +{$endif} + +unit parser; + +interface + +uses + Math, SysUtils; + +Type + {$ifdef ErrCode} + parseErrEnum = + (parseErr_NoErr,parseErr_OpenBracket,parseErr_UnknownVariableOrConstant, + parseErr_InvalidNumber,parseErr_NumberVarFuncOrBracketExpected, + parseErr_OperatorExpected,parseErr_UnknownFunction); + + parseErrInfo = record + ErrPos: Integer; + ErrCode: parseErrEnum; + end; + {$endif} + + Expression = record + Bytecode: array[0..255] of Byte; + Consts: array of Extended; + {$ifdef ErrCode} + ErrInfo: parseErrInfo; + {$endif} + Error: Boolean; + end; + + tyPassType = (tyPassRef,tyPass1V,tyPass2V); + + ExprFuncR = function(var Args): Extended; + ExprFunc1V = function(const x: Extended): Extended; + ExprFunc2V = function(const x,y: Extended): Extended; + +// ----------------------------------------------------------------------------- +// - Interface wrapper --------------------------------------------------------- +// ----------------------------------------------------------------------------- +type +IExpr = interface + function compiled: Boolean; + {$ifdef ErrCode} + function getErrInfo: parseErrInfo; + function getErrStr: String; + {$endif} +end; + +IExpr1V = interface(IExpr) + function Eval(const x: Extended): Extended; +end; + +IExpr2V = interface(IExpr) + function Eval(const x,y: Extended): Extended; +end; + +IExprR = interface(IExpr) + function Eval(var Args: array of Extended): Extended; +end; + +function compileStr1V(const Formula: String): IExpr1V; overload; +function compileStr2V(const Formula: String): IExpr2V; overload; +function compileStr1V(const Formula: String; const Vars: array of Const): IExpr1V; overload; +function compileStr2V(const Formula: String; const Vars: array of Const): IExpr2V; overload; +function compileStrR(const Formula: String; const Vars: array of Const): IExprR; + +// ----------------------------------------------------------------------------- +// - Parser and compiler ------------------------------------------------------- +// ----------------------------------------------------------------------------- + +function ParseExpr(const S: String): Expression; overload; +function ParseExpr(const S: String; const Variables: array of const): Expression; overload; +function EvalExpr(const ByteCode: Expression): Extended; overload; +function EvalExpr(const ByteCode: Expression; const Variables: array of const): Extended; overload; + +function CompileExpr(const Bytecode: Expression; PT: tyPassType = tyPassRef): Pointer; +procedure FreeFunc(E: Pointer); + +{$ifdef ErrCode} +function FormatError(const ErrInfo: parseErrInfo): String; +{$endif} + +implementation + +uses windows; + +// ----------------------------------------------------------------------------- +// - Interface wrapper --------------------------------------------------------- +// ----------------------------------------------------------------------------- +const + evalExStr = 'Cannot evaluate expression due to a syntax error.'; + +type +TExprFunction = class(TInterfacedObject) +{$ifdef ErrCode} +private + FErrInfo: parseErrInfo; +public + function getErrInfo: parseErrInfo; + function getErrStr: String; +{$endif} +end; + +TExprFunction1V = class (TExprFunction,IExpr1V) +public + constructor Create(const S: String); overload; + constructor Create(const S: String; const Vars: array of Const); overload; + destructor Destroy; override; + function Eval(const x: Extended): Extended; +private + FFunc: ExprFunc1V; + function compiled: Boolean; +end; + +TExprFunction2V = class (TExprFunction,IExpr2V) +public + constructor Create(const S: String); overload; + constructor Create(const S: String; const Vars: array of Const); overload; + destructor Destroy; override; + function Eval(const x,y: Extended): Extended; +private + FFunc: ExprFunc2V; + function compiled: Boolean; +end; + +TExprFunctionR = class (TExprFunction,IExprR) +public + constructor Create(const S: String; const Vars: array of Const); + destructor Destroy; override; + function Eval(var Args: array of Extended): Extended; +private + FFunc: ExprFuncR; + FArgCount: Integer; + function compiled: Boolean; +end; + +{$ifdef ErrCode} +function TExprFunction.getErrInfo: parseErrInfo; +begin + Result := FErrInfo; +end; + +function TExprFunction.getErrStr: String; +begin + Result := FormatError(FErrInfo); +end; +{$endif} + +constructor TExprFunction1V.Create(const S: String); +Var + Expr: Expression; +begin + Expr := ParseExpr(S,['x']); + if not Expr.Error then + FFunc := CompileExpr(Expr,tyPass1V) + {$ifdef ErrCode} + else + FErrInfo := Expr.ErrInfo; + {$endif} +end; + +function TExprFunction1V.compiled: Boolean; +begin + Result := @FFunc <> nil; +end; + +constructor TExprFunction1V.Create(const S: String; const Vars: array of Const); +Var + Expr: Expression; +begin + if length(Vars) <> 1 then + raise EInvalidArgument.Create('Wrong variable count: One variable expected.'); + Expr := ParseExpr(S,Vars); + if not Expr.Error then + FFunc := CompileExpr(Expr,tyPass1V) + {$ifdef ErrCode} + else + FErrInfo := Expr.ErrInfo; + {$endif} +end; + +destructor TExprFunction1V.Destroy; +begin + if @FFunc <> nil then + FreeFunc(@FFunc); + inherited; +end; + +function TExprFunction1V.Eval(const x: Extended): Extended; +begin + if @FFunc = nil then + raise Exception.Create(evalExStr); + Result := FFunc(x); +end; + +constructor TExprFunction2V.Create(const S: String); +Var + Expr: Expression; +begin + Expr := ParseExpr(S,['x','y']); + if not Expr.Error then + FFunc := CompileExpr(Expr,tyPass2V) + {$ifdef ErrCode} + else + FErrInfo := Expr.ErrInfo; + {$endif} +end; + +function TExprFunction2V.compiled: Boolean; +begin + Result := @FFunc <> nil; +end; + +constructor TExprFunction2V.Create(const S: String; const Vars: array of Const); +Var + Expr: Expression; +begin + if length(Vars) <> 2 then + raise EInvalidArgument.Create('Wrong variables count: Two variables expected.'); + Expr := ParseExpr(S,Vars); + if not Expr.Error then + FFunc := CompileExpr(Expr,tyPass2V) + {$ifdef ErrCode} + else + FErrInfo := Expr.ErrInfo; + {$endif} +end; + +destructor TExprFunction2V.Destroy; +begin + if @FFunc <> nil then + FreeFunc(@FFunc); + inherited; +end; + +function TExprFunction2V.Eval(const x,y: Extended): Extended; +begin + if @FFunc = nil then + raise Exception.Create(evalExStr); + Result := FFunc(x,y); +end; + +function TExprFunctionR.compiled: Boolean; +begin + Result := @FFunc <> nil; +end; + +constructor TExprFunctionR.Create(const S: String; const Vars: array of Const); +Var + Expr: Expression; +begin + FArgCount := length(Vars); + Expr := ParseExpr(S,Vars); + if not Expr.Error then + FFunc := CompileExpr(Expr) + {$ifdef ErrCode} + else + FErrInfo := Expr.ErrInfo; + {$endif} +end; + +destructor TExprFunctionR.Destroy; +begin + if @FFunc <> nil then + FreeFunc(@FFunc); + inherited; +end; + +function TExprFunctionR.Eval(var Args: array of Extended): Extended; +begin + if @FFunc = nil then + raise Exception.Create(evalExStr); + if length(Args) <> FArgCount then + raise EInvalidArgument.Create(Format('Wrong argument count: %d argument(s) expected.',[FArgCount])); + Result := FFunc(args[0]); +end; + +function compileStr1V(const Formula: String): IExpr1V; +begin + Result := TExprFunction1V.Create(Formula); +end; + +function compileStr2V(const Formula: String): IExpr2V; +begin + Result := TExprFunction2V.Create(Formula); +end; + +function compileStr1V(const Formula: String; const Vars: array of Const): IExpr1V; +begin + Result := TExprFunction1V.Create(Formula, Vars); +end; + +function compileStr2V(const Formula: String; const Vars: array of Const): IExpr2V; +begin + Result := TExprFunction2V.Create(Formula, Vars); +end; + +function compileStrR(const Formula: String; const Vars: array of Const): IExprR; +begin + Result := TExprFunctionR.Create(Formula, Vars); +end; + +// ----------------------------------------------------------------------------- +// - Parser and compiler ------------------------------------------------------- +// ----------------------------------------------------------------------------- + +Type + EFuncs = (_sin,_cos,_tan,_cot,_arcsin,_arccos,_arctan,_arccot,_ln,_lb,_log, + _exp,_sqrt,_sqr,_sign,_abs,_frac,_round,_trunc,_heaviside,_invalid); + EConst = (_pi,_e,_one,_zero); + EOpCodes = (OpEnd,OpVar,OpConst,OpIConst,OpAdd,OpSub,OpMul,OpDiv,OpHoch,OpNeg, + OpFunc); + +function getLastErrorMsg: String; +var + buf: array[0..MAX_PATH] of Char; +begin + ZeroMemory(@buf,sizeof(buf)); + FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError, 0, buf, sizeof(buf), nil); + Result := Buf; +end; + +Function ParseExpr(const S: String): Expression; +begin + Result := parseExpr(S, []); +end; + +{$ifdef ErrCode} +Function FormatError(const ErrInfo: parseErrInfo): String; +const + ErrPrefix = 'Error on char %d: '; +begin + with ErrInfo do + Case ErrCode of + parseErr_OperatorExpected: + Result := Format(ErrPrefix+'Operator expected',[ErrPos]); + parseErr_UnknownVariableOrConstant: + Result := Format(ErrPrefix+'Unknown variable or constant',[ErrPos]); + parseErr_UnknownFunction: + Result := Format(ErrPrefix+'Unknown function',[ErrPos]); + parseErr_InvalidNumber: + Result := Format(ErrPrefix+'Invalid number',[ErrPos]); + parseErr_NumberVarFuncOrBracketExpected: + Result := Format(ErrPrefix+'Number, variable, constant, function or parenthesis expected',[ErrPos]); + parseErr_OpenBracket: + Result := Format(ErrPrefix+'")" or operator expected',[ErrPos]) + else + Result := 'ParseExpr: Unknown syntax error'; + end; +end; +{$endif} + +Function ParseExpr(const S: String; const Variables: array of const): Expression; +type +OutputType = record + Length: Integer; + Wert: Extended; +end; +Var + CodePos: Integer; + globalResult: Expression; + ConstCount: Integer; +{$ifdef ErrCode} + ErrorStrPos: PChar; +{$endif} +Type + cTyp = (cPlusMinus,cMultDiv,cPower,cOpenPar,cClosePar,cUndefined,cDot,cExp); + +function parseWholeNum(SubExpr: PChar; var Output: OutputType): Boolean; forward; +function parseVarFunc(SubExpr: PChar; var ExprLen: Integer): Boolean; forward; +function parseFactor(SubExpr: PChar; var ExprLen: Integer): Boolean; forward; +function parseParExpr(SubExpr: PChar; var ExprLen: Integer): Boolean; forward; +function parseMultiplication(SubExpr: PChar; var ExprLen: Integer): Boolean; forward; +function parseAddition(SubExpr: PChar; var ExprLen: Integer): Boolean; forward; +function parseRealnum(SubExpr: PChar; var ExprLen : Integer): Boolean; forward; + +function SkipWhiteSpace(var SubExpr: PChar): Integer; +begin + Result := 0; + while (SubExpr^<>#0) and (SubExpr^=' ') do + begin + inc(SubExpr); + inc(Result); + end; +end; + +const + parseInvalidTypeStr = 'ParseExpr: Invalid variable type'; + +function getVarNo(const aVarName: Char): Integer; +var + I: Integer; + VarName: Char; +begin + for I := 0 to High(Variables) do + begin + with Variables[I] do + case VType of + vtString, + vtPChar, + vtAnsiString:; + vtChar: VarName := VChar + else + raise EInvalidArgument.Create(parseInvalidTypeStr); + end; + if VarName = aVarName then + begin + Result := I; + exit; + end; + end; + Result := -1; +end; + +function getLongVarNo(const aVarName: String): Integer; +var + I: Integer; + VarName: String; +begin + for I := 0 to High(Variables) do + begin + with Variables[I] do + case VType of + vtChar:; + vtString: VarName := VString^; + vtPChar: VarName := VPChar; + vtAnsiString: VarName := string(VAnsiString) + else + raise EInvalidArgument.Create(parseInvalidTypeStr); + end; + if VarName = aVarName then + begin + Result := I; + exit; + end; + end; + Result := -1; +end; + +function parseChrType(SubExpr: PChar; Typ: cTyp; var Operation: Char; var ExprLen: Integer): Boolean; +Var + sTyp: cTyp; +begin + ExprLen := SkipWhiteSpace(SubExpr)+1; + sTyp := cUndefined; + if SubExpr^ <> #0 then + case SubExpr^ of + '^': sTyp := cPower; + '.',',': sTyp := cDot; + '+','-': sTyp := cPlusMinus; + '*','/': sTyp := cMultDiv; + '(': sTyp := cOpenPar; + ')': sTyp := cClosePar; + 'e','E': sTyp := cExp; + end; + if sTyp = Typ then + begin + Operation := SubExpr^; + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end; + Result := False; +end; +function parseAlphaNum(SubExpr: PChar; var Output: Char): Boolean; +begin + if SubExpr^ = #0 then + begin + result := False; + exit; + end; + Case SubExpr^ of + '0'..'9','A'..'Z','a'..'z': + begin + Output := SubExpr^; + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end; + end; + Result := False; +end; + +function parseWholeNum(SubExpr: PChar; var Output: OutputType): Boolean; +Var + Count: Integer; + C: Char; +begin + Output.Wert := 0; + Count := 0; + if SubExpr^ <> #0 then + begin + C := SubExpr^; + while (C>='0')and(C<='9') do + begin + inc(Count); + Output.Wert := Output.Wert*10 + (ord(SubExpr^)-ord('0')); + inc(SubExpr); + if SubExpr^ = #0 then break; + C := SubExpr^; + end; + Output.Length := Count; + end; + Result := Count > 0; +end; + +function getFunNo(const S: String): EFuncs; +begin + Result := _invalid; + Case S[1] of + 'a': if S = 'abs' then + Result := _abs else + if S = 'arcsin' then + Result := _arcsin else + if S = 'arccos' then + Result := _arccos else + if S = 'arctan' then + Result := _arctan else + if S = 'arccot' then + Result := _arccot; + 'c': if S = 'cos' then + Result := _cos else + if S = 'cot' then + Result := _cot; + 'e': if S = 'exp' then + Result := _exp; + 'f': if S = 'frac' then + Result := _frac; + 'h': if S = 'heaviside' then + Result := _heaviside; + 'r': if S = 'round' then + Result := _round; + 's': if S = 'sin' then + Result := _sin else + if S = 'sqrt' then + Result := _sqrt else + if S = 'sqr' then + Result := _sqr else + if S = 'sign' then + Result := _sign; + 'l': if S = 'ln' then + Result := _ln else + if S = 'log' then + Result := _log else + if S = 'lb' then + Result := _lb; + 't': if S = 'tan' then + Result := _tan else + if S = 'trunc' then + Result := _trunc; + end; +end; + +function parseVarFunc(SubExpr: PChar; var ExprLen: Integer): Boolean; +Var + C: Char; + St: String; + Klammer: Integer; + Temp: Integer; +{$ifdef ErrCode} + oldSubExpr: PChar; +{$endif} +begin + St := ''; + while parseAlphaNum(SubExpr, C) do + begin + St := St + C; + inc(SubExpr); + end; + if St <> '' then + begin + {$ifdef ErrCode} + oldSubExpr := SubExpr; + {$endif} + ExprLen := length(St)+SkipWhiteSpace(SubExpr); + if SubExpr^ = '(' then + begin + Temp := Byte(getFunNo(St)); + if EFuncs(Temp) <> _invalid then + begin + if parseParExpr(SubExpr, Klammer) then + begin + inc(ExprLen, Klammer); + globalResult.Bytecode[CodePos] := Byte(OpFunc); inc(CodePos); + globalResult.Bytecode[CodePos] := Temp; inc(CodePos); + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end; + end else + begin + {$ifdef ErrCode} + Result := False; + if globalResult.ErrInfo.ErrCode = parseErr_NoErr then + begin + globalResult.ErrInfo.ErrCode := parseErr_UnknownFunction; + ErrorStrPos := oldSubExpr; + end; + exit; + {$endif} + end; + end else + begin + if length(St) = 1 then + begin + Temp := getVarNo(St[1]); + if Temp >= 0 then + begin + globalResult.Bytecode[CodePos] := Byte(OpVar); inc(CodePos); + globalResult.Bytecode[CodePos] := Temp; inc(CodePos); + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end else + if St[1] = 'e' then + begin + globalResult.Bytecode[CodePos] := Byte(OpIConst); inc(CodePos); + globalResult.Bytecode[CodePos] := Byte(_e); inc(CodePos); + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end; + end else + begin + Temp := getLongVarNo(St); + if Temp >= 0 then + begin + globalResult.Bytecode[CodePos] := Byte(OpVar); inc(CodePos); + globalResult.Bytecode[CodePos] := Temp; inc(CodePos); + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end else + if St = 'pi' then + begin + globalResult.Bytecode[CodePos] := Byte(OpIConst); inc(CodePos); + globalResult.Bytecode[CodePos] := Byte(_pi); inc(CodePos); + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end; + end; + end; + end; + Result := False; + {$ifdef ErrCode} + if globalResult.ErrInfo.ErrCode = parseErr_NoErr then + begin + globalResult.ErrInfo.ErrCode := parseErr_UnknownVariableOrConstant; + ErrorStrPos := oldSubExpr; + end; + {$endif} +end; + +function parseRealNum(SubExpr: PChar; var ExprLen: Integer): Boolean; +Var + GanzZahl, NachKomma, Exp: OutputType; + Value: Extended; + ignore, Vorzeichen: Char; + Index, Chr: Integer; + AlreadyExists, Success: Boolean; +begin + Result := False; + try + if parseWholeNum(SubExpr, GanzZahl) then + begin + inc(SubExpr, GanzZahl.Length); + if parseChrType(SubExpr, cDot,ignore, Chr) then + begin + if Chr <> 1 then + exit; + inc(SubExpr, Chr); + if parseWholeNum(SubExpr, NachKomma) then + begin + inc(SubExpr, NachKomma.Length); + ExprLen := GanzZahl.Length + Chr + NachKomma.Length; + Value := GanzZahl.Wert + NachKomma.Wert / Power(10, NachKomma.Length); + end else + exit; + end else + begin + Value := GanzZahl.Wert; + ExprLen := GanzZahl.Length; + end; + if parseChrType(SubExpr, cExp,ignore, Chr) then + begin + if Chr <> 1 then + exit; + inc(SubExpr, Chr); + inc(ExprLen, Chr); + if parseChrType(SubExpr, cPlusMinus,Vorzeichen, Chr) then + begin + if Chr <> 1 then + exit; + inc(SubExpr, Chr); + inc(ExprLen, Chr); + end else + Vorzeichen := '+'; // Standardvorzeichen + if parseWholeNum(SubExpr, Exp) then + begin + inc(ExprLen, Exp.Length); + if Vorzeichen = '-' then + Exp.Wert := -Exp.Wert; + Value := Value*Power(10,Exp.Wert); + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end; + end else + begin + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end; + end; + finally + if result then + begin + Success := False; + if Frac(Value)=0 then + begin + Case Trunc(Value) of + 0: begin + globalResult.Bytecode[CodePos] := Byte(OpIConst); inc(CodePos); + globalResult.Bytecode[CodePos] := Byte(_zero); inc(CodePos); + Success := True; + end; + 1: begin + globalResult.Bytecode[CodePos] := Byte(OpIConst); inc(CodePos); + globalResult.Bytecode[CodePos] := Byte(_one); inc(CodePos); + Success := True; + end; + end; + end; + if not Success then + begin + AlreadyExists := False; + For Index := 0 to ConstCount-1 do // look for duplicate constant + if Value = globalResult.Consts[Index] then + begin + AlreadyExists := True; + break; + end; + if not AlreadyExists then + begin + Index := ConstCount; + inc(ConstCount); + SetLength(globalResult.Consts, Index+1); + globalResult.Consts[Index] := Value; + end; + globalResult.Bytecode[CodePos] := Byte(OpConst); inc(CodePos); + globalResult.Bytecode[CodePos] := Index; inc(CodePos); + end; + end else + begin // if result = false + {$ifdef ErrCode} + if globalResult.ErrInfo.ErrCode = parseErr_NoErr then + begin + globalResult.ErrInfo.ErrCode := parseErr_InvalidNumber; + ErrorStrPos := SubExpr; + end; + {$endif} + end; + end; +end; + +function parseParExpr(SubExpr: Pchar; var ExprLen: Integer): Boolean; +var + ignore: Char; + Ausdruck, Chr1, Chr2: Integer; +begin + if parseChrType(SubExpr, cOpenPar, ignore, Chr1) then + begin + inc(SubExpr, Chr1); + if parseAddition(SubExpr, Ausdruck) then + begin + inc(SubExpr, Ausdruck); + if parseChrType(SubExpr, cClosePar, ignore, Chr2) then + begin + ExprLen := Chr1 + Ausdruck + Chr2; + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end else + begin + {$ifdef ErrCode} + if globalResult.ErrInfo.ErrCode = parseErr_NoErr then + begin + globalResult.ErrInfo.ErrCode := parseErr_OpenBracket; + ErrorStrPos := SubExpr; + end; + {$endif} + end; + end; + end; + Result := False; +end; +function parseSem(SubExpr: PChar; var ExprLen: Integer): Boolean; +Var Spaces: Integer; +begin + Spaces := SkipWhiteSpace(SubExpr); + if SubExpr^ = #0 then + begin + Result := False; + {$ifdef ErrCode} + if globalResult.ErrInfo.ErrCode = parseErr_NoErr then + begin + globalResult.ErrInfo.ErrCode := parseErr_NumberVarFuncOrBracketExpected; + ErrorStrPos := SubExpr; + end; + {$endif} + exit; + end; + case SubExpr^ of + '0'..'9' : Result := parseRealnum(SubExpr, ExprLen); + 'a'..'z','A'..'Z' : Result := parseVarFunc(SubExpr, ExprLen); + '(': Result := parseParExpr(SubExpr, ExprLen) else + begin + Result := False; + {$ifdef ErrCode} + if globalResult.ErrInfo.ErrCode = parseErr_NoErr then + begin + globalResult.ErrInfo.ErrCode := parseErr_NumberVarFuncOrBracketExpected; + ErrorStrPos := SubExpr; + end; + {$endif} + end; + end; + inc(ExprLen, Spaces); +end; + +function parseFactor(SubExpr: PChar; var ExprLen: Integer): Boolean; +Var + Exponent, Chr: Integer; + Operation: Char; +begin + if parseChrType(SubExpr, cPlusMinus, Operation, Chr) then // Vorzeichen? + if parseFactor(SubExpr+Chr, Exponent) then + begin + ExprLen := Chr + Exponent; + Case Operation of + '-': begin + globalResult.Bytecode[CodePos] := Byte(OpNeg); inc(CodePos); + end; + '+': begin + end; + end; + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end; + if parseSem(SubExpr, Exponent) then + begin + inc(SubExpr, Exponent); + if parseChrType(SubExpr, cPower, Operation, Chr) then + begin + inc(SubExpr, Chr); + if parseFactor(SubExpr, ExprLen) then + begin + ExprLen := Exponent + Chr + ExprLen; + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + globalResult.Bytecode[CodePos] := Byte(OpHoch); inc(CodePos); + exit; + end; + end else + begin + ExprLen := Exponent; + Result := True; + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + {$endif} + exit; + end; + end; + Result := False; +end; + +function parseMultiplication(SubExpr: PChar; var ExprLen: Integer): Boolean; +var + Faktor, Chr: Integer; + Operation: Char; + Pending: Boolean; + Count: Integer; +begin + ExprLen := 0; + Count := 0; + Pending := False; + while parseFactor(SubExpr, Faktor) do + begin + Pending := False; + inc(ExprLen, Faktor); + inc(SubExpr, Faktor); + if Count > 0 then + Case Operation of + '*': begin + globalResult.Bytecode[CodePos] := Byte(OpMul); inc(CodePos); + end; + '/': begin + globalResult.Bytecode[CodePos] := Byte(OpDiv); inc(CodePos); + end; + end; + inc(Count); + {$ifdef MultDefaultOp} + Inc(ExprLen, SkipWhiteSpace(SubExpr)); + Case SubExpr^ of + #0: break; + '+','-': break; + end; + {$endif} + if parseChrType(SubExpr, cMultDiv, Operation, Chr) then + begin + Pending := True; + inc(SubExpr, Chr); + inc(ExprLen, Chr); + end else + {$ifdef MultDefaultOp} + Operation := '*'; + {$else} + break; + {$endif} + end; + Result := (Count>=1) and not Pending; +end; + +function parseAddition(SubExpr: PChar; var ExprLen: Integer): Boolean; +var + Term: Integer; + Operation: Char; + Pending: Boolean; + Count, Chr: Integer; +begin + ExprLen := 0; + Count := 0; + Pending := False; + while parseMultiplication(SubExpr, Term) do + begin + Pending := False; + inc(ExprLen, Term); + inc(SubExpr, Term); + if Count > 0 then + Case Operation of + '+': begin + globalResult.Bytecode[CodePos] := Byte(OpAdd); inc(CodePos); + end; + '-': begin + globalResult.Bytecode[CodePos] := Byte(OpSub); inc(CodePos); + end; + end; + inc(Count); + if parseChrType(SubExpr, cPlusMinus, Operation, Chr) then + begin + Pending := True; + inc(SubExpr, Chr); + inc(ExprLen, Chr); + end else break; + end; + Result := (Count>=1) and not Pending; + inc(ExprLen, SkipWhiteSpace(SubExpr)); +end; +Var + ExprLen: Integer; +begin + CodePos := 0; + ConstCount := 0; + globalResult.Consts := nil; + ZeroMemory(@globalResult, SizeOf(globalResult)); + {$ifdef ErrCode} + globalResult.ErrInfo.ErrCode := parseErr_NoErr; + globalResult.ErrInfo.ErrPos := -1; + ErrorStrPos := nil; + {$endif} + globalResult.Error := not (parseAddition(PChar(S), ExprLen) and + (ExprLen = length(S))); + {$ifdef ErrCode} + with globalResult do + if Error then + if (ErrInfo.ErrCode = parseErr_NoErr) and (ExprLen <> length(S)) then + begin + ErrInfo.ErrCode := parseErr_OperatorExpected; + ErrInfo.ErrPos := ExprLen; + end else + if ErrorStrPos <> nil then + ErrInfo.ErrPos := ErrorStrPos-PChar(S) + else + ErrInfo.ErrPos := 0; + {$endif} + globalResult.Bytecode[CodePos] := Byte(OpEnd); inc(CodePos); + Result := globalResult; +end; + +function EvalExpr(const Bytecode: Expression): Extended; +begin + Result := evalExpr(Bytecode, []); +end; + +function EvalExpr(const Bytecode: Expression; const Variables: array of const): Extended; +Type + PExtended = ^Extended; +Var + Stack: array[0..31] of Extended; // No check for overflow + _SP: PExtended; // Stack Pointer + _IP: Integer; // Instruction Pointer + Temp: Extended; + Befehl: EOpCodes; +begin + if Bytecode.Error then + begin + Result := NaN; + exit; + end; + _IP := 0; + _SP := @Stack[0]; + Befehl := EOpCodes(ByteCode.Bytecode[0]); + while Befehl <> OpEnd do + begin + inc(_IP); + Case Befehl of + OpVar: + begin + if Bytecode.Bytecode[_IP] > High(Variables) then + raise EInvalidArgument.Create('EvalExpr: Not enough arguments.'); + with Variables[Bytecode.Bytecode[_IP]] do + case VType of + vtExtended: _SP^ := VExtended^; + vtInteger: _SP^ := VInteger; + vtInt64: _SP^ := VInt64^ else + raise EInvalidArgument.Create('EvalExpr: Invalid argument format.'); + end; + inc(_SP); + inc(_IP); + end; + OpConst: + begin + _SP^ := ByteCode.Consts[ByteCode.Bytecode[_IP]]; + inc(_SP); + inc(_IP); + end; + OpIConst: + begin + Case EConst(ByteCode.Bytecode[_IP]) of + _pi : _SP^ := pi; + _e : _SP^ := exp(1); + _one : _SP^ := 1; + _zero: _SP^ := 0; + end; + inc(_SP); + inc(_IP); + end; + OpAdd: + begin + dec(_SP); + Temp := _SP^; + dec(_SP); + _SP^ := _SP^ + Temp; + inc(_SP); + end; + OpSub: + begin + dec(_SP); + Temp := _SP^; + dec(_SP); + _SP^ := _SP^ - Temp; + inc(_SP); + end; + OpMul: + begin + dec(_SP); + Temp := _SP^; + dec(_SP); + _SP^ := _SP^ * Temp; + inc(_SP); + end; + OpDiv: + begin + dec(_SP); + Temp := _SP^; + dec(_SP); + _SP^ := _SP^ / temp; + inc(_SP); + end; + OpHoch: + begin + dec(_SP); + Temp := _SP^; + dec(_SP); + _SP^ := Power(_SP^,Temp); + inc(_SP); + end; + OpNeg: + begin + dec(_SP); + _SP^ := -_SP^; + inc(_SP); + end; + OpFunc: + begin + dec(_SP); + Case EFuncs(ByteCode.Bytecode[_IP]) of + _abs : _SP^ := abs(_SP^); + _frac : _SP^ := frac(_SP^); + _sin : _SP^ := sin(_SP^); + _cos : _SP^ := cos(_SP^); + _tan : _SP^ := tan(_SP^); + _sign : _SP^ := sign(_SP^); + _cot : _SP^ := cot(_SP^); + _arcsin : _SP^ := arcsin(_SP^); + _arccos : _SP^ := arccos(_SP^); + _arctan : _SP^ := arctan(_SP^); + _arccot : _SP^ := arccot(_SP^); + _ln : _SP^ := ln(_SP^); + _log : _SP^ := ln(_SP^)/ln(10); + _lb : _SP^ := ln(_SP^)/ln(2); + _exp : _SP^ := exp(_SP^); + _sqrt : _SP^ := sqrt(_SP^); + _sqr : _sP^ := sqr(_SP^); + _round : _SP^ := round(_SP^); + _trunc : _SP^ := trunc(_SP^); + _heaviside: if _SP^ >= 0 then _SP^ := 1 else _SP^ := 0; + end; + inc(_SP); + inc(_IP); + end; + end; + Befehl := EOpCodes(ByteCode.Bytecode[_IP]); + end; + dec(_SP); + Result := _SP^; +end; + +Procedure XPower; +Var + Base, Exponent: Extended; + Result: Extended absolute Base; +Begin + asm + push eax + fstp tbyte ptr [Exponent] + fstp tbyte ptr [Base] + end; + if (Frac(Exponent) = 0.0) and (Abs(Exponent) <= MaxInt) then + begin + Result := IntPower(Base, Integer(Trunc(Exponent))); + asm + fld tbyte ptr [Result]; + end; + end else + asm // exp(Exponent*ln(Base)) + fldln2 + fld tbyte ptr [Base] + fyl2x + fld tbyte ptr [Exponent] + fmulp st(1), st + fldl2e + fmulp st(1), st + fld st(0) + frndint + fsub st(1), st + fxch st(1) + f2xm1 + fld1 + faddp st(1), st + fscale + fstp st(1) + end; + asm + pop eax + end; +end; + +Const + Epilogue: array[0..1] of Byte = ($9b,$c3); + EpilogueBy1Value: array[0..2] of Byte = ($c2,$0c,$00); + EpilogueBy2Values: array[0..2] of Byte = ($c2,$18,$00); + { pass by reference } + fld8: array[0..1] of Byte = ($db,$68); + fld16: array[0..1] of Byte = ($db,$a8); + fldIndex0: array[0..1] of Byte = ($db,$28); + { pass by value } + fldIndex0By1Value: array[0..3] of Byte = ($db,$6c,$24,$04); + + fldIndex0By2Values: array[0..3] of Byte = ($db,$6c,$24,$10); + fldIndex1By2Values: array[0..3] of Byte = ($db,$6c,$24,$04); + + fldAddr: array[0..1] of Byte = ($db,$2d); + fmulp: array[0..1] of Byte = ($de,$c9); + fdivp: array[0..1] of Byte = ($de,$f9); + faddp: array[0..1] of Byte = ($de,$c1); + fsubp: array[0..1] of Byte = ($de,$e9); + fldpi: array[0..1] of Byte = ($d9,$eb); + fsin: array[0..1] of Byte = ($d9,$fe); + fcos: array[0..1] of Byte = ($d9,$ff); + fabs: array[0..1] of byte = ($d9,$e1); + fatan: array[0..3] of Byte = ($d9,$e8,$d9,$f3); + ftan: array[0..3] of Byte = ($d9,$f2,$dd,$d8); + fcot: array[0..3] of Byte = ($d9,$f2,$de,$f1); + facot: array[0..5] of Byte = ($d9,$e8,$d9,$c9,$d9,$f3); + fsqrt: array[0..1] of Byte = ($d9,$fa); + fsqr: array[0..3] of Byte = ($d9,$c0,$de,$c9); + flog: array[0..9] of Byte = ($d9,$e8,$d9,$c9,$d9,$f1,$d9,$e9,$de,$f9); + fln: array[0..9] of Byte = ($d9,$e8,$d9,$c9,$d9,$f1,$d9,$ea,$de,$f9); + flb: array[0..5] of Byte = ($d9,$e8,$d9,$c9,$d9,$f1); + fxchg: array[0..1] of Byte = ($d9,$c9); + fchs: array[0..1] of Byte = ($d9,$e0); + fld1: array[0..1] of Byte = ($d9,$e8); + fld0: array[0..1] of Byte = ($d9,$ee); + fexp : array[0..21] of Byte = + ($9,$ea,$de,$c9,$d9,$c0,$d9,$fc,$dc,$e9,$d9,$c9,$d9,$f0,$d9,$e8,$de,$c1,$d9, + $fd,$dd,$d9); + fheaviside: array[0..19] of Byte = + ($d9,$ee,$d8,$d9,$9b,$df,$e0,$9e,$76,$06,$dd,$d8,$d9,$ee,$eb,$04,$dd,$d8,$d9, + $e8); + fround: array[0..12] of Byte = + ($83,$ec,$08,$df,$3C,$24,$9b,$df,$2c,$24,$83,$c4,$08); + farcsin: array[0..11] of Byte = + ($d9,$c0,$d8,$c8,$d9,$e8,$de,$e1,$d9,$fa,$d9,$f3); + farccos: array[0..13] of Byte = + ($d9,$c0,$d8,$c8,$d9,$e8,$de,$e1,$d9,$fa,$d9,$c9,$d9,$f3); + ftrunc: array[0..35] of Byte = + ($83,$ec,$0c,$d9,$3c,$24,$d9,$7C,$24,$02,$66,$81,$4c,$24,$02,$00,$0f,$d9,$6c, + $24,$02,$df,$7c,$24,$04,$9b,$d9,$2c,$24,$59,$df,$2c,$24,$83,$c4,$08); + ffrac: array[0..34] of Byte = + ($d9,$c0,$83,$ec,$04,$d9,$3c,$24,$d9,$7c,$24,02,$9b,$66,$81,$4c,$24,$02,$00, + $0f,$d9,$6c,$24,$02,$d9,$fc,$9b,$d9,$2c,$24,$83,$c4,$04,$de,$e9); + fsign: array[0..23] of Byte = + ($d9,$ee,$d8,$d9,$9b,$df,$e0,$9e,$76,$08,$dd,$d8,$d9,$e8,$d9,$e0,$eb,$06,$73, + $04,$dd,$d8,$d9,$e8); + call: Byte = ($e8); + +function CompileExpr(const Bytecode: Expression; PT: tyPassType = tyPassRef): Pointer; +Type + PExtended = ^Extended; + TIConsts = record + e: Integer; + end; + TConstantEntry = record + Addr: ^Pointer; + Index: Integer; + end; +Var + _IP: Integer; // Instruction Pointer + Befehl: EOpCodes; + P: PByte; + I, J, ConstsCount: Integer; + index: Integer; + IConsts: TIConsts; + AddIConsts: array of Extended; + ConstsTable: array of TConstantEntry; + +Procedure LoadArgNo(ConstNo: Integer); +begin + Case PT of + tyPassRef: + begin + ConstNo := ConstNo * SizeOf(Extended); + if ConstNo < 128 then + begin + if ConstNo = 0 then + begin + Move(fldIndex0, P^, SizeOf(fldIndex0)); inc(P, SizeOf(fldIndex0)); + end else + begin + Move(Fld8, P^, SizeOf(Fld8)); inc(P, SizeOf(Fld8)); + P^ := ConstNo; inc(P); + end; + end else + begin + Move(Fld16, P^, SizeOf(Fld16)); inc(P, SizeOf(Fld16)); + Move(ConstNo, P^, SizeOf(DWord)); inc(P, SizeOf(DWord)); + end; + end; + tyPass1V: + begin + if ConstNo > 0 then + EInvalidArgument.Create('CompileExpr: Only one variable can be passed by value'); + Move(fldIndex0by1Value, P^, SizeOf(fldIndex0by1Value)); + inc(P, SizeOf(fldIndex0by1Value)); + end; + tyPass2V: + Case ConstNo of + 0: begin + Move(fldIndex0by2Values, P^, SizeOf(fldIndex0by2Values)); + inc(P, SizeOf(fldIndex0by2Values)); + end; + 1: begin + Move(fldIndex1by2Values, P^, SizeOf(fldIndex1by2Values)); + inc(P, SizeOf(fldIndex1by2Values)); + end + else + EInvalidArgument.Create('CompileExpr: Only two variables can be passed by value'); + end; + end; +end; + +Procedure AddToConstsTable(P: Pointer; Index: Integer); +Var I: Integer; +begin + I := length(ConstsTable); + SetLength(ConstsTable, I+1); + ConstsTable[I].Addr := P; + ConstsTable[I].Index := Index; +end; + +procedure AddIConst(Var IConst: Integer; const Value: Extended); +begin // Add inline constant (e,...) to additional constants table + if IConst >= 0 then + begin + Move(fldAddr, P^, SizeOf(fldAddr)); inc(P, SizeOf(fldAddr)); + AddToConstsTable(P, IConst); inc(P, SizeOf(DWord)); + end else + begin + Index := length(AddIConsts); + SetLength(AddIConsts, Index+1); + AddIConsts[Index] := Value; + IConst := Index+ConstsCount; + Move(fldAddr, P^, SizeOf(fldAddr)); inc(P, SizeOf(fldAddr)); + AddToConstsTable(P, IConst); inc(P, SizeOf(DWord)); + end; +end; + +procedure AddPowerCmd; +Var + Callee: DWord; +begin + P^ := call; inc(P); + Callee := DWord(@XPower)-DWord(P)-4; // relative Position + Move(Callee, P^, SizeOf(Callee)); inc(P, SizeOf(Callee)); +end; + +begin + {$ifdef ErrCode} + with Bytecode do + if Error then + raise Exception.Create('ParseExpr: '+FormatError(ErrInfo)); + {$else} + if Bytecode.Error then + raise Exception.Create('ParseExpr: Syntax error'); + {$endif} + + Result := VirtualAlloc(nil, 4096, MEM_RESERVE or MEM_COMMIT, PAGE_EXECUTE_READWRITE); + if Result = nil then + raise Exception.Create('CompileExpr: '+getLastErrorMsg); + + try + FillChar(IConsts, SizeOF(IConsts), -1); // list with indexes of inline constants that cannot be + // directly converted + ConstsCount := length(Bytecode.Consts); // how many (not inline) constants in expression + + P := Result; + +// Move(Prologue, P^, SizeOf(Prologue)); +// inc(P, SizeOf(Prologue)); + + _IP := 0; + Befehl := EOpCodes(ByteCode.Bytecode[0]); + while Befehl <> OpEnd do + begin + inc(_IP); + Case Befehl of + OpVar: + begin + LoadArgNo(Bytecode.Bytecode[_IP]); + inc(_IP); + end; + OpConst: + begin + Move(fldAddr, P^, SizeOf(fldAddr)); inc(P, SizeOf(fldAddr)); + AddToConstsTable(P, Integer(Bytecode.Bytecode[_IP])); inc(P, SizeOf(DWord)); + inc(_IP); + end; + OpIConst: + begin + Case EConst(ByteCode.Bytecode[_IP]) of + _pi : begin Move(fldpi, P^, SizeOf(fldpi)); inc(P, SizeOf(fldpi)); end; + _one : begin Move(fld1, P^, SizeOf(fld1)); inc(P, SizeOf(fld1)); end; + _zero: begin Move(fld0, P^, SizeOf(fld0)); inc(P, SizeOf(fld0)); end; + _e : AddIConst(IConsts.e, exp(1)); + else + raise Exception.Create('CompileExpr: Constant not supported'); + end; + inc(_IP); + end; + OpMul: begin + Move(fmulp, P^, SizeOf(fmulp)); inc(P, SizeOf(fmulp)); + end; + OpDiv: begin + Move(fdivp, P^, SizeOf(fdivp)); inc(P, SizeOf(fdivp)); + end; + OpAdd: begin + Move(faddp, P^, SizeOf(faddp)); inc(P, SizeOf(faddp)); + end; + OpSub: begin + Move(fsubp, P^, SizeOf(fsubp)); inc(P, SizeOf(fsubp)); + end; + OpHoch: begin + AddPowerCmd; + end; + OpNeg: begin + Move(fchs, P^, SizeOf(fchs)); inc(P, SizeOf(fchs)); + end; + OpFunc: + begin + Case EFuncs(ByteCode.Bytecode[_IP]) of + _abs : begin + Move(fabs, P^, SizeOf(fabs)); inc(P, SizeOf(fabs)); + end; + _arctan : begin + Move(fatan, P^, SizeOf(fatan)); inc(P, SizeOf(fatan)); + end; + _arccot : begin + Move(facot, P^, SizeOf(facot)); inc(P, SizeOf(facot)); + end; + _arcsin : begin + Move(farcsin, P^, SizeOf(farcsin)); inc(P, SizeOf(farcsin)); + end; + _arccos : begin + Move(farccos, P^, SizeOf(farccos)); inc(P, SizeOf(farccos)); + end; + _sqr : begin + Move(fsqr, P^, SizeOf(fsqr)); inc(P, SizeOf(fsqr)); + end; + _sqrt : begin + Move(fsqrt, P^, SizeOf(fsqrt)); inc(P, SizeOf(fsqrt)); + end; + _sign : begin + Move(fsign, P^, SizeOf(fsign)); inc(P, SizeOf(fsign)); + end; + _ln : begin + Move(fln, P^, SizeOf(fln)); inc(P, SizeOf(fln)); + end; + _log : begin + Move(flog, P^, SizeOf(flog)); inc(P, SizeOf(flog)); + end; + _lb : begin + Move(flb, P^, SizeOf(flb)); inc(P, SizeOf(flb)); + end; + _cot : begin + Move(fcot, P^, SizeOf(fcot)); inc(P, SizeOf(fcot)); + end; + _tan : begin + Move(ftan, P^, SizeOf(ftan)); inc(P, SizeOf(ftan)); + end; + _sin : begin + Move(fsin, P^, SizeOf(fsin)); inc(P, SizeOf(fsin)); + end; + _cos : begin + Move(fcos, P^, SizeOf(fcos)); inc(P, SizeOf(fcos)); + end; + _round : begin + Move(fround, P^, SizeOf(fround)); inc(P, SizeOf(fround)); + end; + _trunc : begin + Move(ftrunc, P^, SizeOf(ftrunc)); inc(P, SizeOf(ftrunc)); + end; + _frac : begin + Move(ffrac, P^, SizeOf(ffrac)); inc(P, SizeOf(ffrac)); + end; + _heaviside: begin + Move(fheaviside, P^, SizeOf(fheaviside)); inc(P, SizeOf(fheaviside)); + end; + _exp : begin + Move(fexp, P^, SizeOf(fexp)); inc(P, SizeOf(fexp)); + end else + raise Exception.Create('CompileExpr: Function not supported'); + end; + inc(_IP); + end; + end; + Befehl := EOpCodes(ByteCode.Bytecode[_IP]); + end; + Case PT of + tyPassRef: + begin + Move(Epilogue, P^, SizeOf(Epilogue)); + inc(P, SizeOf(Epilogue)); + end; + tyPass1V: + begin + Move(EpilogueBy1Value, P^, SizeOf(EpilogueBy1Value)); + inc(P, SizeOf(EpilogueBy1Value)); + end; + tyPass2V: + begin + Move(EpilogueBy2Values, P^, SizeOf(EpilogueBy2Values)); + inc(P, SizeOf(EpilogueBy2Values)); + end; + end; + For I := 0 to length(ConstsTable)-1 do + begin + J := ConstsTable[I].Index; + if J < ConstsCount then + Move(Bytecode.Consts[J], P^, SizeOf(Extended)) + else + Move(AddIConsts[J-ConstsCount], P^, SizeOf(Extended)); + ConstsTable[I].Addr^ := P; + inc(P, SizeOf(Extended)); + end; + except + FreeFunc(Result); + raise; + end; +end; + +procedure FreeFunc(E: Pointer); +begin + if not VirtualFree(E, 0, MEM_RELEASE) then + raise Exception.Create('FreeFunc: '+getLastErrorMsg); +end; + +end. +