mirror of
http://gitlab.expertsoft.com.ua/git/expertcad
synced 2026-01-11 17:25:39 +02:00
1106 lines
27 KiB
ObjectPascal
1106 lines
27 KiB
ObjectPascal
{*********************************************************}
|
|
{ }
|
|
{ TParser 10.1 for Borland Delphi }
|
|
{ }
|
|
{ A component for parsing and evaluating }
|
|
{ mathematical expressions specified at runtime }
|
|
{ }
|
|
{ Renate Schaaf (schaaf@math.usu.edu), 1993 }
|
|
{ Alin Flaider (aflaidar@datalog.ro), 1996 }
|
|
{ Stefan Hoffmeister }
|
|
{ Stefan.Hoffmeister@Uni-Passau.de, 1997 }
|
|
{ }
|
|
{ }
|
|
{ See PARSER10.TXT for documentation }
|
|
{ }
|
|
{*********************************************************}
|
|
unit Parser10;
|
|
|
|
{$IFDEF Win32}
|
|
{$H+,S-} { long strings, no stack-checking}
|
|
{$ENDIF}
|
|
|
|
{.$DEFINE DEBUG} { by default make it lean and efficient }
|
|
{$IFNDEF DEBUG}
|
|
{$D-} {$L-} {$Q-} {$R-} {$S-}
|
|
{$ENDIF}
|
|
|
|
{$I+} { I/O checking ON }
|
|
|
|
interface
|
|
|
|
uses
|
|
SysUtils,
|
|
Classes;
|
|
|
|
type
|
|
{ a couple of unfortunately necessary global declarations }
|
|
ParserFloat = double; { please do NOT use "real", only single, double, extended}
|
|
PParserFloat = ^ParserFloat;
|
|
|
|
TToken=( variab, constant,
|
|
minus,
|
|
sum, diff, prod, divis, modulo, IntDiv,
|
|
integerpower, realpower,
|
|
square, third, fourth,
|
|
FuncOneVar, FuncTwoVar);
|
|
|
|
POperation = ^TOperation;
|
|
{ functions that are added to the engine MUST have this declaration }
|
|
{ make sure that the procedure is declared far !!! }
|
|
TMathProcedure = procedure(AnOperation: POperation);
|
|
TOperation = record
|
|
{ MUST use pointers (!), because argument and destination are linked... }
|
|
Arg1, Arg2 : PParserFloat;
|
|
Dest : PParserFloat;
|
|
|
|
NextOperation : POperation;
|
|
|
|
Operation: TMathProcedure;
|
|
Token : TToken;
|
|
end;
|
|
|
|
EMathParserError = class(Exception); { create a new exception class and... }
|
|
|
|
{ ... some descendants }
|
|
ESyntaxError = class(EMathParserError);
|
|
EExpressionHasBlanks = class(EMathParserError);
|
|
EExpressionTooComplex = class(EMathParserError);
|
|
ETooManyNestings = class(EMathParserError);
|
|
EMissMatchingBracket = class(EMathParserError);
|
|
EBadName = class(EMathParserError);
|
|
EParserInternalError = class(EMathParserError); { hopefully we will never see this one }
|
|
|
|
|
|
{ we COULD use Forms and the TExceptionEvent therein,
|
|
but that would give us all the VCL overhead.
|
|
Consequentially we just redeclare an appropriate event }
|
|
TParserExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
|
|
|
|
|
|
|
|
TCustomParser = class(TComponent)
|
|
private
|
|
{ some pre-allocated space for variables }
|
|
FA,
|
|
FB,
|
|
FC,
|
|
FD,
|
|
FE,
|
|
FX,
|
|
FY,
|
|
FT: ParserFloat;
|
|
private
|
|
FExpression : string;
|
|
FPascalNumberformat: boolean;
|
|
FParserError : boolean;
|
|
|
|
FVariables: TStringList;
|
|
|
|
FStartOperationList: POperation;
|
|
|
|
FOnParserError : TParserExceptionEvent;
|
|
|
|
function CalcValue: extended;
|
|
procedure SetExpression(const AnExpression: string);
|
|
procedure SetVar(const VarName: string; const Value: extended);
|
|
protected
|
|
{ lists of available functions, see .Create for example use }
|
|
FunctionOne : TStringList; { functions with ONE argument, e.g. exp() }
|
|
FunctionTwo : TStringList; { functions with TWO arguments, e.g. max(,) }
|
|
|
|
{ predefined variables - could be left out }
|
|
property A: ParserFloat read FA write FA;
|
|
property B: ParserFloat read FB write FB;
|
|
property C: ParserFloat read FC write FC;
|
|
property D: ParserFloat read FD write FD;
|
|
property E: ParserFloat read FE write FE;
|
|
property T: ParserFloat read FT write FT;
|
|
property X: ParserFloat read FX write FX;
|
|
property Y: ParserFloat read FY write FY;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
function ParseExpression(const AnExpression: string): boolean;
|
|
procedure FreeExpression;
|
|
|
|
{ The PParserFloat returned points to the place in memory where the
|
|
variable actually sits; to speed up assignment you can DIRECTLY
|
|
assign data to the memory area. }
|
|
function SetVariable(VarName: string; const Value: extended): PParserFloat;
|
|
function GetVariable(const VarName: string): extended;
|
|
|
|
procedure AddFunctionOneParam(const AFunctionName: string; const Func: TMathProcedure);
|
|
procedure AddFunctionTwoParam(const AFunctionName: string; const Func: TMathProcedure);
|
|
|
|
procedure ClearVariables;
|
|
procedure ClearVariable(const AVarName: string);
|
|
function VariableExists(const AVarName: string): boolean;
|
|
|
|
procedure ClearFunctions;
|
|
procedure ClearFunction(const AFunctionName: string);
|
|
|
|
property ParserError: boolean read FParserError;
|
|
property LinkedOperationList: POperation read FStartOperationList;
|
|
|
|
property Variable[const VarName: string]: extended read GetVariable write SetVar;
|
|
published
|
|
property Value: extended read CalcValue stored false;
|
|
|
|
{ setting Expression automatically parses it
|
|
Warning: exceptions MAY be raised, if OnParserError is NOT assigned,
|
|
otherwise the event will be triggered in case of an error }
|
|
property Expression: string read FExpression write SetExpression;
|
|
property PascalNumberformat: boolean read FPascalNumberformat write FPascalNumberformat default true;
|
|
property OnParserError: TParserExceptionEvent read FOnParserError write FOnParserError;
|
|
end;
|
|
|
|
|
|
|
|
|
|
TParser = class(TCustomParser)
|
|
public
|
|
{ overrides to add the properties below as variables
|
|
and adds all the functions }
|
|
constructor Create(AOwner: TComponent); override;
|
|
|
|
{ returns the string with the blanks inside removed }
|
|
class function RemoveBlanks(const s: string): string;
|
|
published
|
|
{ predefined variables - could be left out }
|
|
property A;
|
|
property B;
|
|
property C;
|
|
property D;
|
|
property E;
|
|
property T;
|
|
property X;
|
|
property Y;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
{$DEFINE UseMath}
|
|
{ Note: if you do not have the MATH unit simply remove the conditional define
|
|
the component will continue to work, just a bit slower }
|
|
|
|
uses
|
|
{$IFDEF UseMath}
|
|
Math,
|
|
{$ENDIF}
|
|
P10Build;
|
|
|
|
(*
|
|
{$IFDEF VER80}
|
|
{$R *.D16}
|
|
{$ELSE}
|
|
{$IFDEF VER90}
|
|
{$R *.D32}
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
*)
|
|
|
|
{****************************************************************}
|
|
{ }
|
|
{ Following are "built-in" calculation procedures }
|
|
{ }
|
|
{****************************************************************}
|
|
{
|
|
Naming convention for functions:
|
|
|
|
Name of built-in function, prepended with an underscore.
|
|
Example:
|
|
|
|
ln --> _ln
|
|
|
|
Passed arguments / results:
|
|
|
|
If the function takes any arguments - i.e. if it has been added to
|
|
either the FunctionOne or the FunctionTwo list:
|
|
|
|
- First argument --> arg1^
|
|
- Second argument --> arg2^
|
|
|
|
The result of the operation must ALWAYS be put into
|
|
|
|
dest^
|
|
|
|
|
|
Note: These are POINTERS to floats.
|
|
}
|
|
|
|
|
|
|
|
{****************************************************************}
|
|
{ }
|
|
{ These are mandatory procedures - never remove them }
|
|
{ }
|
|
{****************************************************************}
|
|
|
|
{ do nothing - this only happens if the "term" is just a number
|
|
or a variable; otherwise this procedure will never be called }
|
|
procedure _nothing(AnOp: POperation); far;
|
|
begin
|
|
end;
|
|
|
|
procedure _Add(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := arg1^ + arg2^;
|
|
end;
|
|
|
|
procedure _Subtract(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := arg1^ - arg2^;
|
|
end;
|
|
|
|
procedure _Multiply(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := arg1^ * arg2^;
|
|
end;
|
|
|
|
procedure _RealDivide(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := arg1^ / arg2^;
|
|
end;
|
|
|
|
procedure _Modulo(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := trunc(arg1^) mod trunc(arg2^);
|
|
end;
|
|
|
|
procedure _IntDiv(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := trunc(arg1^) div trunc(arg2^);
|
|
end;
|
|
|
|
procedure _Negate(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := -arg1^;
|
|
end;
|
|
|
|
procedure _IntPower(AnOp: POperation); far;
|
|
{$IFNDEF UseMath}
|
|
var
|
|
n, i: longint;
|
|
{$ENDIF}
|
|
begin
|
|
|
|
{$IFNDEF UseMath}
|
|
with AnOp^ do
|
|
begin
|
|
n := trunc(abs(arg2^))-1;
|
|
|
|
case n of
|
|
-1: dest^ := 1;
|
|
0: dest^ := arg1^;
|
|
else
|
|
dest^ := arg1^;
|
|
for i := 1 to n do
|
|
dest^ := dest^ * arg1^;
|
|
end;
|
|
|
|
if arg2^ < 0 then
|
|
dest^ := 1 / dest^;
|
|
|
|
end;
|
|
{$ELSE}
|
|
with AnOp^ do
|
|
dest^ := IntPower(arg1^, trunc(arg2^));
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure _square(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := sqr(arg1^);
|
|
end;
|
|
|
|
procedure _third(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := arg1^ * arg1^ * arg1^;
|
|
end;
|
|
|
|
procedure _forth(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := sqr(sqr(arg1^));
|
|
end;
|
|
|
|
procedure _power(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
begin
|
|
{$IFNDEF UseMath}
|
|
if arg1^ = 0 then
|
|
dest^ := 0
|
|
else
|
|
dest^ := exp(arg2^*ln(arg1^));
|
|
{$ELSE}
|
|
dest^ := Power(arg1^, arg2^);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
|
|
{****************************************************************}
|
|
{ }
|
|
{ These are OPTIONAL procedures - you may remove them, though }
|
|
{ it is preferable to not register them for use }
|
|
{ }
|
|
{****************************************************************}
|
|
procedure _sin(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := sin(arg1^);
|
|
end;
|
|
|
|
procedure _cos(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := cos(arg1^);
|
|
end;
|
|
|
|
procedure _arctan(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := arctan(arg1^);
|
|
end;
|
|
|
|
procedure _arg(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
if arg1^ < 0 then
|
|
dest^ := arctan(arg2^/arg1^)+Pi
|
|
else
|
|
if arg1^>0 then
|
|
dest^ := arctan(arg2^/arg1^)
|
|
else
|
|
if arg2^ > 0 then
|
|
dest^ := 0.5 * Pi
|
|
else
|
|
dest^ := -0.5 * Pi;
|
|
end;
|
|
|
|
procedure _sinh(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := (exp(arg1^)-exp(-arg1^))*0.5;
|
|
end;
|
|
|
|
procedure _cosh(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := (exp(arg1^)+exp(-arg1^))*0.5;
|
|
end;
|
|
|
|
procedure _cotan(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
{$IFNDEF UseMath}
|
|
dest^ := cos(arg1^) / sin(arg1^);
|
|
{$ELSE}
|
|
dest^ := cotan(arg1^);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure _tan(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
{$IFNDEF UseMath}
|
|
dest^ := sin(arg1^) / cos(arg1^);
|
|
{$ELSE}
|
|
dest^ := tan(arg1^);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure _exp(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := exp(arg1^);
|
|
end;
|
|
|
|
procedure _ln(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := ln(arg1^);
|
|
end;
|
|
|
|
procedure _log10(AnOp: POperation); far;
|
|
const
|
|
_1_ln10 = 0.4342944819033;
|
|
begin
|
|
with AnOp^ do
|
|
{$IFDEF UseMath}
|
|
dest^ := log10(arg1^);
|
|
{$ELSE}
|
|
dest^ := ln(arg1^) * _1_ln10;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure _log2(AnOp: POperation); far;
|
|
const
|
|
_1_ln2 = 1.4426950409;
|
|
begin
|
|
with AnOp^ do
|
|
{$IFDEF UseMath}
|
|
dest^ := log2(arg1^);
|
|
{$ELSE}
|
|
dest^ := ln(arg1^) * _1_ln2;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure _logN(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
{$IFDEF UseMath}
|
|
dest^ := logN(arg1^, arg2^);
|
|
{$ELSE}
|
|
dest^ := ln(arg1^) / ln(arg2^);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure _sqrt(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := sqrt(arg1^);
|
|
end;
|
|
|
|
|
|
procedure _abs(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := abs(arg1^);
|
|
end;
|
|
|
|
procedure _min(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
if arg1^ < arg2^ then
|
|
dest^ := arg1^
|
|
else
|
|
dest^ := arg2^;
|
|
end;
|
|
|
|
procedure _max(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
if arg1^ < arg2^ then
|
|
dest^ := arg2^
|
|
else
|
|
dest^ := arg1^;
|
|
end;
|
|
|
|
procedure _heaviside(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
if arg1^ < 0 then
|
|
dest^ := 0
|
|
else
|
|
dest^ := 1;
|
|
end;
|
|
|
|
procedure _sign(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
if arg1^ < 0 then
|
|
dest^ := -1
|
|
else
|
|
if arg1^ > 0 then
|
|
dest^ := 1.0
|
|
else
|
|
dest^ := 0.0;
|
|
end;
|
|
|
|
procedure _zero(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
if arg1^ = 0.0 then
|
|
dest^ := 0.0
|
|
else
|
|
dest^ := 1.0;
|
|
end;
|
|
|
|
procedure _trunc(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := int(arg1^)
|
|
end;
|
|
|
|
procedure _ceil(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
if frac(arg1^) > 0 then
|
|
dest^ := int(arg1^ + 1)
|
|
else
|
|
dest^ := int(arg1^);
|
|
end;
|
|
|
|
procedure _floor(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
if frac(arg1^) < 0 then
|
|
dest^ := int(arg1^ - 1)
|
|
else
|
|
dest^ := int(arg1^);
|
|
end;
|
|
|
|
procedure _rnd(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := Random * int(arg1^);
|
|
end;
|
|
|
|
procedure _random(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := Random;
|
|
end;
|
|
|
|
procedure _radius(AnOp: POperation); far;
|
|
begin
|
|
with AnOp^ do
|
|
dest^ := sqrt(sqr(arg1^)+sqr(arg2^));
|
|
end;
|
|
|
|
procedure _phase(AnOp: POperation); far;
|
|
var
|
|
a: ParserFloat;
|
|
begin
|
|
with AnOp^ do
|
|
begin
|
|
a := arg1^ / (2/pi);
|
|
dest^ := (2*pi) * (a-round(a));
|
|
end;
|
|
end;
|
|
|
|
{****************************************************************}
|
|
{ }
|
|
{ TCustomParser }
|
|
{ }
|
|
{ A base class which does not publish the variable properties }
|
|
{ and adds no functions by default }
|
|
{ }
|
|
{****************************************************************}
|
|
function TCustomParser.ParseExpression(const AnExpression: string):boolean;
|
|
var
|
|
OperationLoop: POperation;
|
|
begin
|
|
FreeExpression;
|
|
FExpression := AnExpression;
|
|
|
|
if AnExpression <> '' then
|
|
begin
|
|
Result := false;
|
|
|
|
try
|
|
ParseFunction( AnExpression,
|
|
|
|
FVariables,
|
|
|
|
FunctionOne,
|
|
FunctionTwo,
|
|
|
|
FPascalNumberformat,
|
|
|
|
FStartOperationList,
|
|
Result);
|
|
|
|
FParserError := Result;
|
|
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
FParserError := true;
|
|
|
|
if Assigned(FOnParserError) then
|
|
begin
|
|
FOnParserError(Self, E);
|
|
exit;
|
|
end
|
|
else
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
Result := not Result;
|
|
|
|
OperationLoop := FStartOperationList;
|
|
while OperationLoop <> nil do
|
|
begin
|
|
with OperationLoop^ do
|
|
begin
|
|
case Token of
|
|
|
|
variab,
|
|
constant: Operation := _nothing;
|
|
|
|
minus: Operation := _negate;
|
|
|
|
sum: Operation := _add;
|
|
diff: Operation := _subtract;
|
|
prod: Operation := _multiply;
|
|
divis: Operation := _RealDivide;
|
|
|
|
modulo: Operation := _Modulo;
|
|
intdiv: Operation := _IntDiv;
|
|
|
|
integerpower: Operation := _IntPower;
|
|
realpower: Operation := _Power;
|
|
|
|
square: Operation := _square;
|
|
third: Operation := _third;
|
|
fourth: Operation := _forth;
|
|
|
|
FuncOneVar, FuncTwoVar: { job has been done in build already !};
|
|
end; {case}
|
|
|
|
OperationLoop := NextOperation;
|
|
end; {with OperationLoop^}
|
|
|
|
end; {while OperationLoop<>nil}
|
|
end;
|
|
end;
|
|
|
|
constructor TCustomParser.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
|
|
FPascalNumberformat := true;
|
|
|
|
FVariables := TStringList.Create;
|
|
with FVariables do
|
|
begin
|
|
Sorted := true;
|
|
Duplicates := dupIgnore;
|
|
end;
|
|
|
|
FunctionOne := TStringList.Create;
|
|
with FunctionOne do
|
|
begin
|
|
Sorted := true;
|
|
Duplicates := dupError;
|
|
end;
|
|
|
|
FunctionTwo := TStringList.Create;
|
|
with FunctionTwo do
|
|
begin
|
|
Sorted := true;
|
|
Duplicates := dupError;
|
|
end;
|
|
|
|
end;
|
|
|
|
destructor TCustomParser.Destroy;
|
|
begin
|
|
FreeExpression;
|
|
|
|
ClearVariables;
|
|
FVariables.Free;
|
|
|
|
FunctionOne.Free;
|
|
FunctionTwo.Free;
|
|
|
|
inherited Destroy;
|
|
end;
|
|
|
|
|
|
|
|
|
|
procedure TCustomParser.SetVar(const VarName: string; const Value: extended);
|
|
begin
|
|
SetVariable(VarName, Value);
|
|
end;
|
|
|
|
function TCustomParser.SetVariable(VarName: string; const Value: extended): PParserFloat;
|
|
var
|
|
i: integer;
|
|
begin
|
|
{ always convert to uppercase }
|
|
VarName := UpperCase(VarName);
|
|
|
|
with FVariables do
|
|
if Find(VarName, i) then
|
|
begin
|
|
Result := PParserFloat(Objects[i]);
|
|
Result^ := Value;
|
|
end
|
|
else
|
|
begin
|
|
if Length(Varname) = 1 then
|
|
case VarName[1] of
|
|
'A': Result := @FA;
|
|
'B': Result := @FB;
|
|
'C': Result := @FC;
|
|
'D': Result := @FD;
|
|
'E': Result := @FE;
|
|
'T': Result := @FT;
|
|
'X': Result := @FX;
|
|
'Y': Result := @FY;
|
|
else { case }
|
|
{ is the variable name a valid identifier? }
|
|
if not IsValidIdent(VarName) then
|
|
raise EBadName.Create(VarName);
|
|
|
|
{ unravelled loop for improved (string!) performance! }
|
|
|
|
{ check whether the variable contains any of the operators (DIV and MOD)
|
|
this would confuse the parser... }
|
|
if pos('+', VarName) <> 0 then
|
|
raise EBadName.Create(VarName);
|
|
|
|
if pos('-', VarName) <> 0 then
|
|
raise EBadName.Create(VarName);
|
|
|
|
if pos('*', VarName) <> 0 then
|
|
raise EBadName.Create(VarName);
|
|
|
|
if pos('/', VarName) <> 0 then
|
|
raise EBadName.Create(VarName);
|
|
|
|
if pos('^', VarName) <> 0 then
|
|
raise EBadName.Create(VarName);
|
|
|
|
if pos('DIV', VarName) <> 0 then
|
|
raise EBadName.Create(VarName);
|
|
|
|
if pos('MOD', VarName) <> 0 then
|
|
raise EBadName.Create(VarName);
|
|
|
|
new(Result);
|
|
end { case }
|
|
else
|
|
begin
|
|
{ is the variable name a valid identifier? }
|
|
if not IsValidIdent(VarName) then
|
|
raise EBadName.Create(VarName);
|
|
|
|
new(Result);
|
|
end;
|
|
|
|
Result^ := Value;
|
|
|
|
AddObject(VarName, TObject(Result));
|
|
end
|
|
end;
|
|
|
|
function TCustomParser.GetVariable(const VarName: string): extended;
|
|
var
|
|
i: integer;
|
|
begin
|
|
with FVariables do
|
|
if Find(UpperCase(VarName), i) then
|
|
Result := PParserFloat(Objects[i])^
|
|
else
|
|
Result := 0.0;
|
|
end;
|
|
|
|
procedure TCustomParser.AddFunctionOneParam(const AFunctionName: string; const Func: TMathProcedure);
|
|
begin
|
|
if IsValidIdent(AFunctionName) then
|
|
FunctionOne.AddObject(UpperCase(AFunctionName), TObject(@Func))
|
|
else
|
|
raise EBadName.Create(AFunctionName);
|
|
end;
|
|
|
|
procedure TCustomParser.AddFunctionTwoParam(const AFunctionName: string; const Func: TMathProcedure);
|
|
begin
|
|
if IsValidIdent(AFunctionName) then
|
|
FunctionTwo.AddObject(UpperCase(AFunctionName), TObject(@Func))
|
|
else
|
|
raise EBadName.Create(AFunctionName);
|
|
end;
|
|
|
|
procedure TCustomParser.ClearVariables;
|
|
var
|
|
i: integer;
|
|
APPFloat: PParserFloat;
|
|
AString: string; { disregard stack consumption }
|
|
begin
|
|
with FVariables do
|
|
begin
|
|
i := Count;
|
|
while i > 0 do
|
|
begin
|
|
dec(i);
|
|
AString := Strings[i];
|
|
if (Length(AString) <> 1) or
|
|
(not (AString[1] in ['A'..'E', 'T', 'X', 'Y'])) then
|
|
begin
|
|
APPFloat := PParserFloat(Objects[i]);
|
|
if APPFloat <> nil then
|
|
dispose( APPFloat ); { dispose only user-defined variables }
|
|
end;
|
|
end;
|
|
|
|
Clear;
|
|
end;
|
|
|
|
with FVariables do
|
|
begin
|
|
i := Count;
|
|
while i > 0 do
|
|
begin
|
|
dec(i);
|
|
AString := Strings[i];
|
|
if (Length(AString) <> 1) or
|
|
(not (AString[1] in ['A'..'E', 'T', 'X', 'Y'])) then
|
|
begin
|
|
APPFloat := PParserFloat(Objects[i]);
|
|
if APPFloat <> nil then
|
|
dispose( APPFloat ); { dispose only user-defined variables }
|
|
end;
|
|
end;
|
|
|
|
Clear;
|
|
end;
|
|
|
|
SetExpression(''); { invalidate expression }
|
|
end;
|
|
|
|
procedure TCustomParser.ClearVariable(const AVarName: string);
|
|
var
|
|
index: integer;
|
|
begin
|
|
with FVariables do
|
|
begin
|
|
if Find(AVarName, index) then
|
|
begin
|
|
if (Length(AVarName) <> 1) and
|
|
(not (AVarName[1] in ['A'..'E', 'T', 'X', 'Y'])) then
|
|
dispose( PParserFloat(Objects[index]) ); { dispose only user-defined variables }
|
|
|
|
Delete(index);
|
|
end;
|
|
end;
|
|
|
|
SetExpression(''); { invalidate expression }
|
|
end;
|
|
|
|
function TCustomParser.VariableExists(const AVarName: string): boolean;
|
|
var
|
|
index: integer;
|
|
begin
|
|
Result := FVariables.Find(UpperCase(AVarName), index);
|
|
end;
|
|
|
|
procedure TCustomParser.ClearFunctions;
|
|
begin
|
|
FunctionOne.Clear;
|
|
FunctionTwo.Clear;
|
|
|
|
SetExpression(''); { invalidate expression }
|
|
end;
|
|
|
|
procedure TCustomParser.ClearFunction(const AFunctionName: string);
|
|
var
|
|
index: integer;
|
|
begin
|
|
with FunctionOne do
|
|
begin
|
|
if Find(AFunctionName, index) then
|
|
begin
|
|
Delete(index);
|
|
SetExpression(''); { invalidate expression }
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
with FunctionTwo do
|
|
begin
|
|
if Find(AFunctionName, index) then
|
|
begin
|
|
Delete(index);
|
|
SetExpression(''); { invalidate expression }
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure TCustomParser.FreeExpression;
|
|
var
|
|
LastOP,
|
|
NextOP: POperation;
|
|
begin
|
|
LastOP := FStartOperationList;
|
|
|
|
while LastOP <> nil do
|
|
begin
|
|
NextOP := LastOP^.NextOperation;
|
|
|
|
while NextOP <> nil do
|
|
with NextOP^ do
|
|
begin
|
|
if (Arg1 = lastop^.Arg1) or (Arg1 = lastop^.Arg2) or (Arg1 = lastop^.Dest) then
|
|
Arg1 := nil;
|
|
|
|
if (Arg2 = lastop^.Arg1) or (Arg2 = lastop^.Arg2) or (Arg2 = lastop^.Dest) then
|
|
Arg2 := nil;
|
|
|
|
if (Dest = lastop^.Arg1) or (Dest = lastop^.Arg2) or (Dest = lastop^.Dest) then
|
|
Dest := nil;
|
|
|
|
NextOP := NextOperation;
|
|
end;
|
|
|
|
with LastOP^, FVariables do
|
|
begin
|
|
if IndexOfObject( TObject(Arg1)) >= 0 then Arg1 := nil;
|
|
if IndexOfObject( TObject(Arg2)) >= 0 then Arg2 := nil;
|
|
if IndexOfObject( TObject(Dest)) >= 0 then Dest := nil;
|
|
|
|
if (Dest <> nil) and (Dest <> Arg2) and (Dest <> Arg1) then
|
|
dispose(Dest);
|
|
|
|
if (Arg2 <> nil) and (Arg2 <> Arg1) then
|
|
dispose(Arg2);
|
|
|
|
if (Arg1 <> nil) then
|
|
dispose(Arg1);
|
|
end;
|
|
|
|
NextOP := LastOP^.NextOperation;
|
|
dispose(LastOP);
|
|
LastOP := NextOP;
|
|
end;
|
|
|
|
FStartOperationList := nil;
|
|
end;
|
|
|
|
procedure TCustomParser.SetExpression(const AnExpression: string);
|
|
begin
|
|
ParseExpression(AnExpression); { this implies FExpression := AnExpression }
|
|
end;
|
|
|
|
|
|
function TCustomParser.CalcValue: extended;
|
|
var
|
|
LastOP: POperation;
|
|
begin
|
|
if FStartOperationList <> nil then
|
|
begin
|
|
LastOP := FStartOperationList;
|
|
|
|
while LastOP^.NextOperation <> nil do
|
|
begin
|
|
with LastOP^ do
|
|
begin
|
|
Operation(LastOP);
|
|
LastOP := NextOperation;
|
|
end;
|
|
end;
|
|
LastOP^.Operation(LastOP);
|
|
|
|
Result := LastOP^.Dest^;
|
|
end
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
|
|
{****************************************************************}
|
|
{ }
|
|
{ TCustomParser }
|
|
{ }
|
|
{****************************************************************}
|
|
constructor TParser.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
|
|
with FVariables do
|
|
begin
|
|
AddObject( 'A', TObject(@FA));
|
|
AddObject( 'B', TObject(@FB));
|
|
AddObject( 'C', TObject(@FC));
|
|
AddObject( 'D', TObject(@FD));
|
|
AddObject( 'E', TObject(@FE));
|
|
AddObject( 'X', TObject(@FX));
|
|
AddObject( 'Y', TObject(@FY));
|
|
AddObject( 'T', TObject(@FT));
|
|
end;
|
|
|
|
with FunctionOne do
|
|
begin
|
|
{$DEFINE SpeedCompare} { compare speed against older versions with less functions }
|
|
|
|
AddObject('TAN', TObject(@_tan));
|
|
AddObject('SIN', TObject(@_sin));
|
|
AddObject('COS', TObject(@_cos));
|
|
AddObject('SINH', TObject(@_sinh));
|
|
AddObject('COSH', TObject(@_cosh));
|
|
AddObject('ARCTAN', TObject(@_arctan));
|
|
{$IFNDEF SpeedCompare}
|
|
AddObject('COTAN', TObject(@_cotan));
|
|
AddObject('ARG', TObject(@_arg));
|
|
{$ENDIF}
|
|
|
|
AddObject('EXP', TObject(@_exp));
|
|
AddObject('LN', TObject(@_ln));
|
|
{$IFNDEF SpeedCompare}
|
|
AddObject('LOG10', TObject(@_log10));
|
|
AddObject('LOG2', TObject(@_log2));
|
|
|
|
AddObject('SQR', TObject(@_square));
|
|
{$ENDIF}
|
|
AddObject('SQRT', TObject(@_sqrt));
|
|
|
|
AddObject('ABS', TObject(@_abs));
|
|
{$IFNDEF SpeedCompare}
|
|
AddObject('TRUNC', TObject(@_trunc));
|
|
AddObject('INT', TObject(@_trunc)); { NOTE: INT = TRUNC ! }
|
|
AddObject('CEIL', TObject(@_ceil));
|
|
AddObject('FLOOR', TObject(@_floor));
|
|
{$ENDIF}
|
|
|
|
AddObject('HEAV', TObject(@_heaviside));
|
|
AddObject('SIGN', TObject(@_sign));
|
|
AddObject('ZERO', TObject(@_zero));
|
|
AddObject('PH', TObject(@_phase));
|
|
AddObject('RND', TObject(@_rnd));
|
|
{$IFNDEF SpeedCompare}
|
|
AddObject('RANDOM', TObject(@_random));
|
|
{$ENDIF}
|
|
end;
|
|
|
|
with FunctionTwo do
|
|
begin
|
|
|
|
AddObject('MAX', TObject(@_max));
|
|
AddObject('MIN', TObject(@_min));
|
|
|
|
{$IFNDEF SpeedCompare}
|
|
AddObject('POWER', TObject(@_Power));
|
|
AddObject('INTPOWER', TObject(@_IntPower));
|
|
|
|
AddObject('LOGN', TObject(@_logN)); *)
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
|
|
class function TParser.RemoveBlanks(const s: string): string;
|
|
{deletes all blanks in s}
|
|
var
|
|
i : integer;
|
|
begin
|
|
Result := s;
|
|
|
|
i := pos(' ', Result);
|
|
while i > 0 do
|
|
begin
|
|
delete(Result, i, 1);
|
|
i := pos(' ', Result);
|
|
end;
|
|
end;
|
|
|
|
end.
|