mirror-github-bspeice/Apophysis-AV
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial commit

Browse Source
This commit is contained in:
Alice Vital
2022-03-08 20:25:51 +03:00
commit 25a72c3c86
187 changed files with 154390 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

95
System/AsmRandom.pas Normal file
View File

@ -0,0 +1,95 @@
{
Apophysis Copyright (C) 2001-2004 Mark Townsend
Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov
Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov
Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov
Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne
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
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
This module is (c) Jed Kelsey and originally created for Apophysis JK 2.10.
}
unit AsmRandom;
interface
procedure AsmRandInt;
procedure AsmRandExt;
procedure AsmRandomize;
var
RandSeed: Longint = 0; { Base for random number generator }
implementation
const
advapi32 = 'advapi32.dll';
kernel = 'kernel32.dll';
function QueryPerformanceCounter(var lpPerformanceCount: Int64): LongBool; stdcall;
external kernel name 'QueryPerformanceCounter';
function GetTickCount: Cardinal;
external kernel name 'GetTickCount';
procedure AsmRandomize;
{$IFDEF LINUX}
begin
RandSeed := _time(nil);
end;
{$ENDIF}
{$IFDEF MSWINDOWS}
var
Counter: Int64;
begin
if QueryPerformanceCounter(Counter) then
RandSeed := Counter
else
RandSeed := GetTickCount;
end;
{$ENDIF}
procedure AsmRandInt;
asm
{ ->EAX Range }
{ <-EAX Result }
IMUL EDX,RandSeed,08088405H
INC EDX
MOV RandSeed,EDX
MUL EDX
MOV EAX,EDX
end;
procedure AsmRandExt;
const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32
asm
{ FUNCTION _RandExt: Extended; }
IMUL EDX,RandSeed,08088405H
INC EDX
MOV RandSeed,EDX
FLD two2neg32
PUSH 0
PUSH EDX
FILD qword ptr [ESP]
ADD ESP,8
FMULP ST(1), ST(0)
end;
end.

23
System/CurvesControl.dfm Normal file
View File

@ -0,0 +1,23 @@
object CurvesControl: TCurvesControl
Left = 0
Top = 0
Width = 542
Height = 440
DoubleBuffered = True
Color = clBlack
ParentBackground = False
ParentColor = False
ParentDoubleBuffered = False
TabOrder = 0
object Host: TPanel
Left = 0
Top = 0
Width = 542
Height = 440
Align = alClient
BevelOuter = bvNone
Color = clBlack
ParentBackground = False
TabOrder = 0
end
end

384
System/CurvesControl.pas Normal file
View File

@ -0,0 +1,384 @@
unit CurvesControl;
interface
uses
Windows, Messages, SysUtils, Variants, 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;
type
TCurvesChannel = (ccAll = 0, ccRed = 1, ccGreen = 2, ccBlue = 3);
TCurvesControl = class(TFrame)
Host: TPanel;
private
FRect: BezierRect;
FPoints: array [0..3] of BezierPoints;
FWeights: array [0..3] of BezierWeights;
FDragging: boolean;
FDragIndex: integer;
FActiveChannel : TCurvesChannel;
FChannelIndex : integer;
FFrame : TCustomDrawControl;
FCP: TControlPoint;
p: array [0..MAX_CHANNEL] of BezierPoints;
w: array [0..MAX_CHANNEL] of BezierWeights;
wsum: array [0..MAX_CHANNEL] of double;
procedure SetChannel(value: TCurvesChannel);
procedure SetWeightLeft(value: double);
procedure SetWeightRight(value: double);
function GetChannel: TCurvesChannel;
function GetWeightLeft: double;
function GetWeightRight: double;
procedure FrameMouseLeave(Sender: TObject);
procedure FrameMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FrameMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FrameMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FrameResize(Sender: TObject);
procedure FramePaint(Sender: TObject);
procedure FrameCreate;
procedure PaintCurve(Bitmap: TBitmap; c: integer; p: BezierPoints; w: BezierWeights; widgets: boolean);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property WeightLeft : double read GetWeightLeft write SetWeightLeft;
property WeightRight : double read GetWeightRight write SetWeightRight;
property ActiveChannel : TCurvesChannel read GetChannel write SetChannel;
procedure SetCp(cp: TControlPoint);
procedure UpdateFlame;
end;
implementation
{$R *.DFM}
uses Main, Editor, Mutate, Adjust;
constructor TCurvesControl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFrame := TCustomDrawControl.Create(self);
FFrame.TabStop := True;
FFrame.TabOrder := 0;
FFrame.Parent := Host;
FFrame.Align := alClient;
FFrame.Visible := True;
FFrame.OnPaint := FramePaint;
FFrame.OnMouseDown := FrameMouseDown;
FFrame.OnMouseMove := FrameMouseMove;
FFrame.OnMouseUp := FrameMouseUp;
FFrame.OnMouseLeave := FrameMouseLeave;
FCP := TControlPoint.Create;
FrameCreate;
end;
destructor TCurvesControl.Destroy;
begin
FCP.Destroy;
inherited Destroy;
end;
procedure TCurvesControl.SetCp(cp: TControlPoint);
var i, j: integer;
begin
FCP.Copy(cp, true);
for i := 0 to 3 do
for j := 0 to 3 do begin
FWeights[i,j] := FCP.curveWeights[i,j];
FPoints[i,j].x := FCP.curvePoints[i,j].x;
FPoints[i,j].y := FCP.curvePoints[i,j].y;
end;
Invalidate;
FFrame.Invalidate;
end;
procedure TCurvesControl.UpdateFlame;
begin
MainForm.StopThread;
MainForm.UpdateUndo;
MainCp.Copy(FCP, true);
if EditForm.Visible then EditForm.UpdateDisplay;
if MutateForm.Visible then MutateForm.UpdateDisplay;
if AdjustForm.Visible then AdjustForm.UpdateDisplay(true);
MainForm.RedrawTimer.enabled := true;
end;
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;
i, n: integer;
p: BezierPoints;
begin
BezierCopy(FPoints[FChannelIndex], p);
BezierSetRect(p, true, FRect);
FDragIndex := -1;
FDragging := false;
n := Length(p);
for i := 1 to n - 2 do if
(X >= p[i].x - point_size) and (X <= p[i].x + point_size) and
(Y >= p[i].y - point_size) and (Y <= p[i].y + point_size) then
begin
FDragging := true;
FDragIndex := i;
Break;
end;
end;
procedure TCurvesControl.FrameMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
m: BezierPoints;
tmp: BezierPoint;
i: Integer;
j: Integer;
begin
if (y < 0) then Exit;
if (x < 0) then Exit;
m[0].x := x; m[0].y := y;
BezierUnsetRect(m, true, FRect);
if FDragging then
begin
FPoints[FChannelIndex][FDragIndex] := m[0];
if (FPoints[FChannelIndex][FDragIndex].x <= 0)
then FPoints[FChannelIndex][FDragIndex].x := 0;
if (FPoints[FChannelIndex][FDragIndex].y <= 0)
then FPoints[FChannelIndex][FDragIndex].y := 0;
if (FPoints[FChannelIndex][FDragIndex].x >= 1)
then FPoints[FChannelIndex][FDragIndex].x := 1;
if (FPoints[FChannelIndex][FDragIndex].y >= 1)
then FPoints[FChannelIndex][FDragIndex].y := 1;
if (FPoints[FChannelIndex][1].x > FPoints[FChannelIndex][2].x) then
begin
tmp := FPoints[FChannelIndex][1];
FPoints[FChannelIndex][1] := FPoints[FChannelIndex][2];
FPoints[FChannelIndex][2] := tmp;
if (FDragIndex = 1) then FDragIndex := 2
else FDragIndex := 1;
end;
for i := 0 to 3 do
for j := 0 to 3 do begin
FCP.curveWeights[i,j] := FWeights[i,j];
FCP.curvePoints[i,j].x := FPoints[i,j].x;
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;
FDragging := false;
if (sender <> nil) then UpdateFlame;
end;
procedure TCurvesControl.FrameCreate;
var i: integer;
begin
for i := 0 to channel_count - 1 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;
FPoints[i][2].x := 1.00; FPoints[i][2].y := 1.00; FWeights[i][2] := 1;
FPoints[i][3].x := 1.00; FPoints[i][3].y := 1.00; FWeights[i][3] := 1;
end;
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;
i, j, x, y, sx, sy: integer;
bitmap: TBitMap;
begin
if (FFrame.Width <= 0) or (FFrame.Height <= 0) then Exit;
FrameResize(Sender);
Bitmap := TBitmap.Create;
Bitmap.Width := FFrame.Width;
Bitmap.Height := FFrame.Height;
sx := Bitmap.Width;
sy := Bitmap.Height;
try
with Bitmap.Canvas do
begin
Brush.Color := $000000;
FillRect(Rect(0, 0, sx, sy));
Pen.Color := $555555;
Pen.Style := psSolid;
Pen.Width := 1;
for x := 1 to 7 do begin
MoveTo(Round(0.125 * x * FRect.x1), Round(FRect.y0));
LineTo(Round(0.125 * x * FRect.x1), Round(FRect.y1));
end;
for y := 1 to 3 do begin
MoveTo(Round(FRect.x0), Round(0.25 * y * FRect.y1));
LineTo(Round(FRect.x1), Round(0.25 * y * FRect.y1));
end;
for i := 0 to channel_count - 1 do begin
for j := 0 to 3 do
wsum[i] := wsum[i] + FWeights[i][j];
for j := 0 to 3 do
w[i][j] := FWeights[i][j] / wsum[i];
BezierCopy(FPoints[i], p[i]);
BezierSetRect(p[i], true, FRect);
if i <> FChannelIndex then PaintCurve(Bitmap, i, p[i], w[i], false);
end;
PaintCurve(Bitmap, FChannelIndex, p[FChannelIndex], w[FChannelIndex], true);
FFrame.Canvas.Draw(0, 0, Bitmap);
end;
finally
Bitmap.Free;
end;
end;
procedure TCurvesControl.PaintCurve(Bitmap: TBitmap; c: integer; p: BezierPoints; w: BezierWeights; widgets: boolean);
var
pos0, pos1: BezierPoint;
t, step: Double;
r, g, b: array [0 .. MAX_CHANNEL] of integer;
rgbv: integer;
begin
with Bitmap.Canvas do
begin
if c <> FChannelIndex then begin
r[0] := $aa; r[1] := $aa; r[2] := $40; r[3] := $40;
g[0] := $aa; g[1] := $40; g[2] := $aa; g[3] := $40;
b[0] := $aa; b[1] := $40; b[2] := $40; b[3] := $aa;
end else begin
r[0] := $ff; r[1] := $ff; r[2] := $80; r[3] := $80;
g[0] := $ff; g[1] := $80; g[2] := $ff; g[3] := $80;
b[0] := $ff; b[1] := $80; b[2] := $80; b[3] := $ff;
end;
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;
if widgets then begin
Pen.Color := $808080; Pen.Width := 1;
MoveTo(Round(p[1].x), Round(p[1].y));
LineTo(Round(p[2].x), Round(p[2].y));
MoveTo(Round(FRect.x0), Round(FRect.y1));
LineTo(Round(p[1].x), Round(p[1].y));
MoveTo(Round(FRect.x1), Round(FRect.y0));
LineTo(Round(p[2].x), Round(p[2].y));
end;
while t < 1 do begin
BezierSolve(t, p, w, pos1);
Pen.Color := rgbv;
Pen.Width := 1;
MoveTo(Round(pos0.x), Round(pos0.y));
LineTo(Round(pos1.x), Round(pos1.y));
t := t + step;
pos0 := pos1;
end;
MoveTo(Round(pos0.x), Round(pos0.y));
LineTo(Round(FRect.x1), Round(pos0.y));
if widgets then begin
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)
);
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)
);
end;
end;
end;
procedure TCurvesControl.SetChannel(value: TCurvesChannel);
begin
FActiveChannel := value;
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;
FCP.curveWeights[FChannelIndex][2] := value;
FFrame.Refresh;
end;
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];
end;
end.

99
System/CustomDrawControl.pas Normal file
View File

@ -0,0 +1,99 @@
{
Apophysis Copyright (C) 2001-2004 Mark Townsend
Apophysis Copyright (C) 2005-2006 Ronald Hordijk, Piotr Borys, Peter Sdobnov
Apophysis Copyright (C) 2007-2008 Piotr Borys, Peter Sdobnov
Apophysis "3D hack" Copyright (C) 2007-2008 Peter Sdobnov
Apophysis "7X" Copyright (C) 2009-2010 Georg Kiehne
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
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}
unit CustomDrawControl;
interface
uses
Classes, Controls, Messages, Windows, Graphics;
type
TCustomDrawControl = class(TCustomControl)
private
FOnPaint: TNotifyEvent;
FOnLeave: TNotifyEvent;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
protected
public
procedure Paint; override;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
property Canvas;
property OnDblClick;
property OnKeyDown;
// property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
// property OnMouseWheelDown;
// property OnMouseWheelUp;
property OnEnter;
property OnExit;
property OnMouseLeave: TNotifyEvent read FOnLeave write FOnLeave;
end;
implementation
procedure TCustomDrawControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TCustomDrawControl.WMSetFocus(var Message: TWMSetFocus);
begin
Invalidate;
end;
procedure TCustomDrawControl.WMKillFocus(var Message: TWMKillFocus);
begin
if assigned(OnExit) then OnExit(self);
Invalidate;
end;
procedure TCustomDrawControl.WMGetDlgCode(var Message: TMessage);
begin
inherited;
Message.Result := Message.Result or DLGC_WANTARROWS;
end;
procedure TCustomDrawControl.CMMouseLeave(var Message: TMessage);
begin
if Assigned(FOnLeave) then FOnLeave(Self);
end;
procedure TCustomDrawControl.Paint;
begin
if Assigned(FOnPaint) then FOnPaint(Self);
end;
end.

BIN
System/LibXmlComps.dcr Normal file
View File

Binary file not shown.

122
System/LibXmlComps.pas Normal file
View File

@ -0,0 +1,122 @@
(**
===============================================================================================
Name : LibXmlComps
===============================================================================================
Project : All Projects processing XML documents
===============================================================================================
Subject : XML parser for Delphi's VCL toolbar
===============================================================================================
Dipl.-Ing. (FH) Stefan Heymann, Softwaresysteme, T<>bingen, Germany
===============================================================================================
Date Author Changes
-----------------------------------------------------------------------------------------------
2000-03-31 HeySt 1.0.0 Start
2000-07-27 HeySt 1.0.1 Added "TAttr" declaration
Moved GetNormalize/SetNormalize to PROTECTED section
2001-02-03 HeySt Changed prototype for the TExternalEvent callback function type
so that C++Builder users should get it compiled better.
2001-02-28 HeySt 1.0.2 Introduced the "StopParser" property. When you set this property to
TRUE in one of the Parser Events, parsing is stopped and the Execute
method returns.
Introduced Version numbers
2001-07-10 HeySt 1.0.3 Fixed a bug in TScannerXmlParser.DtdElementFound so that the
OnAttList event is correctly fired
2001-07-11 HeySt 1.1.0 Derived from the new TCustomXmlScanner class from LibXmlParser
2005-07-07 HeySt 1.1.1 Published new TranslateCharacter event property
*)
UNIT LibXmlComps;
INTERFACE
USES
Classes,
LibXmlParser;
TYPE
TXmlScanner = CLASS (TCustomXmlScanner)
PUBLIC
PROPERTY XmlParser;
PROPERTY StopParser;
PUBLISHED
PROPERTY Filename;
PROPERTY Normalize;
PROPERTY OnXmlProlog;
PROPERTY OnComment;
PROPERTY OnPI;
PROPERTY OnDtdRead;
PROPERTY OnStartTag;
PROPERTY OnEmptyTag;
PROPERTY OnEndTag;
PROPERTY OnContent;
PROPERTY OnCData;
PROPERTY OnElement;
PROPERTY OnAttList;
PROPERTY OnEntity;
PROPERTY OnNotation;
PROPERTY OnDtdError;
PROPERTY OnLoadExternal;
PROPERTY OnTranslateEncoding;
PROPERTY OnTranslateCharacter;
END;
// The "Easy" XML Scanner leaves out events and properties which you are unlikely to use
// for "normal" XML files.
// CDATA sections trigger "OnContent" events
TEasyXmlScanner = CLASS (TCustomXmlScanner)
PROTECTED
PROCEDURE WhenCData (Content : string); OVERRIDE;
PUBLIC
PROPERTY XmlParser;
PROPERTY StopParser;
PUBLISHED
PROPERTY Filename;
PROPERTY Normalize;
PROPERTY OnComment;
PROPERTY OnPI;
PROPERTY OnStartTag;
PROPERTY OnEmptyTag;
PROPERTY OnEndTag;
PROPERTY OnContent;
PROPERTY OnLoadExternal;
PROPERTY OnTranslateEncoding;
END;
PROCEDURE Register;
(*
===============================================================================================
IMPLEMENTATION
===============================================================================================
*)
IMPLEMENTATION
PROCEDURE Register;
BEGIN
RegisterComponents ('XML', [TXmlScanner, TEasyXmlScanner]);
END;
(*
===============================================================================================
TEasyXmlScanner
===============================================================================================
*)
PROCEDURE TEasyXmlScanner.WhenCData (Content : string);
BEGIN
INHERITED WhenContent (Content);
END;
(*
===============================================================================================
INITIALIZATION
===============================================================================================
*)
END.

2719
System/LibXmlParser.pas Normal file
View File

File diff suppressed because it is too large Load Diff

90
System/RegexHelper.pas Normal file
View File

@ -0,0 +1,90 @@
unit RegexHelper;
interface
uses Global, SysUtils, StrUtils, RegularExpressionsCore;
type T2Int = record
i1, i2: integer;
end;
type T2Float = record
f1, f2: extended;
end;
type TRgb = record
r, g, b: integer;
end;
function GetStringPart(text, expression: string; group: integer; def: string): string;
function GetBoolPart(text, expression: string; group: integer; def: boolean): boolean;
function GetIntPart(text, expression: string; group: integer; def: integer): integer;
function GetFloatPart(text, expression: string; group: integer; def: extended): extended;
function Get2IntPart(text, expression: string; group: integer; def: integer): T2Int;
function Get2FloatPart(text, expression: string; group: integer; def: extended): T2Float;
function GetRGBPart(text, expression: string; group: integer; def: integer): TRGB;
implementation
(* ***************************** Extract functions ******************************* *)
function GetStringPart(text, expression: string; group: integer; def: string): string;
var Regex: TPerlRegEx;
begin
Regex := TPerlRegEx.Create;
Regex.RegEx := expression;
Regex.Options := [preSingleLine, preCaseless];
Regex.Subject := text;
if Regex.Match and (Regex.GroupCount >= group) then
Result := String(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;
begin
str := GetStringPart(text, expression, group, IntToStr(def) + ' ' + IntToStr(def));
s1 := GetStringPart(str, expr, 1, IntToStr(def));
s2 := GetStringPart(str, expr, 2, IntToStr(def));
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;
begin
str := GetStringPart(text, expression, group, FloatToStr(def) + ' ' + FloatToStr(def));
s1 := GetStringPart(str, expr, 1, FloatToStr(def));
s2 := GetStringPart(str, expr, 2, FloatToStr(def));
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;
begin
str := GetStringPart(text, expression, group, IntToStr(def) + ' ' + IntToStr(def) + ' ' + IntToStr(def));
s1 := GetStringPart(str, expr, 1, IntToStr(def));
s2 := GetStringPart(str, expr, 2, IntToStr(def));
s3 := GetStringPart(str, expr, 3, IntToStr(def));
Result.r := StrToIntDef(s1, def);
Result.g := StrToIntDef(s2, def);
Result.b := StrToIntDef(s3, def);
end;
end.

633
System/sdStringTable.pas Normal file
View File

@ -0,0 +1,633 @@
{ 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.