Added transform syncronization, an animation module and made the app work faster
This commit is contained in:
Alice Vital
@ -3,15 +3,9 @@ unit CurvesControl;
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Messages, SysUtils, Variants, Classes, Math, ControlPoint,
|
||||
Windows, SysUtils, Classes, Math, ControlPoint,
|
||||
Graphics, Controls, Forms, Bezier, CustomDrawControl, Vcl.ExtCtrls;
|
||||
|
||||
const
|
||||
point_size: double = 8;
|
||||
accurancy: double = 3;
|
||||
channel_count: integer = 4;
|
||||
padding = 3;
|
||||
|
||||
const
|
||||
MAX_CHANNEL = 3;
|
||||
|
||||
@ -73,6 +67,9 @@ implementation
|
||||
|
||||
uses Main, Editor, Mutate, Adjust;
|
||||
|
||||
const
|
||||
point_size: double = 8;
|
||||
|
||||
constructor TCurvesControl.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
@ -94,6 +91,7 @@ begin
|
||||
|
||||
FrameCreate;
|
||||
end;
|
||||
|
||||
destructor TCurvesControl.Destroy;
|
||||
begin
|
||||
FCP.Destroy;
|
||||
@ -101,7 +99,7 @@ begin
|
||||
end;
|
||||
|
||||
procedure TCurvesControl.SetCp(cp: TControlPoint);
|
||||
var i, j: integer;
|
||||
var i, j: smallint;
|
||||
begin
|
||||
FCP.Copy(cp, true);
|
||||
for i := 0 to 3 do
|
||||
@ -113,6 +111,7 @@ begin
|
||||
Invalidate;
|
||||
FFrame.Invalidate;
|
||||
end;
|
||||
|
||||
procedure TCurvesControl.UpdateFlame;
|
||||
begin
|
||||
MainForm.StopThread;
|
||||
@ -130,6 +129,7 @@ procedure TCurvesControl.FrameMouseLeave(Sender: TObject);
|
||||
begin
|
||||
FrameMouseUp(nil, mbLeft, [], 0, 0);
|
||||
end;
|
||||
|
||||
procedure TCurvesControl.FrameMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
||||
var
|
||||
ps_half: double;
|
||||
@ -152,12 +152,12 @@ begin
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCurvesControl.FrameMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
|
||||
var
|
||||
m: BezierPoints;
|
||||
tmp: BezierPoint;
|
||||
i: Integer;
|
||||
j: Integer;
|
||||
i, j: shortint;
|
||||
begin
|
||||
|
||||
if (y < 0) then Exit;
|
||||
@ -194,10 +194,10 @@ begin
|
||||
FCP.curvePoints[i,j].y := FPoints[i,j].y;
|
||||
end;
|
||||
|
||||
|
||||
FFrame.Refresh;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCurvesControl.FrameMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
||||
begin
|
||||
FDragIndex := -1;
|
||||
@ -207,9 +207,9 @@ begin
|
||||
end;
|
||||
|
||||
procedure TCurvesControl.FrameCreate;
|
||||
var i: integer;
|
||||
var i: shortint;
|
||||
begin
|
||||
for i := 0 to channel_count - 1 do
|
||||
for i := 0 to MAX_CHANNEL do
|
||||
begin
|
||||
FPoints[i][0].x := 0.00; FPoints[i][0].y := 0.00; FWeights[i][0] := 1;
|
||||
FPoints[i][1].x := 0.00; FPoints[i][1].y := 0.00; FWeights[i][1] := 1;
|
||||
@ -220,12 +220,14 @@ begin
|
||||
FDragIndex := -1;
|
||||
FDragging := false;
|
||||
end;
|
||||
|
||||
procedure TCurvesControl.FrameResize(Sender: TObject);
|
||||
begin
|
||||
FRect.x0 := 0; FRect.y0 := 0;
|
||||
FRect.x1 := self.Width - 1;
|
||||
FRect.y1 := self.Height - 1;
|
||||
end;
|
||||
|
||||
procedure TCurvesControl.FramePaint(Sender: TObject);
|
||||
var
|
||||
clientRect: TRect;
|
||||
@ -261,7 +263,7 @@ begin
|
||||
LineTo(Round(FRect.x1), Round(0.25 * y * FRect.y1));
|
||||
end;
|
||||
|
||||
for i := 0 to channel_count - 1 do begin
|
||||
for i := 0 to MAX_CHANNEL do begin
|
||||
for j := 0 to 3 do
|
||||
wsum[i] := wsum[i] + FWeights[i][j];
|
||||
for j := 0 to 3 do
|
||||
@ -282,9 +284,11 @@ begin
|
||||
end;
|
||||
|
||||
procedure TCurvesControl.PaintCurve(Bitmap: TBitmap; c: integer; p: BezierPoints; w: BezierWeights; widgets: boolean);
|
||||
const
|
||||
step = 0.001; // AV
|
||||
var
|
||||
pos0, pos1: BezierPoint;
|
||||
t, step: Double;
|
||||
t: Double;
|
||||
r, g, b: array [0 .. MAX_CHANNEL] of integer;
|
||||
rgbv: integer;
|
||||
begin
|
||||
@ -303,7 +307,6 @@ begin
|
||||
rgbv := RGB(r[c], g[c], b[c]);
|
||||
|
||||
t := 0;
|
||||
step := 0.001;
|
||||
|
||||
BezierSolve(0, p, w, pos1);
|
||||
pos0.x := 0; pos0.y := pos1.y;
|
||||
@ -332,18 +335,19 @@ begin
|
||||
LineTo(Round(FRect.x1), Round(pos0.y));
|
||||
|
||||
if widgets then begin
|
||||
t := point_size / 2.0; // AV
|
||||
Brush.Color := rgbv;
|
||||
Ellipse(
|
||||
Round(p[1].x - point_size / 2.0),
|
||||
Round(p[1].y - point_size / 2.0),
|
||||
Round(p[1].x + point_size / 2.0),
|
||||
Round(p[1].y + point_size / 2.0)
|
||||
Round(p[1].x - t),
|
||||
Round(p[1].y - t),
|
||||
Round(p[1].x + t),
|
||||
Round(p[1].y + t)
|
||||
);
|
||||
Ellipse(
|
||||
Round(p[2].x - point_size / 2.0),
|
||||
Round(p[2].y - point_size / 2.0),
|
||||
Round(p[2].x + point_size / 2.0),
|
||||
Round(p[2].y + point_size / 2.0)
|
||||
Round(p[2].x - t),
|
||||
Round(p[2].y - t),
|
||||
Round(p[2].x + t),
|
||||
Round(p[2].y + t)
|
||||
);
|
||||
end;
|
||||
end;
|
||||
@ -355,12 +359,14 @@ begin
|
||||
FChannelIndex := Integer(value);
|
||||
FFrame.Refresh;
|
||||
end;
|
||||
|
||||
procedure TCurvesControl.SetWeightLeft(value: double);
|
||||
begin
|
||||
FWeights[FChannelIndex][1] := value;
|
||||
FCP.curveWeights[FChannelIndex][1] := value;
|
||||
FFrame.Refresh;
|
||||
end;
|
||||
|
||||
procedure TCurvesControl.SetWeightRight(value: double);
|
||||
begin
|
||||
FWeights[FChannelIndex][2] := value;
|
||||
@ -372,10 +378,12 @@ function TCurvesControl.GetChannel: TCurvesChannel;
|
||||
begin
|
||||
Result := FActiveChannel;
|
||||
end;
|
||||
|
||||
function TCurvesControl.GetWeightLeft: double;
|
||||
begin
|
||||
Result := FWeights[FChannelIndex][1];
|
||||
end;
|
||||
|
||||
function TCurvesControl.GetWeightRight: double;
|
||||
begin
|
||||
Result := FWeights[FChannelIndex][2];
|
||||
|
||||
@ -5,6 +5,7 @@
|
||||
|
||||
Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov
|
||||
Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne
|
||||
Apophysis AV "Phoenix Edition" Copyright (C) 2021-2022 Alice V. Koryagina
|
||||
|
||||
This program is free software; you can redistribute it and/or modify
|
||||
it under the terms of the GNU General Public License as published by
|
||||
|
||||
337
System/MathExpressions.pas
Normal file
337
System/MathExpressions.pas
Normal file
@ -0,0 +1,337 @@
|
||||
{ Apophysis AV "Phoenix Edition" Copyright (C) 2021-2022 Alice V. Koryagina }
|
||||
|
||||
unit MathExpressions;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
System.Rtti, System.SysUtils, System.Bindings.EvalProtocol,
|
||||
System.Bindings.Evaluator, System.Bindings.EvalSys, System.Bindings.Methods;
|
||||
|
||||
function CalculateExpression(const Expr: string): string;
|
||||
|
||||
var
|
||||
InDegrees: boolean;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
System.Math, Windows, Translation;
|
||||
|
||||
var
|
||||
LScope: IScope;
|
||||
|
||||
function Sine: IInvokable;
|
||||
begin
|
||||
Result := MakeInvokable(
|
||||
function(Args: TArray<IValue>): IValue
|
||||
var
|
||||
IAValue: IValue;
|
||||
ANum: Double;
|
||||
begin
|
||||
// AV: check the number of passed parameters
|
||||
if Length(Args) <> 1 then begin
|
||||
MessageBox(0, PChar(Format(TextByKey('formula-wrongargscount'),
|
||||
['Sin()', 1, Length(Args)])), 'Apophysis AV', 48);
|
||||
exit;
|
||||
end;
|
||||
|
||||
IAValue := Args[0];
|
||||
|
||||
try
|
||||
ANum := IAValue.GetValue.AsExtended; // AV: check the parameter type
|
||||
if InDegrees then // AV: translate the parameter into radians
|
||||
ANum := DegToRad(ANum);
|
||||
Exit(TValueWrapper.Create(RoundTo(sin(ANum), -6)));
|
||||
except
|
||||
MessageBox(0, PChar('Sin(): ' + TextByKey('formula-wrongdatatype')),
|
||||
'Apophysis AV', 16);
|
||||
end;
|
||||
end
|
||||
);
|
||||
end;
|
||||
|
||||
function CoSine: IInvokable;
|
||||
begin
|
||||
Result := MakeInvokable(
|
||||
function(Args: TArray<IValue>): IValue
|
||||
var
|
||||
IAValue: IValue;
|
||||
ANum: Double;
|
||||
begin
|
||||
// AV: check the number of passed parameters
|
||||
if Length(Args) <> 1 then begin
|
||||
MessageBox(0, PChar(Format(TextByKey('formula-wrongargscount'),
|
||||
['Cos()', 1, Length(Args)])), 'Apophysis AV', 48);
|
||||
exit;
|
||||
end;
|
||||
|
||||
IAValue := Args[0];
|
||||
|
||||
try
|
||||
ANum := IAValue.GetValue.AsExtended;
|
||||
if InDegrees then // AV: translate the parameter into radians
|
||||
ANum := DegToRad(ANum);
|
||||
Exit(TValueWrapper.Create(RoundTo(cos(ANum), -6)));
|
||||
except
|
||||
MessageBox(0, PChar('Cos(): ' + TextByKey('formula-wrongdatatype')),
|
||||
'Apophysis AV', 16);
|
||||
end;
|
||||
end
|
||||
);
|
||||
end;
|
||||
|
||||
function ArcSine: IInvokable;
|
||||
begin
|
||||
Result := MakeInvokable(
|
||||
function(Args: TArray<IValue>): IValue
|
||||
var
|
||||
IAValue: IValue;
|
||||
AValue: Double;
|
||||
begin
|
||||
// AV: check the number of passed parameters
|
||||
if Length(Args) <> 1 then begin
|
||||
MessageBox(0, PChar(Format(TextByKey('formula-wrongargscount'),
|
||||
['ArcSin()', 1, Length(Args)])), 'Apophysis AV', 48);
|
||||
exit;
|
||||
end;
|
||||
|
||||
IAValue := Args[0];
|
||||
|
||||
try
|
||||
AValue := IAValue.GetValue.AsExtended;
|
||||
if InRange(AValue, -1, 1) then
|
||||
begin
|
||||
AValue := arcsin(AValue);
|
||||
if InDegrees then
|
||||
AValue := RadToDeg(AValue);
|
||||
Exit(TValueWrapper.Create(RoundTo(AValue, -6)));
|
||||
end
|
||||
else
|
||||
MessageBox(0, PChar('ArcSin(): ' + TextByKey('formula-outofrange')),
|
||||
'Apophysis AV', 48);
|
||||
except
|
||||
MessageBox(0, PChar('ArcSin(): ' + TextByKey('formula-wrongdatatype')),
|
||||
'Apophysis AV', 16);
|
||||
end;
|
||||
end
|
||||
);
|
||||
end;
|
||||
|
||||
function ArcCoSine: IInvokable;
|
||||
begin
|
||||
Result := MakeInvokable(
|
||||
function(Args: TArray<IValue>): IValue
|
||||
var
|
||||
IAValue: IValue;
|
||||
AValue: Double;
|
||||
begin
|
||||
//AV: check the number of passed parameters
|
||||
if Length(Args) <> 1 then begin
|
||||
MessageBox(0, PChar(Format(TextByKey('formula-wrongargscount'),
|
||||
['ArcCos()', 1, Length(Args)])), 'Apophysis AV', 48);
|
||||
exit;
|
||||
end;
|
||||
|
||||
IAValue := Args[0];
|
||||
|
||||
try
|
||||
AValue := IAValue.GetValue.AsExtended;
|
||||
if InRange(AValue, -1, 1) then
|
||||
begin
|
||||
AValue := arccos(AValue);
|
||||
if InDegrees then
|
||||
AValue := RadToDeg(AValue);
|
||||
Exit(TValueWrapper.Create(RoundTo(AValue, -6)));
|
||||
end
|
||||
else
|
||||
MessageBox(0, PChar('ArcCos(): ' + TextByKey('formula-outofrange')),
|
||||
'Apophysis AV', 48);
|
||||
except
|
||||
MessageBox(0, PChar('ArcCos(): ' + TextByKey('formula-wrongdatatype')),
|
||||
'Apophysis AV', 16);
|
||||
end;
|
||||
end
|
||||
);
|
||||
end;
|
||||
|
||||
function ArcTangentYX: IInvokable;
|
||||
begin
|
||||
Result := MakeInvokable(
|
||||
function(Args: TArray<IValue>): IValue
|
||||
var
|
||||
IYValue, IXValue: IValue;
|
||||
AValue: Double;
|
||||
begin
|
||||
// AV: check the number of passed parameters
|
||||
if Length(Args) <> 2 then begin
|
||||
MessageBox(0, PChar(Format(TextByKey('formula-wrongargscount'),
|
||||
['ArcTan2()', 2, Length(Args)])), 'Apophysis AV', 48);
|
||||
exit;
|
||||
end;
|
||||
|
||||
IYValue := Args[0];
|
||||
IXValue := Args[1];
|
||||
|
||||
try
|
||||
AValue := arctan2(IYValue.GetValue.AsExtended,
|
||||
IXValue.GetValue.AsExtended);
|
||||
if InDegrees then
|
||||
AValue := RadToDeg(AValue);
|
||||
Exit(TValueWrapper.Create(RoundTo(AValue, -6)));
|
||||
except
|
||||
MessageBox(0, PChar('ArcTan2(): ' + TextByKey('common-invalidformat')),
|
||||
'Apophysis AV', 16);
|
||||
end;
|
||||
end
|
||||
);
|
||||
end;
|
||||
|
||||
function SquareRoot: IInvokable;
|
||||
begin
|
||||
Result := MakeInvokable(
|
||||
function(Args: TArray<IValue>): IValue
|
||||
var
|
||||
IAValue: IValue;
|
||||
ANum: Double;
|
||||
begin
|
||||
// AV: check the number of passed parameters
|
||||
if Length(Args) <> 1 then begin
|
||||
MessageBox(0, PChar(Format(TextByKey('formula-wrongargscount'),
|
||||
['Sqrt()', 1, Length(Args)])), 'Apophysis AV', 48);
|
||||
exit;
|
||||
end;
|
||||
|
||||
IAValue := Args[0];
|
||||
|
||||
try
|
||||
ANum := IAValue.GetValue.AsExtended;
|
||||
if ANum >= 0 then
|
||||
Exit(TValueWrapper.Create(RoundTo(sqrt(ANum), -6)))
|
||||
else
|
||||
MessageBox(0, PChar('Sqrt(): ' + TextByKey('formula-unsigned')),
|
||||
'Apophysis AV', 48);
|
||||
except
|
||||
MessageBox(0, PChar('Sqrt(): ' + TextByKey('formula-wrongdatatype')),
|
||||
'Apophysis AV', 16);
|
||||
end;
|
||||
end
|
||||
);
|
||||
end;
|
||||
|
||||
function NatLog: IInvokable;
|
||||
begin
|
||||
Result := MakeInvokable(
|
||||
function(Args: TArray<IValue>): IValue
|
||||
var
|
||||
IAValue: IValue;
|
||||
ANum: Double;
|
||||
begin
|
||||
// AV: check the number of passed parameters
|
||||
if Length(Args) <> 1 then begin
|
||||
MessageBox(0, PChar(Format(TextByKey('formula-wrongargscount'),
|
||||
['Ln()', 1, Length(Args)])), 'Apophysis AV', 48);
|
||||
exit;
|
||||
end;
|
||||
|
||||
IAValue := Args[0];
|
||||
|
||||
try
|
||||
ANum := IAValue.GetValue.AsExtended;
|
||||
if ANum > 0 then
|
||||
Exit(TValueWrapper.Create(RoundTo(ln(ANum), -6)))
|
||||
else
|
||||
MessageBox(0, PChar('Ln(): ' + TextByKey('formula-unsigned')),
|
||||
'Apophysis AV', 48);
|
||||
except
|
||||
MessageBox(0, PChar('Ln(): ' + TextByKey('formula-wrongdatatype')),
|
||||
'Apophysis AV', 16);
|
||||
end;
|
||||
end
|
||||
);
|
||||
end;
|
||||
|
||||
function PowerXY: IInvokable;
|
||||
begin
|
||||
Result := MakeInvokable(
|
||||
function(Args: TArray<IValue>): IValue
|
||||
var
|
||||
IYValue, IXValue: IValue;
|
||||
ANum: Double;
|
||||
begin
|
||||
// AV: check the number of passed parameters
|
||||
if Length(Args) <> 2 then begin
|
||||
MessageBox(0, PChar(Format(TextByKey('formula-wrongargscount'),
|
||||
['Power()', 2, Length(Args)])), 'Apophysis AV', 48);
|
||||
exit;
|
||||
end;
|
||||
|
||||
IXValue := Args[0];
|
||||
IYValue := Args[1];
|
||||
|
||||
try
|
||||
ANum := IXValue.GetValue.AsExtended;
|
||||
if ANum >= 0 then
|
||||
Result := TValueWrapper.Create(RoundTo(power(ANum,
|
||||
IYValue.GetValue.AsExtended), -6))
|
||||
else
|
||||
MessageBox(0, PChar('Power(): ' + TextByKey('formula-unsigned')),
|
||||
'Apophysis AV', 48);
|
||||
except
|
||||
MessageBox(0, PChar('Power(): ' + TextByKey('common-invalidformat')),
|
||||
'Apophysis AV', 16);
|
||||
end;
|
||||
end
|
||||
);
|
||||
end;
|
||||
|
||||
procedure RegisterMathFunctions;
|
||||
begin
|
||||
TBindingMethodsFactory.RegisterMethod(TMethodDescription.Create(
|
||||
Sine, 'sin', 'sin', '', True, '', nil));
|
||||
TBindingMethodsFactory.RegisterMethod(TMethodDescription.Create(
|
||||
CoSine, 'cos', 'cos', '', True, '', nil));
|
||||
TBindingMethodsFactory.RegisterMethod(TMethodDescription.Create(
|
||||
ArcSine, 'arcsin', 'arcsin', '', True, '', nil));
|
||||
TBindingMethodsFactory.RegisterMethod(TMethodDescription.Create(
|
||||
ArcCoSine, 'arccos', 'arccos', '', True, '', nil));
|
||||
TBindingMethodsFactory.RegisterMethod(TMethodDescription.Create(
|
||||
ArcTangentYX, 'arctan2', 'arctan2', '', True, '', nil));
|
||||
TBindingMethodsFactory.RegisterMethod(TMethodDescription.Create(
|
||||
SquareRoot, 'sqrt', 'sqrt', '', True, '', nil));
|
||||
TBindingMethodsFactory.RegisterMethod(TMethodDescription.Create(
|
||||
PowerXY, 'power', 'power', '', True, '', nil));
|
||||
TBindingMethodsFactory.RegisterMethod(TMethodDescription.Create(
|
||||
NatLog, 'ln', 'ln', '', True, '', nil));
|
||||
|
||||
LScope := BasicOperators;
|
||||
TDictionaryScope(LScope).Map.Add('pi', TValueWrapper.Create(pi));
|
||||
TDictionaryScope(LScope).Map.Add('exp', TValueWrapper.Create(exp(1)));
|
||||
// AV: add the registered methods
|
||||
LScope := TNestedScope.Create(LScope, TBindingMethodsFactory.GetMethodScope);
|
||||
end;
|
||||
|
||||
function CalculateExpression(const Expr: string): string;
|
||||
var
|
||||
LCompiledExpr : ICompiledBinding;
|
||||
LResult : TValue;
|
||||
begin
|
||||
Result := '';
|
||||
|
||||
try
|
||||
LCompiledExpr := Compile(Expr, LScope);
|
||||
LResult := LCompiledExpr.Evaluate(LScope, nil, nil).GetValue;
|
||||
if not LResult.IsEmpty then
|
||||
Result := LResult.ToString;
|
||||
except
|
||||
Result := '';
|
||||
MessageBox(0, PChar(TextByKey('formula-cannotevaluate')),
|
||||
'Apophysis AV', 16);
|
||||
end;
|
||||
end;
|
||||
|
||||
///////////////////////////////////////////////////////////////////////////////
|
||||
initialization
|
||||
RegisterMathFunctions;
|
||||
|
||||
end.
|
||||
@ -33,27 +33,31 @@ begin
|
||||
Regex.Subject := text;
|
||||
|
||||
if Regex.Match and (Regex.GroupCount >= group) then
|
||||
Result := String(Regex.Groups[group])
|
||||
Result := Regex.Groups[group]
|
||||
else Result := def;
|
||||
|
||||
Regex.Free;
|
||||
end;
|
||||
|
||||
function GetBoolPart(text, expression: string; group: integer; def: boolean): boolean;
|
||||
begin
|
||||
Result := GetFloatPart(text, expression, group, StrToFloat(IfThen(def, '1', '0'))) <> 0;
|
||||
end;
|
||||
|
||||
function GetIntPart(text, expression: string; group: integer; def: integer): integer;
|
||||
var str: string;
|
||||
begin
|
||||
str := GetStringPart(text, expression, group, '');
|
||||
Result := StrToIntDef(str, def);
|
||||
end;
|
||||
|
||||
function GetFloatPart(text, expression: string; group: integer; def: extended): extended;
|
||||
var str: string;
|
||||
begin
|
||||
str := GetStringPart(text, expression, group, '');
|
||||
Result := StrToFloatDef(str, def);
|
||||
end;
|
||||
|
||||
function Get2IntPart(text, expression: string; group: integer; def: integer): T2Int;
|
||||
const expr : string = '(\d+)\s+(\d+)';
|
||||
var str, s1, s2: string;
|
||||
@ -64,6 +68,7 @@ begin
|
||||
Result.i1 := StrToIntDef(s1, def);
|
||||
Result.i2 := StrToIntDef(s2, def);
|
||||
end;
|
||||
|
||||
function Get2FloatPart(text, expression: string; group: integer; def: extended): T2Float;
|
||||
const expr : string = '([\d.eE+-]+)\s+([\d.eE+-]+)';
|
||||
var str, s1, s2: string;
|
||||
@ -74,6 +79,7 @@ begin
|
||||
Result.f1 := StrToFloatDef(s1, def);
|
||||
Result.f2 := StrToFloatDef(s2, def);
|
||||
end;
|
||||
|
||||
function GetRGBPart(text, expression: string; group: integer; def: integer): TRGB;
|
||||
const expr : string = '(\d+)\s+(\d+)\s+(\d+)';
|
||||
var str, s1, s2, s3: string;
|
||||
|
||||
@ -1,633 +0,0 @@
|
||||
{ unit sdStringTable
|
||||
|
||||
Author: Nils Haeck M.Sc. (n.haeck@simdesign.nl)
|
||||
Original Date: 28 May 2007
|
||||
Version: 1.1
|
||||
Copyright (c) 2007 - 2010 Simdesign BV
|
||||
|
||||
It is NOT allowed under ANY circumstances to publish or copy this code
|
||||
without accepting the license conditions in accompanying LICENSE.txt
|
||||
first!
|
||||
|
||||
This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
|
||||
ANY KIND, either express or implied.
|
||||
|
||||
Please visit http://www.simdesign.nl/xml.html for more information.
|
||||
}
|
||||
unit sdStringTable;
|
||||
|
||||
interface
|
||||
|
||||
{$i NativeXml.inc}
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Contnrs;
|
||||
|
||||
type
|
||||
|
||||
// A record describing a string by its first position and length (Count)
|
||||
TsdStringRec = record
|
||||
First: Pbyte;
|
||||
Count: integer;
|
||||
end;
|
||||
|
||||
// A string reference item used in string reference lists (do not use directly)
|
||||
TsdRefString = class
|
||||
private
|
||||
FID: integer;
|
||||
FFrequency: integer;
|
||||
FFirst: Pbyte;
|
||||
FCharCount: integer;
|
||||
protected
|
||||
procedure SetString(const SR: TsdStringRec);
|
||||
function CompareToSR(const SR: TsdStringRec): integer;
|
||||
function StringRec: TsdStringRec;
|
||||
public
|
||||
destructor Destroy; override;
|
||||
function AsString: UTF8String;
|
||||
property CharCount: integer read FCharCount;
|
||||
property Frequency: integer read FFrequency;
|
||||
end;
|
||||
|
||||
// A list of string reference items (do not use directly)
|
||||
TsdRefStringList = class(TObjectList)
|
||||
private
|
||||
function GetItems(Index: integer): TsdRefString;
|
||||
protected
|
||||
// Assumes list is sorted by StringID
|
||||
function IndexOfID(AID: integer; var Index: integer): boolean;
|
||||
// Assumes list is sorted by string rec
|
||||
function IndexOfSR(const AStringRec: TsdStringRec; var Index: integer): boolean;
|
||||
public
|
||||
property Items[Index: integer]: TsdRefString read GetItems; default;
|
||||
end;
|
||||
|
||||
// A string table, holding a collection of unique strings, sorted in 2 ways
|
||||
// for fast access. Strings can be added with AddString or AddStringRec,
|
||||
// and should be updated with SetString. When a string is added or updated,
|
||||
// an ID is returned which the application can use to retrieve the string,
|
||||
// using GetString.
|
||||
TsdStringTable = class(TPersistent)
|
||||
private
|
||||
FByID: TsdRefStringList;
|
||||
FBySR: TsdRefStringList;
|
||||
protected
|
||||
procedure DecFrequency(AItem: TsdRefString; ByIdIndex: integer);
|
||||
function NextUniqueID: integer;
|
||||
public
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
procedure Clear;
|
||||
// Add a new string rec, return fresh ID or ID of existing item, and increase
|
||||
// the existing item's ref count
|
||||
function AddStringRec(const SR: TsdStringRec): integer;
|
||||
// Add a new string S to the table, the function returns its ID.
|
||||
function AddString(const S: UTF8String): integer;
|
||||
// Get the refstring by ID
|
||||
function ById(index: integer): TsdRefString;
|
||||
// Delete refstring by ID
|
||||
procedure Delete(ByIdIndex: integer);
|
||||
// determine if the stringrec exists
|
||||
function ExistStringRec(const SR: TsdStringRec): boolean;
|
||||
// Get the string of refstring with ID
|
||||
function GetString(ID: integer): UTF8String;
|
||||
// Set the string value of refstring with ID.
|
||||
procedure SetString(var ID: integer; const S: UTF8String);
|
||||
// Number of refstrings
|
||||
function StringCount: integer;
|
||||
procedure SaveToFile(const AFileName: string);
|
||||
procedure SaveToStream(S: TStream);
|
||||
end;
|
||||
|
||||
{utility functions}
|
||||
|
||||
// convert a string into a string rec
|
||||
function sdStringToSR(const S: Utf8String): TsdStringRec;
|
||||
|
||||
// convert a string rec into a string
|
||||
function sdSRToString(const SR: TsdStringRec): Utf8String;
|
||||
|
||||
// compare two string recs. This is NOT an alphabetic compare. SRs are first
|
||||
// compared by length, then by first byte, then last byte then second, then
|
||||
// N-1, until all bytes are compared.
|
||||
function sdCompareSR(const SR1, SR2: TsdStringRec): integer;
|
||||
|
||||
// compare 2 bytes
|
||||
function sdCompareByte(Byte1, Byte2: byte): integer;
|
||||
|
||||
// compare 2 integers
|
||||
function sdCompareInteger(Int1, Int2: integer): integer;
|
||||
|
||||
function sdUtf16ToUtf8Mem(Src: Pword; Dst: Pbyte; Count: integer): integer;
|
||||
function sdUtf8ToUtf16Mem(var Src: Pbyte; Dst: Pword; Count: integer): integer;
|
||||
procedure sdStreamWrite(S: TStream; const AString: AnsiString);
|
||||
procedure sdStreamWriteStringRec(S: TStream; const AStringRec: TsdStringRec);
|
||||
procedure sdStreamWriteRefString(S: TStream; ARefString: TsdRefString);
|
||||
|
||||
implementation
|
||||
|
||||
{ TsdRefString }
|
||||
|
||||
function TsdRefString.AsString: UTF8String;
|
||||
begin
|
||||
Result := sdSRToString(StringRec);
|
||||
end;
|
||||
|
||||
function TsdRefString.CompareToSR(const SR: TsdStringRec): integer;
|
||||
begin
|
||||
if SR.Count = 0 then
|
||||
begin
|
||||
// shortcut
|
||||
Result := 1;
|
||||
exit;
|
||||
end;
|
||||
Result := sdCompareSR(StringRec, SR);
|
||||
end;
|
||||
|
||||
destructor TsdRefString.Destroy;
|
||||
begin
|
||||
FreeMem(FFirst);
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TsdRefString.SetString(const SR: TsdStringRec);
|
||||
begin
|
||||
FCharCount := SR.Count;
|
||||
ReallocMem(FFirst, FCharCount);
|
||||
Move(SR.First^, FFirst^, FCharCount);
|
||||
end;
|
||||
|
||||
function TsdRefString.StringRec: TsdStringRec;
|
||||
begin
|
||||
Result.First := FFirst;
|
||||
Result.Count := FCharCount;
|
||||
end;
|
||||
|
||||
{ TsdRefStringList }
|
||||
|
||||
function TsdRefStringList.GetItems(Index: integer): TsdRefString;
|
||||
begin
|
||||
Result := Get(Index);
|
||||
end;
|
||||
|
||||
function TsdRefStringList.IndexOfID(AID: integer; var Index: integer): boolean;
|
||||
var
|
||||
Min, Max: integer;
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
// Find position - binary method
|
||||
Index := 0;
|
||||
Min := 0;
|
||||
Max := Count;
|
||||
while Min < Max do
|
||||
begin
|
||||
Index := (Min + Max) div 2;
|
||||
case sdCompareInteger(Items[Index].FID, AID) of
|
||||
-1: Min := Index + 1;
|
||||
0: begin
|
||||
Result := True;
|
||||
exit;
|
||||
end;
|
||||
1: Max := Index;
|
||||
end;
|
||||
end;
|
||||
|
||||
Index := Min;
|
||||
end;
|
||||
|
||||
function TsdRefStringList.IndexOfSR(const AStringRec: TsdStringRec; var Index: integer): boolean;
|
||||
var
|
||||
Min, Max: integer;
|
||||
SR: TsdStringRec;
|
||||
begin
|
||||
Result := False;
|
||||
|
||||
// Find position - binary method
|
||||
Index := 0;
|
||||
Min := 0;
|
||||
Max := Count;
|
||||
while Min < Max do
|
||||
begin
|
||||
Index := (Min + Max) div 2;
|
||||
SR := TsdRefString(Get(Index)).StringRec;
|
||||
case sdCompareSR(SR, AStringRec) of
|
||||
-1: Min := Index + 1;
|
||||
0: begin
|
||||
Result := True;
|
||||
exit;
|
||||
end;
|
||||
1: Max := Index;
|
||||
end;
|
||||
end;
|
||||
|
||||
Index := Min;
|
||||
end;
|
||||
|
||||
{ TsdStringTable }
|
||||
|
||||
function TsdStringTable.AddString(const S: UTF8String): integer;
|
||||
var
|
||||
SR: TsdStringRec;
|
||||
begin
|
||||
SR := sdStringToSR(S);
|
||||
Result := AddStringRec(SR);
|
||||
end;
|
||||
|
||||
function TsdStringTable.AddStringRec(const SR: TsdStringRec): integer;
|
||||
var
|
||||
BySRIndex: integer;
|
||||
Item: TsdRefString;
|
||||
NewSR: TsdStringRec;
|
||||
Res: boolean;
|
||||
begin
|
||||
// zero-length string
|
||||
if SR.Count = 0 then
|
||||
begin
|
||||
Result := 0;
|
||||
exit;
|
||||
end;
|
||||
|
||||
// Try to find the new string
|
||||
if FBySR.IndexOfSR(SR, BySRIndex) then
|
||||
begin
|
||||
Item := FBySR.Items[BySRIndex];
|
||||
inc(Item.FFrequency);
|
||||
Result := Item.FID;
|
||||
exit;
|
||||
end;
|
||||
|
||||
// Not found.. must make new item
|
||||
Item := TsdRefString.Create;
|
||||
Item.SetString(SR);
|
||||
NewSR := Item.StringRec;
|
||||
Item.FID := NextUniqueID;
|
||||
FById.Add(Item);
|
||||
Item.FFrequency := 1;
|
||||
|
||||
// debug:
|
||||
//SetLength(Item.FValue, Item.FCount);
|
||||
//Move(Item.FirstPtr(FBase)^, Item.FValue[1], Item.FCount);
|
||||
|
||||
// Insert in BySR lists
|
||||
Res := FBySR.IndexOfSR(NewSR, BySRIndex);
|
||||
assert(Res = False);
|
||||
FBySR.Insert(BySRIndex, Item);
|
||||
Result := Item.FID;
|
||||
end;
|
||||
|
||||
function TsdStringTable.ById(index: integer): TsdRefString;
|
||||
begin
|
||||
Result := FById[Index];
|
||||
end;
|
||||
|
||||
procedure TsdStringTable.Clear;
|
||||
begin
|
||||
FByID.Clear;
|
||||
FBySR.Clear;
|
||||
end;
|
||||
|
||||
constructor TsdStringTable.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FByID := TsdRefStringList.Create(False);
|
||||
FBySR := TsdRefStringList.Create(True);
|
||||
end;
|
||||
|
||||
procedure TsdStringTable.DecFrequency(AItem: TsdRefString; ByIdIndex: integer);
|
||||
var
|
||||
BySRIndex: integer;
|
||||
Res: boolean;
|
||||
begin
|
||||
dec(AItem.FFrequency);
|
||||
assert(AItem.FFrequency >= 0);
|
||||
|
||||
if AItem.FFrequency = 0 then
|
||||
begin
|
||||
// We must remove it
|
||||
FById.Delete(ByIdIndex);
|
||||
Res := FBySR.IndexOfSR(AItem.StringRec, BySRIndex);
|
||||
assert(Res = True);
|
||||
FBySR.Delete(BySRIndex);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TsdStringTable.Delete(ByIdIndex: integer);
|
||||
var
|
||||
Item: TsdRefString;
|
||||
BySRIndex: integer;
|
||||
Res: boolean;
|
||||
begin
|
||||
Item := FById[ByIdIndex];
|
||||
if Item = nil then
|
||||
exit;
|
||||
FById.Delete(ByIdIndex);
|
||||
Res := FBySR.IndexOfSR(Item.StringRec, BySRIndex);
|
||||
assert(Res = True);
|
||||
FBySR.Delete(BySRIndex);
|
||||
end;
|
||||
|
||||
destructor TsdStringTable.Destroy;
|
||||
begin
|
||||
FreeAndNil(FByID);
|
||||
FreeAndNil(FBySR);
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TsdStringTable.ExistStringRec(const SR: TsdStringRec): boolean;
|
||||
var
|
||||
BySRIndex: integer;
|
||||
begin
|
||||
// zero-length string
|
||||
if SR.Count = 0 then
|
||||
begin
|
||||
Result := False;
|
||||
exit;
|
||||
end;
|
||||
|
||||
// Try to find the new string
|
||||
Result := FBySR.IndexOfSR(SR, BySRIndex);
|
||||
|
||||
end;
|
||||
|
||||
function TsdStringTable.GetString(ID: integer): UTF8String;
|
||||
var
|
||||
Index, Count: integer;
|
||||
Item: TsdRefString;
|
||||
begin
|
||||
if ID = 0 then
|
||||
begin
|
||||
Result := '';
|
||||
exit;
|
||||
end;
|
||||
|
||||
// Find the ID
|
||||
if FByID.IndexOfID(ID, Index) then
|
||||
begin
|
||||
Item := FById[Index];
|
||||
Count := Item.FCharCount;
|
||||
SetLength(Result, Count);
|
||||
Move(Item.FFirst^, Result[1], Count);
|
||||
exit;
|
||||
end;
|
||||
|
||||
Result := '';
|
||||
end;
|
||||
|
||||
function TsdStringTable.NextUniqueID: integer;
|
||||
begin
|
||||
if FById.Count = 0 then
|
||||
Result := 1
|
||||
else
|
||||
Result := FByID[FByID.Count - 1].FID + 1;
|
||||
end;
|
||||
|
||||
procedure TsdStringTable.SaveToFile(const AFileName: string);
|
||||
var
|
||||
F: TFileStream;
|
||||
begin
|
||||
F := TFileStream.Create(AFileName, fmCreate);
|
||||
try
|
||||
SaveToStream(F);
|
||||
finally
|
||||
F.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TsdStringTable.SaveToStream(S: TStream);
|
||||
var
|
||||
i: integer;
|
||||
R: UTF8String;
|
||||
begin
|
||||
for i := 0 to FBySR.Count - 1 do
|
||||
begin
|
||||
R := FBySR[i].AsString + #13#10;
|
||||
S.Write(R[1], length(R));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TsdStringTable.SetString(var ID: integer; const S: UTF8String);
|
||||
var
|
||||
ByIdIndex: integer;
|
||||
Item: TsdRefString;
|
||||
SR: TsdStringRec;
|
||||
begin
|
||||
// Make temp string record
|
||||
SR := sdStringtoSR(S);
|
||||
|
||||
// Do we have a ref string with this ID?
|
||||
if (ID > 0) and FByID.IndexOfID(ID, ByIdIndex) then
|
||||
begin
|
||||
// Is the string still the same?
|
||||
Item := FById[ByIdIndex];
|
||||
if Item.CompareToSR(SR) = 0 then
|
||||
exit;
|
||||
// The string changed..
|
||||
DecFrequency(Item, ByIdIndex);
|
||||
end;
|
||||
|
||||
ID := AddStringRec(SR);
|
||||
end;
|
||||
|
||||
{utility functions}
|
||||
|
||||
function TsdStringTable.StringCount: integer;
|
||||
begin
|
||||
Result := FBySR.Count;
|
||||
end;
|
||||
|
||||
function sdStringToSR(const S: UTF8String): TsdStringRec;
|
||||
begin
|
||||
Result.Count := length(S);
|
||||
if Result.Count = 0 then
|
||||
Result.First := nil
|
||||
else
|
||||
Result.First := @S[1];
|
||||
end;
|
||||
|
||||
function sdSRToString(const SR: TsdStringRec): UTF8String;
|
||||
begin
|
||||
SetLength(Result, SR.Count);
|
||||
if SR.Count > 0 then
|
||||
Move(SR.First^, Result[1], SR.Count);
|
||||
end;
|
||||
|
||||
function sdCompareByte(Byte1, Byte2: byte): integer;
|
||||
begin
|
||||
if Byte1 < Byte2 then
|
||||
Result := -1
|
||||
else
|
||||
if Byte1 > Byte2 then
|
||||
Result := 1
|
||||
else
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
function sdCompareInteger(Int1, Int2: integer): integer;
|
||||
begin
|
||||
if Int1 < Int2 then
|
||||
Result := -1
|
||||
else
|
||||
if Int1 > Int2 then
|
||||
Result := 1
|
||||
else
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
function sdCompareSR(const SR1, SR2: TsdStringRec): integer;
|
||||
var
|
||||
Count: integer;
|
||||
First1, First2, Last1, Last2: Pbyte;
|
||||
begin
|
||||
// Compare string length first
|
||||
Result := sdCompareInteger(SR1.Count, SR2.Count);
|
||||
if Result <> 0 then
|
||||
exit;
|
||||
|
||||
// Compare first
|
||||
Result := sdCompareByte(SR1.First^, SR2.First^);
|
||||
if Result <> 0 then
|
||||
exit;
|
||||
Count := SR1.Count;
|
||||
|
||||
// Setup First & Last pointers
|
||||
First1 := SR1.First;
|
||||
First2 := SR2.First;
|
||||
Last1 := First1; inc(Last1, Count);
|
||||
Last2 := First2; inc(Last2, Count);
|
||||
|
||||
// Compare each time last ptrs then first ptrs, until they meet in the middle
|
||||
repeat
|
||||
dec(Last1);
|
||||
dec(Last2);
|
||||
if First1 = Last1 then
|
||||
exit;
|
||||
Result := sdCompareByte(Last1^, Last2^);
|
||||
if Result <> 0 then
|
||||
exit;
|
||||
inc(First1); inc(First2);
|
||||
if First1 = Last1 then
|
||||
exit;
|
||||
Result := sdCompareByte(First1^, First2^);
|
||||
if Result <> 0 then
|
||||
exit;
|
||||
until False;
|
||||
end;
|
||||
|
||||
function sdUtf16ToUtf8Mem(Src: Pword; Dst: Pbyte; Count: integer): integer;
|
||||
// Convert an Unicode (UTF16 LE) memory block to UTF8. This routine will process
|
||||
// Count wide characters (2 bytes size) to Count UTF8 characters (1-3 bytes).
|
||||
// Therefore, the block at Dst must be at least 1.5 the size of the source block.
|
||||
// The function returns the number of *bytes* written.
|
||||
var
|
||||
W: word;
|
||||
DStart: Pbyte;
|
||||
begin
|
||||
DStart := Dst;
|
||||
while Count > 0 do
|
||||
begin
|
||||
W := Src^;
|
||||
inc(Src);
|
||||
if W <= $7F then
|
||||
begin
|
||||
Dst^ := byte(W);
|
||||
inc(Dst);
|
||||
end else
|
||||
begin
|
||||
if W > $7FF then
|
||||
begin
|
||||
Dst^ := byte($E0 or (W shr 12));
|
||||
inc(Dst);
|
||||
Dst^ := byte($80 or ((W shr 6) and $3F));
|
||||
inc(Dst);
|
||||
Dst^ := byte($80 or (W and $3F));
|
||||
inc(Dst);
|
||||
end else
|
||||
begin // $7F < W <= $7FF
|
||||
Dst^ := byte($C0 or (W shr 6));
|
||||
inc(Dst);
|
||||
Dst^ := byte($80 or (W and $3F));
|
||||
inc(Dst);
|
||||
end;
|
||||
end;
|
||||
dec(Count);
|
||||
end;
|
||||
Result := integer(Dst) - integer(DStart);
|
||||
end;
|
||||
|
||||
function sdUtf8ToUtf16Mem(var Src: Pbyte; Dst: Pword; Count: integer): integer;
|
||||
// Convert an UTF8 memory block to Unicode (UTF16 LE). This routine will process
|
||||
// Count *bytes* of UTF8 (each character 1-3 bytes) into UTF16 (each char 2 bytes).
|
||||
// Therefore, the block at Dst must be at least 2 times the size of Count, since
|
||||
// many UTF8 characters consist of just one byte, and are mapped to 2 bytes. The
|
||||
// function returns the number of *wide chars* written. Note that the Src block must
|
||||
// have an exact number of UTF8 characters in it, if Count doesn't match then
|
||||
// the last character will be converted anyway (going past the block boundary!)
|
||||
var
|
||||
W: word;
|
||||
C: byte;
|
||||
DStart: Pword;
|
||||
SClose: Pbyte;
|
||||
begin
|
||||
DStart := Dst;
|
||||
SClose := Src;
|
||||
inc(SClose, Count);
|
||||
while integer(Src) < integer(SClose) do
|
||||
begin
|
||||
// 1st byte
|
||||
W := Src^;
|
||||
inc(Src);
|
||||
if W and $80 <> 0 then
|
||||
begin
|
||||
W := W and $3F;
|
||||
if W and $20 <> 0 then
|
||||
begin
|
||||
// 2nd byte
|
||||
C := Src^;
|
||||
inc(Src);
|
||||
if C and $C0 <> $80 then
|
||||
// malformed trail byte or out of range char
|
||||
Continue;
|
||||
W := (W shl 6) or (C and $3F);
|
||||
end;
|
||||
// 2nd or 3rd byte
|
||||
C := Src^;
|
||||
inc(Src);
|
||||
if C and $C0 <> $80 then
|
||||
// malformed trail byte
|
||||
Continue;
|
||||
Dst^ := (W shl 6) or (C and $3F);
|
||||
inc(Dst);
|
||||
end else
|
||||
begin
|
||||
Dst^ := W;
|
||||
inc(Dst);
|
||||
end;
|
||||
end;
|
||||
Result := (integer(Dst) - integer(DStart)) div 2;
|
||||
end;
|
||||
|
||||
procedure sdStreamWrite(S: TStream; const AString: AnsiString);
|
||||
var
|
||||
L: integer;
|
||||
begin
|
||||
L := Length(AString);
|
||||
if L > 0 then
|
||||
begin
|
||||
S.Write(AString[1], L);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure sdStreamWriteStringRec(S: TStream; const AStringRec: TsdStringRec);
|
||||
begin
|
||||
S.Write(PAnsiChar(AStringRec.First)^, AStringRec.Count);
|
||||
end;
|
||||
|
||||
procedure sdStreamWriteRefString(S: TStream; ARefString: TsdRefString);
|
||||
begin
|
||||
if ARefString = nil then
|
||||
exit;
|
||||
S.Write(PAnsiChar(ARefString.FFirst)^, ARefString.FCharCount);
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user