Vichingo455-RePacks/xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity

update to 0.7.0

Browse Source
This commit is contained in:
Razor12911
2023-04-29 22:51:51 +02:00
parent 552a733296
commit 50c7c248da
144 changed files with 42115 additions and 22130 deletions
Download Patch File Download Diff File Expand all files Collapse all files

719
contrib/ParseExpression/__history/ParseClass.pas.~1~
View File

@@ -1,719 +0,0 @@
unit ParseClass;
interface
uses OObjects, SysUtils;
const
MaxArg = 6;
const
Nan: Double = 0 / 0;
function isNan(const d: Double): boolean;
type
TVarType = (vtDouble, vtBoolean, vtString, vtLeftBracket,
vtRightBracket, vtComma);
PDouble = ^Double;
EParserException = class(Exception);
PExpressionRec = ^TExpressionRec;
TExprWord = class;
TArgsArray = record
Res: Double;
Args: array [0 .. MaxArg - 1] of PDouble;
ExprWord: TExprWord; // can be used to notify the object to update
end;
TDoubleFunc = procedure(Expr: PExpressionRec);
TStringFunc = function(s1, s2: string): Double;
TExpressionRec = record
// used both as linked tree and linked list for maximum evaluation efficiency
Oper: TDoubleFunc;
Next: PExpressionRec;
Res: Double;
ExprWord: TExprWord;
case Byte of
0:
(Args: array [0 .. MaxArg - 1] of PDouble;
// can be used to notify the object to update
);
1:
(ArgList: array [0 .. MaxArg - 1] of PExpressionRec);
end;
TExprCollection = class(TNoOwnerCollection)
public
function NextOper(IStart: Integer): Integer;
procedure Check;
procedure EraseExtraBrackets;
end;
TExprWord = class
private
FName: string;
FDoubleFunc: TDoubleFunc;
protected
function GetIsOper: boolean; virtual;
function GetAsString: string; virtual;
function GetIsVariable: boolean;
function GetCanVary: boolean; virtual;
function GetVarType: TVarType; virtual;
function GetNFunctionArg: Integer; virtual;
function GetDescription: string; virtual;
public
constructor Create(AName: string; ADoubleFunc: TDoubleFunc);
function AsPointer: PDouble; virtual;
property AsString: string read GetAsString;
property DoubleFunc: TDoubleFunc read FDoubleFunc;
property IsOper: boolean read GetIsOper;
property CanVary: boolean read GetCanVary;
property isVariable: boolean read GetIsVariable;
property VarType: TVarType read GetVarType;
property NFunctionArg: Integer read GetNFunctionArg;
property Name: string read FName;
property Description: string read GetDescription;
end;
TExpressList = class(TSortedCollection)
public
function KeyOf(Item: Pointer): Pointer; override;
function Compare(Key1, Key2: Pointer): Integer; override;
end;
TDoubleConstant = class(TExprWord)
private
FValue: Double;
public
function AsPointer: PDouble; override;
constructor Create(AName: string; AValue: string);
constructor CreateAsDouble(AName: string; AValue: Double);
// not overloaded to support older Delphi versions
property Value: Double read FValue write FValue;
end;
TConstant = class(TDoubleConstant)
private
FDescription: string;
protected
function GetDescription: string; override;
public
constructor CreateAsDouble(AName, Descr: string; AValue: Double);
end;
TBooleanConstant = class(TDoubleConstant)
protected
function GetVarType: TVarType; override;
end;
TGeneratedVariable = class(TDoubleConstant)
private
FAsString: string;
FVarType: TVarType;
protected
function GetVarType: TVarType; override;
function GetAsString: string; override;
function GetCanVary: boolean; override;
public
constructor Create(AName: string);
property VarType read GetVarType write FVarType;
property AsString: string read GetAsString write FAsString;
end;
TDoubleVariable = class(TExprWord)
private
FValue: PDouble;
protected
function GetCanVary: boolean; override;
public
function AsPointer: PDouble; override;
constructor Create(AName: string; AValue: PDouble);
end;
TStringConstant = class(TExprWord)
private
FValue: string;
protected
function GetVarType: TVarType; override;
function GetAsString: string; override;
public
constructor Create(AValue: string);
end;
TLeftBracket = class(TExprWord)
function GetVarType: TVarType; override;
end;
TRightBracket = class(TExprWord)
protected
function GetVarType: TVarType; override;
end;
TComma = class(TExprWord)
protected
function GetVarType: TVarType; override;
end;
PString = ^string;
TStringVariable = class(TExprWord)
private
FValue: PString;
protected
function GetVarType: TVarType; override;
function GetAsString: string; override;
function GetCanVary: boolean; override;
public
constructor Create(AName: string; AValue: PString);
end;
TFunction = class(TExprWord)
private
FIsOper: boolean;
FOperPrec: Integer;
FNFunctionArg: Integer;
FDescription: string;
protected
function GetDescription: string; override;
function GetIsOper: boolean; override;
function GetNFunctionArg: Integer; override;
public
constructor Create(AName, Descr: string; ADoubleFunc: TDoubleFunc;
ANFunctionArg: Integer);
constructor CreateOper(AName: string; ADoubleFunc: TDoubleFunc;
ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer);
property OperPrec: Integer read FOperPrec;
end;
TVaryingFunction = class(TFunction)
// Functions that can vary for ex. random generators
// should be TVaryingFunction to be sure that they are
// always evaluated
protected
function GetCanVary: boolean; override;
end;
TBooleanFunction = class(TFunction)
protected
function GetVarType: TVarType; override;
end;
TOper = (op_eq, op_gt, op_lt, op_ge, op_le, op_in);
const
ListChar = ','; { the delimiter used with the 'in' operator: e.g.,
('a' in 'a,b') =True
('c' in 'a,b') =False }
type
TSimpleStringFunction = class(TFunction)
private
FStringFunc: TStringFunc;
FLeftArg: TExprWord;
FRightArg: TExprWord;
protected
function GetCanVary: boolean; override;
public
constructor Create(AName, Descr: string; AStringFunc: TStringFunc;
ALeftArg, ARightArg: TExprWord);
function Evaluate: Double;
property StringFunc: TStringFunc read FStringFunc;
end;
TVaryingStringFunction = class(TSimpleStringFunction)
protected
function GetCanVary: boolean; override;
end;
TLogicalStringOper = class(TSimpleStringFunction)
protected
function GetVarType: TVarType; override;
public
constructor Create(AOper: string; ALeftArg: TExprWord;
ARightArg: TExprWord);
end;
procedure _Variable(Param: PExpressionRec);
// procedure _StringFunc(Param: PExpressionRec);
implementation
// function _StrIn(sLookfor, sData: string): Double;
// function _StrInt(a, b: string): Double;
function isNan(const d: Double): boolean;
begin
Result := comp(d) = comp(Nan);
// slower alternative: CompareMem(@d, @Nan, SizeOf(Double))
end;
procedure _Variable(Param: PExpressionRec);
begin
with Param^ do
Res := Args[0]^;
end;
procedure _StringFunc(Param: PExpressionRec);
begin
with Param^ do
Res := TSimpleStringFunction(ExprWord).Evaluate;
end;
function _StrInt(a, b: string): Double;
begin
Result := StrToInt(a);
end;
function _StrEq(s1, s2: string): Double;
begin
Result := Byte(s1 = s2);
end;
function _StrGt(s1, s2: string): Double;
begin
Result := Byte(s1 > s2);
end;
function _Strlt(s1, s2: string): Double;
begin
Result := Byte(s1 < s2);
end;
function _StrGe(s1, s2: string): Double;
begin
Result := Byte(s1 >= s2);
end;
function _Strle(s1, s2: string): Double;
begin
Result := Byte(s1 <= s2);
end;
function _Strne(s1, s2: string): Double;
begin
Result := Byte(s1 <> s2);
end;
function _StrIn(sLookfor, sData: string): Double;
var
loop: Integer;
subString: string;
begin
Result := 0;
loop := pos(ListChar, sData);
while loop > 0 do
begin
subString := Copy(sData, 1, loop - 1);
sData := Copy(sData, loop + 1, Length(sData));
if subString = sLookfor then
begin
Result := 1;
break;
end;
loop := pos(ListChar, sData);
end;
if sLookfor = sData then
Result := 1;
end;
{ TExpressionWord }
function TExprWord.AsPointer: PDouble;
begin
Result := nil;
end;
constructor TExprWord.Create(AName: string; ADoubleFunc: TDoubleFunc);
begin
FName := LowerCase(AName);
FDoubleFunc := ADoubleFunc;
end;
function TExprWord.GetAsString: string;
begin
Result := '';
end;
function TExprWord.GetCanVary: boolean;
begin
Result := False;
end;
function TExprWord.GetDescription: string;
begin
Result := '';
end;
function TExprWord.GetIsOper: boolean;
begin
Result := False;
end;
function TExprWord.GetIsVariable: boolean;
begin
Result := @FDoubleFunc = @_Variable
end;
function TExprWord.GetNFunctionArg: Integer;
begin
Result := 0;
end;
function TExprWord.GetVarType: TVarType;
begin
Result := vtDouble;
end;
{ TDoubleConstant }
function TDoubleConstant.AsPointer: PDouble;
begin
Result := @FValue;
end;
constructor TDoubleConstant.Create(AName, AValue: string);
begin
inherited Create(AName, _Variable);
if AValue <> '' then
FValue := StrToFloat(AValue)
else
FValue := Nan;
end;
constructor TDoubleConstant.CreateAsDouble(AName: string; AValue: Double);
begin
inherited Create(AName, _Variable);
FValue := AValue;
end;
{ TStringConstant }
function TStringConstant.GetAsString: string;
begin
Result := FValue;
end;
constructor TStringConstant.Create(AValue: string);
begin
inherited Create(AValue, _Variable);
if (AValue[1] = '''') and (AValue[Length(AValue)] = '''') then
FValue := Copy(AValue, 2, Length(AValue) - 2)
else
FValue := AValue;
end;
function TStringConstant.GetVarType: TVarType;
begin
Result := vtString;
end;
{ TDoubleVariable }
function TDoubleVariable.AsPointer: PDouble;
begin
Result := FValue;
end;
constructor TDoubleVariable.Create(AName: string; AValue: PDouble);
begin
inherited Create(AName, _Variable);
FValue := AValue;
end;
function TDoubleVariable.GetCanVary: boolean;
begin
Result := True;
end;
{ TFunction }
constructor TFunction.Create(AName, Descr: string; ADoubleFunc: TDoubleFunc;
ANFunctionArg: Integer);
begin
FDescription := Descr;
CreateOper(AName, ADoubleFunc, ANFunctionArg, False, 0);
// to increase compatibility don't use default parameters
end;
constructor TFunction.CreateOper(AName: string; ADoubleFunc: TDoubleFunc;
ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer);
begin
inherited Create(AName, ADoubleFunc);
FNFunctionArg := ANFunctionArg;
if FNFunctionArg > MaxArg then
raise EParserException.Create('Too many arguments');
FIsOper := AIsOper;
FOperPrec := AOperPrec;
end;
function TFunction.GetDescription: string;
begin
Result := FDescription;
end;
function TFunction.GetIsOper: boolean;
begin
Result := FIsOper;
end;
function TFunction.GetNFunctionArg: Integer;
begin
Result := FNFunctionArg;
end;
{ TLeftBracket }
function TLeftBracket.GetVarType: TVarType;
begin
Result := vtLeftBracket;
end;
{ TExpressList }
function TExpressList.Compare(Key1, Key2: Pointer): Integer;
begin
Result := StrIComp(Pchar(Key1), Pchar(Key2));
end;
function TExpressList.KeyOf(Item: Pointer): Pointer;
begin
Result := Pchar(TExprWord(Item).Name);
end;
{ TRightBracket }
function TRightBracket.GetVarType: TVarType;
begin
Result := vtRightBracket;
end;
{ TComma }
function TComma.GetVarType: TVarType;
begin
Result := vtComma;
end;
{ TExprCollection }
procedure TExprCollection.Check;
var
brCount, I: Integer;
begin
brCount := 0;
for I := 0 to Count - 1 do
begin
case TExprWord(Items[I]).VarType of
vtLeftBracket:
Inc(brCount);
vtRightBracket:
Dec(brCount);
end;
end;
if brCount <> 0 then
raise EParserException.Create('Unequal brackets');
end;
procedure TExprCollection.EraseExtraBrackets;
var
I: Integer;
brCount: Integer;
begin
if (TExprWord(Items[0]).VarType = vtLeftBracket) then
begin
brCount := 1;
I := 1;
while (I < Count) and (brCount > 0) do
begin
case TExprWord(Items[I]).VarType of
vtLeftBracket:
Inc(brCount);
vtRightBracket:
Dec(brCount);
end;
Inc(I);
end;
if (brCount = 0) and (I = Count) and
(TExprWord(Items[I - 1]).VarType = vtRightBracket) then
begin
for I := 0 to Count - 3 do
Items[I] := Items[I + 1];
Count := Count - 2;
EraseExtraBrackets; // Check if there are still too many brackets
end;
end;
end;
function TExprCollection.NextOper(IStart: Integer): Integer;
var
brCount: Integer;
begin
brCount := 0;
Result := IStart;
while (Result < Count) and
((brCount > 0) or (TExprWord(Items[Result]).NFunctionArg <= 0)) do
begin
case TExprWord(Items[Result]).VarType of
vtLeftBracket:
Inc(brCount);
vtRightBracket:
Dec(brCount);
end;
Inc(Result);
end;
end;
{ TStringVariable }
function TStringVariable.GetAsString: string;
begin
if (FValue^[1] = '''') and (FValue^[Length(FValue^)] = '''') then
Result := Copy(FValue^, 2, Length(FValue^) - 2)
else
Result := FValue^
end;
constructor TStringVariable.Create(AName: string; AValue: PString);
begin
inherited Create(AName, _Variable);
FValue := AValue;
end;
function TStringVariable.GetVarType: TVarType;
begin
Result := vtString;
end;
function TStringVariable.GetCanVary: boolean;
begin
Result := True;
end;
{ TLogicalStringOper }
constructor TLogicalStringOper.Create(AOper: string;
ALeftArg, ARightArg: TExprWord);
begin
if AOper = '=' then
FStringFunc := @_StrEq
else if AOper = '>' then
FStringFunc := @_StrGt
else if AOper = '<' then
FStringFunc := @_Strlt
else if AOper = '>=' then
FStringFunc := @_StrGe
else if AOper = '<=' then
FStringFunc := @_Strle
else if AOper = '<>' then
FStringFunc := @_Strne
else if AOper = 'in' then
FStringFunc := @_StrIn
else
raise EParserException.Create(AOper + ' is not a valid string operand');
inherited Create(AOper, '', StringFunc, ALeftArg, ARightArg);
end;
function TLogicalStringOper.GetVarType: TVarType;
begin
Result := vtBoolean;
end;
{ TBooleanFunction }
function TBooleanFunction.GetVarType: TVarType;
begin
Result := vtBoolean;
end;
{ TGeneratedVariable }
constructor TGeneratedVariable.Create(AName: string);
begin
inherited Create(AName, '');
FAsString := '';
FVarType := vtDouble;
end;
function TGeneratedVariable.GetAsString: string;
begin
Result := FAsString;
end;
function TGeneratedVariable.GetCanVary: boolean;
begin
Result := True;
end;
function TGeneratedVariable.GetVarType: TVarType;
begin
Result := FVarType;
end;
{ TVaryingFunction }
function TVaryingFunction.GetCanVary: boolean;
begin
Result := True;
end;
{ TBooleanConstant }
function TBooleanConstant.GetVarType: TVarType;
begin
Result := vtBoolean;
end;
{ TConstant }
constructor TConstant.CreateAsDouble(AName, Descr: string; AValue: Double);
begin
FDescription := Descr;
inherited CreateAsDouble(AName, AValue);
end;
function TConstant.GetDescription: string;
begin
Result := FDescription;
end;
{ TSimpleStringFunction }
constructor TSimpleStringFunction.Create(AName, Descr: string;
AStringFunc: TStringFunc; ALeftArg, ARightArg: TExprWord);
begin
FStringFunc := @AStringFunc;
FLeftArg := ALeftArg;
FRightArg := ARightArg;
inherited Create(AName, Descr, _StringFunc, 0)
end;
function TSimpleStringFunction.Evaluate: Double;
var
s1, s2: string;
begin
s1 := FLeftArg.AsString;
if FRightArg <> nil then
s2 := FRightArg.AsString
else
s2 := '';
Result := StringFunc(s1, s2);
end;
function TSimpleStringFunction.GetCanVary: boolean;
begin
Result := ((FLeftArg <> nil) and FLeftArg.CanVary) or
((FRightArg <> nil) and FRightArg.CanVary);
end;
{ TVaryingStringFunction }
function TVaryingStringFunction.GetCanVary: boolean;
begin
Result := True;
end;
end.

719
contrib/ParseExpression/__history/ParseClass.pas.~2~
View File

@@ -1,719 +0,0 @@
unit ParseClass;
interface
uses OObjects, SysUtils;
const
MaxArg = 1000;
const
Nan: Double = 0 / 0;
function isNan(const d: Double): boolean;
type
TVarType = (vtDouble, vtBoolean, vtString, vtLeftBracket,
vtRightBracket, vtComma);
PDouble = ^Double;
EParserException = class(Exception);
PExpressionRec = ^TExpressionRec;
TExprWord = class;
TArgsArray = record
Res: Double;
Args: array [0 .. MaxArg - 1] of PDouble;
ExprWord: TExprWord; // can be used to notify the object to update
end;
TDoubleFunc = procedure(Expr: PExpressionRec);
TStringFunc = function(s1, s2: string): Double;
TExpressionRec = record
// used both as linked tree and linked list for maximum evaluation efficiency
Oper: TDoubleFunc;
Next: PExpressionRec;
Res: Double;
ExprWord: TExprWord;
case Byte of
0:
(Args: array [0 .. MaxArg - 1] of PDouble;
// can be used to notify the object to update
);
1:
(ArgList: array [0 .. MaxArg - 1] of PExpressionRec);
end;
TExprCollection = class(TNoOwnerCollection)
public
function NextOper(IStart: Integer): Integer;
procedure Check;
procedure EraseExtraBrackets;
end;
TExprWord = class
private
FName: string;
FDoubleFunc: TDoubleFunc;
protected
function GetIsOper: boolean; virtual;
function GetAsString: string; virtual;
function GetIsVariable: boolean;
function GetCanVary: boolean; virtual;
function GetVarType: TVarType; virtual;
function GetNFunctionArg: Integer; virtual;
function GetDescription: string; virtual;
public
constructor Create(AName: string; ADoubleFunc: TDoubleFunc);
function AsPointer: PDouble; virtual;
property AsString: string read GetAsString;
property DoubleFunc: TDoubleFunc read FDoubleFunc;
property IsOper: boolean read GetIsOper;
property CanVary: boolean read GetCanVary;
property isVariable: boolean read GetIsVariable;
property VarType: TVarType read GetVarType;
property NFunctionArg: Integer read GetNFunctionArg;
property Name: string read FName;
property Description: string read GetDescription;
end;
TExpressList = class(TSortedCollection)
public
function KeyOf(Item: Pointer): Pointer; override;
function Compare(Key1, Key2: Pointer): Integer; override;
end;
TDoubleConstant = class(TExprWord)
private
FValue: Double;
public
function AsPointer: PDouble; override;
constructor Create(AName: string; AValue: string);
constructor CreateAsDouble(AName: string; AValue: Double);
// not overloaded to support older Delphi versions
property Value: Double read FValue write FValue;
end;
TConstant = class(TDoubleConstant)
private
FDescription: string;
protected
function GetDescription: string; override;
public
constructor CreateAsDouble(AName, Descr: string; AValue: Double);
end;
TBooleanConstant = class(TDoubleConstant)
protected
function GetVarType: TVarType; override;
end;
TGeneratedVariable = class(TDoubleConstant)
private
FAsString: string;
FVarType: TVarType;
protected
function GetVarType: TVarType; override;
function GetAsString: string; override;
function GetCanVary: boolean; override;
public
constructor Create(AName: string);
property VarType read GetVarType write FVarType;
property AsString: string read GetAsString write FAsString;
end;
TDoubleVariable = class(TExprWord)
private
FValue: PDouble;
protected
function GetCanVary: boolean; override;
public
function AsPointer: PDouble; override;
constructor Create(AName: string; AValue: PDouble);
end;
TStringConstant = class(TExprWord)
private
FValue: string;
protected
function GetVarType: TVarType; override;
function GetAsString: string; override;
public
constructor Create(AValue: string);
end;
TLeftBracket = class(TExprWord)
function GetVarType: TVarType; override;
end;
TRightBracket = class(TExprWord)
protected
function GetVarType: TVarType; override;
end;
TComma = class(TExprWord)
protected
function GetVarType: TVarType; override;
end;
PString = ^string;
TStringVariable = class(TExprWord)
private
FValue: PString;
protected
function GetVarType: TVarType; override;
function GetAsString: string; override;
function GetCanVary: boolean; override;
public
constructor Create(AName: string; AValue: PString);
end;
TFunction = class(TExprWord)
private
FIsOper: boolean;
FOperPrec: Integer;
FNFunctionArg: Integer;
FDescription: string;
protected
function GetDescription: string; override;
function GetIsOper: boolean; override;
function GetNFunctionArg: Integer; override;
public
constructor Create(AName, Descr: string; ADoubleFunc: TDoubleFunc;
ANFunctionArg: Integer);
constructor CreateOper(AName: string; ADoubleFunc: TDoubleFunc;
ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer);
property OperPrec: Integer read FOperPrec;
end;
TVaryingFunction = class(TFunction)
// Functions that can vary for ex. random generators
// should be TVaryingFunction to be sure that they are
// always evaluated
protected
function GetCanVary: boolean; override;
end;
TBooleanFunction = class(TFunction)
protected
function GetVarType: TVarType; override;
end;
TOper = (op_eq, op_gt, op_lt, op_ge, op_le, op_in);
const
ListChar = ','; { the delimiter used with the 'in' operator: e.g.,
('a' in 'a,b') =True
('c' in 'a,b') =False }
type
TSimpleStringFunction = class(TFunction)
private
FStringFunc: TStringFunc;
FLeftArg: TExprWord;
FRightArg: TExprWord;
protected
function GetCanVary: boolean; override;
public
constructor Create(AName, Descr: string; AStringFunc: TStringFunc;
ALeftArg, ARightArg: TExprWord);
function Evaluate: Double;
property StringFunc: TStringFunc read FStringFunc;
end;
TVaryingStringFunction = class(TSimpleStringFunction)
protected
function GetCanVary: boolean; override;
end;
TLogicalStringOper = class(TSimpleStringFunction)
protected
function GetVarType: TVarType; override;
public
constructor Create(AOper: string; ALeftArg: TExprWord;
ARightArg: TExprWord);
end;
procedure _Variable(Param: PExpressionRec);
// procedure _StringFunc(Param: PExpressionRec);
implementation
// function _StrIn(sLookfor, sData: string): Double;
// function _StrInt(a, b: string): Double;
function isNan(const d: Double): boolean;
begin
Result := comp(d) = comp(Nan);
// slower alternative: CompareMem(@d, @Nan, SizeOf(Double))
end;
procedure _Variable(Param: PExpressionRec);
begin
with Param^ do
Res := Args[0]^;
end;
procedure _StringFunc(Param: PExpressionRec);
begin
with Param^ do
Res := TSimpleStringFunction(ExprWord).Evaluate;
end;
function _StrInt(a, b: string): Double;
begin
Result := StrToInt(a);
end;
function _StrEq(s1, s2: string): Double;
begin
Result := Byte(s1 = s2);
end;
function _StrGt(s1, s2: string): Double;
begin
Result := Byte(s1 > s2);
end;
function _Strlt(s1, s2: string): Double;
begin
Result := Byte(s1 < s2);
end;
function _StrGe(s1, s2: string): Double;
begin
Result := Byte(s1 >= s2);
end;
function _Strle(s1, s2: string): Double;
begin
Result := Byte(s1 <= s2);
end;
function _Strne(s1, s2: string): Double;
begin
Result := Byte(s1 <> s2);
end;
function _StrIn(sLookfor, sData: string): Double;
var
loop: Integer;
subString: string;
begin
Result := 0;
loop := pos(ListChar, sData);
while loop > 0 do
begin
subString := Copy(sData, 1, loop - 1);
sData := Copy(sData, loop + 1, Length(sData));
if subString = sLookfor then
begin
Result := 1;
break;
end;
loop := pos(ListChar, sData);
end;
if sLookfor = sData then
Result := 1;
end;
{ TExpressionWord }
function TExprWord.AsPointer: PDouble;
begin
Result := nil;
end;
constructor TExprWord.Create(AName: string; ADoubleFunc: TDoubleFunc);
begin
FName := LowerCase(AName);
FDoubleFunc := ADoubleFunc;
end;
function TExprWord.GetAsString: string;
begin
Result := '';
end;
function TExprWord.GetCanVary: boolean;
begin
Result := False;
end;
function TExprWord.GetDescription: string;
begin
Result := '';
end;
function TExprWord.GetIsOper: boolean;
begin
Result := False;
end;
function TExprWord.GetIsVariable: boolean;
begin
Result := @FDoubleFunc = @_Variable
end;
function TExprWord.GetNFunctionArg: Integer;
begin
Result := 0;
end;
function TExprWord.GetVarType: TVarType;
begin
Result := vtDouble;
end;
{ TDoubleConstant }
function TDoubleConstant.AsPointer: PDouble;
begin
Result := @FValue;
end;
constructor TDoubleConstant.Create(AName, AValue: string);
begin
inherited Create(AName, _Variable);
if AValue <> '' then
FValue := StrToFloat(AValue)
else
FValue := Nan;
end;
constructor TDoubleConstant.CreateAsDouble(AName: string; AValue: Double);
begin
inherited Create(AName, _Variable);
FValue := AValue;
end;
{ TStringConstant }
function TStringConstant.GetAsString: string;
begin
Result := FValue;
end;
constructor TStringConstant.Create(AValue: string);
begin
inherited Create(AValue, _Variable);
if (AValue[1] = '''') and (AValue[Length(AValue)] = '''') then
FValue := Copy(AValue, 2, Length(AValue) - 2)
else
FValue := AValue;
end;
function TStringConstant.GetVarType: TVarType;
begin
Result := vtString;
end;
{ TDoubleVariable }
function TDoubleVariable.AsPointer: PDouble;
begin
Result := FValue;
end;
constructor TDoubleVariable.Create(AName: string; AValue: PDouble);
begin
inherited Create(AName, _Variable);
FValue := AValue;
end;
function TDoubleVariable.GetCanVary: boolean;
begin
Result := True;
end;
{ TFunction }
constructor TFunction.Create(AName, Descr: string; ADoubleFunc: TDoubleFunc;
ANFunctionArg: Integer);
begin
FDescription := Descr;
CreateOper(AName, ADoubleFunc, ANFunctionArg, False, 0);
// to increase compatibility don't use default parameters
end;
constructor TFunction.CreateOper(AName: string; ADoubleFunc: TDoubleFunc;
ANFunctionArg: Integer; AIsOper: boolean; AOperPrec: Integer);
begin
inherited Create(AName, ADoubleFunc);
FNFunctionArg := ANFunctionArg;
if FNFunctionArg > MaxArg then
raise EParserException.Create('Too many arguments');
FIsOper := AIsOper;
FOperPrec := AOperPrec;
end;
function TFunction.GetDescription: string;
begin
Result := FDescription;
end;
function TFunction.GetIsOper: boolean;
begin
Result := FIsOper;
end;
function TFunction.GetNFunctionArg: Integer;
begin
Result := FNFunctionArg;
end;
{ TLeftBracket }
function TLeftBracket.GetVarType: TVarType;
begin
Result := vtLeftBracket;
end;
{ TExpressList }
function TExpressList.Compare(Key1, Key2: Pointer): Integer;
begin
Result := StrIComp(Pchar(Key1), Pchar(Key2));
end;
function TExpressList.KeyOf(Item: Pointer): Pointer;
begin
Result := Pchar(TExprWord(Item).Name);
end;
{ TRightBracket }
function TRightBracket.GetVarType: TVarType;
begin
Result := vtRightBracket;
end;
{ TComma }
function TComma.GetVarType: TVarType;
begin
Result := vtComma;
end;
{ TExprCollection }
procedure TExprCollection.Check;
var
brCount, I: Integer;
begin
brCount := 0;
for I := 0 to Count - 1 do
begin
case TExprWord(Items[I]).VarType of
vtLeftBracket:
Inc(brCount);
vtRightBracket:
Dec(brCount);
end;
end;
if brCount <> 0 then
raise EParserException.Create('Unequal brackets');
end;
procedure TExprCollection.EraseExtraBrackets;
var
I: Integer;
brCount: Integer;
begin
if (TExprWord(Items[0]).VarType = vtLeftBracket) then
begin
brCount := 1;
I := 1;
while (I < Count) and (brCount > 0) do
begin
case TExprWord(Items[I]).VarType of
vtLeftBracket:
Inc(brCount);
vtRightBracket:
Dec(brCount);
end;
Inc(I);
end;
if (brCount = 0) and (I = Count) and
(TExprWord(Items[I - 1]).VarType = vtRightBracket) then
begin
for I := 0 to Count - 3 do
Items[I] := Items[I + 1];
Count := Count - 2;
EraseExtraBrackets; // Check if there are still too many brackets
end;
end;
end;
function TExprCollection.NextOper(IStart: Integer): Integer;
var
brCount: Integer;
begin
brCount := 0;
Result := IStart;
while (Result < Count) and
((brCount > 0) or (TExprWord(Items[Result]).NFunctionArg <= 0)) do
begin
case TExprWord(Items[Result]).VarType of
vtLeftBracket:
Inc(brCount);
vtRightBracket:
Dec(brCount);
end;
Inc(Result);
end;
end;
{ TStringVariable }
function TStringVariable.GetAsString: string;
begin
if (FValue^[1] = '''') and (FValue^[Length(FValue^)] = '''') then
Result := Copy(FValue^, 2, Length(FValue^) - 2)
else
Result := FValue^
end;
constructor TStringVariable.Create(AName: string; AValue: PString);
begin
inherited Create(AName, _Variable);
FValue := AValue;
end;
function TStringVariable.GetVarType: TVarType;
begin
Result := vtString;
end;
function TStringVariable.GetCanVary: boolean;
begin
Result := True;
end;
{ TLogicalStringOper }
constructor TLogicalStringOper.Create(AOper: string;
ALeftArg, ARightArg: TExprWord);
begin
if AOper = '=' then
FStringFunc := @_StrEq
else if AOper = '>' then
FStringFunc := @_StrGt
else if AOper = '<' then
FStringFunc := @_Strlt
else if AOper = '>=' then
FStringFunc := @_StrGe
else if AOper = '<=' then
FStringFunc := @_Strle
else if AOper = '<>' then
FStringFunc := @_Strne
else if AOper = 'in' then
FStringFunc := @_StrIn
else
raise EParserException.Create(AOper + ' is not a valid string operand');
inherited Create(AOper, '', StringFunc, ALeftArg, ARightArg);
end;
function TLogicalStringOper.GetVarType: TVarType;
begin
Result := vtBoolean;
end;
{ TBooleanFunction }
function TBooleanFunction.GetVarType: TVarType;
begin
Result := vtBoolean;
end;
{ TGeneratedVariable }
constructor TGeneratedVariable.Create(AName: string);
begin
inherited Create(AName, '');
FAsString := '';
FVarType := vtDouble;
end;
function TGeneratedVariable.GetAsString: string;
begin
Result := FAsString;
end;
function TGeneratedVariable.GetCanVary: boolean;
begin
Result := True;
end;
function TGeneratedVariable.GetVarType: TVarType;
begin
Result := FVarType;
end;
{ TVaryingFunction }
function TVaryingFunction.GetCanVary: boolean;
begin
Result := True;
end;
{ TBooleanConstant }
function TBooleanConstant.GetVarType: TVarType;
begin
Result := vtBoolean;
end;
{ TConstant }
constructor TConstant.CreateAsDouble(AName, Descr: string; AValue: Double);
begin
FDescription := Descr;
inherited CreateAsDouble(AName, AValue);
end;
function TConstant.GetDescription: string;
begin
Result := FDescription;
end;
{ TSimpleStringFunction }
constructor TSimpleStringFunction.Create(AName, Descr: string;
AStringFunc: TStringFunc; ALeftArg, ARightArg: TExprWord);
begin
FStringFunc := @AStringFunc;
FLeftArg := ALeftArg;
FRightArg := ARightArg;
inherited Create(AName, Descr, _StringFunc, 0)
end;
function TSimpleStringFunction.Evaluate: Double;
var
s1, s2: string;
begin
s1 := FLeftArg.AsString;
if FRightArg <> nil then
s2 := FRightArg.AsString
else
s2 := '';
Result := StringFunc(s1, s2);
end;
function TSimpleStringFunction.GetCanVary: boolean;
begin
Result := ((FLeftArg <> nil) and FLeftArg.CanVary) or
((FRightArg <> nil) and FRightArg.CanVary);
end;
{ TVaryingStringFunction }
function TVaryingStringFunction.GetCanVary: boolean;
begin
Result := True;
end;
end.

1912
contrib/ParseExpression/__history/ParseExpr.pas.~10~
View File

File diff suppressed because it is too large Load Diff

1914
contrib/ParseExpression/__history/ParseExpr.pas.~11~
View File

File diff suppressed because it is too large Load Diff

1913
contrib/ParseExpression/__history/ParseExpr.pas.~12~
View File

File diff suppressed because it is too large Load Diff

1921
contrib/ParseExpression/__history/ParseExpr.pas.~13~
View File

File diff suppressed because it is too large Load Diff

1920
contrib/ParseExpression/__history/ParseExpr.pas.~14~
View File

File diff suppressed because it is too large Load Diff

1920
contrib/ParseExpression/__history/ParseExpr.pas.~15~
View File

File diff suppressed because it is too large Load Diff

1920
contrib/ParseExpression/__history/ParseExpr.pas.~16~
View File

File diff suppressed because it is too large Load Diff

1919
contrib/ParseExpression/__history/ParseExpr.pas.~17~
View File

File diff suppressed because it is too large Load Diff

1912
contrib/ParseExpression/__history/ParseExpr.pas.~8~
View File

File diff suppressed because it is too large Load Diff

1912
contrib/ParseExpression/__history/ParseExpr.pas.~9~
View File

File diff suppressed because it is too large Load Diff

203
contrib/ParseExpression/__history/oObjects.pas.~1~
View File

@@ -1,203 +0,0 @@
unit OObjects;
interface
uses Classes;
const
{ TOCollection interfaces between OWL TCollection and VCL TList }
MaxCollectionSize = Maxint div (SizeOf(Integer) * 2);
type
TOCollection = class(TList)
public
constructor Create(ACapacity: Integer);
procedure AtFree(Index: Integer);
procedure FreeAll;
procedure DoFree(Item: Pointer);
procedure FreeItem(Item: Pointer); virtual;
destructor Destroy; override;
end;
TNoOwnerCollection = class(TOCollection)
public
procedure FreeItem(Item: Pointer); override;
end;
{ TSortedCollection object }
TSortedCollection = class(TOCollection)
public
Duplicates: Boolean;
constructor Create(ACapacity: Integer);
function Compare(Key1, Key2: Pointer): Integer; virtual; abstract;
function IndexOf(Item: Pointer): Integer; virtual;
procedure Add(Item: Pointer); virtual;
procedure AddReplace(Item: Pointer); virtual;
{ if duplicate then replace the duplicate else add }
function KeyOf(Item: Pointer): Pointer; virtual;
function Search(Key: Pointer; var Index: Integer): Boolean; virtual;
end;
{ TStrCollection object }
TStrCollection = class(TSortedCollection)
public
function Compare(Key1, Key2: Pointer): Integer; override;
procedure FreeItem(Item: Pointer); override;
end;
implementation
uses SysUtils;
constructor TOCollection.Create(ACapacity: Integer);
begin
inherited Create;
SetCapacity(ACapacity);
{ Delta is automatic in TList }
end;
destructor TOCollection.Destroy;
begin
FreeAll;
inherited Destroy;
end;
procedure TOCollection.AtFree(Index: Integer);
var
Item: Pointer;
begin
Item := Items[Index];
Delete(Index);
FreeItem(Item);
end;
procedure TOCollection.FreeAll;
var
I: Integer;
begin
try
for I := 0 to Count - 1 do
FreeItem(Items[I]);
finally
Count := 0;
end;
end;
procedure TOCollection.DoFree(Item: Pointer);
begin
AtFree(IndexOf(Item));
end;
procedure TOCollection.FreeItem(Item: Pointer);
begin
if (Item <> nil) then
with TObject(Item) as TObject do
Free;
end;
{ ----------------------------------------------------------------virtual;
Implementing TNoOwnerCollection
----------------------------------------------------------------- }
procedure TNoOwnerCollection.FreeItem(Item: Pointer);
begin
end;
{ TSortedCollection }
{$IFDEF maxComp}
constructor TSortedCollection.Create(ACapacity, ADelta: Integer);
begin
inherited Create(ACapacity, ADelta);
Duplicates := False;
end;
{$ELSE}
constructor TSortedCollection.Create(ACapacity: Integer);
begin
inherited Create(ACapacity);
Duplicates := False;
end;
{$ENDIF}
function TSortedCollection.IndexOf(Item: Pointer): Integer;
var
I: Integer;
begin
IndexOf := -1;
if Search(KeyOf(Item), I) then
begin
if Duplicates then
while (I < Count) and (Item <> Items[I]) do
Inc(I);
if I < Count then
IndexOf := I;
end;
end;
procedure TSortedCollection.AddReplace(Item: Pointer);
var
Index: Integer;
begin
if Search(KeyOf(Item), Index) then
Delete(Index);
Add(Item);
end;
procedure TSortedCollection.Add(Item: Pointer);
var
I: Integer;
begin
if not Search(KeyOf(Item), I) or Duplicates then
Insert(I, Item);
end;
function TSortedCollection.KeyOf(Item: Pointer): Pointer;
begin
KeyOf := Item;
end;
function TSortedCollection.Search(Key: Pointer; var Index: Integer): Boolean;
var
L, H, I, C: Integer;
begin
Search := False;
L := 0;
H := Count - 1;
while L <= H do
begin
I := (L + H) shr 1;
C := Compare(KeyOf(Items[I]), Key);
if C < 0 then
L := I + 1
else
begin
H := I - 1;
if C = 0 then
begin
Search := True;
if not Duplicates then
L := I;
end;
end;
end;
Index := L;
end;
{ TStrCollection }
function TStrCollection.Compare(Key1, Key2: Pointer): Integer;
begin
Compare := StrComp(PAnsiChar(Key1), PAnsiChar(Key2));
end;
procedure TStrCollection.FreeItem(Item: Pointer);
begin
StrDispose(PAnsiChar(Item));
end;
end.