diff --git a/Ext/HTMLViewer/Source/HTMLSubs.pas b/Ext/HTMLViewer/Source/HTMLSubs.pas
index 8f3c491..278fd74 100644
--- a/Ext/HTMLViewer/Source/HTMLSubs.pas
+++ b/Ext/HTMLViewer/Source/HTMLSubs.pas
@@ -176,7 +176,7 @@ TFontObj = class(TFontObjBase) {font information}
// BG, 10.02.2013: owns its objects.
TFontList = class(TFontObjBaseList) {a list of TFontObj's}
private
- function GetFont(Index: Integer): TFontObj; {$ifdef UseInline} inline; {$endif}
+ function GetFont(Index: TListSize): TFontObj; {$ifdef UseInline} inline; {$endif}
public
constructor CreateCopy(ASection: TSection; T: TFontList);
function GetFontAt(Posn: Integer; out OHang: Integer): ThtFont;
@@ -184,7 +184,7 @@ TFontList = class(TFontObjBaseList) {a list of TFontObj's}
function GetFontObjAt(Posn: Integer): TFontObj; overload;
function GetFontObjAt(Posn, Leng: Integer; out Obj: TFontObj): Integer; overload;
procedure Decrement(N: Integer; Document: ThtDocument);
- property Items[Index: Integer]: TFontObj read GetFont; default;
+ property Items[Index: TListSize]: TFontObj read GetFont; default;
end;
// BG, 10.02.2013: does not own its font objects.
@@ -1093,11 +1093,11 @@ TFormControlObj = class(TFloatingObj)
//BG, 15.01.2011:
TFormControlObjList = class(TFloatingObjList)
private
- function GetItem(Index: Integer): TFormControlObj; {$ifdef UseInline} inline; {$endif}
+ function GetItem(Index: TListSize): TFormControlObj; {$ifdef UseInline} inline; {$endif}
public
procedure ActivateTabbing;
procedure DeactivateTabbing;
- property Items[Index: Integer]: TFormControlObj read GetItem; default;
+ property Items[Index: TListSize]: TFormControlObj read GetItem; default;
end;
TImageFormControlObj = class(TFormControlObj)
@@ -1749,7 +1749,7 @@ ThtDocument = class(TCell) {a list of all the sections -- the html document}
function GetURL(Canvas: TCanvas; X, Y: Integer; out UrlTarg: TUrlTarget; out FormControl: TIDObject {TImageFormControlObj}; out ATitle: ThtString): ThtguResultType; override;
procedure CancelActives;
procedure CheckGIFList(Sender: TObject);
- procedure Clear; virtual;
+ procedure Clear; {$ifndef Compiler34_Plus}override;{$endif}
procedure ClearLists;
procedure GetBackgroundImage;
procedure HideControls;
@@ -2696,7 +2696,7 @@ constructor TFontList.CreateCopy(ASection: TSection; T: TFontList);
end;
//-- BG ---------------------------------------------------------- 10.02.2013 --
-function TFontList.GetFont(Index: Integer): TFontObj;
+function TFontList.GetFont(Index: TListSize): TFontObj;
begin
Result := TFontObj(inherited Items[Index]);
end;
@@ -13411,7 +13411,7 @@ function TSection.Draw1(Canvas: TCanvas; const ARect: TRect;
NewCP := True;
CPy := Y + LR.DrawY; //Todo: Someone needs to find a sensible default value.
CPx := X + LR.LineIndent;
- {$IFNDEF Compiler32_Plus}CP1x := CPx;{$ENDIF}
+ {$IFNDEF Compiler31_Plus}CP1x := CPx;{$ENDIF}
LR.DrawY := Y - LR.LineHt;
LR.DrawXX := CPx;
AdjustDrawRect( LR.DrawY, LR.DrawXX, LR.DrawWidth, LR.LineHt ); //>-- DZ 19.09.2012
@@ -15593,7 +15593,7 @@ procedure TFormControlObjList.DeactivateTabbing;
end;
//-- BG ---------------------------------------------------------- 15.01.2011 --
-function TFormControlObjList.GetItem(Index: Integer): TFormControlObj;
+function TFormControlObjList.GetItem(Index: TListSize): TFormControlObj;
begin
{$ifdef UseGenerics}
Result := inherited Items[Index] as TFormControlObj;
diff --git a/Ext/HTMLViewer/Source/HTMLUn2.pas b/Ext/HTMLViewer/Source/HTMLUn2.pas
index 95a4372..bf9c8d0 100644
--- a/Ext/HTMLViewer/Source/HTMLUn2.pas
+++ b/Ext/HTMLViewer/Source/HTMLUn2.pas
@@ -276,9 +276,9 @@ TIndentRec = class
TIndentRecList = class(TObjectList)
private
- function Get(Index: Integer): TIndentRec; {$ifdef UseInline} inline; {$endif}
+ function Get(Index: TListSize): TIndentRec; {$ifdef UseInline} inline; {$endif}
public
- property Items[Index: Integer]: TIndentRec read Get; default;
+ property Items[Index: TListSize]: TIndentRec read Get; default;
end;
TIndentManager = class
@@ -3779,7 +3779,7 @@ procedure ThvMeter.SetHighColor(const value: TColor);
{ TIndentRecList }
//-- BG ---------------------------------------------------------- 06.10.2016 --
-function TIndentRecList.Get(Index: Integer): TIndentRec;
+function TIndentRecList.Get(Index: TListSize): TIndentRec;
begin
Result := inherited Get(Index);
end;
diff --git a/Ext/HTMLViewer/Source/HtmlBuffer.pas b/Ext/HTMLViewer/Source/HtmlBuffer.pas
index 27de58f..fa7a4db 100644
--- a/Ext/HTMLViewer/Source/HtmlBuffer.pas
+++ b/Ext/HTMLViewer/Source/HtmlBuffer.pas
@@ -199,7 +199,7 @@ TBuffConvInfo = class
TBuffConvInfoList = class(TList)
private
FSorted: Boolean;
- function GetItem(Index: Integer): TBuffConvInfo;
+ function GetItem(Index: TListSize): TBuffConvInfo;
protected
procedure Notify(Ptr: Pointer; Action: TListNotification); override;
public
@@ -207,7 +207,7 @@ TBuffConvInfoList = class(TList)
procedure Add(Item: TBuffConvInfo);
function Find(CodePage: TBuffCodePage): Integer;
procedure Sort;
- property Items[Index: Integer]: TBuffConvInfo read GetItem; default;
+ property Items[Index: TListSize]: TBuffConvInfo read GetItem; default;
property Sorted: Boolean read FSorted;
end;
@@ -640,7 +640,7 @@ function TBuffConvInfoList.Find(CodePage: TBuffCodePage): Integer;
end;
//-- BG ---------------------------------------------------------- 12.10.2012 --
-function TBuffConvInfoList.GetItem(Index: Integer): TBuffConvInfo;
+function TBuffConvInfoList.GetItem(Index: TListSize): TBuffConvInfo;
begin
Result := Get(Index);
end;
diff --git a/Ext/HTMLViewer/Source/HtmlGlobals.pas b/Ext/HTMLViewer/Source/HtmlGlobals.pas
index 372cd5e..0ec94c6 100644
--- a/Ext/HTMLViewer/Source/HtmlGlobals.pas
+++ b/Ext/HTMLViewer/Source/HtmlGlobals.pas
@@ -116,6 +116,8 @@ interface
type
+{$IF (CompilerVersion >= 36)}TListSize = NativeInt;{$ELSE}TListSize = Integer;{$IFEND}
+
{$IFNDEF DOTNET}
{$IFNDEF FPC}
{$ifndef PtrInt_defined}
diff --git a/Ext/HTMLViewer/Source/framview.pas b/Ext/HTMLViewer/Source/framview.pas
index 9969ccc..1de271b 100644
--- a/Ext/HTMLViewer/Source/framview.pas
+++ b/Ext/HTMLViewer/Source/framview.pas
@@ -378,7 +378,7 @@ TFrameBase = class(THtmlFrameBase) {base class for other classes}
UnLoaded: Boolean;
LocalCharSet: TFontCharset;
LocalCodePage: TBuffCodePage;
- function GetPixelsPerInch: Integer; override;
+ function GetPixelsPerInch: Integer; {$ifdef Compiler35_Plus}override;{$endif}
procedure SetQuirksMode(const AValue: THtQuirksMode); virtual;
procedure FVMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); virtual; abstract;
procedure FVMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); virtual; abstract;
diff --git a/Ext/HTMLViewer/Source/htmlcons.inc b/Ext/HTMLViewer/Source/htmlcons.inc
index 34e10ce..acb3633 100644
--- a/Ext/HTMLViewer/Source/htmlcons.inc
+++ b/Ext/HTMLViewer/Source/htmlcons.inc
@@ -58,6 +58,7 @@ are covered by separate copyright notices located in those modules.
{ Identify Delphi Compiler Version:
# Compiler Version Compiler Defined Symbol Codename
+ D29 Delphi 12 36 VER360 Athens
D28 Delphi 11 35 VER350 Alexandria
D27 Delphi 10.4 34 VER340 Sydney
D26 Delphi 10.3 33 VER330 Rio
@@ -173,6 +174,10 @@ are covered by separate copyright notices located in those modules.
{$define Compiler35_Plus}
{$ifdef ver350}
{$else}
+ {$define Compiler36_Plus}
+ {$ifdef ver360}
+ {$else}
+ {$endif}
{$endif}
{$endif}
{$endif}
diff --git a/Ext/HTMLViewer/Source/htmlview.pas b/Ext/HTMLViewer/Source/htmlview.pas
index 2fd870e..6104097 100644
--- a/Ext/HTMLViewer/Source/htmlview.pas
+++ b/Ext/HTMLViewer/Source/htmlview.pas
@@ -5075,7 +5075,7 @@ function THtmlViewer.GetSelHtml: UTF8String;
LTML: ThtString;
C: ThtChar;
begin
- {$IFNDEF Compiler32_Plus}C := #0;{$ENDIF} // valium for Delphi 2009+
+ {$IFNDEF Compiler31_Plus}C := #0;{$ENDIF} // valium for Delphi 2009+
LTML := htLowerCase(HTML);
repeat
I := Pos(Tag, LTML);
diff --git a/Ext/SVGIconImageList/Image32/ChangeLog.txt b/Ext/SVGIconImageList/Image32/ChangeLog.txt
index fce3fff..1e44680 100644
--- a/Ext/SVGIconImageList/Image32/ChangeLog.txt
+++ b/Ext/SVGIconImageList/Image32/ChangeLog.txt
@@ -1,17 +1,33 @@
-Image32 - 2D graphics library for Delphi Pascal
-Latest version: 4.3
-Released: 27 September 2022
-
-Copyright © 2019-2022 Angus Johnson
+Image32 - a 2D graphics library for Delphi Pascal
+Latest version: 4.8
+Released: 18 January 2024
+Copyright © 2019-2025 Angus Johnson
Freeware released under Boost Software License
https://www.boost.org/LICENSE_1_0.txt
-Documentation : http://www.angusj.com/delphi/image32/Docs/
-Download : https://sourceforge.net/projects/image32/files/
+Documentation : https://www.angusj.com/image32/Docs/Overview.htm
+Download : https://github.com/AngusJohnson/Image32
Recent changes:
+Version 4.8
+* This version contains further improvements in text rendering.
+ CAUTION: Some function and method renaming too in Img32.Text.pas.
+* Minor bug fixes too (issues #128..#130 in the GitHub repository).
+
+Version 4.7
+* There have been significant improvements in SVG file reading
+* There have also been significant improvements in managing text rendering.
+ These include a new TChunkedText class and changes in the TFontManager class.
+* Andreas Hausladen has continued to contribute changes that improve performance.
+* Additional bug fixes (see issues #102..#125 in the GitHub repository).
+Version 4.6
+* This release contains many bug fixes (see issues #10..#101) in the
+GitHub repository.
+* Andreas Hausladen has also made multiple contributions to
+the library that that have very significantly improved its performance.
+
Version 4.3
Numerous minor bugfixes
diff --git a/Ext/SVGIconImageList/Image32/Readme.md b/Ext/SVGIconImageList/Image32/Readme.md
index 38a14a2..1f00a2f 100644
--- a/Ext/SVGIconImageList/Image32/Readme.md
+++ b/Ext/SVGIconImageList/Image32/Readme.md
@@ -13,7 +13,7 @@ Image32 is a comprehensive 2D graphics library written entirely in Delphi Pascal
Extensive documentation can be found [**here**](http://www.angusj.com/image32/Docs/_Body.htm).
-### Images from demo sample applications
+### Images & videos from demo sample applications
Layers201 video
@@ -24,6 +24,10 @@ Extensive documentation can be found [**here**](http://www.angusj.com/image32/Do
SVG101 video
+
+
Vectorize video
+
+Drawing video
diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.Core.pas b/Ext/SVGIconImageList/Image32/source/Clipper.Core.pas
index 84b7a14..77bc276 100644
--- a/Ext/SVGIconImageList/Image32/source/Clipper.Core.pas
+++ b/Ext/SVGIconImageList/Image32/source/Clipper.Core.pas
@@ -2,12 +2,12 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Date : 3 May 2024 *
-* Website : http://www.angusj.com *
+* Date : 22 November 2024 *
+* Website : https://www.angusj.com *
* Copyright : Angus Johnson 2010-2024 *
* Purpose : Core Clipper Library module *
* Contains structures and functions used throughout the library *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
{$I Clipper.inc}
@@ -18,12 +18,15 @@ interface
SysUtils, Classes, Math;
type
+{$IFDEF USINGZ}
+ ZType = Int64; // or alternatively, ZType = double
+{$ENDIF}
PPoint64 = ^TPoint64;
TPoint64 = record
X, Y: Int64;
{$IFDEF USINGZ}
- Z: Int64;
+ Z: ZType;
{$ENDIF}
end;
@@ -31,7 +34,7 @@ TPoint64 = record
TPointD = record
X, Y: double;
{$IFDEF USINGZ}
- Z: Int64;
+ Z: ZType;
{$ENDIF}
end;
@@ -121,6 +124,7 @@ TListEx = class
fCount : integer;
fCapacity : integer;
fList : TPointerList;
+ fSorted : Boolean;
protected
function UnsafeGet(idx: integer): Pointer; // no range checking
procedure UnsafeSet(idx: integer; val: Pointer);
@@ -130,14 +134,16 @@ TListEx = class
destructor Destroy; override;
procedure Clear; virtual;
function Add(item: Pointer): integer;
+ procedure DeleteLast;
procedure Swap(idx1, idx2: integer);
- procedure Sort(Compare: TListSortCompare);
+ procedure Sort(Compare: TListSortCompareFunc);
procedure Resize(count: integer);
property Count: integer read fCount;
+ property Sorted: Boolean read fSorted;
property Item[idx: integer]: Pointer read UnsafeGet; default;
end;
- TClipType = (ctNone, ctIntersection, ctUnion, ctDifference, ctXor);
+ TClipType = (ctNoClip, ctIntersection, ctUnion, ctDifference, ctXor);
TPointInPolygonResult = (pipOn, pipInside, pipOutside);
@@ -154,8 +160,7 @@ function IsPositive(const path: TPath64): Boolean; overload;
function IsPositive(const path: TPathD): Boolean; overload;
{$IFDEF INLINING} inline; {$ENDIF}
-function IsCollinear(const pt1, pt2, pt3: TPoint64): Boolean;
- {$IFDEF INLINING} inline; {$ENDIF}
+function IsCollinear(const pt1, sharedPt, pt2: TPoint64): Boolean;
function CrossProduct(const pt1, pt2, pt3: TPoint64): double; overload;
{$IFDEF INLINING} inline; {$ENDIF}
@@ -187,11 +192,11 @@ function PointsNearEqual(const pt1, pt2: TPointD; distanceSqrd: double): Boolean
{$IFDEF INLINING} inline; {$ENDIF}
{$IFDEF USINGZ}
-function Point64(const X, Y: Int64; Z: Int64 = 0): TPoint64; overload;
+function Point64(const X, Y: Int64; Z: ZType = 0): TPoint64; overload;
{$IFDEF INLINING} inline; {$ENDIF}
-function Point64(const X, Y: Double; Z: Int64 = 0): TPoint64; overload;
+function Point64(const X, Y: Double; Z: ZType = 0): TPoint64; overload;
{$IFDEF INLINING} inline; {$ENDIF}
-function PointD(const X, Y: Double; Z: Int64 = 0): TPointD; overload;
+function PointD(const X, Y: Double; Z: ZType = 0): TPointD; overload;
{$IFDEF INLINING} inline; {$ENDIF}
{$ELSE}
function Point64(const X, Y: Int64): TPoint64; overload; {$IFDEF INLINING} inline; {$ENDIF}
@@ -541,6 +546,7 @@ procedure TListEx.Clear;
fList := nil;
fCount := 0;
fCapacity := 0;
+ fSorted := false;
end;
//------------------------------------------------------------------------------
@@ -556,6 +562,13 @@ function TListEx.Add(item: Pointer): integer;
fList[fCount] := item;
Result := fCount;
inc(fCount);
+ fSorted := false;
+end;
+//------------------------------------------------------------------------------
+
+procedure TListEx.DeleteLast;
+begin
+ dec(fCount);
end;
//------------------------------------------------------------------------------
@@ -612,10 +625,11 @@ procedure QuickSort(SortList: TPointerList; L, R: Integer;
end;
//------------------------------------------------------------------------------
-procedure TListEx.Sort(Compare: TListSortCompare);
+procedure TListEx.Sort(Compare: TListSortCompareFunc);
begin
if fCount < 2 then Exit;
QuickSort(FList, 0, fCount - 1, Compare);
+ fSorted := true;
end;
//------------------------------------------------------------------------------
@@ -655,6 +669,7 @@ procedure TListEx.Swap(idx1, idx2: integer);
p := fList[idx1];
fList[idx1] := fList[idx2];
fList[idx2] := p;
+ fSorted := false;
end;
//------------------------------------------------------------------------------
@@ -1384,7 +1399,7 @@ function ArrayOfPathsToPaths(const ap: TArrayOfPaths): TPaths64;
//------------------------------------------------------------------------------
{$IFDEF USINGZ}
-function Point64(const X, Y: Int64; Z: Int64): TPoint64;
+function Point64(const X, Y: Int64; Z: ZType): TPoint64;
begin
Result.X := X;
Result.Y := Y;
@@ -1392,7 +1407,7 @@ function Point64(const X, Y: Int64; Z: Int64): TPoint64;
end;
//------------------------------------------------------------------------------
-function Point64(const X, Y: Double; Z: Int64): TPoint64;
+function Point64(const X, Y: Double; Z: ZType): TPoint64;
begin
Result.X := Round(X);
Result.Y := Round(Y);
@@ -1400,7 +1415,7 @@ function Point64(const X, Y: Double; Z: Int64): TPoint64;
end;
//------------------------------------------------------------------------------
-function PointD(const X, Y: Double; Z: Int64): TPointD;
+function PointD(const X, Y: Double; Z: ZType): TPointD;
begin
Result.X := X;
Result.Y := Y;
@@ -1864,16 +1879,70 @@ function IsPositive(const path: TPathD): Boolean;
end;
//------------------------------------------------------------------------------
-{$OVERFLOWCHECKS OFF}
-function IsCollinear(const pt1, pt2, pt3: TPoint64): Boolean;
+function TriSign(val: Int64): integer; // returns 0, 1 or -1
+{$IFDEF INLINING} inline; {$ENDIF}
+begin
+ if (val < 0) then Result := -1
+ else if (val > 1) then Result := 1
+ else Result := 0;
+end;
+//------------------------------------------------------------------------------
+
+type
+ TMultiplyUInt64Result = record
+ lo64: UInt64;
+ hi64 : UInt64;
+ end;
+
+function MultiplyUInt64(a, b: UInt64): TMultiplyUInt64Result; // #834, #835
+{$IFDEF INLINING} inline; {$ENDIF}
+var
+ x1, x2, x3: UInt64;
+begin
+ x1 := (a and $FFFFFFFF) * (b and $FFFFFFFF);
+ x2 := (a shr 32) * (b and $FFFFFFFF) + (x1 shr 32);
+ x3 := (a and $FFFFFFFF) * (b shr 32) + (x2 and $FFFFFFFF);
+ Result.lo64 := ((x3 and $FFFFFFFF) shl 32) or (x1 and $FFFFFFFF);
+ Result.hi64 := hi(a shr 32) * (b shr 32) + (x2 shr 32) + (x3 shr 32);
+end;
+//------------------------------------------------------------------------------
+
+function ProductsAreEqual(a, b, c, d: Int64): Boolean;
+var
+ absA,absB,absC,absD: UInt64;
+ absAB, absCD : TMultiplyUInt64Result;
+ signAB, signCD : integer;
+begin
+ // nb: unsigned values will be needed for CalcOverflowCarry()
+ absA := UInt64(Abs(a));
+ absB := UInt64(Abs(b));
+ absC := UInt64(Abs(c));
+ absD := UInt64(Abs(d));
+
+ absAB := MultiplyUInt64(absA, absB);
+ absCD := MultiplyUInt64(absC, absD);
+
+ // nb: it's important to differentiate 0 values here from other values
+ signAB := TriSign(a) * TriSign(b);
+ signCD := TriSign(c) * TriSign(d);
+
+ Result := (absAB.lo64 = absCD.lo64) and
+ (absAB.hi64 = absCD.hi64) and (signAB = signCD);
+end;
+//------------------------------------------------------------------------------
+
+function IsCollinear(const pt1, sharedPt, pt2: TPoint64): Boolean;
var
- a,b: Int64;
+ a,b,c,d: Int64;
begin
- a := (pt2.X - pt1.X) * (pt3.Y - pt2.Y);
- b := (pt2.Y - pt1.Y) * (pt3.X - pt2.X);
- result := a = b;
+ a := sharedPt.X - pt1.X;
+ b := pt2.Y - sharedPt.Y;
+ c := sharedPt.Y - pt1.Y;
+ d := pt2.X - sharedPt.X;
+ // When checking for collinearity with very large coordinate values
+ // then ProductsAreEqual is more accurate than using CrossProduct.
+ Result := ProductsAreEqual(a, b, c, d);
end;
-{$OVERFLOWCHECKS ON}
//------------------------------------------------------------------------------
function CrossProduct(const pt1, pt2, pt3: TPoint64): double;
diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.Engine.pas b/Ext/SVGIconImageList/Image32/source/Clipper.Engine.pas
index 950e847..e66db76 100644
--- a/Ext/SVGIconImageList/Image32/source/Clipper.Engine.pas
+++ b/Ext/SVGIconImageList/Image32/source/Clipper.Engine.pas
@@ -2,11 +2,11 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Date : 27 April 2024 *
-* Website : http://www.angusj.com *
+* Date : 22 November 2024 *
+* Website : https://www.angusj.com *
* Copyright : Angus Johnson 2010-2024 *
* Purpose : This is the main polygon clipping module *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -219,7 +219,7 @@ TClipperBase = class
FSucceeded : Boolean;
FReverseSolution : Boolean;
{$IFDEF USINGZ}
- fDefaultZ : Int64;
+ fDefaultZ : Ztype;
fZCallback : TZCallback64;
{$ENDIF}
procedure Reset;
@@ -287,7 +287,7 @@ TClipperBase = class
{$IFDEF USINGZ}
procedure SetZ( e1, e2: PActive; var intersectPt: TPoint64);
property ZCallback : TZCallback64 read fZCallback write fZCallback;
- property DefaultZ : Int64 read fDefaultZ write fDefaultZ;
+ property DefaultZ : Ztype read fDefaultZ write fDefaultZ;
{$ENDIF}
property Succeeded : Boolean read FSucceeded;
public
@@ -372,8 +372,7 @@ TClipperD = class(TClipperBase) // for floating point coordinates
FInvScale: double;
{$IFDEF USINGZ}
fZCallback : TZCallbackD;
- procedure ZCB(const bot1, top1, bot2, top2: TPoint64;
- var intersectPt: TPoint64);
+ procedure ZCB(const bot1, top1, bot2, top2: TPoint64; var intersectPt: TPoint64);
procedure CheckCallback;
{$ENDIF}
public
@@ -900,7 +899,7 @@ function PointInOpPolygon(const pt: TPoint64; op: POutPt): TPointInPolygonResult
while (op2 <> op) and (op2.pt.Y > pt.Y) do op2 := op2.next;
if (op2 = op) then break;
- // must have touched or crossed the pt.Y horizonal
+ // must have touched or crossed the pt.Y horizontal
// and this must happen an even number of times
if (op2.pt.Y = pt.Y) then // touching the horizontal
@@ -1017,6 +1016,11 @@ procedure AddPathsToVertexList(const paths: TPaths64;
GetMem(v, sizeof(TVertex) * totalVerts);
vertexList.Add(v);
+ {$IF not defined(FPC) and (CompilerVersion <= 26.0)}
+ // Delphi 7-XE5 have a problem with "continue" and the
+ // code analysis, marking "ascending" as "not initialized"
+ ascending := False;
+ {$IFEND}
for i := 0 to High(paths) do
begin
len := Length(paths[i]);
@@ -2559,9 +2563,8 @@ procedure TClipperBase.IntersectEdges(e1, e2: PActive; pt: TPoint64);
var
e1WindCnt, e2WindCnt, e1WindCnt2, e2WindCnt2: Integer;
e3: PActive;
- resultOp, op2: POutPt;
+ op, op2: POutPt;
begin
- resultOp := nil;
// MANAGE OPEN PATH INTERSECTIONS SEPARATELY ...
if FHasOpenPaths and (IsOpen(e1) or IsOpen(e2)) then
begin
@@ -2586,7 +2589,7 @@ procedure TClipperBase.IntersectEdges(e1, e2: PActive; pt: TPoint64);
// toggle contribution ...
if IsHotEdge(e1) then
begin
- resultOp := AddOutPt(e1, pt);
+ op := AddOutPt(e1, pt);
if IsFront(e1) then
e1.outrec.frontE := nil else
e1.outrec.backE := nil;
@@ -2610,12 +2613,12 @@ procedure TClipperBase.IntersectEdges(e1, e2: PActive; pt: TPoint64);
SetSides(e3.outrec, e3, e1);
Exit;
end else
- resultOp := StartOpenPath(e1, pt);
+ op := StartOpenPath(e1, pt);
end else
- resultOp := StartOpenPath(e1, pt);
+ op := StartOpenPath(e1, pt);
{$IFDEF USINGZ}
- SetZ(e1, e2, resultOp.pt);
+ SetZ(e1, e2, op.pt);
{$ENDIF}
Exit;
end;
@@ -2679,20 +2682,20 @@ procedure TClipperBase.IntersectEdges(e1, e2: PActive; pt: TPoint64);
if not (e1WindCnt in [0,1]) or not (e2WindCnt in [0,1]) or
(not IsSamePolyType(e1, e2) and (fClipType <> ctXor)) then
begin
- resultOp := AddLocalMaxPoly(e1, e2, pt);
+ op := AddLocalMaxPoly(e1, e2, pt);
{$IFDEF USINGZ}
- if Assigned(Result) then SetZ(e1, e2, Result.pt);
+ if Assigned(op) then SetZ(e1, e2, op.pt);
{$ENDIF}
end else if IsFront(e1) or (e1.outrec = e2.outrec) then
begin
// this 'else if' condition isn't strictly needed but
- // it's sensible to split polygons that ony touch at
+ // it's sensible to split polygons that only touch at
// a common vertex (not at common edges).
- resultOp := AddLocalMaxPoly(e1, e2, pt);
+ op := AddLocalMaxPoly(e1, e2, pt);
{$IFDEF USINGZ}
op2 := AddLocalMinPoly(e1, e2, pt);
- if Assigned(Result) then SetZ(e1, e2, Result.pt);
+ if Assigned(op) then SetZ(e1, e2, op.pt);
SetZ(e1, e2, op2.pt);
{$ELSE}
AddLocalMinPoly(e1, e2, pt);
@@ -2700,10 +2703,10 @@ procedure TClipperBase.IntersectEdges(e1, e2: PActive; pt: TPoint64);
end else
begin
// can't treat as maxima & minima
- resultOp := AddOutPt(e1, pt);
+ op := AddOutPt(e1, pt);
{$IFDEF USINGZ}
op2 := AddOutPt(e2, pt);
- SetZ(e1, e2, Result.pt);
+ SetZ(e1, e2, op.pt);
SetZ(e1, e2, op2.pt);
{$ELSE}
AddOutPt(e2, pt);
@@ -2715,17 +2718,17 @@ procedure TClipperBase.IntersectEdges(e1, e2: PActive; pt: TPoint64);
// if one or other edge is 'hot' ...
else if IsHotEdge(e1) then
begin
- resultOp := AddOutPt(e1, pt);
+ op := AddOutPt(e1, pt);
{$IFDEF USINGZ}
- SetZ(e1, e2, Result.pt);
+ SetZ(e1, e2, op.pt);
{$ENDIF}
SwapOutRecs(e1, e2);
end
else if IsHotEdge(e2) then
begin
- resultOp := AddOutPt(e2, pt);
+ op := AddOutPt(e2, pt);
{$IFDEF USINGZ}
- SetZ(e1, e2, Result.pt);
+ SetZ(e1, e2, op.pt);
{$ENDIF}
SwapOutRecs(e1, e2);
end
@@ -2753,32 +2756,32 @@ procedure TClipperBase.IntersectEdges(e1, e2: PActive; pt: TPoint64);
if not IsSamePolyType(e1, e2) then
begin
- resultOp := AddLocalMinPoly(e1, e2, pt, false);
+ op := AddLocalMinPoly(e1, e2, pt, false);
{$IFDEF USINGZ}
- SetZ(e1, e2, Result.pt);
+ SetZ(e1, e2, op.pt);
{$ENDIF}
end
else if (e1WindCnt = 1) and (e2WindCnt = 1) then
begin
- resultOp := nil;
+ op := nil;
case FClipType of
ctIntersection:
if (e1WindCnt2 <= 0) or (e2WindCnt2 <= 0) then Exit
- else resultOp := AddLocalMinPoly(e1, e2, pt, false);
+ else op := AddLocalMinPoly(e1, e2, pt, false);
ctUnion:
if (e1WindCnt2 <= 0) and (e2WindCnt2 <= 0) then
- resultOp := AddLocalMinPoly(e1, e2, pt, false);
+ op := AddLocalMinPoly(e1, e2, pt, false);
ctDifference:
if ((GetPolyType(e1) = ptClip) and
(e1WindCnt2 > 0) and (e2WindCnt2 > 0)) or
((GetPolyType(e1) = ptSubject) and
(e1WindCnt2 <= 0) and (e2WindCnt2 <= 0)) then
- resultOp := AddLocalMinPoly(e1, e2, pt, false);
+ op := AddLocalMinPoly(e1, e2, pt, false);
else // xOr
- resultOp := AddLocalMinPoly(e1, e2, pt, false);
+ op := AddLocalMinPoly(e1, e2, pt, false);
end;
{$IFDEF USINGZ}
- if assigned(Result) then SetZ(e1, e2, Result.pt);
+ if assigned(op) then SetZ(e1, e2, op.pt);
{$ENDIF}
end;
end;
@@ -2842,7 +2845,7 @@ procedure TClipperBase.ExecuteInternal(clipType: TClipType;
Y: Int64;
e: PActive;
begin
- if clipType = ctNone then Exit;
+ if clipType = ctNoClip then Exit;
FFillRule := fillRule;
FClipType := clipType;
Reset;
@@ -3525,7 +3528,7 @@ procedure TClipperBase.DoHorizontal(horzEdge: PActive);
end;
if IsHotEdge(horzEdge) then
begin
- //nb: The outrec containining the op returned by IntersectEdges
+ //nb: The outrec containing the op returned by IntersectEdges
//above may no longer be associated with horzEdge.
FHorzSegList.Add(GetLastOp(horzEdge));
end;
diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.Minkowski.pas b/Ext/SVGIconImageList/Image32/source/Clipper.Minkowski.pas
index bacb3ea..d2e9705 100644
--- a/Ext/SVGIconImageList/Image32/source/Clipper.Minkowski.pas
+++ b/Ext/SVGIconImageList/Image32/source/Clipper.Minkowski.pas
@@ -5,7 +5,7 @@
* Date : 21 December 2023 *
* Copyright : Angus Johnson 2010-2022 *
* Purpose : Minkowski Addition and Difference *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
{$I Clipper.inc}
diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.Offset.pas b/Ext/SVGIconImageList/Image32/source/Clipper.Offset.pas
index 3fd9e9a..e9c474b 100644
--- a/Ext/SVGIconImageList/Image32/source/Clipper.Offset.pas
+++ b/Ext/SVGIconImageList/Image32/source/Clipper.Offset.pas
@@ -2,11 +2,11 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Date : 17 April 2024 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2010-2024 *
+* Date : 22 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2010-2025 *
* Purpose : Path Offset (Inflate/Shrink) *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
{$I Clipper.inc}
@@ -72,13 +72,14 @@ TClipperOffset = class
fZCallback64 : TZCallback64;
procedure ZCB(const bot1, top1, bot2, top2: TPoint64;
var intersectPt: TPoint64);
- procedure AddPoint(x,y: double; z: Int64); overload;
+ procedure AddPoint(x,y: double; z: ZType); overload;
procedure AddPoint(const pt: TPoint64); overload;
{$IFDEF INLINING} inline; {$ENDIF}
- procedure AddPoint(const pt: TPoint64; newZ: Int64); overload;
+ procedure AddPoint(const pt: TPoint64; newZ: ZType); overload;
{$IFDEF INLINING} inline; {$ENDIF}
{$ELSE}
procedure AddPoint(x,y: double); overload;
+
procedure AddPoint(const pt: TPoint64); overload;
{$IFDEF INLINING} inline; {$ENDIF}
{$ENDIF}
@@ -141,6 +142,20 @@ implementation
TwoPi : Double = 2 * PI;
InvTwoPi : Double = 1/(2 * PI);
+// Clipper2 approximates arcs by using series of relatively short straight
+//line segments. And logically, shorter line segments will produce better arc
+// approximations. But very short segments can degrade performance, usually
+// with little or no discernable improvement in curve quality. Very short
+// segments can even detract from curve quality, due to the effects of integer
+// rounding. Since there isn't an optimal number of line segments for any given
+// arc radius (that perfectly balances curve approximation with performance),
+// arc tolerance is user defined. Nevertheless, when the user doesn't define
+// an arc tolerance (ie leaves alone the 0 default value), the calculated
+// default arc tolerance (offset_radius / 500) generally produces good (smooth)
+// arc approximations without producing excessively small segment lengths.
+// See also: https://www.angusj.com/clipper2/Docs/Trigonometry.htm
+const arc_const = 0.002; // <-- 1/500
+
//------------------------------------------------------------------------------
// Miscellaneous offset support functions
//------------------------------------------------------------------------------
@@ -363,13 +378,12 @@ procedure TClipperOffset.DoGroupOffset(group: TGroup);
if (group.joinType = jtRound) or (group.endType = etRound) then
begin
// calculate the number of steps required to approximate a circle
- // (see http://www.angusj.com/clipper2/Docs/Trigonometry.htm)
+ // (see https://www.angusj.com/clipper2/Docs/Trigonometry.htm)
// arcTol - when arc_tolerance_ is undefined (0) then curve imprecision
// will be relative to the size of the offset (delta). Obviously very
//large offsets will almost always require much less precision.
- arcTol := Iif(fArcTolerance > 0.01,
- Min(absDelta, fArcTolerance),
- Log10(2 + absDelta) * 0.25); // empirically derived
+ arcTol := Iif(fArcTolerance > 0.0,
+ Min(absDelta, fArcTolerance), absDelta * arc_const);
stepsPer360 := Pi / ArcCos(1 - arcTol / absDelta);
if (stepsPer360 > absDelta * Pi) then
@@ -447,6 +461,7 @@ procedure TClipperOffset.BuildNormals;
begin
len := Length(fInPath);
SetLength(fNorms, len);
+ if len = 0 then Exit;
for i := 0 to len-2 do
fNorms[i] := GetUnitNormal(fInPath[i], fInPath[i+1]);
fNorms[len -1] := GetUnitNormal(fInPath[len -1], fInPath[0]);
@@ -694,7 +709,7 @@ procedure TClipperOffset.ZCB(const bot1, top1, bot2, top2: TPoint64;
//------------------------------------------------------------------------------
{$IFDEF USINGZ}
-procedure TClipperOffset.AddPoint(x,y: double; z: Int64);
+procedure TClipperOffset.AddPoint(x,y: double; z: ZType);
{$ELSE}
procedure TClipperOffset.AddPoint(x,y: double);
{$ENDIF}
@@ -718,7 +733,7 @@ procedure TClipperOffset.AddPoint(x,y: double);
//------------------------------------------------------------------------------
{$IFDEF USINGZ}
-procedure TClipperOffset.AddPoint(const pt: TPoint64; newZ: Int64);
+procedure TClipperOffset.AddPoint(const pt: TPoint64; newZ: ZType);
begin
AddPoint(pt.X, pt.Y, newZ);
end;
@@ -743,7 +758,7 @@ function IntersectPoint(const ln1a, ln1b, ln2a, ln2b: TPointD): TPointD;
m1,b1,m2,b2: double;
begin
result := NullPointD;
- //see http://astronomy.swin.edu.au/~pbourke/geometry/lineline2d/
+ //see https://paulbourke.net/geometry/pointlineplane/#i2l
if (ln1B.X = ln1A.X) then
begin
if (ln2B.X = ln2A.X) then exit; //parallel lines
@@ -915,10 +930,8 @@ procedure TClipperOffset.DoRound(j, k: Integer; angle: double);
// when fDeltaCallback64 is assigned, fGroupDelta won't be constant,
// so we'll need to do the following calculations for *every* vertex.
absDelta := Abs(fGroupDelta);
- arcTol := Iif(fArcTolerance > 0.01,
- Min(absDelta, fArcTolerance),
- Log10(2 + absDelta) * 0.25); // empirically derived
- //http://www.angusj.com/clipper2/Docs/Trigonometry.htm
+ arcTol := Iif(fArcTolerance > 0.0,
+ Min(absDelta, fArcTolerance), absDelta * arc_const);
stepsPer360 := Pi / ArcCos(1 - arcTol / absDelta);
if (stepsPer360 > absDelta * Pi) then
stepsPer360 := absDelta * Pi; // avoid excessive precision
@@ -988,19 +1001,18 @@ procedure TClipperOffset.DoRound(j, k: Integer; angle: double);
if (cosA > -0.999) and (sinA * fGroupDelta < 0) then
begin
// is concave
+ // by far the simplest way to construct concave joins, especially those
+ // joining very short segments, is to insert 3 points that produce negative
+ // regions. These regions will be removed later by the finishing union
+ // operation. This is also the best way to ensure that path reversals
+ // (ie over-shrunk paths) are removed.
{$IFDEF USINGZ}
AddPoint(GetPerpendic(fInPath[j], fNorms[k], fGroupDelta), fInPath[j].Z);
-{$ELSE}
- AddPoint(GetPerpendic(fInPath[j], fNorms[k], fGroupDelta));
-{$ENDIF}
- // this extra point is the only simple way to ensure that path reversals
- // (ie over-shrunk paths) are fully cleaned out with the trailing union op.
- // However it's probably safe to skip this whenever an angle is almost flat.
- if (cosA < 0.99) then
- AddPoint(fInPath[j]); // (#405)
-{$IFDEF USINGZ}
+ AddPoint(fInPath[j]); // (#405, #873)
AddPoint(GetPerpendic(fInPath[j], fNorms[j], fGroupDelta), fInPath[j].Z);
{$ELSE}
+ AddPoint(GetPerpendic(fInPath[j], fNorms[k], fGroupDelta));
+ AddPoint(fInPath[j]); // (#405, #873)
AddPoint(GetPerpendic(fInPath[j], fNorms[j], fGroupDelta));
{$ENDIF}
end
diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.RectClip.pas b/Ext/SVGIconImageList/Image32/source/Clipper.RectClip.pas
index 8a0cf05..a6898ba 100644
--- a/Ext/SVGIconImageList/Image32/source/Clipper.RectClip.pas
+++ b/Ext/SVGIconImageList/Image32/source/Clipper.RectClip.pas
@@ -2,11 +2,11 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Date : 27 April 2024 *
-* Website : http://www.angusj.com *
+* Date : 5 July 2024 *
+* Website : https://www.angusj.com *
* Copyright : Angus Johnson 2010-2024 *
* Purpose : FAST rectangular clipping *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -650,9 +650,28 @@ function TRectClip64.Execute(const paths: TPaths64): TPaths64;
end;
//------------------------------------------------------------------------------
+function StartLocsAreClockwise(const startLocs: TList): Boolean;
+var
+ i,j, res: integer;
+begin
+ res := 0;
+ for i := 1 to startLocs.Count -1 do
+ begin
+ j := Ord(TLocation(startLocs[i])) - Ord(TLocation(startLocs[i - 1]));
+ case j of
+ -1: dec(res);
+ 1: inc(res);
+ -3: inc(res);
+ 3: dec(res);
+ end;
+ end;
+ result := res > 0;
+end;
+//------------------------------------------------------------------------------
+
procedure TRectClip64.ExecuteInternal(const path: TPath64);
var
- i,highI : integer;
+ i,j, highI : integer;
prevPt,ip,ip2 : TPoint64;
loc, prevLoc : TLocation;
loc2 : TLocation;
@@ -661,6 +680,7 @@ procedure TRectClip64.ExecuteInternal(const path: TPath64);
crossingLoc : TLocation;
prevCrossLoc : TLocation;
isCw : Boolean;
+ startLocsCW : Boolean;
begin
if (Length(path) < 3) then Exit;
fStartLocs.Clear;
@@ -797,10 +817,12 @@ procedure TRectClip64.ExecuteInternal(const path: TPath64);
begin
// yep, the path does fully contain rect
// so add rect to the solution
+ startLocsCW := StartLocsAreClockwise(fStartLocs);
for i := 0 to 3 do
begin
- Add(fRectPath[i]);
- AddToEdge(fEdges[i*2], fResults[0]);
+ if startLocsCW then j := i else j := 3 - i;
+ Add(fRectPath[j]);
+ AddToEdge(fEdges[j*2], fResults[0]);
end;
end;
end;
diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.inc b/Ext/SVGIconImageList/Image32/source/Clipper.inc
index 5b15f92..17da40d 100644
--- a/Ext/SVGIconImageList/Image32/source/Clipper.inc
+++ b/Ext/SVGIconImageList/Image32/source/Clipper.inc
@@ -7,7 +7,7 @@
{.$DEFINE USINGZ}
///////////////////////////////////////////////////////////////////////////////
-//COMPILER DIFINED PREPROCESSOR DIRECTIVES (ie. do not touch ;))
+//COMPILER DEFINED PREPROCESSOR DIRECTIVES (ie. do not touch ;))
///////////////////////////////////////////////////////////////////////////////
{$IFDEF FPC}
diff --git a/Ext/SVGIconImageList/Image32/source/Clipper.pas b/Ext/SVGIconImageList/Image32/source/Clipper.pas
index 0c2fe87..09a33f4 100644
--- a/Ext/SVGIconImageList/Image32/source/Clipper.pas
+++ b/Ext/SVGIconImageList/Image32/source/Clipper.pas
@@ -3,10 +3,10 @@
(*******************************************************************************
* Author : Angus Johnson *
* Date : 7 May 2024 *
-* Website : http://www.angusj.com *
+* Website : https://www.angusj.com *
* Copyright : Angus Johnson 2010-2024 *
* Purpose : This module provides a simple interface to the Clipper Library *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -52,7 +52,7 @@ interface
etSquare = Clipper.Offset.etSquare;
etRound = Clipper.Offset.etRound;
- ctNone = Clipper.Core.ctNone;
+ ctNone = Clipper.Core.ctNoClip;
ctIntersection = Clipper.Core.ctIntersection;
ctUnion = Clipper.Core.ctUnion;
ctDifference = Clipper.Core.ctDifference;
@@ -821,7 +821,7 @@ function DistanceSqrd(const pt1, pt2: TPoint64): double;
var
x1,y1,x2,y2: double;
begin
- // nb: older versions of Delphi don't allow explicit typcasting
+ // nb: older versions of Delphi don't allow explicit typecasting
x1 := pt1.X; y1 := pt1.Y;
x2 := pt2.X; y2 := pt2.Y;
result := Sqr(x1 - x2) + Sqr(y1 - y2);
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas b/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas
index 8acea08..2fae705 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas
@@ -2,13 +2,13 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 10 April 2024 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2024 *
+* Version : 4.7 *
+* Date : 6 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : Color reduction for TImage32 *
* : Uses Octree Color Quantization & Floyd / Steinberg Dithering *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -39,7 +39,7 @@ TColFreqRec = record
// https://web.archive.org/web/20140605161956/
// http://www.microsoft.com/msj/archive/S3F1.aspx
- TReduceType = (rtSimple, rtMedianCut, rtFrequency, rtMixed);
+ TReduceType = (rtSimple, rtMedianCut, rtFrequency);
TOctree = class;
TOctNodes8 = array[0 .. 7] of TOctNode;
@@ -71,11 +71,12 @@ TOctNode = class
TOctree = class
private
- fLeaves : cardinal;
+ fLeafCount : cardinal;
fTop : TOctNode;
ColorPxlCnt : integer;
fReducible8 : TOctNodes8;
fReduceType : TReduceType;
+ procedure AddInternal(color: TColor32; var node: TOctNode);
procedure Delete(var node: TOctNode);
procedure Add(color: TColor32);
procedure GetNodeColor(var color: TColor32);
@@ -83,8 +84,7 @@ TOctree = class
function ReduceOne: Boolean;
protected
function BasicReduce(palSize: cardinal): TArrayOfColor32;
- procedure FrequencyCut(palSize: integer; var cfArr: TArrayOfColFreq);
- procedure MedianCut(palSize, arrLen: integer; var cfArr: TArrayOfColFreq);
+ procedure MedianCut(palSize: integer; var cfArr: TArrayOfColFreq);
public
constructor Create;
destructor Destroy; override;
@@ -92,7 +92,7 @@ TOctree = class
procedure BuildTree(image: TImage32);
procedure ApplyPalette(image: TImage32);
function GetColorFreqArray: TArrayOfColFreq;
- property ColorCount: cardinal read fLeaves;
+ property ColorCount: cardinal read fLeafCount;
// PixelCount: = Sum( leaves[ 0 .. n-1 ].Count )
// and semi-transparent pixels aren't counted
property PixelCount: integer read ColorPxlCnt;
@@ -101,7 +101,7 @@ TOctree = class
function ReduceImage(image: TImage32; maxColors: Cardinal;
useDithering: Boolean = true; reduceType: TReduceType = rtMedianCut): TArrayOfColor32;
-function CreatePaletteOctree(image: TImage32; reduceType: TReduceType = rtMixed): TOctree;
+function CreatePaletteOctree(image: TImage32; reduceType: TReduceType = rtMedianCut): TOctree;
{$IFDEF MSWINDOWS}
function CreateLogPalette(const palColors: TArrayOfColor32): TMaxLogPalette;
@@ -424,6 +424,18 @@ procedure MedianCutInternal(var cfArr: TArrayOfColFreq;
MedianCutInternal(cfArr, ints, idx, sizeAdjust, start, mid-1, level);
MedianCutInternal(cfArr, ints, idx, sizeAdjust, mid, finish, level);
end;
+//------------------------------------------------------------------------------
+
+procedure FrequencyCut(palSize: integer; var cfArr: TArrayOfColFreq);
+var
+ i,len : integer;
+begin
+ len := Length(cfArr); // total colors in octree
+ if palSize >= len then Exit;
+ PaletteSort(cfArr, 0, len -1, PalSortDescending);
+ for i := palSize to len -1 do
+ cfArr[i].freq := 0;
+end;
//------------------------------------------------------------------------------
// TOctNode methods
@@ -562,21 +574,10 @@ procedure TOctNode.GetNodeColor(var color: TColor32);
//------------------------------------------------------------------------------
function TOctNode.GetColor: TColor32;
-var
- argb: TARGB absolute Result;
begin
if palColor = UnassignedColor then
- begin
- argb.R := TotalR;
- argb.G := TotalG;
- argb.B := TotalB;
- argb.A := 255;
- palColor := Result;
- end else
- begin
- Result := palColor;
- end;
-
+ palColor := Color32(255, TotalR, TotalG, TotalB);
+ Result := palColor;
end;
//------------------------------------------------------------------------------
@@ -586,7 +587,7 @@ function TOctNode.GetColor: TColor32;
constructor TOctree.Create;
begin
fReduceType := rtMedianCut;
- fLeaves := 0;
+ fLeafCount := 0;
fTop := TOctNode.Create(0);
fReducible8 := NullOctNodes8;
end;
@@ -613,7 +614,7 @@ procedure TOctree.Delete(var node: TOctNode);
procedure TOctree.Reset;
begin
if Assigned(fTop) then Delete(fTop);
- fLeaves := 0;
+ fLeafCount := 0;
fTop := TOctNode.Create(0);
fReducible8 := NullOctNodes8;
end;
@@ -683,13 +684,14 @@ function TOctree.ReduceOne: Boolean;
end;
node.Add(wc.Color);
inc(node.Count, wc.Weight -1);
- Dec(fLeaves, childCnt -1);
+ Dec(fLeafCount, childCnt -1);
end;
//------------------------------------------------------------------------------
-procedure TOctree.MedianCut(palSize, arrLen: integer; var cfArr: TArrayOfColFreq);
+procedure TOctree.MedianCut(palSize: integer; var cfArr: TArrayOfColFreq);
var
i,j : integer;
+ arrLen : integer;
sizeAdjust: cardinal;
idxArrLen : integer;
idxArr : TArrayOfInteger;
@@ -699,6 +701,7 @@ procedure TOctree.MedianCut(palSize, arrLen: integer; var cfArr: TArrayOfColFreq
// precondition: palSize == 2^n
SetLength(idxArr, palSize +1);
idxArrLen := 0; sizeAdjust := 0;
+ arrLen := Length(cfArr);
MedianCutInternal(cfArr, idxArr, idxArrLen, sizeAdjust, 0, arrLen -1, palSize);
idxArr[idxArrLen] := arrLen;
@@ -722,19 +725,7 @@ procedure TOctree.MedianCut(palSize, arrLen: integer; var cfArr: TArrayOfColFreq
end;
//------------------------------------------------------------------------------
-procedure TOctree.FrequencyCut(palSize: integer; var cfArr: TArrayOfColFreq);
-var
- i,len : integer;
-begin
- len := Length(cfArr); // total colors in octree
- if palSize >= len then Exit;
- PaletteSort(cfArr, 0, len -1, PalSortDescending);
- for i := palSize to len -1 do
- cfArr[i].freq := 0;
-end;
-//------------------------------------------------------------------------------
-
-procedure AddColor(octree: TOctree; color: TColor32; var node: TOctNode);
+procedure TOctree.AddInternal(color: TColor32; var node: TOctNode);
var
idx, level: integer;
child: TOctNode;
@@ -749,25 +740,25 @@ procedure AddColor(octree: TOctree; color: TColor32; var node: TOctNode);
if child.IsLeaf then
begin
child.Add(color);
- Inc(octree.fLeaves);
+ Inc(fLeafCount);
end else
begin
- child.Next := octree.fReducible8[level];
- octree.fReducible8[level] := child;
- AddColor(octree, color, child);
+ child.Next := fReducible8[level];
+ fReducible8[level] := child;
+ AddInternal(color, child);
end;
end
else if child.IsLeaf then
child.Add(color)
else
- AddColor(octree, color, child);
+ AddInternal(color, child);
end;
//------------------------------------------------------------------------------
procedure TOctree.Add(color: TColor32);
begin
inc(ColorPxlCnt);
- AddColor(self, color, fTop);
+ AddInternal(color, fTop);
end;
//------------------------------------------------------------------------------
@@ -802,7 +793,7 @@ procedure TOctree.GetTreePalette(out colors: TArrayOfColor32);
end;
begin
- SetLength(colors, fLeaves);
+ SetLength(colors, fLeafCount);
count := 0;
FillPalette(fTop);
end;
@@ -831,7 +822,7 @@ function TOctree.GetColorFreqArray: TArrayOfColFreq;
end;
begin
- SetLength(Result, fLeaves);
+ SetLength(Result, fLeafCount);
count := 0;
FillPalette(fTop);
end;
@@ -876,7 +867,7 @@ function SortPaletteByLuminence(const pal: TArrayOfColor32): TArrayOfColor32;
function TOctree.BasicReduce(palSize: cardinal): TArrayOfColor32;
begin
- while (fLeaves > palSize) and ReduceOne do;
+ while (fLeafCount > palSize) and ReduceOne do;
GetTreePalette(Result);
end;
@@ -994,11 +985,20 @@ function CreatePaletteOctree(image: TImage32; reduceType: TReduceType): TOctree;
function ReduceImage(image: TImage32; maxColors: Cardinal;
useDithering: Boolean; reduceType: TReduceType): TArrayOfColor32;
var
- i, len : integer;
- j : cardinal;
- octree : TOctree;
- pc : PARGB;
- cfArr : TArrayOfColFreq;
+ i : integer;
+ j : Cardinal;
+ octree : TOctree;
+ pc : PARGB;
+
+ cfArr1024 : TArrayOfColFreq;
+ cfaLen : integer;
+
+ procedure BuildColorFreqArray1024;
+ begin
+ while (octree.ColorCount > 1024) and octree.ReduceOne do ;
+ cfArr1024 := octree.GetColorFreqArray;
+ end;
+
begin
if MaxColors < 2 then
MaxColors := 1 else
@@ -1006,50 +1006,48 @@ function ReduceImage(image: TImage32; maxColors: Cardinal;
octree := CreatePaletteOctree(image, reduceType);
try
- if octree.fReduceType = rtSimple then
- begin
- Result := octree.BasicReduce(maxColors);
- octree.ApplyPalette(image);
- Exit;
- end;
-
- while (octree.ColorCount > 1024) and octree.ReduceOne do ;
- cfArr := octree.GetColorFreqArray;
- len := Length(cfArr); // total colors in octree
case octree.fReduceType of
- rtMedianCut: // mostly :)
+ rtSimple:
+ octree.BasicReduce(maxColors);
+ rtMedianCut:
begin
- octree.FrequencyCut(512, cfArr); // trim only very infrequent colors
- octree.MedianCut(maxColors, Min(len, 512), cfArr); // otherwise MC
+ BuildColorFreqArray1024;
+ octree.MedianCut(maxColors, cfArr1024);
end;
rtFrequency:
- octree.FrequencyCut(maxColors, cfArr); // trim just on frequency
- rtMixed:
begin
- octree.FrequencyCut(maxColors * 4, cfArr);
- octree.MedianCut(maxColors, Min(len, maxColors *4), cfArr);
+ BuildColorFreqArray1024;
+ FrequencyCut(maxColors, cfArr1024); // trim just on frequency
end;
end;
- // build result palette
- j := 0;
- SetLength(Result, maxColors);
- for i := 0 to len -1 do
+ // build the result palette
+ if octree.fReduceType = rtSimple then
begin
- if cfArr[i].freq > 0 then
+ octree.GetTreePalette(Result);
+ end else
+ begin
+ j := 0;
+ SetLength(Result, maxColors);
+ cfaLen := Length(cfArr1024);
+ for i := 0 to cfaLen -1 do
begin
- Result[j] := cfArr[i].color;
- inc(j);
- if j = maxColors then break;
+ if cfArr1024[i].freq > 0 then
+ begin
+ Result[j] := cfArr1024[i].color;
+ inc(j);
+ if j = maxColors then break;
+ end;
end;
- end;
- Result := SortPaletteByLuminence(Result);
+ if j < maxColors then SetLength(Result, j);
+ Result := SortPaletteByLuminence(Result);
- // update all (residual) nodes with its closest palette color match
- for i := maxColors to len -1 do
- cfArr[i].node.palColor :=
- GetNearestPaletteColor(cfArr[i].node.GetColor, Result);
+ // update all (residual) nodes with its closest palette color match
+ for i := maxColors to cfaLen -1 do
+ cfArr1024[i].node.palColor :=
+ GetNearestPaletteColor(cfArr1024[i].node.GetColor, Result);
+ end;
if useDithering then
begin
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Clipper2.pas b/Ext/SVGIconImageList/Image32/source/Img32.Clipper2.pas
index 4fa6708..eccd8dc 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Clipper2.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Clipper2.pas
@@ -2,12 +2,12 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.3 *
-* Date : 27 September 2022 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2022 *
+* Version : 4.7 *
+* Date : 6 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : Wrapper module for the Clipper library *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas b/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas
index e7b89c4..6aea69c 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas
@@ -2,30 +2,22 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 23 March 2024 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2024 *
+* Version : 4.8 *
+* Date : 2 February 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* *
* Purpose : Polygon renderer for TImage32 *
* *
* License : Use, modification & distribution is subject to *
* Boost Software License Ver 1 *
-* http://www.boost.org/LICENSE_1_0.txt *
+* https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
{$I Img32.inc}
-// MemCheck may be useful for debugging (adds a minimal cost to performance)
-{.$DEFINE MemCheck}
-
-// UseTrunc makes rendering thread safe,
-// so it's generally preferred over Round and SetRoundMode().
-// See https://github.com/AngusJohnson/Image32/issues/45
-{$DEFINE UseTrunc}
-
uses
SysUtils, Classes, Types, Math, Img32, Img32.Vector;
@@ -58,6 +50,7 @@ TCustomRenderer = class {$IFDEF ABSTRACT_CLASSES} abstract {$ENDIF}
fCurrLinePtr : Pointer;
fPixelSize : integer;
fChangeProc : TImage32ChangeProc;
+ fOpacity : Byte;
protected
procedure NotifyChange;
function Initialize(imgBase: Pointer;
@@ -67,32 +60,82 @@ TCustomRenderer = class {$IFDEF ABSTRACT_CLASSES} abstract {$ENDIF}
// RenderProc: x & y refer to pixel coords in the destination image and
// where x1 is the start (and left) and x2 is the end of the render
procedure RenderProc(x1, x2, y: integer; alpha: PByte); virtual; abstract;
+ // RenderProcSkip: is called for every skipped line block if
+ // SupportsRenderProcSkip=True and the Rasterize() function skips scanlines.
+ procedure RenderProcSkip(const skippedRect: TRect); virtual;
+ // SetClipRect is called by the Rasterize() function with the
+ // rasterization clipRect. The default implementation does nothing.
+ procedure SetClipRect(const clipRect: TRect); virtual;
+ // If SupportsRenderProcSkip returns True the Rasterize() function
+ // will call RenderProcSkip() for every scanline where it didn't have
+ // anything to rasterize.
+ function SupportsRenderProcSkip: Boolean; virtual;
+ public
+ constructor Create; virtual;
property ImgWidth: integer read fImgWidth;
property ImgHeight: integer read fImgHeight;
property ImgBase: Pointer read fImgBase;
property PixelSize: integer read fPixelSize;
+ property Opacity: Byte read fOpacity write fOpacity;
end;
- TColorRenderer = class(TCustomRenderer)
+ TCustomColorRenderer = class(TCustomRenderer)
private
- fAlpha: Byte;
fColor: TColor32;
+ protected
+ property Color: TColor32 read fColor write fColor;
+ public
+ procedure SetColor(value: TColor32); virtual;
+ end;
+
+ TColorRenderer = class(TCustomColorRenderer)
+ private
+ fAlpha: Byte;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
- constructor Create(color: TColor32 = clNone32);
- procedure SetColor(value: TColor32);
+ constructor Create(color: TColor32 = clNone32); reintroduce;
+ procedure SetColor(value: TColor32); override;
end;
- TAliasedColorRenderer = class(TCustomRenderer)
- private
- fColor: TColor32;
+ TAliasedColorRenderer = class(TCustomColorRenderer)
protected
function Initialize(targetImage: TImage32): Boolean; override;
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
public
- constructor Create(color: TColor32 = clNone32);
+ constructor Create(color: TColor32 = clNone32); reintroduce;
+ end;
+
+ // TMaskRenderer masks all pixels inside the clipRect area
+ // where the alpha[]-array is zero.
+ TMaskRenderer = class(TCustomRenderer)
+ private
+ fClipRect: TRect;
+ protected
+ procedure SetClipRect(const clipRect: TRect); override;
+ procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
+ procedure RenderProcSkip(const skippedRect: TRect); override;
+ function SupportsRenderProcSkip: Boolean; override;
+ end;
+
+ // TCustomRendererCache is used to not create Renderer
+ // objects for every DrawPolygon/DrawLine function call. The color
+ // of the TCustomColorRenderer will be changed by the DrawPolygon/
+ // DrawLine method.
+ TCustomRendererCache = class(TObject)
+ private
+ fColorRenderer: TColorRenderer;
+ fAliasedColorRenderer: TAliasedColorRenderer;
+ fMaskRenderer: TMaskRenderer;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ function GetColorRenderer(color: TColor32): TColorRenderer;
+
+ property ColorRenderer: TColorRenderer read fColorRenderer;
+ property AliasedColorRenderer: TAliasedColorRenderer read fAliasedColorRenderer;
+ property MaskRenderer: TMaskRenderer read fMaskRenderer;
end;
TEraseRenderer = class(TCustomRenderer)
@@ -101,8 +144,15 @@ TEraseRenderer = class(TCustomRenderer)
end;
TInverseRenderer = class(TCustomRenderer)
+ private
+ fBackImage : TImage32;
+ fCurrBackY : integer;
+ fCurrBkLinePtr : Pointer;
protected
+ function GetSrcPixel(x, y: integer): Pointer;
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
+ public
+ constructor Create(bkImg: TImage32 = nil); reintroduce;
end;
TImageRenderer = class(TCustomRenderer)
@@ -113,13 +163,13 @@ TImageRenderer = class(TCustomRenderer)
fLastYY : integer;
fMirrorY : Boolean;
fBoundsProc : TBoundsProc;
- function GetFirstBrushPixel(x, y: integer): PARGB;
+ function GetFirstBrushPixel(x, y: integer): PColor32;
protected
procedure RenderProc(x1, x2, y: integer; alpha: PByte); override;
function Initialize(targetImage: TImage32): Boolean; override;
public
constructor Create(tileFillStyle: TTileFillStyle = tfsRepeat;
- brushImage: TImage32 = nil);
+ brushImage: TImage32 = nil); reintroduce;
destructor Destroy; override;
procedure SetTileFillStyle(value: TTileFillStyle);
property Image: TImage32 read fImage;
@@ -136,7 +186,7 @@ TCustomGradientRenderer = class(TCustomRenderer)
fColorsCnt : integer;
procedure SetGradientFillStyle(value: TGradientFillStyle); virtual;
public
- constructor Create;
+ constructor Create; override;
procedure SetParameters(startColor, endColor: TColor32;
gradFillStyle: TGradientFillStyle = gfsClamp); virtual;
procedure InsertColorStop(offsetFrac: double; color: TColor32);
@@ -224,6 +274,11 @@ TBarycentricRenderer = class(TCustomRenderer)
const line: TPathD; lineWidth: double; color: TColor32;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
miterLimit: double = 2); overload;
+ procedure DrawLine(img: TImage32;
+ const line: TPathD; lineWidth: double; color: TColor32;
+ rendererCache: TCustomRendererCache;
+ endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
+ miterLimit: double = 2); overload;
procedure DrawLine(img: TImage32;
const line: TPathD; lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
@@ -232,6 +287,10 @@ TBarycentricRenderer = class(TCustomRenderer)
lineWidth: double; color: TColor32;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
miterLimit: double = 2); overload;
+ procedure DrawLine(img: TImage32; const lines: TPathsD;
+ lineWidth: double; color: TColor32; rendererCache: TCustomRendererCache;
+ endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
+ miterLimit: double = 2); overload;
procedure DrawLine(img: TImage32; const lines: TPathsD;
lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
@@ -245,30 +304,42 @@ TBarycentricRenderer = class(TCustomRenderer)
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawDashedLine(img: TImage32; const line: TPathD;
- dashPattern: TArrayOfInteger; patternOffset: PDouble;
+ dashPattern: TArrayOfDouble; patternOffset: PDouble;
lineWidth: double; color: TColor32;
- endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
+ endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
+ rendererCache: TCustomRendererCache = nil); overload;
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
- dashPattern: TArrayOfInteger; patternOffset: PDouble;
+ dashPattern: TArrayOfDouble; patternOffset: PDouble;
lineWidth: double; color: TColor32; endStyle: TEndStyle;
- joinStyle: TJoinStyle = jsAuto); overload;
+ joinStyle: TJoinStyle = jsAuto;
+ rendererCache: TCustomRendererCache = nil); overload;
procedure DrawDashedLine(img: TImage32; const line: TPathD;
- dashPattern: TArrayOfInteger; patternOffset: PDouble;
+ dashPattern: TArrayOfDouble; patternOffset: PDouble;
lineWidth: double; renderer: TCustomRenderer; endStyle: TEndStyle;
joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
- dashPattern: TArrayOfInteger; patternOffset: PDouble;
+ dashPattern: TArrayOfDouble; patternOffset: PDouble;
lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawInvertedDashedLine(img: TImage32;
- const line: TPathD; dashPattern: TArrayOfInteger;
+ const line: TPathD; dashPattern: TArrayOfDouble;
patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawInvertedDashedLine(img: TImage32;
- const lines: TPathsD; dashPattern: TArrayOfInteger;
- patternOffset: PDouble; lineWidth: double;
- endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto); overload;
+ const lines: TPathsD; dashPattern: TArrayOfDouble;
+ patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
+ joinStyle: TJoinStyle = jsAuto); overload;
+ // bkgndImg - an alternative background image
+ // (useful when drawing on a layered image)
+ procedure DrawInvertedDashedLine(img, bkgndImg: TImage32;
+ const line: TPathD; dashPattern: TArrayOfDouble;
+ patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
+ joinStyle: TJoinStyle = jsAuto); overload;
+ procedure DrawInvertedDashedLine(img, bkgndImg: TImage32;
+ const lines: TPathsD; dashPattern: TArrayOfDouble;
+ patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
+ joinStyle: TJoinStyle = jsAuto); overload;
procedure DrawPolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; color: TColor32); overload;
@@ -276,6 +347,9 @@ TBarycentricRenderer = class(TCustomRenderer)
fillRule: TFillRule; renderer: TCustomRenderer); overload;
procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32); overload;
+ procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
+ fillRule: TFillRule; color: TColor32;
+ rendererCache: TCustomRendererCache); overload;
procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; renderer: TCustomRenderer); overload;
@@ -297,6 +371,13 @@ TBarycentricRenderer = class(TCustomRenderer)
// MISCELLANEOUS FUNCTIONS
// /////////////////////////////////////////////////////////////////////////
+ procedure EraseLine(img: TImage32; const line: TPathD; lineWidth: double;
+ endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
+ miterLimit: double = 2); overload;
+ procedure EraseLine(img: TImage32; const lines: TPathsD; lineWidth: double;
+ endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto;
+ miterLimit: double = 2); overload;
+
procedure ErasePolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule); overload;
procedure ErasePolygon(img: TImage32; const polygons: TPathsD;
@@ -310,28 +391,31 @@ TBarycentricRenderer = class(TCustomRenderer)
const mask: TArrayOfByte; color: TColor32 = clBlack32);
procedure Rasterize(const paths: TPathsD;
- const clipRec: TRect; fillRule: TFillRule; renderer: TCustomRenderer);
+ const clipRec: TRect; fillRule: TFillRule; renderer: TCustomRenderer); overload;
+ procedure Rasterize(img: TImage32; const paths: TPathsD;
+ const clipRec: TRect; fillRule: TFillRule; renderer: TCustomRenderer); overload;
implementation
-{$IFDEF MemCheck}
-resourcestring
- sMemCheckError = 'Img32.Draw: Memory allocation error';
-{$ENDIF}
+{$IFDEF CPUX86}
+const
+ // Use faster Trunc for x86 code in this unit.
+ Trunc: function(Value: Double): Integer = __Trunc;
+{$ENDIF CPUX86}
type
// A horizontal scanline contains any number of line fragments. A fragment
// can be a number of pixels wide but it can't be more than one pixel high.
- // TFragment = record
- // botX, topX, dy, dydx: double; // ie x at bottom and top of scanline
- // end;
+ PFragment = ^TFragment;
+ TFragment = record
+ botX, topX, dy, dydx: double; // ie x at bottom and top of scanline
+ end;
TScanLine = record
Y: integer;
minX, maxX: integer;
fragCnt: integer;
- {$IFDEF MemCheck} total: integer; {$ENDIF}
fragOffset: integer;
end;
PScanline = ^TScanline;
@@ -446,16 +530,35 @@ function GetPixel(current: PARGB; delta: integer): PARGB;
end;
// ------------------------------------------------------------------------------
-function ReverseColors(const colors: TArrayOfGradientColor): TArrayOfGradientColor;
+// Here "const" is used for optimization reasons, to skip the
+// dyn-array reference counting. "const" for dyn-arrays doesn't
+// prevent one from changing the array's content.
+procedure ReverseColors(const colors: TArrayOfGradientColor);
var
- i, highI: integer;
+ highI: integer;
+ dst, src: ^TGradientColor;
+ // Not using a TGradientColor record for the temporary value
+ // allows the 64-bit compiler to use an XMM register for it.
+ tmpOffset: double;
+ tmpColor: TColor32;
begin
highI := High(colors);
- SetLength(result, highI +1);
- for i := 0 to highI do
+
+ dst := @colors[0];
+ src := @colors[highI];
+ while PByte(dst) < PByte(src) do
begin
- result[i].color := colors[highI -i].color;
- result[i].offset := 1 - colors[highI -i].offset;
+ tmpColor := dst.color;
+ tmpOffset := dst.offset;
+
+ dst.color := src.color;
+ dst.offset := 1 - src.offset;
+
+ src.color := tmpColor;
+ src.offset := 1 - tmpOffset;
+
+ inc(dst);
+ dec(src);
end;
end;
// ------------------------------------------------------------------------------
@@ -519,15 +622,9 @@ function MirrorQ(q, endQ: integer): integer;
function MirrorD(d: double; colorCnt: integer): integer;
begin
dec(colorCnt);
-{$IFDEF UseTrunc} // used in TSvgRadialGradientRenderer.RenderProc
if Odd(Trunc(d)) then
result := Trunc((1 - frac(d)) * colorCnt) else
result := Trunc(frac(d) * colorCnt);
-{$ELSE}
- if Odd(Round(d)) then
- result := Round((1 - frac(d)) * colorCnt) else
- result := Round(frac(d) * colorCnt);
-{$ENDIF}
end;
// ------------------------------------------------------------------------------
@@ -555,15 +652,9 @@ function SoftRptQ(q, endQ: integer): integer;
function RepeatD(d: double; colorCnt: integer): integer;
begin
dec(colorCnt);
-{$IFDEF UseTrunc} // used in TSvgRadialGradientRenderer.RenderProc
if (d < 0) then
result := Trunc((1 + frac(d)) * colorCnt) else
result := Trunc(frac(d) * colorCnt);
-{$ELSE}
- if (d < 0) then
- result := Round((1 + frac(d)) * colorCnt) else
- result := Round(frac(d) * colorCnt);
-{$ENDIF}
end;
// ------------------------------------------------------------------------------
@@ -577,12 +668,12 @@ function BlendColorUsingMask(bgColor, fgColor: TColor32; mask: Byte): TColor32;
if fg.A = 0 then
begin
Result := bgColor;
- res.A := MulBytes(res.A, not mask);
+ res.A := MulTable[res.A, not mask];
end
else if bg.A = 0 then
begin
Result := fgColor;
- res.A := MulBytes(res.A, mask);
+ res.A := MulTable[res.A, mask];
end
else if (mask = 0) then
Result := bgColor
@@ -602,21 +693,23 @@ function BlendColorUsingMask(bgColor, fgColor: TColor32; mask: Byte): TColor32;
// MakeColorGradient: using the supplied array of TGradientColor,
// create an array of TColor32 of the specified length
-function MakeColorGradient(const gradColors: TArrayOfGradientColor;
- len: integer): TArrayOfColor32;
+procedure MakeColorGradient(const gradColors: TArrayOfGradientColor;
+ len: integer; var result: TArrayOfColor32);
var
i,j, lenC: integer;
- dist, offset1, offset2, step, pos: double;
+ dist, offset1, offset2, step, pos, reciprocalDistTimes255: double;
color1, color2: TColor32;
begin
lenC := length(gradColors);
if (len = 0) or (lenC < 2) then Exit;
- SetLength(result, len);
+ if Length(result) <> len then // we can reuse the array
+ SetLength(result, len);
color2 := gradColors[0].color;
result[0] := color2;
if len = 1 then Exit;
+ reciprocalDistTimes255 := 0;
step := 1/(len-1);
pos := step;
offset2 := 0;
@@ -627,9 +720,11 @@ function MakeColorGradient(const gradColors: TArrayOfGradientColor;
dist := offset2 - offset1;
color1 := color2;
color2 := gradColors[i].color;
+ if dist > 0 then
+ reciprocalDistTimes255 := 255/dist; // 1/dist*255
while (pos <= dist) and (j < len) do
begin
- result[j] := BlendColorUsingMask(color1, color2, Round(pos/dist * 255));
+ result[j] := BlendColorUsingMask(color1, color2, Round(pos * reciprocalDistTimes255));
inc(j);
pos := pos + step;
end;
@@ -644,7 +739,7 @@ function MakeColorGradient(const gradColors: TArrayOfGradientColor;
// ------------------------------------------------------------------------------
procedure AllocateScanlines(const polygons: TPathsD;
- var scanlines: TArrayOfScanline; out fragments: PDouble; clipBottom, clipRight: integer);
+ const scanlines: TArrayOfScanline; var fragments: PFragment; clipBottom, clipRight: integer);
var
i,j, highI, highJ: integer;
y1, y2: integer;
@@ -656,18 +751,10 @@ procedure AllocateScanlines(const polygons: TPathsD;
begin
highJ := high(polygons[i]);
if highJ < 2 then continue;
-{$IFDEF UseTrunc}
y1 := Trunc(polygons[i][highJ].Y);
-{$ELSE}
- y1 := Round(polygons[i][highJ].Y);
-{$ENDIF}
for j := 0 to highJ do
begin
-{$IFDEF UseTrunc}
y2 := Trunc(polygons[i][j].Y);
-{$ELSE}
- y2 := Round(polygons[i][j].Y);
-{$ENDIF}
if y1 < y2 then
begin
// descending (but ignore edges outside the clipping range)
@@ -709,10 +796,9 @@ procedure AllocateScanlines(const polygons: TPathsD;
if j > 0 then
begin
psl.fragOffset := fragOff;
- inc(fragOff, j * 4); // 4 doubles are needed for each fragment
+ inc(fragOff, j);
end else
psl.fragOffset := -1;
- {$IFDEF MemCheck} psl.total := j; {$ENDIF}
psl.fragCnt := 0; // reset for later
psl.minX := clipRight;
psl.maxX := 0;
@@ -720,39 +806,38 @@ procedure AllocateScanlines(const polygons: TPathsD;
dec(psl);
end;
// allocate fragments as a single block of memory
- GetMem(fragments, fragOff * sizeOf(Double));
+ GetMem(fragments, fragOff * sizeOf(TFragment));
end;
// ------------------------------------------------------------------------------
procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD;
- const scanlines: TArrayOfScanline; fragments: PDouble; const clipRec: TRect);
+ const scanlines: TArrayOfScanline; fragments: PFragment; const clipRec: TRect);
var
x,y, dx,dy, absDx, dydx, dxdy: double;
i, scanlineY, maxY, maxX: integer;
psl: PScanLine;
- pFrag: PDouble;
+ pFrag: PFragment;
bot, top: TPointD;
begin
dy := pt1.Y - pt2.Y;
- dx := pt2.X - pt1.X;
- RectWidthHeight(clipRec, maxX, maxY);
- absDx := abs(dx);
if dy > 0 then
begin
// ASCENDING EDGE (+VE WINDING DIR)
if dy < 0.0001 then Exit; //ignore near horizontals
bot := pt1; top := pt2;
- // exclude edges that are completely outside the top or bottom clip region
- if (top.Y >= maxY) or (bot.Y <= 0) then Exit;
end else
begin
// DESCENDING EDGE (-VE WINDING DIR)
if dy > -0.0001 then Exit; //ignore near horizontals
bot := pt2; top := pt1;
- // exclude edges that are completely outside the top or bottom clip region
- if (top.Y >= maxY) or (bot.Y <= 0) then Exit;
end;
+ // exclude edges that are completely outside the top or bottom clip region
+ RectWidthHeight(clipRec, maxX, maxY);
+ if (top.Y >= maxY) or (bot.Y <= 0) then Exit;
+
+ dx := pt2.X - pt1.X;
+ absDx := abs(dx);
if absDx < 0.000001 then
begin
@@ -763,13 +848,8 @@ procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD;
// but still update maxX for each scanline the edge passes
if bot.X > maxX then
begin
-{$IFDEF UseTrunc}
for i := Min(maxY, Trunc(bot.Y)) downto Max(0, Trunc(top.Y)) do
scanlines[i].maxX := maxX;
-{$ELSE}
- for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(top.Y)) do
- scanlines[i].maxX := maxX;
-{$ENDIF}
Exit;
end;
@@ -786,24 +866,14 @@ procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD;
begin
if top.X >= maxX then
begin
-{$IFDEF UseTrunc}
for i := Min(maxY, Trunc(bot.Y)) downto Max(0, Trunc(top.Y)) do
scanlines[i].maxX := maxX;
-{$ELSE}
- for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(top.Y)) do
- scanlines[i].maxX := maxX;
-{$ENDIF}
Exit;
end;
// here the edge must be oriented bottom-right to top-left
y := bot.Y - (bot.X - maxX) * Abs(dydx);
-{$IFDEF UseTrunc}
for i := Min(maxY, Trunc(bot.Y)) downto Max(0, Trunc(y)) do
scanlines[i].maxX := maxX;
-{$ELSE}
- for i := Min(maxY, Round(bot.Y)) downto Max(0, Round(y)) do
- scanlines[i].maxX := maxX;
-{$ENDIF}
bot.Y := y;
if bot.Y <= 0 then Exit;
bot.X := maxX;
@@ -812,13 +882,8 @@ procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD;
begin
// here the edge must be oriented bottom-left to top-right
y := top.Y + (top.X - maxX) * Abs(dydx);
-{$IFDEF UseTrunc}
for i := Min(maxY, Trunc(y)) downto Max(0, Trunc(top.Y)) do
scanlines[i].maxX := maxX;
-{$ELSE}
- for i := Min(maxY, Round(y)) downto Max(0, Round(top.Y)) do
- scanlines[i].maxX := maxX;
-{$ENDIF}
top.Y := y;
if top.Y >= maxY then Exit;
top.X := maxX;
@@ -837,11 +902,7 @@ procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD;
end;
// SPLIT THE EDGE INTO MULTIPLE SCANLINE FRAGMENTS
-{$IFDEF UseTrunc}
scanlineY := Trunc(bot.Y);
-{$ELSE}
- scanlineY := Round(bot.Y);
-{$ENDIF}
if bot.Y = scanlineY then dec(scanlineY);
// at the lower-most extent of the edge 'split' the first fragment
@@ -849,61 +910,52 @@ procedure SplitEdgeIntoFragments(const pt1, pt2: TPointD;
psl := @scanlines[scanlineY];
if psl.fragOffset < 0 then Exit; //a very rare event
- {$IFDEF MemCheck}
- if psl.fragCnt = psl.total then raise Exception.Create(sMemCheckError);
- {$ENDIF}
pFrag := fragments;
- inc(pFrag, psl.fragOffset + psl.fragCnt * 4);
+ inc(pFrag, psl.fragOffset + psl.fragCnt);
inc(psl.fragCnt);
- pFrag^ := bot.X; inc(pFrag);
+ pFrag.botX := bot.X;
if scanlineY <= top.Y then
begin
// the whole edge is within 1 scanline
- pFrag^ := top.X; inc(pFrag);
- pFrag^ := bot.Y - top.Y; inc(pFrag);
- pFrag^ := dydx;
+ pFrag.topX := top.X;
+ pFrag.dy := bot.Y - top.Y;
+ pFrag.dydx := dydx;
Exit;
end;
x := bot.X + (bot.Y - scanlineY) * dxdy;
- pFrag^ := x; inc(pFrag);
- pFrag^ := bot.Y - scanlineY; inc(pFrag);
- pFrag^ := dydx;
+ pFrag.topX := x;
+ pFrag.dy := bot.Y - scanlineY;
+ pFrag.dydx := dydx;
// 'split' subsequent fragments until the top fragment
dec(psl);
while psl.Y > top.Y do
begin
- {$IFDEF MemCheck}
- if psl.fragCnt = psl.total then raise Exception.Create(sMemCheckError);
- {$ENDIF}
pFrag := fragments;
- inc(pFrag, psl.fragOffset + psl.fragCnt * 4);
+ inc(pFrag, psl.fragOffset + psl.fragCnt);
inc(psl.fragCnt);
- pFrag^ := x; inc(pFrag);
+ pFrag.botX := x;
x := x + dxdy;
- pFrag^ := x; inc(pFrag);
- pFrag^ := 1; inc(pFrag);
- pFrag^ := dydx;
+ pFrag.topX := x;
+ pFrag.dy := 1;
+ pFrag.dydx := dydx;
dec(psl);
end;
// and finally the top fragment
- {$IFDEF MemCheck}
- if psl.fragCnt = psl.total then raise Exception.Create(sMemCheckError);
- {$ENDIF}
pFrag := fragments;
- inc(pFrag, psl.fragOffset + psl.fragCnt * 4);
+ inc(pFrag, psl.fragOffset + psl.fragCnt);
inc(psl.fragCnt);
- pFrag^ := x; inc(pFrag);
- pFrag^ := top.X; inc(pFrag);
- pFrag^ := psl.Y + 1 - top.Y; inc(pFrag);
- pFrag^ := dydx;
+ pFrag.botX := x;
+ pFrag.topX := top.X;
+ pFrag.dy := psl.Y + 1 - top.Y;
+ pFrag.dydx := dydx;
end;
// ------------------------------------------------------------------------------
-procedure InitializeScanlines(var polygons: TPathsD;
- const scanlines: TArrayOfScanline; fragments: PDouble; const clipRec: TRect);
+procedure InitializeScanlines(const polygons: TPathsD;
+ const scanlines: TArrayOfScanline; fragments: PFragment; const clipRec: TRect);
var
i,j, highJ: integer;
pt1, pt2: PPointD;
@@ -925,21 +977,23 @@ procedure InitializeScanlines(var polygons: TPathsD;
// ------------------------------------------------------------------------------
procedure ProcessScanlineFragments(var scanline: TScanLine;
- fragments: PDouble; var buffer: TArrayOfDouble);
+ fragments: PFragment; const buffer: TArrayOfDouble);
var
i,j, leftXi,rightXi: integer;
- fracX, yy, q, windDir: double;
+ fracX, yy, q{, windDir}: double;
left, right, dy, dydx: double;
- pd, frag: PDouble;
+ frag: PFragment;
+ pd: PDouble;
begin
frag := fragments;
inc(frag, scanline.fragOffset);
for i := 1 to scanline.fragCnt do
begin
- left := frag^; inc(frag); //botX
- right := frag^; inc(frag); //topX
- dy := frag^; inc(frag);
- dydx := frag^; inc(frag);
+ left := frag.botX;
+ right := frag.topX;
+ dy := frag.dy;
+ dydx := frag.dydx;
+ inc(frag);
// converting botX & topX to left & right simplifies code
if {botX > topX} left > right then
@@ -949,18 +1003,14 @@ procedure ProcessScanlineFragments(var scanline: TScanLine;
right := q;
end;
-{$IFDEF UseTrunc}
leftXi := Max(0, Trunc(left));
rightXi := Max(0, Trunc(right));
-{$ELSE}
- leftXi := Max(0, Round(left));
- rightXi := Max(0, Round(right));
-{$ENDIF}
-
if (leftXi = rightXi) then
begin
- if dydx < 0 then windDir := -1.0 else windDir := 1.0;
// the fragment is only one pixel wide
+ //if dydx < 0 then windDir := -1.0 else windDir := 1.0;
+ if dydx < 0 then dy := -dy;
+
if leftXi < scanline.minX then
scanline.minX := leftXi;
if rightXi > scanline.maxX then
@@ -968,13 +1018,13 @@ procedure ProcessScanlineFragments(var scanline: TScanLine;
pd := @buffer[leftXi];
if (left <= 0) then
begin
- pd^ := pd^ + dy * windDir;
+ pd^ := pd^ + dy {* windDir};
end else
begin
q := (left + right) * 0.5 - leftXi;
- pd^ := pd^ + (1-q) * dy * windDir;
+ pd^ := pd^ + (1-q) * dy {* windDir};
inc(pd);
- pd^ := pd^ + q * dy * windDir;
+ pd^ := pd^ + q * dy {* windDir};
end;
end else
begin
@@ -1009,135 +1059,343 @@ procedure ProcessScanlineFragments(var scanline: TScanLine;
end;
// ------------------------------------------------------------------------------
-{$IFNDEF TROUNDINGMODE}
-type
- TRoundingMode = {$IFNDEF FPC}Math.{$ENDIF}TFPURoundingMode;
+{$RANGECHECKS OFF} // negative array index is used
+{ CPU register optimized implementations. Every data type must be exactly the one used. }
+procedure FillByteBufferEvenOdd(byteBuffer: PByte;
+ windingAccum: PDouble; count: nativeint);
+var
+ accum: double;
+ lastValue: integer;
+ start: nativeint;
+ buf: PByteArray;
+begin
+ accum := 0; //winding count accumulator
+ lastValue := 0;
+ // Copy byteBuffer to a local variable, so Delphi's 32bit compiler
+ // can put buf into a CPU register.
+ buf := PByteArray(byteBuffer);
+
+ // Use the negative offset trick to only increment "count"
+ // until it reaches zero. And by offsetting the arrays, "count"
+ // also becomes the index for those.
+ inc(PByte(buf), count);
+ inc(windingAccum, count);
+ count := -count;
+ while count < 0 do
+ begin
+ // lastValue can be used if accum doesn't change
+ if PInt64Array(windingAccum)[count] = 0 then
+ begin
+ start := count;
+ repeat
+ inc(count);
+ until (count = 0) or (PInt64Array(windingAccum)[count] <> 0);
+ FillChar(buf[start], count - start, Byte(lastValue));
+ if count = 0 then break;
+ end;
+
+ accum := accum + PDoubleArray(windingAccum)[count];
+
+ // EvenOdd
+ lastValue := Trunc(Abs(accum) * 1275) mod 2550; // mul 5
+ if lastValue > 1275 then
+ lastValue := (2550 - lastValue) shr 2 else // div 4
+ lastValue := lastValue shr 2; // div 4
+ if lastValue > 255 then lastValue := 255;
+
+ buf[count] := Byte(lastValue);
+ PDoubleArray(windingAccum)[count] := 0;
+ inc(count); // walk towards zero
+ end;
+end;
+
+procedure FillByteBufferNonZero(byteBuffer: PByte;
+ windingAccum: PDouble; count: nativeint);
+var
+ accum: double;
+ lastValue: integer;
+ start: nativeint;
+ buf: PByteArray;
+begin
+ accum := 0; //winding count accumulator
+ lastValue := 0;
+ // Copy byteBuffer to a local variable, so Delphi's 32bit compiler
+ // can put buf into a CPU register.
+ buf := PByteArray(byteBuffer);
+
+ // Use the negative offset trick to only increment "count"
+ // until it reaches zero. And by offsetting the arrays, "count"
+ // also becomes the index for those.
+ inc(PByte(buf), count);
+ inc(windingAccum, count);
+ count := -count;
+ while count < 0 do
+ begin
+ // lastValue can be used if accum doesn't change
+ if PInt64Array(windingAccum)[count] = 0 then
+ begin
+ start := count;
+ repeat
+ inc(count);
+ until (count = 0) or (PInt64Array(windingAccum)[count] <> 0);
+ FillChar(buf[start], count - start, Byte(lastValue));
+ if count = 0 then break;
+ end;
+
+ accum := accum + PDoubleArray(windingAccum)[count];
+
+ // NonZero
+ lastValue := Trunc(Abs(accum) * 318);
+ if lastValue > 255 then lastValue := 255;
+
+ buf[count] := Byte(lastValue);
+ PDoubleArray(windingAccum)[count] := 0;
+ inc(count); // walk towards zero
+ end;
+end;
+
+procedure FillByteBufferPositive(byteBuffer: PByte;
+ windingAccum: PDouble; count: nativeint);
+var
+ accum: double;
+ lastValue: integer;
+ start: nativeint;
+ buf: PByteArray;
+begin
+ accum := 0; //winding count accumulator
+ lastValue := 0;
+ // Copy byteBuffer to a local variable, so Delphi's 32bit compiler
+ // can put buf into a CPU register.
+ buf := PByteArray(byteBuffer);
+
+ // Use the negative offset trick to only increment "count"
+ // until it reaches zero. And by offsetting the arrays, "count"
+ // also becomes the index for those.
+ inc(PByte(buf), count);
+ inc(windingAccum, count);
+ count := -count;
+ while count < 0 do
+ begin
+ // lastValue can be used if accum doesn't change
+ if PInt64Array(windingAccum)[count] = 0 then
+ begin
+ start := count;
+ repeat
+ inc(count);
+ until (count = 0) or (PInt64Array(windingAccum)[count] <> 0);
+ FillChar(buf[start], count - start, Byte(lastValue));
+ if count = 0 then break;
+ end;
+
+ accum := accum + PDoubleArray(windingAccum)[count];
+
+ // Positive
+ lastValue := 0;
+ if accum > 0.002 then
+ begin
+ lastValue := Trunc(accum * 318);
+ if lastValue > 255 then lastValue := 255;
+ end;
+
+ buf[count] := Byte(lastValue);
+ PDoubleArray(windingAccum)[count] := 0;
+ inc(count); // walk towards zero
+ end;
+end;
+
+procedure FillByteBufferNegative(byteBuffer: PByte;
+ windingAccum: PDouble; count: nativeint);
+var
+ accum: double;
+ lastValue: integer;
+ start: nativeint;
+ buf: PByteArray;
+begin
+ accum := 0; //winding count accumulator
+ lastValue := 0;
+ // Copy byteBuffer to a local variable, so Delphi's 32bit compiler
+ // can put buf into a CPU register.
+ buf := PByteArray(byteBuffer);
+
+ // Use the negative offset trick to only increment "count"
+ // until it reaches zero. And by offsetting the arrays, "count"
+ // also becomes the index for those.
+ inc(PByte(buf), count);
+ inc(windingAccum, count);
+ count := -count;
+ while count < 0 do
+ begin
+ // lastValue can be used if accum doesn't change
+ if PInt64Array(windingAccum)[count] = 0 then
+ begin
+ start := count;
+ repeat
+ inc(count);
+ until (count = 0) or (PInt64Array(windingAccum)[count] <> 0);
+ FillChar(buf[start], count - start, Byte(lastValue));
+ if count = 0 then break;
+ end;
+
+ accum := accum + PDoubleArray(windingAccum)[count];
+
+ // Negative
+ lastValue := 0;
+ if accum < -0.002 then
+ begin
+ lastValue := Trunc(accum * -318);
+ if lastValue > 255 then lastValue := 255;
+ end;
+
+ buf[count] := Byte(lastValue);
+ PDoubleArray(windingAccum)[count] := 0;
+ inc(count); // walk towards zero
+ end;
+end;
+{$IFDEF RANGECHECKS_ENABLED}
+ {$RANGECHECKS ON}
{$ENDIF}
procedure Rasterize(const paths: TPathsD; const clipRec: TRect;
fillRule: TFillRule; renderer: TCustomRenderer);
var
- i,j, xli,xri, maxW, maxH, aa: integer;
+ i, xli,xri, maxW, maxH: integer;
clipRec2: TRect;
paths2: TPathsD;
- accum: double;
windingAccum: TArrayOfDouble;
- byteBuffer: TArrayOfByte;
+ byteBuffer: PByteArray;
scanlines: TArrayOfScanline;
- fragments: PDouble;
+ fragments: PFragment;
scanline: PScanline;
-{$IFnDEF UseTrunc}
- savedRoundMode: TRoundingMode;
-{$ENDIF}
+ skippedScanlines: integer;
+ skipRenderer: boolean;
+
+ // FPC generates wrong code if "count" isn't NativeInt
+ FillByteBuffer: procedure(byteBuffer: PByte; windingAccum: PDouble; count: nativeint);
begin
// See also https://nothings.org/gamedev/rasterize/
- if not assigned(renderer) then Exit;
+ if not assigned(paths) or not assigned(renderer) then Exit;
+ renderer.SetClipRect(clipRec);
+ skipRenderer := renderer.SupportsRenderProcSkip;
+
Types.IntersectRect(clipRec2, clipRec, GetBounds(paths));
- if IsEmptyRect(clipRec2) then Exit;
+ if IsEmptyRect(clipRec2) then
+ begin
+ if skipRenderer then renderer.RenderProcSkip(clipRec);
+ Exit;
+ end;
- paths2 := TranslatePath(paths, -clipRec2.Left, -clipRec2.Top);
+ if (clipRec2.Left = 0) and (clipRec2.Top = 0) then
+ paths2 := paths
+ else
+ paths2 := TranslatePath(paths, -clipRec2.Left, -clipRec2.Top);
// Delphi's Round() function is *much* faster than Trunc(),
// and even a little faster than Trunc() above (except
// when the FastMM4 memory manager is enabled.)
fragments := nil;
-{$IFnDEF UseTrunc}
- savedRoundMode := SetRoundMode(rmDown);
-{$ENDIF}
+ byteBuffer := nil;
try
RectWidthHeight(clipRec2, maxW, maxH);
+ if maxW <= 0 then Exit;
+ GetMem(byteBuffer, maxW); // no need for dyn. array zero initialize
SetLength(scanlines, maxH +1);
SetLength(windingAccum, maxW +2);
AllocateScanlines(paths2, scanlines, fragments, maxH, maxW-1);
InitializeScanlines(paths2, scanlines, fragments, clipRec2);
- SetLength(byteBuffer, maxW);
- if byteBuffer = nil then Exit;
+ case fillRule of
+ frEvenOdd:
+ FillByteBuffer := FillByteBufferEvenOdd;
+ frNonZero:
+ FillByteBuffer := FillByteBufferNonZero;
+{$IFDEF REVERSE_ORIENTATION}
+ frPositive:
+{$ELSE}
+ frNegative:
+{$ENDIF}
+ FillByteBuffer := FillByteBufferPositive;
+{$IFDEF REVERSE_ORIENTATION}
+ frNegative:
+{$ELSE}
+ frPositive:
+{$ENDIF}
+ FillByteBuffer := FillByteBufferNegative;
+ else
+ if skipRenderer then renderer.RenderProcSkip(clipRec);
+ Exit;
+ end;
+
+ // Notify the renderer about the parts at the top
+ // that we didn't touch.
+ if skipRenderer and (clipRec2.Top > clipRec.Top) then
+ begin
+ renderer.RenderProcSkip(Rect(clipRec.Left, clipRec.Top,
+ clipRec.Right, clipRec2.Top - 1));
+ end;
+
+ skippedScanlines := 0;
scanline := @scanlines[0];
for i := 0 to high(scanlines) do
begin
if scanline.fragCnt = 0 then
begin
inc(scanline);
+ if skipRenderer then inc(skippedScanlines);
Continue;
end;
+ // If we have skipped some scanlines, we must notify the renderer.
+ if skipRenderer and (skippedScanlines > 0) then
+ begin
+ renderer.RenderProcSkip(Rect(clipRec.Left, clipRec2.Top + i - skippedScanlines,
+ clipRec.Right, clipRec2.Top + i - 1));
+ skippedScanlines := 0;
+ end;
+
// process each scanline to fill the winding count accumulation buffer
ProcessScanlineFragments(scanline^, fragments, windingAccum);
// it's faster to process only the modified sub-array of windingAccum
xli := scanline.minX;
xri := Min(maxW -1, scanline.maxX +1);
- FillChar(byteBuffer[xli], xri - xli +1, 0);
// a 25% weighting has been added to the alpha channel to minimize any
// background bleed-through where polygons join with a common edge.
- accum := 0; //winding count accumulator
- for j := xli to xri do
- begin
- accum := accum + windingAccum[j];
- case fillRule of
- frEvenOdd:
- begin
-{$IFDEF UseTrunc}
- aa := Trunc(Abs(accum) * 1275) mod 2550; // *5
-{$ELSE}
- aa := Round(Abs(accum) * 1275) mod 2550; // *5
-{$ENDIF}
- if aa > 1275 then
- byteBuffer[j] := Min(255, (2550 - aa) shr 2) else // /4
- byteBuffer[j] := Min(255, aa shr 2); // /4
- end;
- frNonZero:
- begin
-{$IFDEF UseTrunc}
- byteBuffer[j] := Min(255, Trunc(Abs(accum) * 318));
-{$ELSE}
- byteBuffer[j] := Min(255, Round(Abs(accum) * 318));
-{$ENDIF}
- end;
- {$IFDEF REVERSE_ORIENTATION}
- frPositive:
- {$ELSE}
- frNegative:
- {$ENDIF}
- begin
-{$IFDEF UseTrunc}
- if accum > 0.002 then
- byteBuffer[j] := Min(255, Trunc(accum * 318));
-{$ELSE}
- if accum > 0.002 then
- byteBuffer[j] := Min(255, Round(accum * 318));
-{$ENDIF}
- end;
- {$IFDEF REVERSE_ORIENTATION}
- frNegative:
- {$ELSE}
- frPositive:
- {$ENDIF}
- begin
-{$IFDEF UseTrunc}
- if accum < -0.002 then
- byteBuffer[j] := Min(255, Trunc(-accum * 318));
-{$ELSE}
- if accum < -0.002 then
- byteBuffer[j] := Min(255, Round(-accum * 318));
-{$ENDIF}
- end;
- end;
- end;
+ // FillByteBuffer overwrites every byte in byteBuffer[xli..xri] and also resets
+ // windingAccum[xli..xri] to 0.
+ FillByteBuffer(@byteBuffer[xli], @windingAccum[xli], xri - xli +1);
+
renderer.RenderProc(clipRec2.Left + xli, clipRec2.Left + xri,
clipRec2.Top + i, @byteBuffer[xli]);
- // cleanup and deallocate memory
- FillChar(windingAccum[xli], (xri - xli +1) * sizeOf(Double), 0);
inc(scanline);
end;
+
+ // Notify the renderer about the last skipped scanlines
+ if skipRenderer then
+ begin
+ clipRec2.Bottom := clipRec2.top + High(scanlines) - skippedScanlines;
+ if clipRec2.Bottom < clipRec.Bottom then
+ begin
+ renderer.RenderProcSkip(Rect(clipRec.Left, clipRec2.Bottom + 1,
+ clipRec.Right, clipRec.Bottom));
+ end;
+ end;
finally
+ // cleanup and deallocate memory
FreeMem(fragments);
-{$IFnDEF UseTrunc}
- SetRoundMode(savedRoundMode);
-{$ENDIF}
+ FreeMem(byteBuffer);
+ end;
+end;
+// ------------------------------------------------------------------------------
+
+procedure Rasterize(img: TImage32; const paths: TPathsD;
+ const clipRec: TRect; fillRule: TFillRule; renderer: TCustomRenderer);
+begin
+ if renderer.Initialize(img) then
+ begin
+ Rasterize(paths, clipRec, fillRule, renderer);
+ renderer.NotifyChange;
end;
end;
@@ -1145,6 +1403,13 @@ procedure Rasterize(const paths: TPathsD; const clipRec: TRect;
// TAbstractRenderer
// ------------------------------------------------------------------------------
+constructor TCustomRenderer.Create;
+begin
+ inherited;
+ fOpacity := 255;
+end;
+// ------------------------------------------------------------------------------
+
function TCustomRenderer.Initialize(imgBase: Pointer;
imgWidth, imgHeight, pixelSize: integer): Boolean;
begin
@@ -1154,7 +1419,7 @@ function TCustomRenderer.Initialize(imgBase: Pointer;
fPixelSize := pixelSize;
fCurrLinePtr := fImgBase;
- fCurrY := 0;
+ fCurrY := -1;
result := true;
end;
// ------------------------------------------------------------------------------
@@ -1186,6 +1451,33 @@ function TCustomRenderer.GetDstPixel(x, y: integer): Pointer;
Result := fCurrLinePtr;
inc(PByte(Result), x * fPixelSize);
end;
+// ------------------------------------------------------------------------------
+
+procedure TCustomRenderer.SetClipRect(const clipRect: TRect);
+begin
+ // default: do nothing
+end;
+// ------------------------------------------------------------------------------
+
+procedure TCustomRenderer.RenderProcSkip(const skippedRect: TRect);
+begin
+ // default: do nothing
+end;
+// ------------------------------------------------------------------------------
+
+function TCustomRenderer.SupportsRenderProcSkip: Boolean;
+begin
+ Result := False;
+end;
+
+// ------------------------------------------------------------------------------
+// TCustomColorRenderer
+// ------------------------------------------------------------------------------
+
+procedure TCustomColorRenderer.SetColor(value: TColor32);
+begin
+ fColor := value;
+end;
// ------------------------------------------------------------------------------
// TColorRenderer
@@ -1193,6 +1485,7 @@ function TCustomRenderer.GetDstPixel(x, y: integer): Pointer;
constructor TColorRenderer.Create(color: TColor32 = clNone32);
begin
+ inherited Create;
if color <> clNone32 then SetColor(color);
end;
// ------------------------------------------------------------------------------
@@ -1211,22 +1504,100 @@ procedure TColorRenderer.SetColor(value: TColor32);
end;
// ------------------------------------------------------------------------------
-procedure TColorRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
+{$RANGECHECKS OFF} // negative array index usage (Delphi 7-2007 have no pointer math)
+type
+ // Used to reduce the number of parameters to help the compiler's
+ // optimizer.
+ TRenderProcData = record
+ dst: PColor32Array;
+ alpha: PByteArray;
+ end;
+
+function RenderProcBlendToAlpha255(count: nativeint; dstColor: TColor32;
+ var data: TRenderProcData): nativeint;
+// CPU register optimized
var
- i: integer;
- dst: PColor32;
+ a: byte;
+ dst: PColor32Array;
+ alpha: PByteArray;
begin
- dst := GetDstPixel(x1,y);
- for i := x1 to x2 do
+ Result := count;
+ dst := data.dst;
+ alpha := data.alpha;
+
+ a := alpha[Result];
+ dst[Result] := dstColor;
+ inc(Result);
+
+ while (Result < 0) and (alpha[Result] = a) do
begin
- // BlendToAlpha is marginally slower than BlendToOpaque but it's used
- // here because it's universally applicable.
- // Ord() is used here because very old compilers define PByte as a PChar
- if Ord(alpha^) > 1 then
- dst^ := BlendToAlpha(dst^, ((Ord(alpha^) * fAlpha) shr 8) shl 24 or fColor);
- inc(dst); inc(alpha);
+ dst[Result] := dstColor;
+ inc(Result);
+ end;
+end;
+
+procedure RenderProcBlendToAlpha(dst: PColor32Array; alpha: PByteArray;
+ count: nativeint; color: TColor32; alphaTable: PByteArray);
+var
+ a: byte;
+ lastDst, dstColor: TColor32;
+ data: TRenderProcData;
+begin
+ // Use negative offset trick.
+ alpha := @alpha[count];
+ dst := @dst[count];
+ count := -count;
+
+ // store pointers for RenderProcBlendToAlpha255
+ data.dst := dst;
+ data.alpha := alpha;
+
+ while count < 0 do
+ begin
+ a := alpha[count];
+ if a > 1 then
+ begin
+ a := alphaTable[a];
+ dstColor := (a shl 24) or color;
+
+ // Special handling for alpha channel 255 (copy dstColor into dst)
+ if a = 255 then
+ count := RenderProcBlendToAlpha255(count, dstColor, data)
+ else
+ begin
+ lastDst := dst[count];
+ dstColor := BlendToAlpha(lastDst, dstColor);
+
+ a := alpha[count];
+ dst[count] := dstColor;
+ inc(count);
+
+ // if we have the same dst-pixel and the same alpha channel, we can
+ // just copy the already calculated BlendToAlpha color.
+ while (count < 0) and (a = alpha[count]) and (dst[count] = lastDst) do
+ begin
+ dst[count] := dstColor;
+ inc(count);
+ end;
+ end;
+ end
+ else
+ inc(count);
end;
end;
+{$IFDEF RANGECHECKS_ENABLED}
+ {$RANGECHECKS ON}
+{$ENDIF}
+
+procedure TColorRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
+begin
+ // Help the compiler to get better CPU register allocation.
+ // Without the hidden Self parameter the compiler optimizes
+ // better.
+ RenderProcBlendToAlpha(PColor32Array(GetDstPixel(x1, y)),
+ PByteArray(alpha), x2 - x1 + 1, fColor,
+ PByteArray(@MulTable[fAlpha]));
+end;
// ------------------------------------------------------------------------------
// TAliasedColorRenderer
@@ -1234,6 +1605,7 @@ procedure TColorRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
constructor TAliasedColorRenderer.Create(color: TColor32 = clNone32);
begin
+ inherited Create;
fColor := color;
end;
// ------------------------------------------------------------------------------
@@ -1250,15 +1622,138 @@ procedure TAliasedColorRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dst: PColor32;
+ c: TColor32;
begin
dst := GetDstPixel(x1,y);
+ c := fColor; // copy fColor to local variable
for i := x1 to x2 do
begin
- if Ord(alpha^) > 127 then dst^ := fColor; //ie no blending
+ if Ord(alpha^) > 127 then dst^ := c; //ie no blending
inc(dst); inc(alpha);
end;
end;
+// ------------------------------------------------------------------------------
+// TMaskRenderer
+// ------------------------------------------------------------------------------
+
+procedure TMaskRenderer.SetClipRect(const clipRect: TRect);
+begin
+ fClipRect := clipRect;
+ // clipping to the image size
+ if fClipRect.Left < 0 then fClipRect.Left := 0;
+ if fClipRect.Top < 0 then fClipRect.Top := 0;
+ if fClipRect.Right > fImgWidth then fClipRect.Right := fImgWidth;
+ if fClipRect.Bottom > fImgHeight then fClipRect.Bottom := fImgHeight;
+end;
+// ------------------------------------------------------------------------------
+
+procedure TMaskRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
+var
+ p: PColor32;
+ i: integer;
+begin
+ // CopyBlend excludes ClipRect.Right/Bottom, so we also
+ // need to exclude it.
+ if (y < fClipRect.Top) or (y >= fClipRect.Bottom) then Exit;
+ if x2 >= fClipRect.Right then x2 := fClipRect.Right - 1;
+
+ if x1 < fClipRect.Left then
+ begin
+ inc(alpha, fClipRect.Left - x1);
+ x1 := fClipRect.Left;
+ end;
+
+ p := GetDstPixel(fClipRect.Left, y);
+
+ // Clear the area before x1 (inside OutsideBounds)
+ FillChar(p^, (x1 - fClipRect.Left) * SizeOf(TColor32), 0);
+ inc(p, x1 - fClipRect.Left);
+
+ // Fill the area between x1 and x2
+ for i := x1 to x2 do
+ begin
+ if p^ <> 0 then
+ begin
+ if Ord(alpha^) = 0 then
+ p^ := 0
+ else if Ord(alpha^) <> 255 then
+ p^ := BlendMask(p^, Ord(alpha^) shl 24);
+ end;
+ inc(p);
+ inc(alpha);
+ end;
+
+ // Clear the area after x2 (inside OutsideBounds)
+ FillChar(p^, (fClipRect.Right - (x2 + 1)) * SizeOf(TColor32), 0);
+end;
+// ------------------------------------------------------------------------------
+
+procedure TMaskRenderer.RenderProcSkip(const skippedRect: TRect);
+var
+ i, h, w: integer;
+ p: PColor32;
+ r: TRect;
+begin
+ r := skippedRect;
+ if r.Left < fClipRect.Left then r.Left := fClipRect.Left;
+ if r.Top < fClipRect.Top then r.Top := fClipRect.Top;
+ // CopyBlend excludes ClipRect.Right/Bottom, so we also
+ // need to exclude it.
+ if r.Right >= fClipRect.Right then r.Right := fClipRect.Right - 1;
+ if r.Bottom >= fClipRect.Bottom then r.Bottom := fClipRect.Bottom - 1;
+
+ if r.Right < r.Left then Exit;
+ if r.Bottom < r.Top then Exit;
+
+ w := r.Right - r.Left + 1;
+ h := r.Bottom - r.Top + 1;
+ p := GetDstPixel(r.Left, r.Top);
+ if w = fImgWidth then
+ FillChar(p^, w * h * SizeOf(TColor32), 0)
+ else
+ begin
+ for i := 1 to h do
+ begin
+ FillChar(p^, w * SizeOf(TColor32), 0);
+ inc(p, fImgWidth);
+ end;
+ end;
+end;
+
+// ------------------------------------------------------------------------------
+function TMaskRenderer.SupportsRenderProcSkip: Boolean;
+begin
+ Result := True;
+end;
+
+// ------------------------------------------------------------------------------
+// TCustomRendererCache
+// ------------------------------------------------------------------------------
+
+constructor TCustomRendererCache.Create;
+begin
+ inherited Create;
+ fColorRenderer := TColorRenderer.Create;
+ fAliasedColorRenderer := TAliasedColorRenderer.Create;
+ fMaskRenderer := TMaskRenderer.Create;
+end;
+// ------------------------------------------------------------------------------
+
+destructor TCustomRendererCache.Destroy;
+begin
+ fColorRenderer.Free;
+ fAliasedColorRenderer.Free;
+ fMaskRenderer.Free;
+end;
+// ------------------------------------------------------------------------------
+
+function TCustomRendererCache.GetColorRenderer(color: TColor32): TColorRenderer;
+begin
+ Result := fColorRenderer;
+ Result.SetColor(color);
+end;
+
// ------------------------------------------------------------------------------
// TBrushImageRenderer
// ------------------------------------------------------------------------------
@@ -1266,6 +1761,7 @@ procedure TAliasedColorRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
constructor TImageRenderer.Create(tileFillStyle: TTileFillStyle;
brushImage: TImage32);
begin
+ inherited Create;
fImage := TImage32.Create(brushImage);
SetTileFillStyle(tileFillStyle);
end;
@@ -1303,24 +1799,34 @@ procedure TImageRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
pDst: PColor32;
- pBrush: PARGB;
+ pImg: PColor32;
+ opacityTable: PByteArray;
begin
pDst := GetDstPixel(x1,y);
dec(x1, fOffset.X);
dec(x2, fOffset.X);
dec(y, fOffset.Y);
- pBrush := GetFirstBrushPixel(x1, y);
- for i := x1 to x2 do
+ pImg := GetFirstBrushPixel(x1, y);
+ if Opacity < 255 then
begin
- pDst^ := BlendToAlpha(pDst^,
- MulBytes(pBrush.A, Ord(alpha^)) shl 24 or (pBrush.Color and $FFFFFF));
- inc(pDst); inc(alpha);
- pBrush := GetPixel(fBrushPixel, fBoundsProc(i, fImage.Width));
- end;
+ opacityTable := PByteArray(@MulTable[Opacity]);
+ for i := x1 to x2 do
+ begin
+ pDst^ := BlendToAlpha3(pDst^, pImg^, opacityTable[Ord(alpha^)]);
+ inc(pDst); inc(alpha);
+ pImg := PColor32(GetPixel(fBrushPixel, fBoundsProc(i, fImage.Width)));
+ end;
+ end else
+ for i := x1 to x2 do
+ begin
+ pDst^ := BlendToAlpha3(pDst^, pImg^, Ord(alpha^));
+ inc(pDst); inc(alpha);
+ pImg := PColor32(GetPixel(fBrushPixel, fBoundsProc(i, fImage.Width)));
+ end;
end;
// ------------------------------------------------------------------------------
-function TImageRenderer.GetFirstBrushPixel(x, y: integer): PARGB;
+function TImageRenderer.GetFirstBrushPixel(x, y: integer): PColor32;
begin
if fMirrorY then
y := MirrorQ(y, fImage.Height) else
@@ -1331,7 +1837,7 @@ function TImageRenderer.GetFirstBrushPixel(x, y: integer): PARGB;
fLastYY := y;
end;
x := fBoundsProc(x, fImage.Width);
- result := GetPixel(fBrushPixel, x);
+ result := PColor32(GetPixel(fBrushPixel, x));
end;
// ------------------------------------------------------------------------------
@@ -1340,6 +1846,7 @@ function TImageRenderer.GetFirstBrushPixel(x, y: integer): PARGB;
constructor TCustomGradientRenderer.Create;
begin
+ inherited Create;
fBoundsProc := ClampQ; //default proc
end;
// ------------------------------------------------------------------------------
@@ -1365,7 +1872,7 @@ procedure TCustomGradientRenderer.SetParameters(startColor, endColor: TColor32;
gradFillStyle: TGradientFillStyle = gfsClamp);
begin
SetGradientFillStyle(gradFillStyle);
- // reset gradient colors if perviously set
+ // reset gradient colors if previously set
SetLength(fGradientColors, 2);
fGradientColors[0].offset := 0;
fGradientColors[0].color := startColor;
@@ -1434,7 +1941,7 @@ function TLinearGradientRenderer.Initialize(targetImage: TImage32): Boolean;
// gradient > 45 degrees
if (fEndPt.Y < fStartPt.Y) then
begin
- fGradientColors := ReverseColors(fGradientColors);
+ ReverseColors(fGradientColors);
SwapPoints(fStartPt, fEndPt);
end;
fIsVert := true;
@@ -1443,9 +1950,9 @@ function TLinearGradientRenderer.Initialize(targetImage: TImage32): Boolean;
dxdy := dx/dy;
fColorsCnt := Ceil(dy + dxdy * (fEndPt.X - fStartPt.X));
- fColors := MakeColorGradient(fGradientColors, fColorsCnt);
+ MakeColorGradient(fGradientColors, fColorsCnt, fColors);
// get a list of perpendicular offsets for each
- SetLength(fPerpendicOffsets, ImgWidth);
+ NewIntegerArray(fPerpendicOffsets, ImgWidth, True);
// from an imaginary line that's through fStartPt and perpendicular to
// the gradient line, get a list of Y offsets for each X in image width
for i := 0 to ImgWidth -1 do
@@ -1460,7 +1967,7 @@ function TLinearGradientRenderer.Initialize(targetImage: TImage32): Boolean;
end;
if (fEndPt.X < fStartPt.X) then
begin
- fGradientColors := ReverseColors(fGradientColors);
+ ReverseColors(fGradientColors);
SwapPoints(fStartPt, fEndPt);
end;
fIsVert := false;
@@ -1469,8 +1976,8 @@ function TLinearGradientRenderer.Initialize(targetImage: TImage32): Boolean;
dydx := dy/dx; //perpendicular slope
fColorsCnt := Ceil(dx + dydx * (fEndPt.Y - fStartPt.Y));
- fColors := MakeColorGradient(fGradientColors, fColorsCnt);
- SetLength(fPerpendicOffsets, ImgHeight);
+ MakeColorGradient(fGradientColors, fColorsCnt, fColors);
+ NewIntegerArray(fPerpendicOffsets, ImgHeight, True);
// from an imaginary line that's through fStartPt and perpendicular to
// the gradient line, get a list of X offsets for each Y in image height
for i := 0 to ImgHeight -1 do
@@ -1481,27 +1988,66 @@ function TLinearGradientRenderer.Initialize(targetImage: TImage32): Boolean;
procedure TLinearGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
- i, off: integer;
+ i, colorsCnt: integer;
pDst: PColor32;
- color: TARGB;
+ color: TColor32;
+ boundsProc: TBoundsProc;
+ offset: Integer;
+ colors: PColor32Array;
+ perpendicOffsets: PIntegerArray;
+ opacityTable: PByteArray;
begin
pDst := GetDstPixel(x1,y);
- for i := x1 to x2 do
+ // optimize self fields access
+ colorsCnt := fColorsCnt;
+ colors := @fColors[0];
+ boundsProc := fBoundsProc;
+ if fIsVert then
+ begin
+ perpendicOffsets := @fPerpendicOffsets[0]; // optimize self field access
+ if Opacity < 255 then
+ begin
+ opacityTable := PByteArray(@MulTable[Opacity]);
+ for i := x1 to x2 do
+ begin
+ // when fIsVert = true, fPerpendicOffsets is an array of Y for each X
+ color := colors[boundsProc(y - perpendicOffsets[i], colorsCnt)];
+ pDst^ := BlendToAlpha3(pDst^, color, opacityTable[Ord(alpha^)]);
+ inc(pDst); inc(alpha);
+ end;
+ end else
+ begin
+ for i := x1 to x2 do
+ begin
+ // when fIsVert = true, fPerpendicOffsets is an array of Y for each X
+ color := colors[boundsProc(y - perpendicOffsets[i], colorsCnt)];
+ pDst^ := BlendToAlpha3(pDst^, color, Ord(alpha^));
+ inc(pDst); inc(alpha);
+ end;
+ end;
+ end
+ else
begin
- if fIsVert then
+ // when fIsVert = false, fPerpendicOffsets is an array of X for each Y
+ offset := fPerpendicOffsets[y];
+ if Opacity < 255 then
begin
- // when fIsVert = true, fPerpendicOffsets is an array of Y for each X
- off := fPerpendicOffsets[i];
- color.Color := fColors[fBoundsProc(y - off, fColorsCnt)];
+ opacityTable := PByteArray(@MulTable[Opacity]);
+ for i := x1 to x2 do
+ begin
+ color := colors[boundsProc(i - offset, colorsCnt)];
+ pDst^ := BlendToAlpha3(pDst^, color, opacityTable[Ord(alpha^)]);
+ inc(pDst); inc(alpha);
+ end;
end else
begin
- // when fIsVert = false, fPerpendicOffsets is an array of X for each Y
- off := fPerpendicOffsets[y];
- color.Color := fColors[fBoundsProc(i - off, fColorsCnt)];
+ for i := x1 to x2 do
+ begin
+ color := colors[boundsProc(i - offset, colorsCnt)];
+ pDst^ := BlendToAlpha3(pDst^, color, Ord(alpha^));
+ inc(pDst); inc(alpha);
+ end;
end;
- pDst^ := BlendToAlpha(pDst^,
- MulBytes(color.A, Ord(alpha^)) shl 24 or (color.Color and $FFFFFF));
- inc(pDst); inc(alpha);
end;
end;
@@ -1513,7 +2059,7 @@ function TRadialGradientRenderer.Initialize(targetImage: TImage32): Boolean;
begin
result := inherited Initialize(targetImage) and (fColorsCnt > 1);
if result then
- fColors := MakeColorGradient(fGradientColors, fColorsCnt);
+ MakeColorGradient(fGradientColors, fColorsCnt, fColors);
end;
// ------------------------------------------------------------------------------
@@ -1551,21 +2097,30 @@ procedure TRadialGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
dist: double;
- color: TARGB;
+ color: TColor32;
pDst: PColor32;
+ opacityTable: PByteArray;
begin
pDst := GetDstPixel(x1,y);
- for i := x1 to x2 do
+ if Opacity < 255 then
begin
- dist := Hypot((y - fCenterPt.Y) *fScaleY, (i - fCenterPt.X) *fScaleX);
-{$IFDEF UseTrunc}
- color.Color := fColors[fBoundsProc(Trunc(dist), fColorsCnt)];
-{$ELSE}
- color.Color := fColors[fBoundsProc(Round(dist), fColorsCnt)];
-{$ENDIF}
- pDst^ := BlendToAlpha(pDst^,
- MulBytes(color.A, Ord(alpha^)) shl 24 or (color.Color and $FFFFFF));
- inc(pDst); inc(alpha);
+ opacityTable := PByteArray(@MulTable[Opacity]);
+ for i := x1 to x2 do
+ begin
+ dist := Hypot((y - fCenterPt.Y) *fScaleY, (i - fCenterPt.X) *fScaleX);
+ color := fColors[fBoundsProc(Trunc(dist), fColorsCnt)];
+ pDst^ := BlendToAlpha3(pDst^, color, opacityTable[Ord(alpha^)]);
+ inc(pDst); inc(alpha);
+ end;
+ end else
+ begin
+ for i := x1 to x2 do
+ begin
+ dist := Hypot((y - fCenterPt.Y) *fScaleY, (i - fCenterPt.X) *fScaleX);
+ color := fColors[fBoundsProc(Trunc(dist), fColorsCnt)];
+ pDst^ := BlendToAlpha3(pDst^, color, Ord(alpha^));
+ inc(pDst); inc(alpha);
+ end;
end;
end;
@@ -1577,7 +2132,7 @@ function TSvgRadialGradientRenderer.Initialize(targetImage: TImage32): Boolean;
begin
result := inherited Initialize(targetImage) and (fColorsCnt > 1);
if result then
- fColors := MakeColorGradient(fGradientColors, fColorsCnt);
+ MakeColorGradient(fGradientColors, fColorsCnt, fColors);
end;
// ------------------------------------------------------------------------------
@@ -1615,10 +2170,12 @@ procedure TSvgRadialGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte
i: integer;
q,qq, m,c, qa,qb,qc,qs: double;
dist, dist2: double;
- color: TARGB;
+ color: TColor32;
pDst: PColor32;
pt, ellipsePt: TPointD;
+ opacityTable: PByteArray;
begin
+ opacityTable := PByteArray(@MulTable[Opacity]);
// get the left-most pixel to render
pDst := GetDstPixel(x1,y);
pt.X := x1 - fCenterPt.X; pt.Y := y - fCenterPt.Y;
@@ -1665,17 +2222,18 @@ procedure TSvgRadialGradientRenderer.RenderProc(x1, x2, y: integer; alpha: PByte
ellipsePt.X := (-qb -qs)/(2 * qa) else
ellipsePt.X := (-qb +qs)/(2 * qa);
ellipsePt.Y := m * ellipsePt.X + c;
- dist := Hypot(pt.X - fFocusPt.X, pt.Y - fFocusPt.Y);
- dist2 := Hypot(ellipsePt.X - fFocusPt.X, ellipsePt.Y - fFocusPt.Y);
+
+ // Use sqr'ed distances (Sqrt(a^2+b^2)/Sqrt(x^2+y^2) => Sqrt((a^2+b^2)/(x^2+y^2))
+ dist := Sqr(pt.X - fFocusPt.X) + Sqr(pt.Y - fFocusPt.Y);
+ dist2 := Sqr(ellipsePt.X - fFocusPt.X) + Sqr(ellipsePt.Y - fFocusPt.Y);
if dist2 = 0 then
q := 1 else
- q := dist/ dist2;
+ q := Sqrt(dist/dist2);
end else
q := 1; //shouldn't happen :)
end;
- color.Color := fColors[fBoundsProcD(Abs(q), fColorsCnt)];
- pDst^ := BlendToAlpha(pDst^,
- MulBytes(color.A, Ord(alpha^)) shl 24 or (color.Color and $FFFFFF));
+ color := fColors[fBoundsProcD(Abs(q), fColorsCnt)];
+ pDst^ := BlendToAlpha3(pDst^, color, opacityTable[Ord(alpha^)]);
inc(pDst); pt.X := pt.X + 1; inc(alpha);
end;
end;
@@ -1693,9 +2251,9 @@ procedure TEraseRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
for i := x1 to x2 do
begin
{$IFDEF PBYTE}
- dst.A := MulBytes(dst.A, not alpha^);
+ dst.A := MulTable[dst.A, not alpha^];
{$ELSE}
- dst.A := MulBytes(dst.A, not Ord(alpha^));
+ dst.A := MulTable[dst.A, not Ord(alpha^)];
{$ENDIF}
inc(dst); inc(alpha);
end;
@@ -1705,23 +2263,74 @@ procedure TEraseRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
// TInverseRenderer
// ------------------------------------------------------------------------------
+constructor TInverseRenderer.Create(bkImg: TImage32);
+begin
+ inherited Create;
+ fCurrBackY := -1;
+ // bkImg, when assigned, is the background master image
+ // and fImage is very likely a transparent (layered) image
+ fBackImage := bkImg;
+end;
+// ------------------------------------------------------------------------------
+
+function TInverseRenderer.GetSrcPixel(x, y: integer): Pointer;
+begin
+ if (y <> fCurrBackY) then
+ begin
+ fCurrBackY := y;
+ fCurrBkLinePtr := fBackImage.PixelBase;
+ inc(PByte(fCurrBkLinePtr), y * fImgWidth * fPixelSize);
+ end;
+ Result := fCurrBkLinePtr;
+ inc(PByte(Result), x * fPixelSize);
+end;
+// ------------------------------------------------------------------------------
+
+function IsMidColor(const color: TARGB): Boolean;
+{$IFDEF INLINE} inline; {$ENDIF}
+begin
+ // not too dark and not too light :))
+ Result := Abs(color.R + color.G + color.B - 383) < 64;
+end;
+// ------------------------------------------------------------------------------
+
procedure TInverseRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
var
i: integer;
- dst: PARGB;
+ src, dst: PARGB;
c: TARGB;
begin
dst := PARGB(GetDstPixel(x1,y));
- for i := x1 to x2 do
+ if Assigned(fBackImage) then
begin
- c.Color := not dst.Color;
- c.A := MulBytes(dst.A, Ord(alpha^));
- dst.Color := BlendToAlpha(dst.Color, c.Color);
- inc(dst); inc(alpha);
+ src := PARGB(GetSrcPixel(x1,y));
+ for i := x1 to x2 do
+ begin
+ if src.Color = 0 then c.Color := clBlack32
+ else if IsMidColor(src^) then c.Color := clWhite32
+ else c.Color := not src.Color;
+ c.A := Ord(alpha^);
+ dst.Color := BlendToAlpha(dst.Color, c.Color);
+ inc(dst); inc(src); inc(alpha);
+ end;
+ end else
+ begin
+ for i := x1 to x2 do
+ begin
+ if dst.Color = 0 then c.Color := clBlack32
+ else if IsMidColor(dst^) then c.Color := clWhite32
+ else c.Color := not dst.Color;
+ c.A := Ord(alpha^);
+ dst.Color := BlendToAlpha(dst.Color, c.Color);
+ inc(dst); inc(alpha);
+ end;
end;
end;
// ------------------------------------------------------------------------------
+// TBarycentricRenderer
+// ------------------------------------------------------------------------------
+
procedure TBarycentricRenderer.SetParameters(const a, b, c: TPointD;
c1, c2, c3: TColor32);
@@ -1771,16 +2380,31 @@ procedure TBarycentricRenderer.RenderProc(x1, x2, y: integer; alpha: PByte);
x: integer;
p: PARGB;
c: TARGB;
+ opacityTable: PByteArray;
begin
p := PARGB(fImgBase);
inc(p, y * ImgWidth + x1);
- for x := x1 to x2 do
+ if Opacity < 255 then
begin
- c.Color := GetColor(PointD(x, y));
- c.A := c.A * Ord(alpha^) shr 8;
- p.Color := BlendToAlpha(p.Color, c.Color);
- inc(p); inc(alpha);
- end;
+ opacityTable := PByteArray(@MulTable[Opacity]);
+ for x := x1 to x2 do
+ begin
+ c.Color := GetColor(PointD(x, y));
+ c.A := opacityTable[MulTable[c.A, Ord(alpha^)]];
+ p.Color := BlendToAlpha(p.Color, c.Color);
+ inc(p); inc(alpha);
+ end
+ end
+ else
+ for x := x1 to x2 do
+ begin
+ c.Color := GetColor(PointD(x, y));
+ c.A := MulTable[c.A, Ord(alpha^)];
+ p.Color := BlendToAlpha(p.Color, c.Color);
+ inc(p); inc(alpha);
+ end
+
+
end;
// ------------------------------------------------------------------------------
@@ -1848,7 +2472,7 @@ procedure DrawLine(img: TImage32;
lines: TPathsD;
begin
setLength(lines, 1);
- setLength(lines[0], 2);
+ NewPointDArray(lines[0], 2, True);
lines[0][0] := pt1;
lines[0][1] := pt2;
DrawLine(img, lines, lineWidth, color, esRound);
@@ -1867,6 +2491,19 @@ procedure DrawLine(img: TImage32; const line: TPathD; lineWidth: double;
end;
// ------------------------------------------------------------------------------
+procedure DrawLine(img: TImage32; const line: TPathD; lineWidth: double;
+ color: TColor32; rendererCache: TCustomRendererCache;
+ endStyle: TEndStyle; joinStyle: TJoinStyle; miterLimit: double);
+var
+ lines: TPathsD;
+begin
+ setLength(lines, 1);
+ lines[0] := line;
+ DrawLine(img, lines, lineWidth, color, rendererCache, endStyle, joinStyle,
+ miterLimit);
+end;
+// ------------------------------------------------------------------------------
+
procedure DrawLine(img: TImage32; const line: TPathD; lineWidth: double;
renderer: TCustomRenderer; endStyle: TEndStyle; joinStyle: TJoinStyle;
miterLimit: double);
@@ -1894,28 +2531,40 @@ procedure DrawLine(img: TImage32; const lines: TPathsD;
lineWidth: double; color: TColor32;
endStyle: TEndStyle; joinStyle: TJoinStyle; miterLimit: double);
var
- lines2: TPathsD;
- cr: TCustomRenderer;
+ cr: TCustomColorRenderer;
begin
if not assigned(lines) then exit;
- if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
- lines2 := RoughOutline(lines, lineWidth, joinStyle, endStyle, miterLimit);
if img.AntiAliased then
cr := TColorRenderer.Create(color) else
cr := TAliasedColorRenderer.Create(color);
try
- if cr.Initialize(img) then
- begin
- Rasterize(lines2, img.bounds, frNonZero, cr);
- cr.NotifyChange;
- end;
+ DrawLine(img, lines, lineWidth, cr, endStyle, joinStyle, miterLimit);
finally
cr.free;
end;
end;
// ------------------------------------------------------------------------------
+procedure DrawLine(img: TImage32; const lines: TPathsD;
+ lineWidth: double; color: TColor32; rendererCache: TCustomRendererCache;
+ endStyle: TEndStyle; joinStyle: TJoinStyle; miterLimit: double);
+var
+ cr: TCustomColorRenderer;
+begin
+ if not assigned(lines) then exit;
+ if rendererCache = nil then
+ DrawLine(img, lines, lineWidth, color, endStyle, joinStyle, miterLimit)
+ else
+ begin
+ if img.AntiAliased then
+ cr := rendererCache.ColorRenderer else
+ cr := rendererCache.AliasedColorRenderer;
+ DrawLine(img, lines, lineWidth, cr, endStyle, joinStyle, miterLimit);
+ end;
+end;
+// ------------------------------------------------------------------------------
+
procedure DrawLine(img: TImage32; const lines: TPathsD;
lineWidth: double; renderer: TCustomRenderer;
endStyle: TEndStyle; joinStyle: TJoinStyle;
@@ -1926,11 +2575,7 @@ procedure DrawLine(img: TImage32; const lines: TPathsD;
if (not assigned(lines)) or (not assigned(renderer)) then exit;
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
lines2 := RoughOutline(lines, lineWidth, joinStyle, endStyle, miterLimit);
- if renderer.Initialize(img) then
- begin
- Rasterize(lines2, img.bounds, frNonZero, renderer);
- renderer.NotifyChange;
- end;
+ Rasterize(img, lines2, img.bounds, frNonZero, renderer);
end;
// ------------------------------------------------------------------------------
@@ -1946,11 +2591,7 @@ procedure DrawInvertedLine(img: TImage32;
lines2 := RoughOutline(lines, lineWidth, joinStyle, endStyle, 2);
ir := TInverseRenderer.Create;
try
- if ir.Initialize(img) then
- begin
- Rasterize(lines2, img.bounds, frNonZero, ir);
- ir.NotifyChange;
- end;
+ Rasterize(img, lines2, img.bounds, frNonZero, ir);
finally
ir.free;
end;
@@ -1958,8 +2599,9 @@ procedure DrawInvertedLine(img: TImage32;
// ------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const line: TPathD;
- dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
- color: TColor32; endStyle: TEndStyle; joinStyle: TJoinStyle);
+ dashPattern: TArrayOfDouble; patternOffset: PDouble; lineWidth: double;
+ color: TColor32; endStyle: TEndStyle; joinStyle: TJoinStyle;
+ rendererCache: TCustomRendererCache);
var
lines: TPathsD;
cr: TColorRenderer;
@@ -1987,34 +2629,36 @@ procedure DrawDashedLine(img: TImage32; const line: TPathD;
endStyle := esButt;
end;
lines := RoughOutline(lines, lineWidth, joinStyle, endStyle);
- cr := TColorRenderer.Create(color);
+
+ if rendererCache = nil then
+ cr := TColorRenderer.Create(color) else
+ cr := rendererCache.GetColorRenderer(color);
try
- if cr.Initialize(img) then
- begin
- Rasterize(lines, img.bounds, frNonZero, cr);
- cr.NotifyChange;
- end;
+ Rasterize(img, lines, img.bounds, frNonZero, cr);
finally
- cr.free;
+ if rendererCache = nil then
+ cr.free;
end;
end;
// ------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
- dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
- color: TColor32; endStyle: TEndStyle; joinStyle: TJoinStyle);
+ dashPattern: TArrayOfDouble; patternOffset: PDouble; lineWidth: double;
+ color: TColor32; endStyle: TEndStyle; joinStyle: TJoinStyle;
+ rendererCache: TCustomRendererCache);
var
i: integer;
begin
if not assigned(lines) then exit;
for i := 0 to high(lines) do
DrawDashedLine(img, lines[i],
- dashPattern, patternOffset, lineWidth, color, endStyle, joinStyle);
+ dashPattern, patternOffset, lineWidth, color, endStyle, joinStyle,
+ rendererCache);
end;
// ------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const line: TPathD;
- dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
+ dashPattern: TArrayOfDouble; patternOffset: PDouble; lineWidth: double;
renderer: TCustomRenderer; endStyle: TEndStyle; joinStyle: TJoinStyle);
var
i: integer;
@@ -2029,16 +2673,12 @@ procedure DrawDashedLine(img: TImage32; const line: TPathD;
lines := GetDashedPath(line, endStyle = esPolygon, dashPattern, patternOffset);
if Length(lines) = 0 then Exit;
lines := RoughOutline(lines, lineWidth, joinStyle, endStyle);
- if renderer.Initialize(img) then
- begin
- Rasterize(lines, img.bounds, frNonZero, renderer);
- renderer.NotifyChange;
- end;
+ Rasterize(img, lines, img.bounds, frNonZero, renderer);
end;
// ------------------------------------------------------------------------------
procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
- dashPattern: TArrayOfInteger; patternOffset: PDouble; lineWidth: double;
+ dashPattern: TArrayOfDouble; patternOffset: PDouble; lineWidth: double;
renderer: TCustomRenderer; endStyle: TEndStyle; joinStyle: TJoinStyle);
var
i: integer;
@@ -2050,8 +2690,8 @@ procedure DrawDashedLine(img: TImage32; const lines: TPathsD;
end;
// ------------------------------------------------------------------------------
-procedure DrawInvertedDashedLine(img: TImage32;
- const line: TPathD; dashPattern: TArrayOfInteger;
+procedure DrawInvertedDashedLine(img, bkgndImg: TImage32;
+ const line: TPathD; dashPattern: TArrayOfDouble;
patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
joinStyle: TJoinStyle = jsAuto);
var
@@ -2059,7 +2699,14 @@ procedure DrawInvertedDashedLine(img: TImage32;
lines: TPathsD;
renderer: TInverseRenderer;
begin
- if not assigned(line) then exit;
+ // when using an alterate background image,
+ // make sure it's the same size as img ...
+ if Assigned(bkgndImg) and
+ (bkgndImg.Width <> img.Width) or
+ (bkgndImg.Height <> img.Height) then bkgndImg := nil;
+
+ if not assigned(line) or img.IsEmpty then exit;
+
if (lineWidth < MinStrokeWidth) then lineWidth := MinStrokeWidth;
for i := 0 to High(dashPattern) do
@@ -2068,29 +2715,49 @@ procedure DrawInvertedDashedLine(img: TImage32;
lines := GetDashedPath(line, endStyle = esPolygon, dashPattern, patternOffset);
if Length(lines) = 0 then Exit;
lines := RoughOutline(lines, lineWidth, joinStyle, endStyle);
- renderer := TInverseRenderer.Create;
+ renderer := TInverseRenderer.Create(bkgndImg);
try
- if renderer.Initialize(img) then
- begin
- Rasterize(lines, img.bounds, frNonZero, renderer);
- renderer.NotifyChange;
- end;
+ Rasterize(img, lines, img.bounds, frNonZero, renderer);
finally
renderer.Free;
end;
end;
// ------------------------------------------------------------------------------
+procedure DrawInvertedDashedLine(img, bkgndImg: TImage32;
+ const lines: TPathsD; dashPattern: TArrayOfDouble;
+ patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
+ joinStyle: TJoinStyle = jsAuto);
+var
+ i: integer;
+begin
+ if not assigned(lines) then exit;
+ for i := 0 to high(lines) do
+ DrawInvertedDashedLine(img, bkgndImg, lines[i],
+ dashPattern, patternOffset, lineWidth, endStyle, joinStyle);
+end;
+// ------------------------------------------------------------------------------
+
procedure DrawInvertedDashedLine(img: TImage32;
- const lines: TPathsD; dashPattern: TArrayOfInteger;
- patternOffset: PDouble; lineWidth: double;
- endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto);
+ const line: TPathD; dashPattern: TArrayOfDouble;
+ patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
+ joinStyle: TJoinStyle);
+begin
+ DrawInvertedDashedLine(img, nil, line,
+ dashPattern, patternOffset, lineWidth, endStyle, joinStyle);
+end;
+// ------------------------------------------------------------------------------
+
+procedure DrawInvertedDashedLine(img: TImage32;
+ const lines: TPathsD; dashPattern: TArrayOfDouble;
+ patternOffset: PDouble; lineWidth: double; endStyle: TEndStyle;
+ joinStyle: TJoinStyle);
var
i: integer;
begin
if not assigned(lines) then exit;
for i := 0 to high(lines) do
- DrawInvertedDashedLine(img, lines[i],
+ DrawInvertedDashedLine(img, nil, lines[i],
dashPattern, patternOffset, lineWidth, endStyle, joinStyle);
end;
// ------------------------------------------------------------------------------
@@ -2115,11 +2782,7 @@ procedure DrawPolygon(img: TImage32; const polygon: TPathD;
if (not assigned(polygon)) or (not assigned(renderer)) then exit;
setLength(polygons, 1);
polygons[0] := polygon;
- if renderer.Initialize(img) then
- begin
- Rasterize(polygons, img.Bounds, fillRule, renderer);
- renderer.NotifyChange;
- end;
+ Rasterize(img, polygons, img.Bounds, fillRule, renderer);
end;
// ------------------------------------------------------------------------------
@@ -2133,11 +2796,7 @@ procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
cr := TColorRenderer.Create(color) else
cr := TAliasedColorRenderer.Create(color);
try
- if cr.Initialize(img) then
- begin
- Rasterize(polygons, img.bounds, fillRule, cr);
- cr.NotifyChange;
- end;
+ Rasterize(img, polygons, img.bounds, fillRule, cr);
finally
cr.free;
end;
@@ -2145,17 +2804,33 @@ procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
// ------------------------------------------------------------------------------
procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
- fillRule: TFillRule; renderer: TCustomRenderer);
+ fillRule: TFillRule; color: TColor32;
+ rendererCache: TCustomRendererCache);
+var
+ cr: TCustomColorRenderer;
begin
- if (not assigned(polygons)) or (not assigned(renderer)) then exit;
- if renderer.Initialize(img) then
+ if not assigned(polygons) then exit;
+ if rendererCache = nil then
+ DrawPolygon(img, polygons, fillRule, color)
+ else
begin
- Rasterize(polygons, img.bounds, fillRule, renderer);
- renderer.NotifyChange;
+ if img.AntiAliased then
+ cr := rendererCache.ColorRenderer else
+ cr := rendererCache.AliasedColorRenderer;
+ cr.SetColor(color);
+ Rasterize(img, polygons, img.bounds, fillRule, cr);
end;
end;
// ------------------------------------------------------------------------------
+procedure DrawPolygon(img: TImage32; const polygons: TPathsD;
+ fillRule: TFillRule; renderer: TCustomRenderer);
+begin
+ if (not assigned(polygons)) or (not assigned(renderer)) then exit;
+ Rasterize(img, polygons, img.bounds, fillRule, renderer);
+end;
+// ------------------------------------------------------------------------------
+
procedure DrawInvertedPolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule);
var
@@ -2176,11 +2851,7 @@ procedure DrawInvertedPolygon(img: TImage32; const polygons: TPathsD;
if not assigned(polygons) then exit;
cr := TInverseRenderer.Create;
try
- if cr.Initialize(img) then
- begin
- Rasterize(polygons, img.bounds, fillRule, cr);
- cr.NotifyChange;
- end;
+ Rasterize(img, polygons, img.bounds, fillRule, cr);
finally
cr.free;
end;
@@ -2206,19 +2877,45 @@ procedure DrawPolygon_ClearType(img: TImage32; const polygons: TPathsD;
tmpPolygons := ScalePath(tmpPolygons, 3, 1);
cr := TColorRenderer.Create(clBlack32);
try
- if cr.Initialize(tmpImg) then
- Rasterize(tmpPolygons, tmpImg.bounds, fillRule, cr);
+ Rasterize(tmpImg, tmpPolygons, tmpImg.bounds, fillRule, cr);
finally
cr.Free;
end;
ApplyClearType(tmpImg, color, backColor);
- img.CopyBlend(tmpImg, tmpImg.Bounds, rec, BlendToAlpha);
+ img.CopyBlend(tmpImg, tmpImg.Bounds, rec, BlendToAlphaLine);
finally
tmpImg.Free;
end;
end;
// ------------------------------------------------------------------------------
+procedure EraseLine(img: TImage32; const line: TPathD; lineWidth: double;
+ endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto; miterLimit: double = 2);
+var
+ lines: TPathsD;
+begin
+ if not assigned(line) then exit;
+ setLength(lines, 1);
+ lines[0] := line;
+ EraseLine(img, lines, lineWidth, endStyle, joinStyle, miterLimit);
+end;
+// ------------------------------------------------------------------------------
+
+procedure EraseLine(img: TImage32; const lines: TPathsD; lineWidth: double;
+ endStyle: TEndStyle; joinStyle: TJoinStyle = jsAuto; miterLimit: double = 2);
+var
+ er: TEraseRenderer;
+begin
+ if not assigned(lines) then exit;
+ er := TEraseRenderer.Create;
+ try
+ DrawLine(img, lines, lineWidth, er, endStyle, joinStyle, miterLimit);
+ finally
+ er.Free;
+ end;
+end;
+// ------------------------------------------------------------------------------
+
procedure ErasePolygon(img: TImage32; const polygon: TPathD;
fillRule: TFillRule);
var
@@ -2238,11 +2935,7 @@ procedure ErasePolygon(img: TImage32; const polygons: TPathsD;
begin
er := TEraseRenderer.Create;
try
- if er.Initialize(img) then
- begin
- Rasterize(polygons, img.bounds, fillRule, er);
- er.NotifyChange;
- end;
+ Rasterize(img, polygons, img.bounds, fillRule, er);
finally
er.Free;
end;
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas b/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas
index 4e8a576..a639e12 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas
@@ -2,12 +2,12 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 11 May 2024 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2024 *
+* Version : 4.8 *
+* Date : 2 February 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : Miscellaneous routines that don't belong in other modules. *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -30,7 +30,7 @@ procedure DrawEdge(img: TImage32; const path: TPathD;
topLeftColor, bottomRightColor: TColor32;
penWidth: double = 1.0; closePath: Boolean = true); overload;
-//DrawShadowRect: is **much** faster than DrawShadow
+// DrawShadowRect: is **much** faster than DrawShadow
procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double;
angle: double = angle45; color: TColor32 = $80000000);
procedure DrawShadow(img: TImage32; const polygon: TPathD;
@@ -45,8 +45,8 @@ procedure DrawGlow(img: TImage32; const polygon: TPathD;
procedure DrawGlow(img: TImage32; const polygons: TPathsD;
fillRule: TFillRule; color: TColor32; blurRadius: integer); overload;
-//FloodFill: If no CompareFunc is provided, FloodFill will fill whereever
-//adjoining pixels exactly match the starting pixel - Point(x,y).
+// FloodFill: If no CompareFunc is provided, FloodFill will fill wherever
+// adjoining pixels exactly match the starting pixel - Point(x,y).
procedure FloodFill(img: TImage32; x, y: Integer; newColor: TColor32;
tolerance: Byte = 0; compareFunc: TCompareFunctionEx = nil);
@@ -57,16 +57,24 @@ procedure FastGaussianBlur(img: TImage32;
procedure GaussianBlur(img: TImage32; rec: TRect; radius: Integer);
-//Emboss: A smaller radius is sharper. Increasing depth increases contrast.
-//Luminance changes grayscale balance (unless preserveColor = true)
+// Emboss: A smaller radius is sharper. Increasing depth increases contrast.
+// Luminance changes grayscale balance (unless preserveColor = true)
procedure Emboss(img: TImage32; radius: Integer = 1; depth: Integer = 10;
luminance: Integer = 75; preserveColor: Boolean = false);
-//Sharpen: Radius range is 1 - 10; amount range is 1 - 50.
-//see https://en.wikipedia.org/wiki/Unsharp_masking
+// Sharpen: Radius range is 1 - 10; amount range is 1 - 50.
+// see https://en.wikipedia.org/wiki/Unsharp_masking
procedure Sharpen(img: TImage32; radius: Integer = 2; amount: Integer = 10);
-//HatchBackground: Assumes the current image is semi-transparent.
+// Hatch: This will overwrite the image and ignore any transparency
+procedure Hatch(img: TImage32; color1: TColor32 = clWhite32;
+ color2: TColor32= $FFE8E8E8; hatchSize: Integer = 10); overload;
+procedure Hatch(img: TImage32; const rec: TRect;
+ color1: TColor32 = clWhite32; color2: TColor32= $FFE8E8E8;
+ hatchSize: Integer = 10); overload;
+
+// HatchBackground: hatches behind the existing image, so
+// it assumes the current image is semi-transparent.
procedure HatchBackground(img: TImage32; color1: TColor32 = clWhite32;
color2: TColor32= $FFE8E8E8; hatchSize: Integer = 10); overload;
procedure HatchBackground(img: TImage32; const rec: TRect;
@@ -77,22 +85,27 @@ procedure GridBackground(img: TImage32; majorInterval, minorInterval: integer;
fillColor: TColor32 = clWhite32;
majColor: TColor32 = $30000000; minColor: TColor32 = $20000000);
+procedure ReplaceColor(img: TImage32; oldColor, newColor: TColor32;
+ channelTolerance: Byte; preserveAlpha: Boolean = false);
procedure ReplaceExactColor(img: TImage32; oldColor, newColor: TColor32);
-//RemoveColor: Removes the specified color from the image, even from
-//pixels that are a blend of colors including the specified color.
-//see https://stackoverflow.com/questions/9280902/
+// RemoveColor: Removes the specified color from the image, even from
+// pixels that are a blend of colors including the specified color.
+// see https://stackoverflow.com/questions/9280902/
procedure RemoveColor(img: TImage32; color: TColor32);
+procedure RemoveExactColor(img: TImage32; color: TColor32);
+// RemoveAllExceptColor: Opposite of RemoveColor
+procedure RemoveAllExceptColor(img: TImage32; color: TColor32);
-//FilterOnColor: Removes everything not nearly matching 'color'
-//This uses an algorithm that's very similar to the one in RemoveColor.
-procedure FilterOnColor(img: TImage32; color: TColor32);
-
-procedure FilterOnExactColor(img: TImage32; color: TColor32);
+// FilterOnColor - renamed RemoveAllExceptColor
+procedure FilterOnColor(img: TImage32; color: TColor32); deprecated;
+// FilterOnExactColor - renamed RemoveExactColor
+procedure FilterOnExactColor(img: TImage32; color: TColor32); deprecated;
-procedure FilterOnAlpha(img: TImage32; alpha: byte; tolerance: byte);
+// FilterOnAlpha - simpler just to set alpha to zero below a specified alpha
+// procedure FilterOnAlpha(img: TImage32; alpha: byte; tolerance: byte);
-//RedEyeRemove: Removes 'red eye' from flash photo images.
+// RedEyeRemove: Removes 'red eye' from flash photo images.
procedure RedEyeRemove(img: TImage32; const rect: TRect);
procedure PencilEffect(img: TImage32; intensity: integer = 0);
@@ -107,7 +120,8 @@ procedure EraseInsidePaths(img: TImage32;
procedure EraseOutsidePath(img: TImage32; const path: TPathD;
fillRule: TFillRule; const outsideBounds: TRect);
procedure EraseOutsidePaths(img: TImage32; const paths: TPathsD;
- fillRule: TFillRule; const outsideBounds: TRect);
+ fillRule: TFillRule; const outsideBounds: TRect;
+ rendererCache: TCustomRendererCache = nil); overload;
procedure Draw3D(img: TImage32; const polygon: TPathD;
fillRule: TFillRule; height, blurRadius: double;
@@ -149,8 +163,8 @@ function SimplifyPaths(const paths: TPathsD;
shapeTolerance: double = 0.1; isClosedPath: Boolean = true): TPathsD;
{$ENDIF}
-// SimplifyPathEx: this is mainly useful following Vectorize()
-// Also removes very short segments that zig-zag (rather than curve)
+// SimplifyPathEx: this is particularly useful following Vectorize()
+// because it also removes very short zig-zag segments
function SimplifyPathEx(const path: TPathD; shapeTolerance: double): TPathD;
function SimplifyPathsEx(const paths: TPathsD; shapeTolerance: double): TPathsD;
@@ -172,12 +186,9 @@ function SmoothPath(const path: TPathD; isClosedPath: Boolean;
function SmoothPaths(const paths: TPathsD; isClosedPath: Boolean;
tension: double = 0; shapeTolerance: double = 0.1): TPathsD;
-function GetFloodFillMask(imgIn, imgMaskOut: TImage32; x, y: Integer;
- tolerance: Byte; compareFunc: TCompareFunctionEx): Boolean;
+function SymmetricCropTransparent(img: TImage32): TPoint;
-procedure SymmetricCropTransparent(img: TImage32);
-
-//3 additional blend functions (see TImage32.CopyBlend)
+// Three additional blend functions (see TImage32.CopyBlend)
function BlendAverage(bgColor, fgColor: TColor32): TColor32;
function BlendLinearBurn(bgColor, fgColor: TColor32): TColor32;
function BlendColorDodge(bgColor, fgColor: TColor32): TColor32;
@@ -217,6 +228,23 @@ TVertex = record
// Miscellaneous functions
//------------------------------------------------------------------------------
+function Clamp(val, endVal: integer): integer;
+ {$IFDEF INLINE} inline; {$ENDIF}
+begin
+ if val < 0 then Result := 0
+ else if val >= endVal then Result := endVal -1
+ else Result := val;
+end;
+//------------------------------------------------------------------------------
+
+function ModEx(val, endVal: integer): integer;
+ {$IFDEF INLINE} inline; {$ENDIF}
+begin
+ Result := val mod endVal;
+ if Result < 0 then Result := endVal + Result;
+end;
+//------------------------------------------------------------------------------
+
function GetSymmetricCropTransparentRect(img: TImage32): TRect;
var
w,h, x,y, x1,y1: Integer;
@@ -275,14 +303,15 @@ function GetSymmetricCropTransparentRect(img: TImage32): TRect;
end;
//------------------------------------------------------------------------------
-//SymmetricCropTransparent: after cropping, the image's midpoint
-//will be the same pixel as before cropping. (Important for rotating.)
-procedure SymmetricCropTransparent(img: TImage32);
+// SymmetricCropTransparent: after cropping, the image's midpoint
+// will be the same pixel as before cropping. (Important for rotating.)
+function SymmetricCropTransparent(img: TImage32): TPoint;
var
rec: TRect;
begin
rec := GetSymmetricCropTransparentRect(img);
- if (rec.Top > 0) or (rec.Left > 0) then img.Crop(rec);
+ Result := rec.TopLeft;
+ if (Result.X > 0) or (Result.Y > 0) then img.Crop(rec);
end;
//------------------------------------------------------------------------------
@@ -345,7 +374,7 @@ procedure DrawEdge(img: TImage32; const path: TPathD;
p := path;
if closePath and not PointsNearEqual(p[0], p[highI], 0.01) then
begin
- AppendToPath(p, p[0]);
+ AppendPoint(p, p[0]);
inc(highI);
end;
for i := 1 to highI do
@@ -538,7 +567,9 @@ procedure DrawShadow(img: TImage32; const polygons: TPathsD;
begin
rec := GetBounds(polygons);
if IsEmptyRect(rec) or (depth < 1) then Exit;
- if not ClockwiseRotationIsAnglePositive then angleRads := -angleRads;
+{$IFDEF CLOCKWISE_ROTATION_WITH_NEGATIVE_ANGLES}
+ angleRads := -angleRads;
+{$ENDIF}
NormalizeAngle(angleRads);
GetSinCos(angleRads, y, x);
depth := depth * 0.5;
@@ -554,7 +585,7 @@ procedure DrawShadow(img: TImage32; const polygons: TPathsD;
DrawPolygon(shadowImg, shadowPolys, fillRule, color);
FastGaussianBlur(shadowImg, shadowImg.Bounds, blurSize, 1);
if cutoutInsideShadow then EraseInsidePaths(shadowImg, polys, fillRule);
- img.CopyBlend(shadowImg, shadowImg.Bounds, rec, BlendToAlpha);
+ img.CopyBlend(shadowImg, shadowImg.Bounds, rec, BlendToAlphaLine);
finally
shadowImg.Free;
end;
@@ -590,7 +621,7 @@ procedure DrawGlow(img: TImage32; const polygons: TPathsD;
DrawPolygon(glowImg, glowPolys, fillRule, color);
FastGaussianBlur(glowImg, glowImg.Bounds, blurRadius, 2);
glowImg.ScaleAlpha(4);
- img.CopyBlend(glowImg, glowImg.Bounds, rec, BlendToAlpha);
+ img.CopyBlend(glowImg, glowImg.Bounds, rec, BlendToAlphaLine);
finally
glowImg.Free;
end;
@@ -631,30 +662,106 @@ procedure Sharpen(img: TImage32; radius: Integer; amount: Integer);
end;
//------------------------------------------------------------------------------
-procedure HatchBackground(img: TImage32; const rec: TRect;
- color1: TColor32 = clWhite32; color2: TColor32= $FFE8E8E8;
- hatchSize: Integer = 10); overload;
+procedure InternalHatch(img: TImage32; const rec: TRect;
+ color1, color2: TColor32; hatchSize: Integer = 10);
var
- i,j: Integer;
+ i, j, imgWidth: Integer;
pc: PColor32;
colors: array[boolean] of TColor32;
hatch: Boolean;
+ x: integer;
begin
colors[false] := color1;
colors[true] := color2;
+ imgWidth := img.Width;
+
+ for i := rec.Top to rec.Bottom -1 do
+ begin
+ pc := @img.Pixels[i * imgWidth + rec.Left];
+ hatch := Odd(i div hatchSize);
+ x := (rec.Left + 1) mod hatchSize;
+ if x = 0 then hatch := not hatch;
+ for j := rec.Left to rec.Right -1 do
+ begin
+ pc^ := colors[hatch];
+ inc(pc); inc(x);
+ if x >= hatchSize then
+ begin
+ x := 0;
+ hatch := not hatch;
+ end;
+ end;
+ end;
+end;
+//------------------------------------------------------------------------------
+
+procedure Hatch(img: TImage32; color1: TColor32 = clWhite32;
+ color2: TColor32= $FFE8E8E8; hatchSize: Integer = 10);
+begin
+ Hatch(img, img.Bounds, color1, color2, hatchSize);
+end;
+//------------------------------------------------------------------------------
+
+procedure Hatch(img: TImage32; const rec: TRect;
+ color1: TColor32 = clWhite32; color2: TColor32= $FFE8E8E8;
+ hatchSize: Integer = 10);
+begin
+ if (rec.Right <= rec.Left) or (rec.Bottom - rec.Top <= 0) then Exit;
img.BeginUpdate;
try
- for i := rec.Top to rec.Bottom -1 do
+ InternalHatch(img, rec, color1, color2, hatchSize);
+ finally
+ img.EndUpdate;
+ end;
+end;
+//------------------------------------------------------------------------------
+
+procedure InternalHatchBackground(img: TImage32; const rec: TRect;
+ color1, color2: TColor32; hatchSize: Integer = 10);
+var
+ i, j, imgWidth: Integer;
+ pc: PColor32;
+ colors: array[boolean] of TColor32;
+ hatch: Boolean;
+ x: integer;
+begin
+ colors[false] := color1;
+ colors[true] := color2;
+ imgWidth := img.Width;
+
+ for i := rec.Top to rec.Bottom -1 do
+ begin
+ pc := @img.Pixels[i * imgWidth + rec.Left];
+ hatch := Odd(i div hatchSize);
+
+ x := (rec.Left + 1) mod hatchSize;
+ if x = 0 then hatch := not hatch;
+ for j := rec.Left to rec.Right -1 do
begin
- pc := @img.Pixels[i * img.Width + rec.Left];
- hatch := Odd(i div hatchSize);
- for j := rec.Left to rec.Right -1 do
- begin
- if (j + 1) mod hatchSize = 0 then hatch := not hatch;
+ if pc^ = 0 then
+ pc^ := colors[hatch]
+ else if GetAlpha(pc^) < 255 then
pc^ := BlendToOpaque(colors[hatch], pc^);
- inc(pc);
+ inc(pc);
+ inc(x);
+ if x >= hatchSize then
+ begin
+ x := 0;
+ hatch := not hatch;
end;
end;
+ end;
+end;
+//------------------------------------------------------------------------------
+
+procedure HatchBackground(img: TImage32; const rec: TRect;
+ color1: TColor32 = clWhite32; color2: TColor32= $FFE8E8E8;
+ hatchSize: Integer = 10); overload;
+begin
+ if (rec.Right <= rec.Left) or (rec.Bottom - rec.Top <= 0) then Exit;
+ img.BeginUpdate;
+ try
+ InternalHatchBackground(img, rec, color1, color2, hatchSize);
finally
img.EndUpdate;
end;
@@ -673,47 +780,58 @@ procedure GridBackground(img: TImage32; majorInterval, minorInterval: integer;
var
i, x,y, w,h: integer;
path: TPathD;
+ cr: TCustomColorRenderer;
begin
img.Clear(fillColor);
w := img.Width; h := img.Height;
- SetLength(path, 2);
- if minorInterval > 0 then
- begin
- x := minorInterval;
- path[0] := PointD(x, 0); path[1] := PointD(x, h);;
- for i := 1 to (w div minorInterval) do
- begin
- Img32.Draw.DrawLine(img, path, 1, minColor, esSquare);
- path[0].X := path[0].X + minorInterval;
- path[1].X := path[1].X + minorInterval;
- end;
- y := minorInterval;
- path[0] := PointD(0, y); path[1] := PointD(w, y);
- for i := 1 to (h div minorInterval) do
- begin
- Img32.Draw.DrawLine(img, path, 1, minColor, esSquare);
- path[0].Y := path[0].Y + minorInterval;
- path[1].Y := path[1].Y + minorInterval;
- end;
- end;
- if majorInterval > minorInterval then
- begin
- x := majorInterval;
- path[0] := PointD(x, 0); path[1] := PointD(x, h);;
- for i := 1 to (w div majorInterval) do
+ NewPointDArray(path, 2, True);
+
+ if img.AntiAliased then
+ cr := TColorRenderer.Create(minColor) else
+ cr := TAliasedColorRenderer.Create(minColor);
+ try
+ if minorInterval > 0 then
begin
- Img32.Draw.DrawLine(img, path, 1, majColor, esSquare);
- path[0].X := path[0].X + majorInterval;
- path[1].X := path[1].X + majorInterval;
+ x := minorInterval;
+ path[0] := PointD(x, 0); path[1] := PointD(x, h);;
+ for i := 1 to (w div minorInterval) do
+ begin
+ Img32.Draw.DrawLine(img, path, 1, cr, esSquare);
+ path[0].X := path[0].X + minorInterval;
+ path[1].X := path[1].X + minorInterval;
+ end;
+ y := minorInterval;
+ path[0] := PointD(0, y); path[1] := PointD(w, y);
+ for i := 1 to (h div minorInterval) do
+ begin
+ Img32.Draw.DrawLine(img, path, 1, cr, esSquare);
+ path[0].Y := path[0].Y + minorInterval;
+ path[1].Y := path[1].Y + minorInterval;
+ end;
end;
- y := majorInterval;
- path[0] := PointD(0, y); path[1] := PointD(w, y);
- for i := 1 to (h div majorInterval) do
+ if majorInterval > minorInterval then
begin
- Img32.Draw.DrawLine(img, path, 1, majColor, esSquare);
- path[0].Y := path[0].Y + majorInterval;
- path[1].Y := path[1].Y + majorInterval;
+ cr.SetColor(majColor);
+
+ x := majorInterval;
+ path[0] := PointD(x, 0); path[1] := PointD(x, h);;
+ for i := 1 to (w div majorInterval) do
+ begin
+ Img32.Draw.DrawLine(img, path, 1, cr, esSquare);
+ path[0].X := path[0].X + majorInterval;
+ path[1].X := path[1].X + majorInterval;
+ end;
+ y := majorInterval;
+ path[0] := PointD(0, y); path[1] := PointD(w, y);
+ for i := 1 to (h div majorInterval) do
+ begin
+ Img32.Draw.DrawLine(img, path, 1, cr, esSquare);
+ path[0].Y := path[0].Y + majorInterval;
+ path[1].Y := path[1].Y + majorInterval;
+ end;
end;
+ finally
+ cr.Free;
end;
end;
//------------------------------------------------------------------------------
@@ -743,6 +861,40 @@ procedure ReplaceExactColor(img: TImage32; oldColor, newColor: TColor32);
end;
//------------------------------------------------------------------------------
+procedure ReplaceColor(img: TImage32; oldColor, newColor: TColor32;
+ channelTolerance: Byte; preserveAlpha: Boolean);
+var
+ c: PARGB;
+ a,r,g,b: Byte;
+ i: Integer;
+begin
+ c := PARGB(img.PixelBase);
+ a := TARGB(oldColor).A;
+ r := TARGB(oldColor).R;
+ g := TARGB(oldColor).G;
+ b := TARGB(oldColor).B;
+
+ if preserveAlpha then
+ begin
+ newColor := newColor and $FFFFFF;
+ for i := 0 to img.Width * img.Height -1 do
+ begin
+ if Abs(c.R - r) + Abs(c.G - g) + Abs(c.B - b) <= channelTolerance then
+ c.Color := a or newColor;
+ inc(c);
+ end
+ end else
+ for i := 0 to img.Width * img.Height -1 do
+ begin
+ if (Abs(c.A - a) <= channelTolerance) and
+ (Abs(c.R - r) <= channelTolerance) and
+ (Abs(c.G - g) <= channelTolerance) and
+ (Abs(c.B - b) <= channelTolerance) then c.Color := newColor;
+ inc(c);
+ end
+end;
+//------------------------------------------------------------------------------
+
procedure RemoveColor(img: TImage32; color: TColor32);
var
fg: TARGB absolute color;
@@ -772,12 +924,14 @@ procedure RemoveColor(img: TImage32; color: TColor32);
if (Q = 0) then
bg.Color := clNone32
- else if (Q < 255) then
+ else if (Q = 255) then
+ // do nothing
+ else
begin
bg.A := MulTable[bg.A, Q];
- bg.R := DivTable[bg.R - MulTable[not Q, fg.R], Q];
- bg.G := DivTable[bg.G - MulTable[not Q, fg.G], Q];
- bg.B := DivTable[bg.B - MulTable[not Q, fg.B], Q];
+ bg.R := DivTable[ClampByte(bg.R - MulTable[not Q, fg.R]), Q];
+ bg.G := DivTable[ClampByte(bg.G - MulTable[not Q, fg.G]), Q];
+ bg.B := DivTable[ClampByte(bg.B - MulTable[not Q, fg.B]), Q];
end;
end;
inc(bg);
@@ -785,7 +939,7 @@ procedure RemoveColor(img: TImage32; color: TColor32);
end;
//------------------------------------------------------------------------------
-procedure FilterOnColor(img: TImage32; color: TColor32);
+procedure RemoveAllExceptColor(img: TImage32; color: TColor32);
var
fg: TARGB absolute color;
bg: PARGB;
@@ -799,24 +953,16 @@ procedure FilterOnColor(img: TImage32; color: TColor32);
if bg.A > 0 then
begin
// red
- if (bg.R > fg.R) then
- Q := bg.R - fg.R
- else if (bg.R < fg.R) then
- Q := DivTable[fg.R - bg.R, fg.R]
- else
- Q := 0;
-
+ if (bg.R > fg.R) then Q := bg.R - fg.R
+ else if (bg.R < fg.R) then Q := DivTable[fg.R - bg.R, fg.R]
+ else Q := 0;
// green
- if (bg.G > fg.G) then
- Q := Max(Q, bg.G - fg.G)
- else if (bg.G < fg.G) then
- Q := Max(Q, DivTable[fg.G - bg.G, fg.G]);
+ if (bg.G > fg.G) then Q := Max(Q, bg.G - fg.G)
+ else if (bg.G < fg.G) then Q := Max(Q, DivTable[fg.G - bg.G, fg.G]);
// blue
- if (bg.B > fg.B) then
- Q := Max(Q, bg.B - fg.B)
- else if (bg.B < fg.B) then
- Q := Max(Q, DivTable[fg.B - bg.B, fg.B]);
+ if (bg.B > fg.B) then Q := Max(Q, bg.B - fg.B)
+ else if (bg.B < fg.B) then Q := Max(Q, DivTable[fg.B - bg.B, fg.B]);
// weight Q toward either fully opaque or fully translucent
Q := Sigmoid[Q];
@@ -830,7 +976,13 @@ procedure FilterOnColor(img: TImage32; color: TColor32);
end;
//------------------------------------------------------------------------------
-procedure FilterOnExactColor(img: TImage32; color: TColor32);
+procedure FilterOnColor(img: TImage32; color: TColor32);
+begin
+ RemoveAllExceptColor(img, color);
+end;
+//------------------------------------------------------------------------------
+
+procedure RemoveExactColor(img: TImage32; color: TColor32);
var
pc: PColor32;
i: Integer;
@@ -849,20 +1001,26 @@ procedure FilterOnExactColor(img: TImage32; color: TColor32);
end;
//------------------------------------------------------------------------------
-procedure FilterOnAlpha(img: TImage32; alpha: byte; tolerance: byte);
-var
- bg: PARGB;
- i: Integer;
+procedure FilterOnExactColor(img: TImage32; color: TColor32);
begin
- bg := PARGB(img.PixelBase);
- for i := 0 to img.Width * img.Height -1 do
- begin
- if abs(bg.A - alpha) > tolerance then bg.A := 0;
- inc(bg);
- end;
+ RemoveExactColor(img, color);
end;
//------------------------------------------------------------------------------
+// procedure FilterOnAlpha(img: TImage32; alpha: byte; tolerance: byte);
+// var
+// bg: PARGB;
+// i: Integer;
+// begin
+// bg := PARGB(img.PixelBase);
+// for i := 0 to img.Width * img.Height -1 do
+// begin
+// if abs(bg.A - alpha) > tolerance then bg.A := 0;
+// inc(bg);
+// end;
+// end;
+//------------------------------------------------------------------------------
+
procedure RedEyeRemove(img: TImage32; const rect: TRect);
var
k: integer;
@@ -895,7 +1053,7 @@ procedure RedEyeRemove(img: TImage32; const rect: TRect);
path := Ellipse(cutoutRec);
radGrad.SetParameters(rect3, clBlack32, clNone32);
DrawPolygon(mask, path, frNonZero, radGrad);
- cutout.CopyBlend(mask, mask.Bounds, cutout.Bounds, BlendMask);
+ cutout.CopyBlend(mask, mask.Bounds, cutout.Bounds, BlendMaskLine);
// now remove red from the cutout
RemoveColor(cutout, clRed32);
// finally replace the cutout ...
@@ -922,42 +1080,86 @@ procedure EraseInsidePaths(img: TImage32; const paths: TPathsD; fillRule: TFillR
end;
//------------------------------------------------------------------------------
+procedure EraseOutsideRect(img: TImage32; const r, outsideBounds: TRect);
+begin
+ // Fill the parts, that are in outsideBounds but not in r with zeros
+
+ // whole top block
+ if r.Top > outsideBounds.Top then
+ img.FillRect(Rect(outsideBounds.Left, outsideBounds.Top, outsideBounds.Right, r.Top - 1), 0);
+ // whole bottom block
+ if r.Bottom < outsideBounds.Bottom then
+ img.FillRect(Rect(outsideBounds.Left, r.Bottom + 1, outsideBounds.Right, outsideBounds.Bottom), 0);
+
+ // remaining left block
+ if r.Left > outsideBounds.Left then
+ img.FillRect(Rect(outsideBounds.Left, r.Top, r.Left - 1, r.Bottom), 0);
+ // remaining right block
+ if r.Right < outsideBounds.Right then
+ img.FillRect(Rect(r.Right + 1, r.Top, outsideBounds.Right, r.Bottom), 0);
+end;
+//------------------------------------------------------------------------------
+
procedure EraseOutsidePath(img: TImage32; const path: TPathD;
fillRule: TFillRule; const outsideBounds: TRect);
var
- mask: TImage32;
- p: TPathD;
- w,h: integer;
+ w, h: integer;
+ renderer: TMaskRenderer;
+ r: TRect;
+ polygons: TPathsD;
begin
if not assigned(path) then Exit;
- RectWidthHeight(outsideBounds, w,h);
- mask := TImage32.Create(w, h);
+ RectWidthHeight(outsideBounds, w, h);
+ if (w <= 0) or (h <= 0) then Exit;
+
+ // We can skip the costly polygon rasterization if the path is
+ // a rectangle
+ if (fillRule in [frEvenOdd, frNonZero]) and IsSimpleRectanglePath(path, r) then
+ begin
+ EraseOutsideRect(img, r, outsideBounds);
+ Exit;
+ end;
+
+ renderer := TMaskRenderer.Create;
try
- p := TranslatePath(path, -outsideBounds.Left, -outsideBounds.top);
- DrawPolygon(mask, p, fillRule, clBlack32);
- img.CopyBlend(mask, mask.Bounds, outsideBounds, BlendMask);
+ SetLength(polygons, 1);
+ polygons[0] := path;
+ Rasterize(img, polygons, outsideBounds, fillRule, renderer);
finally
- mask.Free;
+ renderer.Free;
end;
end;
//------------------------------------------------------------------------------
procedure EraseOutsidePaths(img: TImage32; const paths: TPathsD;
- fillRule: TFillRule; const outsideBounds: TRect);
+ fillRule: TFillRule; const outsideBounds: TRect;
+ rendererCache: TCustomRendererCache);
var
- mask: TImage32;
- pp: TPathsD;
- w,h: integer;
+ w, h: integer;
+ renderer: TMaskRenderer;
+ r: TRect;
begin
if not assigned(paths) then Exit;
- RectWidthHeight(outsideBounds, w,h);
- mask := TImage32.Create(w, h);
+ RectWidthHeight(outsideBounds, w, h);
+ if (w <= 0) or (h <= 0) then Exit;
+
+ // We can skip the costly polygon rasterization if the path is
+ // a rectangle.
+ if (fillRule in [frEvenOdd, frNonZero]) and IsSimpleRectanglePath(paths, r) then
+ begin
+ EraseOutsideRect(img, r, outsideBounds);
+ Exit;
+ end;
+
+ if rendererCache = nil then
+ renderer := TMaskRenderer.Create
+ else
+ renderer := rendererCache.MaskRenderer;
try
- pp := TranslatePath(paths, -outsideBounds.Left, -outsideBounds.top);
- DrawPolygon(mask, pp, fillRule, clBlack32);
- img.CopyBlend(mask, mask.Bounds, outsideBounds, BlendMask);
+ Rasterize(img, paths, outsideBounds, fillRule, renderer);
finally
- mask.Free;
+ if rendererCache = nil then
+ renderer.Free;
end;
end;
//------------------------------------------------------------------------------
@@ -986,7 +1188,9 @@ procedure Draw3D(img: TImage32; const polygons: TPathsD;
begin
rec := GetBounds(polygons);
if IsEmptyRect(rec) then Exit;
- if not ClockwiseRotationIsAnglePositive then angleRads := -angleRads;
+{$IFDEF CLOCKWISE_ROTATION_WITH_NEGATIVE_ANGLES}
+ angleRads := -angleRads;
+{$ENDIF}
GetSinCos(angleRads, y, x);
paths := TranslatePath(polygons, -rec.Left, -rec.Top);
RectWidthHeight(rec, w, h);
@@ -999,7 +1203,7 @@ procedure Draw3D(img: TImage32; const polygons: TPathsD;
EraseInsidePaths(tmp, paths2, fillRule);
FastGaussianBlur(tmp, tmp.Bounds, Round(blurRadius), 0);
EraseOutsidePaths(tmp, paths, fillRule, tmp.Bounds);
- img.CopyBlend(tmp, tmp.Bounds, rec, BlendToAlpha);
+ img.CopyBlend(tmp, tmp.Bounds, rec, BlendToAlphaLine);
end;
if GetAlpha(colorDk) > 0 then
begin
@@ -1008,7 +1212,7 @@ procedure Draw3D(img: TImage32; const polygons: TPathsD;
EraseInsidePaths(tmp, paths2, fillRule);
FastGaussianBlur(tmp, tmp.Bounds, Round(blurRadius), 0);
EraseOutsidePaths(tmp, paths, fillRule, tmp.Bounds);
- img.CopyBlend(tmp, tmp.Bounds, rec, BlendToAlpha);
+ img.CopyBlend(tmp, tmp.Bounds, rec, BlendToAlphaLine);
end;
finally
tmp.Free;
@@ -1087,7 +1291,7 @@ function DrawButton(img: TImage32; const pt: TPointD;
case buttonShape of
bsDiamond:
begin
- SetLength(Result, 4);
+ NewPointDArray(Result, 4, True);
for i := 0 to 3 do Result[i] := pt;
Result[0].X := Result[0].X -radius;
Result[1].Y := Result[1].Y -radius;
@@ -1115,7 +1319,7 @@ function DrawButton(img: TImage32; const pt: TPointD;
if ba3D in buttonAttributes then
Draw3D(img, Result, frNonZero, lightSize*2,
Ceil(lightSize), $CCFFFFFF, $AA000000, lightAngle);
- DrawLine(img, Result, dpiAware1, clBlack32, esPolygon);
+ DrawLine(img, Result, dpiAware1, clBlack32, esPolygon, jsButt);
finally
img.EndUpdate;
end;
@@ -1198,8 +1402,8 @@ procedure TraceContours(img: TImage32; intensity: integer);
begin
w := img.Width; h := img.Height;
if w * h = 0 then Exit;
- SetLength(tmp, w * h);
- SetLength(tmp2, w * h);
+ NewColor32Array(tmp, w * h);
+ NewColor32Array(tmp2, w * h);
s := img.PixelRow[0]; d := @tmp[0];
for j := 0 to h-1 do
begin
@@ -1221,7 +1425,11 @@ procedure TraceContours(img: TImage32; intensity: integer);
inc(s, w); inc(s2, w); inc(d, w);
end;
end;
- Move(tmp2[0], img.PixelBase^, w * h * sizeOf(TColor32));
+
+ img.BlockNotify;
+ img.AssignPixelArray(tmp2, w, h);
+ img.UnblockNotify;
+
if intensity < 1 then Exit;
if intensity > 10 then
intensity := 10; // range = 1-10
@@ -1660,97 +1868,64 @@ TSimplifyRec = record
pdSqrd : double;
prev : PSimplifyRec;
next : PSimplifyRec;
- isEnd : Boolean;
+ isEndPt : Boolean;
end;
function SimplifyPath(const path: TPathD;
shapeTolerance: double; isClosedPath: Boolean): TPathD;
var
- i, highI, minLen: integer;
+ i, iPrev, iNext, len, minLen: integer;
tolSqrd: double;
srArray: array of TSimplifyRec;
- first, last: PSimplifyRec;
+ current, last: PSimplifyRec;
begin
Result := nil;
- highI := High(path);
+ len := Length(path);
if not isClosedPath then minLen := 2 else minLen := 3;
+ if len < minLen then Exit;
- if highI +1 < minLen then Exit;
-
- SetLength(srArray, highI +1);
- with srArray[0] do
- begin
- pt := path[0];
- prev := @srArray[highI];
- next := @srArray[1];
- if isClosedPath then
- begin
- pdSqrd := PerpendicularDistSqrd(path[0], path[highI], path[1]);
- isEnd := false;
- end else
- begin
- pdSqrd := MaxDouble;
- isEnd := true;
- end;
- end;
-
- with srArray[highI] do
- begin
- pt := path[highI];
- prev := @srArray[highI-1];
- next := @srArray[0];
- if isClosedPath then
- begin
- pdSqrd := PerpendicularDistSqrd(path[highI], path[highI-1], path[0]);
- isEnd := false;
- end else
- begin
- pdSqrd := MaxDouble;
- isEnd := true;
- end;
- end;
-
- for i := 1 to highI -1 do
+ SetLength(srArray, len);
+ for i := 0 to len -1 do
with srArray[i] do
begin
+ iPrev := ModEx(i-1, len);
+ iNext := ModEx(i+1, len);
pt := path[i];
- prev := @srArray[i-1];
- next := @srArray[i+1];
- pdSqrd := PerpendicularDistSqrd(path[i], path[i-1], path[i+1]);
- isEnd := false;
+ prev := @srArray[iPrev];
+ next := @srArray[iNext];
+ pdSqrd := PerpendicularDistSqrd(path[i], path[iPrev], path[iNext]);
+ isEndPt := not isClosedPath and ((i = 0) or (i = len -1));
end;
- first := @srArray[0];
- last := first.prev;
+ current := @srArray[0];
+ last := current.prev;
tolSqrd := Sqr(shapeTolerance);
- while first <> last do
+ while current <> last do
begin
- if first.isEnd or (first.pdSqrd > tolSqrd) or
- (first.next.pdSqrd < first.pdSqrd) then
+ if not current.isEndPt and
+ ((current.pdSqrd < tolSqrd) and (current.next.pdSqrd > current.pdSqrd)) then
begin
- first := first.next;
- end else
- begin
- first.prev.next := first.next;
- first.next.prev := first.prev;
- last := first.prev;
- dec(highI);
+ current.prev.next := current.next;
+ current.next.prev := current.prev;
+ last := current.prev;
+ dec(len);
if last.next = last.prev then break;
- last.pdSqrd :=
- PerpendicularDistSqrd(last.pt, last.prev.pt, last.next.pt);
- first := last.next;
- first.pdSqrd :=
- PerpendicularDistSqrd(first.pt, first.prev.pt, first.next.pt);
- end;
+ last.pdSqrd := PerpendicularDistSqrd(last.pt, last.prev.pt, last.next.pt);
+ current := last.next;
+ current.pdSqrd := PerpendicularDistSqrd(current.pt, current.prev.pt, current.next.pt);
+ end
+ else
+ current := current.next;
end;
- if highI +1 < minLen then Exit;
- if not isClosedPath then first := @srArray[0];
- SetLength(Result, highI +1);
- for i := 0 to HighI do
+
+ if len < minLen then Exit;
+ if not isClosedPath then current := @srArray[0];
+ NewPointDArray(Result, len, True);
+ for i := 0 to len -1 do
begin
- Result[i] := first.pt;
- first := first.next;
+ Result[i] := current.pt;
+ current := current.next;
end;
end;
//------------------------------------------------------------------------------
@@ -1777,11 +1952,11 @@ function SimplifyPaths(const paths: TPathsD;
type
PSimplifyExRec = ^TSimplifyExRec;
TSimplifyExRec = record
- pt : TPointD;
- pdSqrd : double;
- segLenSq: double;
- prev : PSimplifyExRec;
- next : PSimplifyExRec;
+ pt : TPointD;
+ pdSqrd : double;
+ segLenSq : double;
+ prev : PSimplifyExRec;
+ next : PSimplifyExRec;
end;
function DeleteCurrent(var current: PSimplifyExRec): Boolean;
@@ -1795,37 +1970,36 @@ function DeleteCurrent(var current: PSimplifyExRec): Boolean;
Result := next <> current.prev;
if not Result then Exit;
next.pdSqrd := PerpendicularDistSqrd(next.pt, next.prev.pt, next.next.pt);
- next.segLenSq := DistanceSqrd(next.prev.pt, next.pt);
+ current.segLenSq := DistanceSqrd(current.pt, current.next.pt);
current.pdSqrd := PerpendicularDistSqrd(current.pt, current.prev.pt, current.next.pt);
end;
//---------------------------------------------------------------------------
function SimplifyPathEx(const path: TPathD; shapeTolerance: double): TPathD;
var
- i, prevI, nextI, highI: integer;
- cp, cp2, shapeTolSqr, shapeTolSqrEx: double;
+ i, prevI, nextI, len: integer;
+ shapeTolSqr: double;
srArray: array of TSimplifyExRec;
current, start: PSimplifyExRec;
begin
Result := nil;
- highI := High(path);
- if highI < 2 then Exit;
+ len := Length(path);
+ if len < 3 then Exit;
shapeTolSqr := Sqr(shapeTolerance);
- shapeTolSqrEx := shapeTolerance * 4 +1; // may need adjusting
- SetLength(srArray, highI +1);
+ SetLength(srArray, len);
- for i := 0 to highI do
+ for i := 0 to len -1 do
begin
prevI := i -1;
nextI := i +1;
- if i = 0 then prevI := highI
- else if i = highI then nextI := 0;
+ if i = 0 then prevI := len -1
+ else if i = len -1 then nextI := 0;
with srArray[i] do
begin
pt := path[i];
- segLenSq:= DistanceSqrd(path[prevI], path[i]);
+ segLenSq:= DistanceSqrd(path[i], path[nextI]);
pdSqrd := PerpendicularDistSqrd(path[i], path[prevI], path[nextI]);
prev := @srArray[prevI];
next := @srArray[nextI];
@@ -1837,40 +2011,33 @@ function SimplifyPathEx(const path: TPathD; shapeTolerance: double): TPathD;
while current <> start do
begin
+ // Irrespective of segment length, remove vertices that deviate very little
+ // from imaginary lines that pass through their adjacent vertices.
+ // However, if the following vertex has an even sorter distance from its
+ // respective imaginary line, its important to remove that vertex first.
if ((current.pdSqrd < shapeTolSqr) and
(current.pdSqrd < current.next.pdSqrd)) then
begin
- // nb: always remove the shorter segment first
- // irrespective of segment length remove vertices that
- // deviate insignificantly from their adjacent vertices.
- dec(highI);
+ dec(len);
if not DeleteCurrent(current) then Break;
start := current.prev;
- end else if
- (current.segLenSq * shapeTolSqrEx < current.prev.segLenSq) and
- (current.segLenSq * shapeTolSqrEx < current.next.segLenSq) then
+ end
+ // also remove insignificant path zig-zags
+ else if (current.prev.segLenSq < shapeTolSqr) and
+ (current.segLenSq < shapeTolSqr) and
+ ((CrossProduct(current.prev.pt, current.pt, current.next.pt) > 0) <>
+ (CrossProduct(current.pt, current.next.pt, current.next.next.pt) > 0)) then
begin
- cp := CrossProduct(current.prev.prev.pt, current.prev.pt, current.pt);
- cp2 := CrossProduct(current.prev.pt, current.pt, current.next.pt);
- if ((cp > 0) = (cp2 > 0)) then
- begin
- // not a zig-zag (ie avoids truncating tightly rounded corners)
- current := current.next;
- end else
- begin
- // remove insignificant zigzags
- current.prev.pt := MidPoint(current.pt, current.prev.pt);
- if not DeleteCurrent(current) then Break;
- start := current.prev;
- dec(highI);
- end;
+ dec(len);
+ if not DeleteCurrent(current) then Break;
+ start := current.prev;
end else
current := current.next;
end;
- if highI < 2 then Exit;
- SetLength(Result, highI +1);
- for i := 0 to HighI do
+ if len < 3 then Exit;
+ NewPointDArray(Result, len, True);
+ for i := 0 to len -1 do
begin
Result[i] := current.pt;
current := current.next;
@@ -1917,7 +2084,7 @@ function SmoothToCubicBezier(const path: TPathD;
len := Length(path);
if len < 3 then Exit;
- SetLength(Result, len *3 +1);
+ NewPointDArray(Result, len *3 +1, True);
prev := len-1;
SetLength(pl, len);
SetLength(unitVecs, len);
@@ -1990,7 +2157,7 @@ function SmoothToCubicBezier2(const path: TPathD;
len := Length(path);
if len < 3 then Exit;
- SetLength(Result, len *3 +1);
+ NewPointDArray(Result, len *3 +1);
prev := len-1;
SetLength(pl, len);
SetLength(unitVecs, len);
@@ -2047,21 +2214,6 @@ function SmoothToCubicBezier2(const paths: TPathsD;
end;
//------------------------------------------------------------------------------
-function Clamp(val, endVal: integer): integer; inline;
-begin
- if val < 0 then Result := 0
- else if val >= endVal then Result := endVal -1
- else Result := val;
-end;
-//------------------------------------------------------------------------------
-
-function ModEx(val, endVal: integer): integer; inline;
-begin
- Result := val mod endVal;
- if Result < 0 then Result := endVal + Result;
-end;
-//------------------------------------------------------------------------------
-
function CubicInterpolate(v1, v2, v3, v4: double;
t: double; tension: double = 0): double;
var
@@ -2079,12 +2231,13 @@ function CubicInterpolate(v1, v2, v3, v4: double;
end;
//------------------------------------------------------------------------------
-procedure Append(var path: TPathD; const pt: TPointD); inline;
+procedure Append(var path: TPathD; const pt: TPointD);
+ {$IFDEF INLINE} inline; {$ENDIF}
var
len: integer;
begin
len := Length(path);
- SetLength(path, len +1);
+ SetLengthUninit(path, len +1);
path[len] := pt;
end;
//------------------------------------------------------------------------------
@@ -2179,43 +2332,68 @@ function SmoothPaths(const paths: TPathsD; isClosedPath: Boolean;
procedure GaussianBlur(img: TImage32; rec: TRect; radius: Integer);
var
- i, w,h, x,y,yy,z: Integer;
- gaussTable: array [-MaxBlur .. MaxBlur] of Cardinal;
+ i, w,h, highX, x,y,yy,z,startz: Integer;
+ expConst: double;
+ gaussTable: array [-MaxBlur .. MaxBlur] of integer;
wc: TWeightedColor;
wca: TArrayOfWeightedColor;
+ wcaColor: TArrayOfColor32;
row: PColor32Array;
wcRow: PWeightedColorArray;
+ imgWidth: Integer;
+ dst, pc: PColor32;
+const
+ tableConst = 1024;
+ sigma = 3;
begin
Types.IntersectRect(rec, rec, img.Bounds);
if IsEmptyRect(rec) or (radius < 1) then Exit
else if radius > MaxBlur then radius := MaxBlur;
- for i := 0 to radius do
+
+ expConst := - 1 / (Sqr(radius) * 2 * Sqr(sigma));
+ gaussTable[0] := Round(tableConst * Exp(expConst));
+ for i := 1 to radius do
begin
- gaussTable[i] := Sqr(Radius - i +1);
+ gaussTable[i] := Round(tableConst * Exp(expConst * Sqr(i)));
gaussTable[-i] := gaussTable[i];
end;
+
RectWidthHeight(rec, w, h);
setLength(wca, w * h);
+ NewColor32Array(wcaColor, w * h, True);
+ imgWidth := img.Width;
+ highX := imgWidth -1;
for y := 0 to h -1 do
begin
- row := PColor32Array(@img.Pixels[(y + rec.Top) * img.Width + rec.Left]);
+ row := PColor32Array(@img.Pixels[(y + rec.Top) * imgWidth + rec.Left]);
wcRow := PWeightedColorArray(@wca[y * w]);
for x := 0 to w -1 do
- for z := max(0, x - radius) to min(img.Width -1, x + radius) do
+ for z := max(0, x - radius) to min(highX, x + radius) do
wcRow[x].Add(row[z], gaussTable[x-z]);
end;
+
+ // calculate colors
+ for x := 0 to w * h - 1 do
+ wcaColor[x] := wca[x].Color;
+
+ dst := @img.Pixels[rec.Left + rec.Top * imgWidth];
+ imgWidth := imgWidth * SizeOf(TColor32); // convert to byte size
for x := 0 to w -1 do
begin
+ pc := dst;
+ inc(pc, x);
for y := 0 to h -1 do
begin
wc.Reset;
- yy := max(0, y - radius) * w;
- for z := max(0, y - radius) to min(h -1, y + radius) do
+ startz := max(0, y - radius);
+ yy := startz * w;
+ for z := startz to min(h -1, y + radius) do
begin
- wc.Add(wca[x + yy].Color, gaussTable[y-z]);
+ wc.Add(wcaColor[x + yy], gaussTable[y-z]);
inc(yy, w);
end;
- img.Pixels[x + rec.Left + (y + rec.Top) * img.Width] := wc.Color;
+ pc^ := wc.Color;
+ inc(PByte(pc), imgWidth); // increment by byte size
end;
end;
end;
@@ -2224,15 +2402,15 @@ procedure GaussianBlur(img: TImage32; rec: TRect; radius: Integer);
// FastGaussian blur - and support functions
//------------------------------------------------------------------------------
-//http://blog.ivank.net/fastest-gaussian-blur.html
-//https://www.peterkovesi.com/papers/FastGaussianSmoothing.pdf
+// http://blog.ivank.net/fastest-gaussian-blur.html
+// https://www.peterkovesi.com/papers/FastGaussianSmoothing.pdf
function BoxesForGauss(stdDev, boxCnt: integer): TArrayOfInteger;
var
i, wl, wu, m: integer;
wIdeal, mIdeal: double;
begin
- SetLength(Result, boxCnt);
+ NewIntegerArray(Result, boxCnt, True);
wIdeal := Sqrt((12*stdDev*stdDev/boxCnt)+1); // Ideal averaging filter width
wl := Floor(wIdeal); if not Odd(wl) then dec(wl);
mIdeal :=
@@ -2254,11 +2432,64 @@ procedure FastGaussianBlur(img: TImage32;
end;
//------------------------------------------------------------------------------
-procedure BoxBlurH(var src, dst: TArrayOfColor32; w,h, stdDev: integer);
+procedure BoxBlurHLine(src, dst: PColor32; srcRiOffset: nativeint;
+ count, w: integer; dstLast: PColor32; var v: TWeightedColor);
+var
+ lastColor: TColor32;
+ val: PWeightedColor;
+ s, d: PColor32;
+begin
+ lastColor := v.Color;
+ if count > w then
+ count := w;
+ w := w - count;
+
+ // The Delphi compiler sometimes is really stupid with
+ // the CPU register allocation. With this, even if no actual
+ // code is produced, the compiler happens to make better
+ // decisions.
+ val := @v;
+ s := src;
+ d := dst;
+
+ if count > 0 then
+ begin
+ while count > 0 do
+ begin
+ if val.AddSubtract(PColor32Array(s)[srcRiOffset], s^) then
+ lastColor := val.Color;
+ inc(s);
+ d^ := lastColor;
+ inc(d);
+ dec(count);
+ end;
+
+ count := w;
+ while count > 0 do
+ begin
+ d^ := lastColor;
+ inc(d);
+ dec(count);
+ end;
+ end;
+
+ while PByte(d) <= PByte(dstLast) do
+ begin
+ if val.AddNoneSubtract(s^) then
+ lastColor := val.Color;
+ inc(s);
+ d^ := lastColor;
+ inc(d);
+ end;
+end;
+//------------------------------------------------------------------------------
+
+procedure BoxBlurH(const src, dst: TArrayOfColor32; w,h, stdDev: integer);
var
i,j, ti, li, ri, re, ovr: integer;
fv, val: TWeightedColor;
- ce: TColor32;
+ lastColor: TColor32;
+ stdDevW: integer;
begin
ovr := Max(0, stdDev - w);
for i := 0 to h -1 do
@@ -2267,7 +2498,6 @@ procedure BoxBlurH(var src, dst: TArrayOfColor32; w,h, stdDev: integer);
li := ti;
ri := ti +stdDev;
re := ti +w -1; // idx of last pixel in row
- ce := src[re]; // color of last pixel in row
fv.Reset(src[ti]);
val.Reset(src[ti], stdDev +1);
for j := 0 to stdDev -1 - ovr do
@@ -2275,41 +2505,109 @@ procedure BoxBlurH(var src, dst: TArrayOfColor32; w,h, stdDev: integer);
if ovr > 0 then val.Add(clNone32, ovr);
for j := 0 to stdDev do
begin
- if ri > re then
- val.Add(ce) else
- val.Add(src[ri]);
+ if ri <= re then
+ val.Add(src[ri]) else
+ val.Add(src[re]); // color of last pixel in row
inc(ri);
val.Subtract(fv);
if ti <= re then
dst[ti] := val.Color;
inc(ti);
end;
- for j := stdDev +1 to w - stdDev -1 do
+
+ // Skip "val.Color" calculation if both for-loops are skipped anyway
+ stdDevW := w - stdDev*2 - 1;
+ if (ti <= re) or (stdDevW > 0) then
begin
- if ri <= re then
+ if w > 4 then // prevent the call-overhead if it would be slower than the inline version
+ BoxBlurHLine(@src[li], @dst[ti], ri - li, re - ri + 1, stdDevW, @dst[re], val)
+ else
begin
- val.Add(src[ri]); inc(ri);
- val.Subtract(src[li]); inc(li);
+ lastColor := val.Color;
+ for j := stdDevW downto 1 do
+ begin
+ if ri <= re then
+ begin
+ if val.AddSubtract(src[ri], src[li]) then
+ lastColor := val.Color;
+ inc(ri);
+ inc(li);
+ end;
+ dst[ti] := lastColor;
+ inc(ti);
+ end;
+ while ti <= re do
+ begin
+ if val.AddNoneSubtract(src[li]) then
+ lastColor := val.Color;
+ inc(li);
+ dst[ti] := lastColor;
+ inc(ti);
+ end;
end;
- dst[ti] := val.Color; inc(ti);
end;
- while ti <= re do
+ end;
+end;
+//------------------------------------------------------------------------------
+
+procedure BoxBlurVLine(src, dst: PColor32; srcRiOffset: nativeint;
+ widthBytes, count, h: integer; dstLast: PColor32; var v: TWeightedColor);
+var
+ lastColor: TColor32;
+ val: PWeightedColor;
+ s, d: PColor32;
+begin
+ lastColor := v.Color;
+ if count > h then
+ count := h;
+ h := h - count;
+
+ // The Delphi compiler sometimes is really stupid with
+ // the CPU register allocation. With this, even if no actual
+ // code is produced, the compiler happens to make better
+ // decisions.
+ val := @v;
+ s := src;
+ d := dst;
+
+ if count > 0 then
+ begin
+ while count > 0 do
begin
- if ti > re then Break;
- val.Add(clNone32);
- val.Subtract(src[li]); inc(li);
- dst[ti] := val.Color;
- inc(ti);
+ if val.AddSubtract(PColor32Array(s)[srcRiOffset], s^) then
+ lastColor := val.Color;
+ inc(PByte(s), widthBytes);
+ d^ := lastColor;
+ inc(PByte(d), widthBytes);
+ dec(count);
+ end;
+
+ count := h;
+ while count > 0 do
+ begin
+ d^ := lastColor;
+ inc(PByte(d), widthBytes);
+ dec(count);
end;
end;
+
+ while PByte(d) <= PByte(dstLast) do
+ begin
+ if val.AddNoneSubtract(s^) then
+ lastColor := val.Color;
+ inc(PByte(s), widthBytes);
+ d^ := lastColor;
+ inc(PByte(d), widthBytes);
+ end;
end;
//------------------------------------------------------------------------------
-procedure BoxBlurV(var src, dst: TArrayOfColor32; w, h, stdDev: integer);
+procedure BoxBlurV(const src, dst: TArrayOfColor32; w, h, stdDev: integer);
var
i,j, ti, li, ri, re, ovr: integer;
fv, val: TWeightedColor;
- ce: TColor32;
+ lastColor: TColor32;
+ stdDevH: integer;
begin
ovr := Max(0, stdDev - h);
for i := 0 to w -1 do
@@ -2318,7 +2616,6 @@ procedure BoxBlurV(var src, dst: TArrayOfColor32; w, h, stdDev: integer);
li := ti;
ri := ti + stdDev * w;
re := ti +w *(h-1); // idx of last pixel in column
- ce := src[re]; // color of last pixel in column
fv.Reset(src[ti]);
val.Reset(src[ti], stdDev +1);
for j := 0 to stdDev -1 -ovr do
@@ -2326,30 +2623,47 @@ procedure BoxBlurV(var src, dst: TArrayOfColor32; w, h, stdDev: integer);
if ovr > 0 then val.Add(clNone32, ovr);
for j := 0 to stdDev do
begin
- if ri > re then
- val.Add(ce) else
- val.Add(src[ri]);
+ if ri <= re then
+ val.Add(src[ri]) else
+ val.Add(src[re]); // color of last pixel in column
inc(ri, w);
val.Subtract(fv);
if ti <= re then
dst[ti] := val.Color;
inc(ti, w);
end;
- for j := stdDev +1 to h - stdDev -1 do
+
+ // Skip "val.Color" calculation if both for-loops are skipped anyway
+ stdDevH := h - stdDev*2 - 1;
+ if (ti <= re) or (stdDevH > 0) then
begin
- if ri <= re then
+ if stdDevH > 4 then // prevent the call-overhead if it would be slower than the inline version
+ BoxBlurVLine(@src[li], @dst[ti], ri - li, w * SizeOf(TColor32), re - ri + 1, stdDevH, @dst[re], val)
+ else
begin
- val.Add(src[ri]); inc(ri, w);
- val.Subtract(src[li]); inc(li, w);
+ lastColor := val.Color;
+ for j := stdDevH downto 1 do
+ begin
+ if ri <= re then
+ begin
+ if val.AddSubtract(src[ri], src[li]) then
+ lastColor := val.Color;
+ inc(ri, w);
+ inc(li, w);
+ end;
+
+ dst[ti] := lastColor;
+ inc(ti, w);
+ end;
+ while ti <= re do
+ begin
+ if val.AddNoneSubtract(src[li]) then
+ lastColor := val.Color;
+ inc(li, w);
+ dst[ti] := lastColor;
+ inc(ti, w);
+ end;
end;
- dst[ti] := val.Color; inc(ti, w);
- end;
- while ti <= re do
- begin
- val.Add(clNone32);
- val.Subtract(src[li]); inc(li, w);
- dst[ti] := val.Color;
- inc(ti, w);
end;
end;
end;
@@ -2373,15 +2687,17 @@ procedure FastGaussianBlur(img: TImage32;
RectWidthHeight(rec2, w, h);
if (Min(w, h) < 2) or ((stdDevX < 1) and (stdDevY < 1)) then Exit;
len := w * h;
- SetLength(src, len);
- SetLength(dst, len);
+ NewColor32Array(src, len, True); // content is overwritten in BoxBlurH
if blurFullImage then
begin
- // copy the entire image into 'dst'
- Move(img.PixelBase^, dst[0], len * SizeOf(TColor32));
- end else
+ // Use the img.Pixels directly instead of copying the entire image into 'dst'.
+ // The first thing the code does is BoxBlurH({source:=}dst, {dest:=}src, ...).
+ dst := img.Pixels;
+ end
+ else
begin
// copy a rectangular region into 'dst'
+ NewColor32Array(dst, len, True);
pSrc := img.PixelRow[rec2.Top];
inc(pSrc, rec2.Left);
pDst := @dst[0];
@@ -2392,25 +2708,25 @@ procedure FastGaussianBlur(img: TImage32;
inc(pDst, w);
end;
end;
+
// do the blur
inc(repeats); // now represents total iterations
boxesH := BoxesForGauss(stdDevX, repeats);
if stdDevY = stdDevX then
boxesV := boxesH else
boxesV := BoxesForGauss(stdDevY, repeats);
- for j := 0 to repeats -1 do
+
+ img.BeginUpdate;
+ try
+ for j := 0 to repeats -1 do
begin
BoxBlurH(dst, src, w, h, boxesH[j]);
BoxBlurV(src, dst, w, h, boxesV[j]);
end;
- // copy dst array back to image rect
- img.BeginUpdate;
- try
- if blurFullImage then
- begin
- Move(dst[0], img.PixelBase^, len * SizeOf(TColor32));
- end else
+
+ if not blurFullImage then
begin
+ // copy dst array back to image rect
pDst := img.PixelRow[rec2.Top];
inc(pDst, rec2.Left);
pSrc := @dst[0];
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.FMX.pas b/Ext/SVGIconImageList/Image32/source/Img32.FMX.pas
index a2cf921..060873f 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.FMX.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.FMX.pas
@@ -2,12 +2,12 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 3 September 2023 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2023 *
+* Version : 4.7 *
+* Date : 6 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : Image file format support for TImage32 and FMX *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -82,6 +82,9 @@ function TImageFormat_FMX.LoadFromStream(stream: TStream;
var
cm: TBitmapCodecManager;
surf: TBitmapSurface;
+//{$IF DEFINED(ANDROID)}
+// i: integer;
+//{$IFEND}
begin
result := false;
surf := TBitmapSurface.Create;
@@ -95,6 +98,11 @@ function TImageFormat_FMX.LoadFromStream(stream: TStream;
else Exit;
img32.SetSize(surf.Width, surf.Height);
Move(surf.Scanline[0]^, img32.PixelBase^, surf.Width * surf.Height * 4);
+// {$IF DEFINED(ANDROID)}
+// if img32.HasTransparency then
+// for i := 0 to img32.Width * img32.Height -1 do
+// img32.Pixels[i] := SwapRedBlue(img32.Pixels[i]);
+// {$IFEND}
result := true;
finally
cm.Free;
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas
index 80c1a3e..84bfc9b 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas
@@ -2,12 +2,12 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 8 May 2024 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2024 *
+* Version : 4.7 *
+* Date : 6 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : BMP file format extension for TImage32 *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.GIF.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.GIF.pas
index ea92178..bb0b2de 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.GIF.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.GIF.pas
@@ -1,12 +1,12 @@
unit Img32.Fmt.GIF;
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 12 March 2023 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2023 *
+* Version : 4.7 *
+* Date : 6 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : GIF file format extension for TImage32 *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.JPG.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.JPG.pas
index 4d9a97f..9c9e291 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.JPG.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.JPG.pas
@@ -2,12 +2,12 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 12 March 2023 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2023 *
+* Version : 4.7 *
+* Date : 6 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : JPG/JPEG file format extension for TImage32 *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -26,7 +26,7 @@ TImageFormat_JPG = class(TImageFormat)
img32: TImage32; imgIndex: integer = 0): Boolean; override;
//SaveToStream: compressionQuality (range: 0-100%)
procedure SaveToStream(stream: TStream;
- img32: TImage32; compressionQlty: integer = -1); override;
+ img32: TImage32; compressionQlty: integer = defaultCompression); override;
class function CopyToClipboard(img32: TImage32): Boolean; override;
class function CanPasteFromClipboard: Boolean; override;
class function PasteFromClipboard(img32: TImage32): Boolean; override;
@@ -98,8 +98,9 @@ procedure TImageFormat_JPG.SaveToStream(stream: TStream;
Jpeg := TJpegImage.Create;
with TJpegImageHack(jpeg) do
try
- if (compressionQlty >= 0) then
- jpeg.CompressionQuality := Min(100, compressionQlty);
+ if compressionQuality = defaultCompression then
+ jpeg.CompressionQuality := 75 else
+ jpeg.CompressionQuality := Max(0, Min(100, compressionQuality));
NewImage;
NewBitmap;
Bitmap.Width := img32.Width;
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.PNG.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.PNG.pas
index 6f1bfb8..f44381d 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.PNG.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.PNG.pas
@@ -2,12 +2,12 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 9 May 2023 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2023 *
+* Version : 4.7 *
+* Date : 6 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : PNG file format extension for TImage32 *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -25,9 +25,9 @@ TImageFormat_PNG = class(TImageFormat)
class function IsValidImageStream(stream: TStream): Boolean; override;
function LoadFromStream(stream: TStream;
img32: TImage32; imgIndex: integer = 0): Boolean; override;
- // SaveToStream: the compressionQuality parameter is ignored here
+ // SaveToStream: compressionQuality range is 0 .. 9 (ZLIB compression)
procedure SaveToStream(stream: TStream;
- img32: TImage32; compressionQuality: integer = 0); override;
+ img32: TImage32; compressionQuality: integer = defaultCompression); override;
class function CanCopyToClipboard: Boolean; override;
class function CopyToClipboard(img32: TImage32): Boolean; override;
class function CanPasteFromClipboard: Boolean; override;
@@ -87,7 +87,7 @@ function TImageFormat_PNG.LoadFromStream(stream: TStream;
//------------------------------------------------------------------------------
procedure TImageFormat_PNG.SaveToStream(stream: TStream;
- img32: TImage32; compressionQuality: integer = 0);
+ img32: TImage32; compressionQuality: integer);
var
png: TPortableNetworkGraphic;
begin
@@ -95,6 +95,9 @@ procedure TImageFormat_PNG.SaveToStream(stream: TStream;
img32.BeginUpdate;
png := TPortableNetworkGraphic.Create;
try
+ if compressionQuality = defaultCompression then
+ png.CompressionLevel := 7 else
+ png.CompressionLevel := Max(0, Min(9, compressionQuality));
png.SetSize(img32.Width, img32.Height);
png.PixelFormat := pf32bit;
Move(img32.PixelBase^, png.ScanLine[0]^, img32.Width * img32.Height *4);
@@ -107,16 +110,97 @@ procedure TImageFormat_PNG.SaveToStream(stream: TStream;
//------------------------------------------------------------------------------
{$ELSE}
+procedure CopyLineWithAlpha(dst: PARGB; srcAlpha, srcColor: PByte; Width: Integer);
+type
+ PARGBStaticArray = ^TARGBStaticArray;
+ TARGBStaticArray = array[0..3] of TARGB;
+var
+ j: Integer;
+begin
+ j := Width;
+
+ // Copy 4 Pixels at a time.
+ // Instead of ">= 4" we need ">= 5" here. Otherwise the code would
+ // read a byte from the last srcColor (3 bytes per pixel) that doesn't exist
+ while j >= 5 do
+ begin
+ // Read and mask the 4 bytes from srcColor because it has only 3 bytes per pixel
+ // and replace the alpha channel
+ PARGBStaticArray(dst)[0].Color := (PColor32(@srcColor[0])^ and $00FFFFFF) or (srcAlpha[0] shl 24);
+ PARGBStaticArray(dst)[1].Color := (PColor32(@srcColor[3])^ and $00FFFFFF) or (srcAlpha[1] shl 24);
+ PARGBStaticArray(dst)[2].Color := (PColor32(@srcColor[6])^ and $00FFFFFF) or (srcAlpha[2] shl 24);
+ PARGBStaticArray(dst)[3].Color := (PColor32(@srcColor[9])^ and $00FFFFFF) or (srcAlpha[3] shl 24);
+
+ inc(srcColor, 3 * 4);
+ inc(srcAlpha, 4);
+ inc(dst, 4);
+ dec(j, 4);
+ end;
+
+ // Copy the remaining pixels by accessing only the 3 bytes per pixel.
+ while j > 0 do
+ begin
+ dst.Color := {A:} (srcAlpha^ shl 24) or
+ {B:} (srcColor[0]) or
+ {G:} (srcColor[1] shl 8) or
+ {R:} (srcColor[2] shl 16);
+ inc(srcColor, 3);
+ inc(srcAlpha);
+ inc(dst);
+ dec(j);
+ end;
+end;
+
+procedure CopyLineWithoutAlpha(dst: PARGB; srcColor: PByte; Width: Integer);
+type
+ PARGBStaticArray = ^TARGBStaticArray;
+ TARGBStaticArray = array[0..3] of TARGB;
+var
+ j: Integer;
+begin
+ j := Width;
+
+ // Copy 4 Pixels at a time
+ // Instead of ">= 4" we need ">= 5" here. Otherwise the code would
+ // read a byte from the last srcColor (3 bytes per pixel) that doesn't exist
+ while j >= 5 do
+ begin
+ // Replace the alpha channel with 255
+ PARGBStaticArray(dst)[0].Color := PColor32(@srcColor[0])^ or $FF000000;
+ PARGBStaticArray(dst)[1].Color := PColor32(@srcColor[3])^ or $FF000000;
+ PARGBStaticArray(dst)[2].Color := PColor32(@srcColor[6])^ or $FF000000;
+ PARGBStaticArray(dst)[3].Color := PColor32(@srcColor[9])^ or $FF000000;
+
+ inc(srcColor, 3 * 4);
+ inc(dst, 4);
+ dec(j, 4);
+ end;
+
+ // Copy the remaining pixels by accessing only the 3 bytes per pixel.
+ while j > 0 do
+ begin
+ dst.Color := {A:} $FF000000 or
+ {B:} (srcColor[0]) or
+ {G:} (srcColor[1] shl 8) or
+ {R:} (srcColor[2] shl 16);
+ inc(srcColor, 3);
+ inc(dst);
+ dec(j);
+ end;
+end;
+
function TImageFormat_PNG.LoadFromStream(stream: TStream;
img32: TImage32; imgIndex: integer): Boolean;
var
i,j : integer;
png : TPngImage;
dst : PARGB;
- srcAlpha : PByte;
srcColor : PByte;
- palentries : array[0..255] of TPaletteEntry;
+ palentries : array of TPaletteEntry;
+ palSize : integer;
+ palIs4Bits : Boolean;
usingPal : Boolean;
+ palOdd : Boolean;
transpColor : TColor32;
begin
img32.BeginUpdate;
@@ -125,59 +209,72 @@ function TImageFormat_PNG.LoadFromStream(stream: TStream;
png.LoadFromStream(stream);
img32.SetSize(png.Width, png.Height);
- //bytesPerRow := PByte(png.Scanline[1]) - PByte(png.Scanline[0]);
- //usingPal := (Abs(bytesPerRow) = png.Width) and (png.Palette <> 0);
usingPal := (png.Header.BitDepth <= 8) and (png.Palette <> 0);
if usingPal then
begin
- GetPaletteEntries(png.Palette, 0, 256, palentries);
- FixPalette(@palentries[0], 256);
- end;
-
- for i := 0 to img32.Height -1 do
- begin
- dst := PARGB(img32.PixelRow[i]);
- srcColor := png.Scanline[i];
+ palSize := 256;
+ SetLength(palentries, palSize);
+ GetPaletteEntries(png.Palette, 0, 256, palentries[0]);
+ if (Cardinal(palentries[255]) = 0) and (Cardinal(palentries[254]) = 0) then
+ begin
+ palSize := 253;
+ while (palSize > 0) and (Cardinal(palentries[palSize -1]) = 0) do
+ dec(palSize);
+ end;
+ palIs4Bits := palSize <= 16; // each pal index uses only 4 bits
+ FixPalette(@palentries[0], palSize);
- if usingPal then
+ transpColor := TColor32(png.transparentColor) or $FF000000;
+ for i := 0 to img32.Height -1 do
begin
- transpColor := TColor32(png.transparentColor) or $FF000000;
+ dst := PARGB(img32.PixelRow[i]);
+ srcColor := png.Scanline[i];
+ palOdd := false;
for j := 0 to img32.Width -1 do
begin
- dst.Color := TColor32(palentries[srcColor^]);
- if dst.Color = transpColor then
- dst.Color := clNone32;
- inc(srcColor);
+ if not palIs4Bits then
+ begin
+ dst.Color := TColor32(palentries[srcColor^]);
+ inc(srcColor);
+ end
+ else if palOdd then
+ begin
+ dst.Color := TColor32(palentries[srcColor^ and $F]);
+ palOdd := false;
+ inc(srcColor);
+ end else
+ begin
+ dst.Color := TColor32(palentries[srcColor^ shr 4]);
+ palOdd := true;
+ end;
+ if dst.Color = transpColor then dst.Color := clNone32;
inc(dst);
end;
- end
- else if png.Transparent and
- (png.Header.ColorType = COLOR_RGBALPHA) or
+ end;
+ end
+
+ else if png.Transparent and
+ (png.Header.ColorType = COLOR_RGBALPHA) or
(png.Header.ColorType = COLOR_GRAYSCALEALPHA) then
+ begin
+ for i := 0 to img32.Height -1 do
begin
- srcAlpha := PByte(png.AlphaScanline[i]);
- for j := 0 to img32.Width -1 do
- begin
- dst.A := srcAlpha^; inc(srcAlpha);
- dst.B := srcColor^; inc(srcColor);
- dst.G := srcColor^; inc(srcColor);
- dst.R := srcColor^; inc(srcColor);
- inc(dst);
- end
- end else
- begin
- for j := 0 to img32.Width -1 do
- begin
- dst.A := 255;
- dst.B := srcColor^; inc(srcColor);
- dst.G := srcColor^; inc(srcColor);
- dst.R := srcColor^; inc(srcColor);
- inc(dst);
- end;
+ dst := PARGB(img32.PixelRow[i]);
+ srcColor := png.Scanline[i];
+ CopyLineWithAlpha(dst, PByte(png.AlphaScanline[i]), srcColor, img32.Width);
end;
+ end else
+ begin
+ for i := 0 to img32.Height -1 do
+ begin
+ dst := PARGB(img32.PixelRow[i]);
+ srcColor := png.Scanline[i];
+ CopyLineWithoutAlpha(dst, srcColor, img32.Width);
+ end;
end;
+
finally
png.Free;
img32.EndUpdate;
@@ -187,7 +284,7 @@ function TImageFormat_PNG.LoadFromStream(stream: TStream;
//------------------------------------------------------------------------------
procedure TImageFormat_PNG.SaveToStream(stream: TStream;
- img32: TImage32; compressionQuality: integer = 0);
+ img32: TImage32; compressionQuality: integer);
var
i,j: integer;
png: TPngImage;
@@ -196,6 +293,9 @@ procedure TImageFormat_PNG.SaveToStream(stream: TStream;
begin
png := TPngImage.CreateBlank(COLOR_RGBALPHA, 8, img32.Width, img32.Height);
try
+ if compressionQuality = defaultCompression then
+ png.CompressionLevel := 7 else
+ png.CompressionLevel := Max(0, Min(9, compressionQuality));
png.CreateAlpha;
for i := 0 to img32.Height -1 do
begin
@@ -327,7 +427,7 @@ class function TImageFormat_PNG.PasteFromClipboard(img32: TImage32): Boolean;
initialization
TImage32.RegisterImageFormatClass('PNG', TImageFormat_PNG, cpHigh);
- CF_PNG := RegisterClipboardFormat('PNG');
+ CF_PNG := RegisterClipboardFormat('PNG');
CF_IMAGEPNG := RegisterClipboardFormat('image/png');
{$IFEND}
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.QOI.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.QOI.pas
index 3f5363c..f88a68d 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.QOI.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.QOI.pas
@@ -1,12 +1,12 @@
unit Img32.Fmt.QOI;
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 12 March 2023 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2023 *
+* Version : 4.7 *
+* Date : 6 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : QOI file format extension for TImage32 *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
(*******************************************************************************
@@ -99,7 +99,7 @@ function SwapBytes(Value: Cardinal): Cardinal;
function ReadByte(var p: PByte): Byte; {$IFDEF INLINE} inline; {$ENDIF}
begin
- Result := Byte(p^); //nb: Delphi 7 compatability
+ Result := Byte(p^); //nb: Delphi 7 compatibility
inc(p);
end;
@@ -132,7 +132,7 @@ function TImageFormat_QOI.LoadFromStream(stream: TStream;
inc(src, stream.Position);
end else
begin
- SetLength(srcTmp, size);
+ NewByteArray(srcTmp, size, True);
stream.Read(srcTmp[0], size);
src := @srcTmp[0];
end;
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas
index 2166d71..02fabbe 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas
@@ -2,12 +2,12 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 11 March 2024 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2024 *
+* Version : 4.7 *
+* Date : 6 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : SVG file format extension for TImage32 *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -377,19 +377,27 @@ function TImageFormat_SVG.LoadFromStream(stream: TStream;
Result := LoadFromStream(stream);
if not Result then Exit;
- r := RootElement.GetViewbox;
+ r := RootElement.viewboxWH;
img32.BeginUpdate;
try
- if img32.IsEmpty and not r.IsEmpty then
- img32.SetSize(Round(r.Width), Round(r.Height))
+ if img32.IsEmpty then
+ begin
+ with RootElement do
+ if Width.IsValid and Height.IsValid then
+ img32.SetSize(
+ Round(Width.GetValue(defaultSvgWidth, 0)),
+ Round(Height.GetValue(defaultSvgHeight, 0)))
+ else if not r.IsEmpty then
+ img32.SetSize(Round(r.Width), Round(r.Height))
+ else
+ img32.SetSize(defaultSvgWidth, defaultSvgHeight);
+ end
else if not r.IsEmpty then
begin
// scale the SVG to best fit the image dimensions
sx := GetScaleForBestFit(r.Width, r.Height, img32.Width, img32.Height);
img32.SetSize(Round(r.Width * sx), Round(r.Height * sx));
- end
- else
- img32.SetSize(defaultSvgWidth, defaultSvgHeight);
+ end;
//draw the SVG image to fit inside the canvas
DrawImage(img32, True);
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas b/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas
index c91b417..ec6996d 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas
@@ -2,12 +2,12 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 16 April 2024 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2024 *
+* Version : 4.8 *
+* Date : 11 Febuary 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : Layered images support *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -74,7 +74,6 @@ TLayer32 = class(TStorage)
{$IFNDEF NO_STORAGE}
fStreamingRec : TRectWH;
{$ENDIF}
- fDesignerLayer : Boolean;
function GetMidPoint: TPointD;
procedure SetVisible(value: Boolean);
procedure SetHeight(value: double);
@@ -88,11 +87,12 @@ TLayer32 = class(TStorage)
function GetPrevLayerInGroup: TLayer32;
function GetLayer32Parent: TLayer32;
procedure SetLayer32Parent(parent: TLayer32);
- procedure SetOuterMargin(value: double);
procedure CreateInternal(parent: TStorage = nil; const name: string = '');
protected
- UpdateInfo : TUpdateInfo;
+ fIsDesignLayer : Boolean;
+ fUpdateInfo : TUpdateInfo;
procedure SetDesignerLayer(value: Boolean);
+ procedure SetOuterMargin(value: double); virtual;
function GetUpdateNeeded: Boolean;
procedure DoBeforeMerge; virtual;
procedure PreMerge(hideDesigners: Boolean); virtual;
@@ -111,6 +111,7 @@ TLayer32 = class(TStorage)
procedure SetOpacity(value: Byte); virtual;
procedure ImageChanged(Sender: TImage32); virtual;
procedure UpdateLayeredImage(newLayeredImage: TLayeredImage32);
+ property UpdateInfo: TUpdateInfo read fUpdateInfo;
property UpdateNeeded : Boolean read GetUpdateNeeded;
public
constructor Create(parent: TStorage = nil; const name: string = ''); overload; override;
@@ -139,7 +140,6 @@ TLayer32 = class(TStorage)
procedure SetSize(width, height: double);
procedure Invalidate; virtual;
- //procedure Invalidate(const rec: TRectD); overload; virtual;
function AddChild(layerClass: TLayer32Class;
const name: string = ''): TLayer32; reintroduce; virtual;
@@ -153,7 +153,7 @@ TLayer32 = class(TStorage)
//Portions of child layers residing outside this region will be clipped.
property ClipPath: TPathsD read fClipPath write SetClipPath;
procedure Offset(dx, dy: double); overload; virtual;
- property IsDesignerLayer: Boolean read fDesignerLayer;
+ property IsDesignerLayer: Boolean read fIsDesignLayer write SetDesignerLayer;
property InnerBounds: TRectD read GetInnerBounds;
property InnerRect: TRectD read GetInnerRectD;
property OuterBounds: TRectD read GetOuterBounds;
@@ -203,16 +203,19 @@ THitTestLayer32 = class(TLayer32) //abstract class
property HitTestEnabled: Boolean read GetEnabled write SetEnabled;
end;
- //TRotLayer32: rotation methods added
+ //TRotLayer32: rotating and scaling methods added
//(abstract base layer for TVectorLayer32 and TRasterLayer32)
TRotLayer32 = class(THitTestLayer32)
private
fAngle : double;
+ fScaleX : double;
+ fScaleY : double;
fPivotPt : TPointD;
fAutoPivot : Boolean;
function GetPivotPt: TPointD;
procedure SetAutoPivot(val: Boolean);
procedure SetAngle(newAngle: double);
+ procedure Scale(sx, sy: double); virtual;
protected
procedure SetPivotPt(const pivot: TPointD); virtual;
{$IFNDEF NO_STORAGE}
@@ -222,7 +225,7 @@ TRotLayer32 = class(THitTestLayer32)
public
constructor Create(parent: TLayer32 = nil; const name: string = ''); override;
function Rotate(angleDelta: double): Boolean; virtual;
- procedure ResetAngle;
+ procedure Reset;
procedure Offset(dx, dy: double); override;
property Angle: double read fAngle write SetAngle;
property PivotPt: TPointD read GetPivotPt write SetPivotPt;
@@ -233,10 +236,15 @@ TRotLayer32 = class(THitTestLayer32)
//or transforms Paths when bounds change
TVectorLayer32 = class(TRotLayer32)
private
- fPaths : TPathsD;
- fOnDraw : TNotifyEvent;
+ fPaths : TPathsD;
+ fIsDrawing : Boolean;
+ fOnDraw : TNotifyEvent;
procedure RepositionAndDraw;
+ function GetRelativePaths: TPathsD;
protected
+ // we need to accommodate drawing bezier splines on TVectorLayer32 where
+ // the drawn path goes well outside the stored control points (Paths).
+ //procedure SetOuterMargin(value: double); override;
procedure SetPaths(const newPaths: TPathsD); virtual;
procedure Draw; virtual;
public
@@ -244,20 +252,22 @@ TVectorLayer32 = class(TRotLayer32)
procedure SetInnerBounds(const newBounds: TRectD); override;
procedure Offset(dx,dy: double); override;
function Rotate(angleDelta: double): Boolean; override;
+ procedure Scale(sx, sy: double); override;
procedure UpdateHitTestMask(const vectorRegions: TPathsD); virtual;
procedure UpdateHitTestMaskFromImage;
+ procedure AppendPoint(const pt: TPointD);
+ procedure AppendPath(const path: TPathD);
property Paths: TPathsD read fPaths write SetPaths;
+ property PathsRelativeToLayer: TPathsD read GetRelativePaths;
property OnDraw: TNotifyEvent read fOnDraw write fOnDraw;
end;
TRasterLayer32 = class(TRotLayer32) //display layer for raster images
private
fMasterImg : TImage32;
- //fMatrix: allows combining any number of scaling & rotating ops.
- fMatrix : TMatrixD;
- fRotating : Boolean;
- fPreScaleSize : TSize;
fAutoHitTest : Boolean;
+ fAutoCrop : Boolean;
+ fCropMargins : TPoint;
procedure DoAutoHitTest;
protected
procedure ImageChanged(Sender: TImage32); override;
@@ -270,9 +280,11 @@ TRasterLayer32 = class(TRotLayer32) //display layer for raster images
procedure UpdateHitTestMaskTransparent(alphaValue: Byte = 127); overload; virtual;
procedure SetInnerBounds(const newBounds: TRectD); override;
function Rotate(angleDelta: double): Boolean; override;
+ procedure Scale(sx, sy: double); override;
property AutoSetHitTestMask: Boolean read fAutoHitTest write fAutoHitTest;
- property MasterImage: TImage32 read fMasterImg;
+ property AutoCrop : Boolean read fAutoCrop write fAutoCrop;
+ property MasterImage : TImage32 read fMasterImg;
end;
TButtonDesignerLayer32 = class;
@@ -443,7 +455,7 @@ function UpdateRotatingButtonGroup(rotateButton: TLayer32): double;
var
DefaultButtonSize: integer;
- dashes: TArrayOfInteger;
+ dashes: TArrayOfDouble;
const
crDefault = 0;
@@ -470,6 +482,7 @@ implementation
rsUpdateRotateGroupError = 'UpdateRotateGroup - invalid group';
rsLayeredImage32Error = 'TLayeredImage32: ''root'' must be a TGroupLayer32';
rsLayer32Error = 'TLayer32 - children must also be TLayer32';
+ rsVectorLayer32Error = 'TVectorLayer32 - updating Paths during draw events will cause recursion.';
//------------------------------------------------------------------------------
// TLayerNotifyImage32
@@ -580,11 +593,11 @@ procedure TLayer32.CreateInternal(parent: TStorage = nil; const name: string = '
constructor TLayer32.Create(parent: TStorage; const name: string);
begin
- fDesignerLayer := true; //must do this first
+ fIsDesignLayer := true; //must do this first
if not Assigned(parent) then
CreateInternal(nil, name)
else if parent.InheritsFrom(TLayer32) then
- //this constructor is commonly overrided in descendant layer classes
+ //this constructor is commonly overridden in descendant layer classes
Create(TLayer32(parent), name)
else
begin
@@ -613,9 +626,9 @@ destructor TLayer32.Destroy;
begin
Invalidate;
rec := OuterBounds;
- if not UpdateInfo.priorPosition.IsEmpty then
+ if not fUpdateInfo.priorPosition.IsEmpty then
begin
- rec := Parent.MakeAbsolute(UpdateInfo.priorPosition);
+ rec := Parent.MakeAbsolute(fUpdateInfo.priorPosition);
with fLayeredImage do
fInvalidRect := UnionRect(fInvalidRect, rec);
end;
@@ -629,7 +642,7 @@ destructor TLayer32.Destroy;
procedure TLayer32.SetDesignerLayer(value: Boolean);
begin
- fDesignerLayer := value;
+ fIsDesignLayer := value;
end;
//------------------------------------------------------------------------------
@@ -654,7 +667,7 @@ procedure TLayer32.SetLayer32Parent(parent: TLayer32);
function TLayer32.GetUpdateNeeded: Boolean;
begin
- Result := (UpdateInfo.updateMethod <> umNone);
+ Result := (fUpdateInfo.updateMethod <> umNone);
end;
//------------------------------------------------------------------------------
@@ -662,42 +675,19 @@ procedure TLayer32.Invalidate;
var
layer : TLayer32;
begin
- if (UpdateInfo.updateMethod = umSelf) then Exit;
- UpdateInfo.updateMethod := umSelf;
+ if (fUpdateInfo.updateMethod = umSelf) then Exit;
+ fUpdateInfo.updateMethod := umSelf;
layer := Parent;
while Assigned(layer) do
begin
- if layer.UpdateInfo.updateMethod <> umNone then Break;
- layer.UpdateInfo.updateMethod := umChild;
+ if layer.fUpdateInfo.updateMethod <> umNone then Break;
+ layer.fUpdateInfo.updateMethod := umChild;
layer := layer.Parent;
end;
end;
//------------------------------------------------------------------------------
-//procedure TLayer32.Invalidate(const rec: TRectD);
-//var
-// layer : TLayer32;
-//begin
-// if (UpdateInfo.updateMethod = umAll) or
-// not Assigned(fLayeredImage) or (self = Root) then Exit;
-//
-// with UpdateInfo do
-// begin
-// updateMethod := umRegion;
-// updateRegion := UnionRect(updateRegion, rec);
-// end;
-//
-// layer := Parent;
-// while Assigned(layer) do
-// begin
-// if layer.UpdateInfo.childUpdating then Break;
-// layer.UpdateInfo.childUpdating := true;
-// layer := layer.Parent;
-// end;
-//end;
-//------------------------------------------------------------------------------
-
function TLayer32.GetNextLayerInGroup: TLayer32;
begin
if not Assigned(Parent) or (Index = Parent.ChildCount -1) then
@@ -1142,21 +1132,21 @@ procedure TLayer32.PreMerge(hideDesigners: Boolean);
begin
if not Visible or
(hideDesigners and IsDesignerLayer) or
- (UpdateInfo.updateMethod = umNone) then
+ (fUpdateInfo.updateMethod = umNone) then
Continue;
- if UpdateInfo.updateMethod = umSelf then
+ if fUpdateInfo.updateMethod = umSelf then
begin
- rec := Parent.MakeAbsolute(UpdateInfo.priorPosition);
+ rec := Parent.MakeAbsolute(fUpdateInfo.priorPosition);
with fLayeredImage do
fInvalidRect := UnionRect(fInvalidRect, rec);
- UpdateInfo.priorPosition := OuterBounds;
- rec := Parent.MakeAbsolute(UpdateInfo.priorPosition);
+ fUpdateInfo.priorPosition := OuterBounds;
+ rec := Parent.MakeAbsolute(fUpdateInfo.priorPosition);
with fLayeredImage do
fInvalidRect := UnionRect(fInvalidRect, rec);
end;
- // premerge children (recursion)
+ // premerge children
DoBeforeMerge;
PreMerge(hideDesigners);
end;
@@ -1189,6 +1179,11 @@ procedure TLayer32.Merge(hideDesigners: Boolean; updateRect: TRect);
img := fMergeImage;
end;
+ {$IF not defined(FPC) and (CompilerVersion <= 26.0)}
+ // Delphi 7-XE5 have a problem with "continue" and the
+ // code analysis, marking "childImg" as "not initialized"
+ childImg := nil;
+ {$IFEND}
//merge redraw all children
for i := 0 to ChildCount -1 do
begin
@@ -1199,7 +1194,7 @@ procedure TLayer32.Merge(hideDesigners: Boolean; updateRect: TRect);
Continue;
//recursive merge
- if (UpdateInfo.updateMethod <> umNone) then
+ if (fUpdateInfo.updateMethod <> umNone) then
Merge(hideDesigners, updateRect);
if Assigned(fMergeImage) then
@@ -1218,7 +1213,7 @@ procedure TLayer32.Merge(hideDesigners: Boolean; updateRect: TRect);
//independently of the group layer's positioning
if (self is TGroupLayer32) then
TranslateRect(dstRect, Floor(-self.Left), Floor(-self.Top));
- Types.IntersectRect(dstRect, dstRect, self.Image.Bounds);
+ Types.IntersectRect(dstRect, dstRect, self.Image.Bounds);
end;
if IsEmptyRect(dstRect) then Continue;
@@ -1254,7 +1249,7 @@ procedure TLayer32.Merge(hideDesigners: Boolean; updateRect: TRect);
TranslateRect(rec2,
Floor(childLayer.fOuterMargin -childLayer.Left -fOuterMargin),
Floor(childLayer.fOuterMargin -childLayer.Top -fOuterMargin));
- childImg2.CopyBlend(fClipImage, rec, rec2, BlendMask);
+ childImg2.CopyBlend(fClipImage, rec, rec2, BlendMaskLine);
end;
end else
childImg2 := childImg;
@@ -1269,7 +1264,7 @@ procedure TLayer32.Merge(hideDesigners: Boolean; updateRect: TRect);
end;
end;
- with UpdateInfo do
+ with fUpdateInfo do
begin
priorPosition := OuterBounds;
updateMethod := umNone;
@@ -1400,7 +1395,7 @@ procedure TGroupLayer32.Invalidate;
procedure TGroupLayer32.PreMerge(hideDesigners: Boolean);
begin
inherited;
- if (self <> Root) and (UpdateInfo.updateMethod <> umNone) then
+ if (self <> Root) and (fUpdateInfo.updateMethod <> umNone) then
UpdateGroupBounds;
end;
//------------------------------------------------------------------------------
@@ -1490,7 +1485,7 @@ constructor TRotLayer32.Create(parent: TLayer32; const name: string);
begin
inherited;
fAutoPivot := true;
- fPivotPt := InvalidPointD;
+ Reset;
end;
//------------------------------------------------------------------------------
@@ -1498,12 +1493,18 @@ procedure TRotLayer32.SetAngle(newAngle: double);
begin
NormalizeAngle(newAngle);
if newAngle = fAngle then Exit;
- if PointsEqual(fPivotPt, InvalidPointD) then
- fPivotPt := MidPoint;
+ if not IsValid(fPivotPt) then fPivotPt := MidPoint;
Rotate(newAngle - fAngle);
end;
//------------------------------------------------------------------------------
+procedure TRotLayer32.Scale(sx, sy: double);
+begin
+ if (sx > 0) then fScaleX := fScaleX * sx;
+ if (sy > 0) then fScaleY := fScaleY * sy;
+end;
+//------------------------------------------------------------------------------
+
function TRotLayer32.Rotate(angleDelta: double): Boolean;
begin
Result := (angleDelta <> 0) and not HasChildren;
@@ -1515,10 +1516,12 @@ function TRotLayer32.Rotate(angleDelta: double): Boolean;
end;
//------------------------------------------------------------------------------
-procedure TRotLayer32.ResetAngle;
+procedure TRotLayer32.Reset;
begin
- fAngle := 0;
fPivotPt := InvalidPointD;
+ fAngle := 0;
+ fScaleX := 1.0;
+ fScaleY := 1.0;
end;
//------------------------------------------------------------------------------
@@ -1600,12 +1603,26 @@ function TVectorLayer32.Rotate(angleDelta: double): Boolean;
end;
//------------------------------------------------------------------------------
+procedure TVectorLayer32.Scale(sx, sy: double);
+begin
+ inherited;
+ SetInnerBounds(RectD(fLeft, fTop, fWidth * sx, fHeight * sy));
+end;
+//------------------------------------------------------------------------------
+
procedure TVectorLayer32.SetPaths(const newPaths: TPathsD);
begin
fPaths := CopyPaths(newPaths);
fPivotPt := InvalidPointD;
- if Assigned(fPaths) then RepositionAndDraw
- else inherited SetInnerBounds(NullRectD);
+ if not Assigned(fPaths) then inherited SetInnerBounds(NullRectD)
+ else if fIsDrawing then Raise Exception.Create(rsVectorLayer32Error)
+ else RepositionAndDraw;
+end;
+//------------------------------------------------------------------------------
+
+function TVectorLayer32.GetRelativePaths: TPathsD;
+begin
+ Result := TranslatePath(fPaths, -Left + fOuterMargin, -Top + fOuterMargin);
end;
//------------------------------------------------------------------------------
@@ -1647,6 +1664,33 @@ procedure TVectorLayer32.Offset(dx,dy: double);
end;
//------------------------------------------------------------------------------
+procedure TVectorLayer32.AppendPoint(const pt: TPointD);
+var
+ highPaths, lenPts: integer;
+begin
+ highPaths := High(fPaths);
+ if highPaths < 0 then
+ begin
+ SetLength(fPaths, 1);
+ SetLength(fPaths[0], 1);
+ fPaths[0][0] := pt;
+ end else
+ begin
+ lenPts := Length(fPaths[highPaths]);
+ SetLength(fPaths[highPaths], lenPts +1);
+ fPaths[highPaths][lenPts] := pt;
+ end;
+ RepositionAndDraw;
+end;
+//------------------------------------------------------------------------------
+
+procedure TVectorLayer32.AppendPath(const path: TPathD);
+begin
+ Img32.Vector.AppendPath(fPaths, path);
+ RepositionAndDraw;
+end;
+//------------------------------------------------------------------------------
+
procedure TVectorLayer32.RepositionAndDraw;
var
rec: TRectD;
@@ -1669,7 +1713,10 @@ procedure TVectorLayer32.Draw;
begin
//to draw the layer, either override this event
//in a descendant class or assign the OnDraw property
- if Assigned(fOnDraw) then fOnDraw(self);
+ if not Assigned(fOnDraw) then Exit;
+ fIsDrawing := true;
+ fOnDraw(self);
+ fIsDrawing := false;
end;
//------------------------------------------------------------------------------
@@ -1698,6 +1745,7 @@ constructor TRasterLayer32.Create(parent: TLayer32; const name: string);
fCursorId := crHandPoint;
fAutoHitTest := true;
fOuterMargin := 0;
+ fAutoCrop := true;
end;
//------------------------------------------------------------------------------
@@ -1752,28 +1800,28 @@ procedure TRasterLayer32.ImageChanged(Sender: TImage32);
begin
if (Sender = MasterImage) then
begin
+ Reset;
if MasterImage.IsEmpty then Exit;
- MasterImage.BlockNotify;
- MasterImage.CropTransparentPixels;
- MasterImage.UnblockNotify;
- Invalidate;
-
+ if fAutoCrop then
+ begin
+ MasterImage.BlockNotify;
+ MasterImage.CropTransparentPixels;
+ MasterImage.UnblockNotify;
+ end;
//reset whenever MasterImage changes
- fAngle := 0;
- fMatrix := IdentityMatrix;
- fRotating := false;
- fPreScaleSize := Size(MasterImage.Width, MasterImage.Height);
-
- if Image.IsEmpty and
- (TLayerNotifyImage32(Image).UpdateCount = 0) then
- Image.Assign(MasterImage);
+ if Image.IsEmpty and (TLayerNotifyImage32(Image).UpdateCount = 0) then
+ Image.Assign(MasterImage);
+ fCropMargins := NullPoint;
+ Invalidate;
end else
begin
if MasterImage.IsEmpty and not Image.IsEmpty then
begin
Image.BlockNotify;
try
- Image.CropTransparentPixels;
+ if fAutoCrop then
+ fCropMargins := SymmetricCropTransparent(Image);
+ PositionAt(Left + fCropMargins.X, Top + fCropMargins.Y);
MasterImage.Assign(Image);
finally
Image.UnblockNotify;
@@ -1787,42 +1835,79 @@ procedure TRasterLayer32.ImageChanged(Sender: TImage32);
procedure TRasterLayer32.SetInnerBounds(const newBounds: TRectD);
var
- newWidth, newHeight: double;
- w,h: integer;
+ x,y, rx,ry: double;
+ mat: TMatrixD;
+ sinA, cosA, tanA: double;
begin
-
- if fRotating and Assigned(Image) then
- begin
- //rotation has just ended
- fRotating := false;
- //update fMatrix with the new rotation angle
- if (fAngle <> 0) then
- MatrixRotate(fMatrix, Image.MidPoint, fAngle);
-
- //and since we're about to start scaling, we need
- //to store the starting size, and reset the angle
- fPreScaleSize := Size(Image.Width, Image.Height);
- fAngle := 0;
- end;
-
- newWidth := newBounds.Width;
- newHeight := newBounds.Height;
-
- //make sure the image is large enough to scale safely
- if not MasterImage.IsEmpty and (newWidth > 1) and (newHeight > 1) then
+ if not MasterImage.IsEmpty and
+ //the image must be large enough to scale safely
+ (newBounds.Width > 1) and (newBounds.Height > 1) then
begin
Image.BeginUpdate;
try
- Image.Assign(MasterImage);
- //apply any prior transformations
+ // determine the amount of scaling in the **un-rotated**
+ // image that will fit 'newBounds' once the image is rotated
+
+ // given:
+ // the pivot point is unimportant (final position already defined)
+ // rotated x = sin(angle)*y + cos(angle)*x
+ // rotated y = cos(angle)*y + sin(angle)*x
+ // let:
+ // X, Y : unrotated image width & height
+ // rX, rY : rotated image width & height
+
+ // rX = sinA * Y + cosA * X
+ // X = rX / cosA - sinA/cosA * Y
+ // X = rX / cosA - tanA * Y
+ // rY = cosA*Y + sinA*X
+ // Y = rY/cosA - tanA * X
+ // X = rX / cosA - tanA * (rY / cosA - tanA * X)
+ // X = rX / cosA - tanA * rY/cosA + tanA*tanA * X
+ // X - tanA*tanA * X = rX / cosA - tanA * rY/cosA
+ // X * (1 - tanA*tanA) = rX / cosA - tanA * rY/cosA
+ // X = (rX / cosA - tanA * rY/cosA) / (1 - tanA*tanA)
+ // Y := (rY - sinA * x) /cosA;
+
+ sinA := Abs(Sin(fAngle));
+ cosA := Abs(Cos(fAngle));
+ if sinA = 0.0 then // no rotation (or 180 deg. rotation)
+ begin
+ fScaleX := newBounds.Width / MasterImage.Width;
+ fScaleY := newBounds.Height / MasterImage.Height;
+ end
+ else if cosA = 0.0 then // rotated 90 or 270 degrees
+ begin
+ fScaleX := newBounds.Height / MasterImage.Width;
+ fScaleY := newBounds.Width / MasterImage.Height;
+ end else
+ begin
+ tanA := sinA/cosA;
+ // adjust for rotational cropping
+ rx := newBounds.Width + fCropMargins.X * 2;
+ ry := newBounds.Height + fCropMargins.Y * 2;
+ x := (rx /cosA - tanA * ry / cosA) / (1 - tanA*tanA);
+ y := (ry - sinA * x) /cosA;
+
+ if (x <= 0) or (y <= 0) then
+ begin
+ Image.SetSize(Round(newBounds.Width), Round(newBounds.Height));
+ PositionAt(newBounds.Left, newBounds.Top);
+ Exit;
+ end;
+
+ fScaleX := x / MasterImage.Width;
+ fScaleY := y / MasterImage.Height;
+ end;
+
+ Image.AssignSettings(MasterImage);
Image.Resampler := rWeightedBilinear;
- AffineTransformImage(Image, fMatrix, true); // assumes no skew
- //cropping is very important with rotation
- SymmetricCropTransparent(Image);
- w := Ceil(newBounds.Right) - Floor(newBounds.Left);
- h := Ceil(newBounds.Bottom) - Floor(newBounds.Top);
- Image.Resize(w, h); //nb: stretch resizes
- PositionAt(newBounds.TopLeft);
+ mat := IdentityMatrix;
+ MatrixScale(mat, fScaleX, fScaleY);
+ MatrixRotate(mat, fAngle);
+ AffineTransformImage(MasterImage, Image, mat, true);
+ if fAutoCrop then
+ fCropMargins := SymmetricCropTransparent(Image);
+ PositionAt(newBounds.Left, newBounds.Top);
finally
Image.EndUpdate;
end;
@@ -1834,8 +1919,8 @@ procedure TRasterLayer32.SetInnerBounds(const newBounds: TRectD);
function TRasterLayer32.Rotate(angleDelta: double): Boolean;
var
- mat: TMatrixD;
- pt, mp: TPointD;
+ mat : TMatrixD;
+ mp : TPointD;
begin
Result := (angleDelta <> 0) and
not MasterImage.IsEmpty and
@@ -1844,38 +1929,37 @@ function TRasterLayer32.Rotate(angleDelta: double): Boolean;
if not Result then Exit;
mp := MidPoint;
-
- //if not already rotating, then update fMatrix with prior scaling
- if not fRotating then
- begin
- Assert((fPreScaleSize.cx > 0) and (fPreScaleSize.cy > 0), 'oops!');
- MatrixScale(fMatrix,
- Image.Width/fPreScaleSize.cx,
- Image.Height/fPreScaleSize.cy);
-
- fRotating := true;
- if fAutoPivot then fPivotPt := mp;
- end;
-
+ mat := IdentityMatrix;
+ MatrixScale(mat, fScaleX, fScaleY);
+ MatrixRotate(mat, fAngle);
RotatePoint(mp, PivotPt, angleDelta);
Image.BlockNotify;
try
- Image.Assign(MasterImage);
- mat := fMatrix;
- pt := PointD(PivotPt.X - fLeft, PivotPt.Y - fTop);
- MatrixRotate(mat, pt, Angle);
+ Image.AssignSettings(MasterImage);
Image.Resampler := rWeightedBilinear;
- AffineTransformImage(Image, mat, true); // assumes no skew
+ AffineTransformImage(MasterImage, Image, mat, true);
finally
Image.UnblockNotify;
end;
+ // cropping the image significantly improves performance
+ if fAutoCrop then
+ fCropMargins := SymmetricCropTransparent(Image);
+
fWidth := Image.Width;
fHeight := Image.Height;
PositionCenteredAt(mp);
DoAutoHitTest;
end;
+//------------------------------------------------------------------------------
+
+procedure TRasterLayer32.Scale(sx, sy: double);
+begin
+ inherited;
+ SetInnerBounds(RectD(fLeft, fTop,
+ MasterImage.Width * fSCaleX, MasterImage.Height * fSCaleY));
+end;
//------------------------------------------------------------------------------
// TRotatingGroupLayer32 class
@@ -1900,8 +1984,9 @@ procedure TRotatingGroupLayer32.Init(const rec: TRect;
rec2: TRectD;
begin
//startingZeroOffset: default = 0 (ie 3 o'clock)
- if not ClockwiseRotationIsAnglePositive then
+{$IFDEF CLOCKWISE_ROTATION_WITH_NEGATIVE_ANGLES}
startingZeroOffset := -startingZeroOffset;
+{$ENDIF}
fZeroOffset := startingZeroOffset;
if buttonSize <= 0 then buttonSize := DefaultButtonSize;
@@ -2072,7 +2157,7 @@ procedure TButtonDesignerLayer32.Draw;
constructor TLayeredImage32.Create(parent: TStorage; const name: string);
begin
inherited;
- fBackColor := clBtnFace32;
+ fBackColor := clNone32;
fResampler := DefaultResampler;
fLastUpdateType := utUndefined;
@@ -2188,7 +2273,7 @@ procedure TLayeredImage32.Invalidate;
function TLayeredImage32.GetRepaintNeeded: Boolean;
begin
- Result := Root.UpdateInfo.updateMethod <> umNone;
+ Result := Root.fUpdateInfo.updateMethod <> umNone;
end;
//------------------------------------------------------------------------------
@@ -2371,7 +2456,7 @@ function GetRectEdgeMidPoints(const rec: TRectD): TPathD;
mp: TPointD;
begin
mp := MidPoint(rec);
- SetLength(Result, 4);
+ NewPointDArray(Result, 4, True);
Result[0] := PointD(mp.X, rec.Top);
Result[1] := PointD(rec.Right, mp.Y);
Result[2] := PointD(mp.X, rec.Bottom);
@@ -2456,7 +2541,7 @@ function UpdateSizingButtonGroup(movedButton: TLayer32): TRect;
group := TSizingGroupLayer32(movedButton.Parent);
with group do
begin
- SetLength(path, ChildCount);
+ NewPointDArray(path, ChildCount, True);
for i := 0 to ChildCount -1 do
path[i] := Child[i].MidPoint;
end;
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Panels.pas b/Ext/SVGIconImageList/Image32/source/Img32.Panels.pas
index 8083609..fd614a8 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Panels.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Panels.pas
@@ -2,12 +2,12 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 24 April 2024 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2024 *
+* Version : 4.8 *
+* Date : 2 Febuary 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : Component that displays images on a TPanel descendant *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -26,19 +26,19 @@ interface
TShowScrollBtns = (ssbFocused, ssAlways, ssNever);
TPanelBkgType = (pbtSolidColor, pbtChessBoard);
- //TDrawImageEvent: template for TBaseImgPanel's OnDrawImage event property.
- //nb: with scaling, srcRect & dstRect may have different widths +/- heights.
+ // TDrawImageEvent: template for TBaseImgPanel's OnDrawImage event property.
+ // nb: with scaling, srcRect & dstRect may have different widths +/- heights.
TDrawImageEvent = procedure (Sender: TObject;
dstCanvas: TCanvas; const srcRect, dstRect: TRect) of Object;
TFileDropEvent = procedure (Sender: TObject; const filename: string) of Object;
- //TPanelScrollbar: used internally by TBaseImgPanel and TImage32Panel
+ // TPanelScrollbar: used internally by TBaseImgPanel and TImage32Panel
TPanelScrollbar = record
- btnSize : integer; //in dst coords
- btnDelta : double; //how much src moves for each px of the ScrollBar
- srcOffset : integer; //offset in unscaled src coords
- maxSrcOffset : double; //max offset in unscaled src coords
+ btnSize : integer; // in dst coords
+ btnDelta : double; // how much src moves for each px of the ScrollBar
+ srcOffset : integer; // offset in unscaled src coords
+ maxSrcOffset : double; // max offset in unscaled src coords
MouseOver : Boolean;
MouseDown : Boolean;
MouseDownPos : integer;
@@ -65,6 +65,7 @@ TBaseImgPanel = class(TPanel)
fOnScrolling : TNotifyEvent;
fOnZooming : TNotifyEvent;
fOnMouseWheel : TMouseWheelEvent;
+ fCursor : TCursor;
{$IFDEF GESTURES}
fLastDistance: integer;
fLastLocation: TPoint;
@@ -73,6 +74,7 @@ TBaseImgPanel = class(TPanel)
fBkgChBrdColor1 : TColor32;
fBkgChBrdColor2 : TColor32;
fBkgChBrdSize : Integer;
+ procedure SetCursor(cursor: TCursor);
procedure UpdateOffsetDelta(resetOrigin: Boolean);
function GetMinScrollBtnSize: integer;
function GetDstOffset: TPoint;
@@ -92,11 +94,12 @@ TBaseImgPanel = class(TPanel)
procedure SetBkgChBrdColor1(value : TColor32);
procedure SetBkgChBrdColor2(value : TColor32);
procedure SetBkgChBrdSize(value : Integer);
+ function GetTabStop: Boolean;
+ procedure SetTabStop(tabstop: Boolean);
{$IFDEF GESTURES}
procedure Gesture(Sender: TObject;
const EventInfo: TGestureEventInfo; var Handled: Boolean);
{$ENDIF}
- procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure WMEraseBkgnd(var message: TMessage); message WM_ERASEBKGND;
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
@@ -113,6 +116,7 @@ TBaseImgPanel = class(TPanel)
X, Y: Integer); override;
procedure DrawToPanelCanvas(const srcRect, dstRect: TRect); virtual;
procedure Paint; override;
+ procedure Resize; override;
procedure WMKeyDown(var Message: TWMKey); message WM_KEYDOWN;
procedure WMKeyUp(var Message: TWMKey); message WM_KEYUP;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
@@ -126,7 +130,7 @@ TBaseImgPanel = class(TPanel)
function ClientToImage(const clientPt: TPoint): TPoint;
function ImageToClient(const surfacePt: TPoint): TPoint;
function RecenterImageAt(const imagePt: TPoint): Boolean;
- //ScaleAtPoint: zooms in or out keeping 'pt' stationary relative to display
+ // ScaleAtPoint: zooms in or out keeping 'pt' stationary relative to display
procedure ScaleAtPoint(scaleDelta: double; const pt: TPoint);
property InnerClientRect: TRect read GetInnerClientRect;
property InnerMargin: integer read GetInnerMargin;
@@ -136,33 +140,35 @@ TBaseImgPanel = class(TPanel)
property ScrollbarVert: TPanelScrollbar
read fScrollbarVert write fScrollbarVert;
published
- //AutoCenter: centers the image when its size is less than the display size
+ // AutoCenter: centers the image when its size is less than the display size
property AutoCenter: Boolean read fAutoCenter write SetAutoCenter;
property Color: TColor read GetColor write SetColor;
- //FocusedColor: colour of the border when the panel is focused
+ // FocusedColor: colour of the border when the panel is focused
property FocusedColor: TColor read fFocusedColor write fFocusedColor;
property UnFocusedColor: TColor read fUnfocusedColor write fUnfocusedColor;
- //Scale: image scale (between ScaleMin and ScaleMax) if AllowZoom is enabled
+ // Scale: image scale (between ScaleMin and ScaleMax) if AllowZoom is enabled
property Scale: double read fScale write SetScale;
property ScaleMin: double read fScaleMin write SetScaleMin;
property ScaleMax: double read fScaleMax write SetScaleMax;
- //ShowScrollButtons: defaults to ssbFocused (ie only when Panel has focus)
+ // ShowScrollButtons: defaults to ssbFocused (ie only when Panel has focus)
property ShowScrollButtons : TShowScrollBtns
read fShowScrollBtns write SetShowScrollButtons;
property AllowKeyScroll: Boolean read fAllowKeyScroll write fAllowKeyScroll;
property AllowScrnScroll: Boolean read fAllowScrnScroll write fAllowScrnScroll;
property AllowZoom: Boolean read fAllowZoom write SetAllowZoom;
- //Hatched background option
+ // Hatched background option
property BkgType : TPanelBkgType read fBkgType write SetBkgType;
property BkgChBrdColor1 : TColor32 read fBkgChBrdColor1 write SetBkgChBrdColor1;
property BkgChBrdColor2 : TColor32 read fBkgChBrdColor2 write SetBkgChBrdColor2;
property BkgChBrdSize : Integer read fBkgChBrdSize write SetBkgChBrdSize;
- //OnKeyDown: optional event for custom keyboard actions
+ // OnKeyDown: optional event for custom keyboard actions
property OnKeyDown: TKeyEvent read fOnKeyDown write fOnKeyDown;
property OnKeyUp: TKeyEvent read fOnKeyUp write fOnKeyUp;
property OnMouseWheel: TMouseWheelEvent read FOnMouseWheel write FOnMouseWheel;
property OnScrolling: TNotifyEvent read fOnScrolling write fOnScrolling;
property OnZooming: TNotifyEvent read fOnZooming write fOnZooming;
+ property Cursor: TCursor read fCursor write SetCursor;
+ property TabStop: Boolean read GetTabStop write SetTabStop stored True;
end;
TImage32Panel = class(TBaseImgPanel)
@@ -186,7 +192,7 @@ TImage32Panel = class(TBaseImgPanel)
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ClearImage;
- //CopyToImage: avoids a full redraw
+ // CopyToImage: avoids a full redraw
procedure CopyToImage(srcImg: TImage32; const rec: TRect);
function CopyToClipboard: Boolean;
function PasteFromClipboard: Boolean;
@@ -227,9 +233,9 @@ TNotifyImage32 = class(TImage32)
//------------------------------------------------------------------------------
var
- //The minimum width for scrolling buttons. If borders are too narrow
- //to properly display scroll buttons then scroll buttons will be disabled.
- MinBorderWidth: integer = 0; //see initialization
+ // The minimum width for scrolling buttons. If borders are too narrow
+ // to properly display scroll buttons then scroll buttons will be disabled.
+ MinBorderWidth: integer = 0; // see initialization
const
MinImageScale = 0.001;
@@ -368,15 +374,15 @@ constructor TBaseImgPanel.Create(AOwner: TComponent);
Height := 200;
Width := 200;
{$IFnDEF FPC}
- {$IF COMPILERVERSION >= 17} //this is a guess
+ {$IF COMPILERVERSION >= 17} // this is a guess
ShowCaption := false;
{$IFEND}
{$ENDIF}
BevelWidth := 1;
BorderWidth := 12;
BevelInner := bvLowered;
- DoubleBuffered := true;
- TabStop := true;
+ //DoubleBuffered := true;
+ inherited TabStop := true;
{$IFDEF GESTURES}
OnGesture := Gesture;
Touch.InteractiveGestures := [igPressAndTap, igZoom, igPan];
@@ -388,6 +394,7 @@ constructor TBaseImgPanel.Create(AOwner: TComponent);
fAutoCenter := true;
fFocusedColor := RgbColor(clActiveCaption);
fUnfocusedColor := clBtnFace;
+ fCursor := inherited Cursor;
fScale := 1.0;
fScaleMin := 0.05;
fScaleMax := 20;
@@ -405,13 +412,6 @@ destructor TBaseImgPanel.Destroy;
end;
//------------------------------------------------------------------------------
-procedure TBaseImgPanel.WMSize(var Message: TWMSize);
-begin
- inherited;
- UpdateOffsetDelta(true);
-end;
-//------------------------------------------------------------------------------
-
function TBaseImgPanel.GetDstOffset: TPoint;
begin
if not fAutoCenter then
@@ -427,11 +427,11 @@ function TBaseImgPanel.GetDstOffset: TPoint;
function TBaseImgPanel.GetInnerMargin: integer;
begin
- //nb: BorderWidth is the space between outer and inner bevels
+ // nb: BorderWidth is the space between outer and inner bevels
Result := DpiAware(BorderWidth);
if BevelInner <> bvNone then inc(result, BevelWidth);
if BevelOuter <> bvNone then inc(result, BevelWidth);
- //BorderStyle changes the OUTSIDE of the panel so won't affect InnerMargin.
+ // BorderStyle changes the OUTSIDE of the panel so won't affect InnerMargin.
end;
//------------------------------------------------------------------------------
@@ -484,7 +484,7 @@ procedure TBaseImgPanel.ScaleToFit;
h,w: integer;
begin
if IsEmpty then Exit;
- //fScale := 1;
+ // fScale := 1;
fScrollbarHorz.srcOffset := 0;
fScrollbarVert.srcOffset := 0;
rec := GetInnerClientRect;
@@ -562,6 +562,18 @@ procedure TBaseImgPanel.SetColor(acolor: TColor);
end;
//------------------------------------------------------------------------------
+function TBaseImgPanel.GetTabStop: Boolean;
+begin
+ Result := inherited TabStop;
+end;
+//------------------------------------------------------------------------------
+
+procedure TBaseImgPanel.SetTabStop(tabstop: Boolean);
+begin
+ inherited TabStop := tabstop;
+end;
+//------------------------------------------------------------------------------
+
procedure TBaseImgPanel.SetAutoCenter(value: Boolean);
begin
if value = fAutoCenter then Exit;
@@ -592,7 +604,7 @@ procedure TBaseImgPanel.UpdateOffsetDelta(resetOrigin: Boolean);
innerClientW, innerClientH, btnMin: integer;
scaledW, scaledH: double;
begin
- //we need to determine 2 things:
+ // we need to determine 2 things:
// 1. scroll button size
// 2. how much a 1px button move moves the scaled image
if (fImageSize.cx = 0) or (fImageSize.cy = 0) then Exit;
@@ -605,7 +617,7 @@ procedure TBaseImgPanel.UpdateOffsetDelta(resetOrigin: Boolean);
with fScrollbarVert do
begin
if resetOrigin then srcOffset := 0;
- if (scaledH < innerClientH + tolerance) then //no scroll button needed
+ if (scaledH < innerClientH + tolerance) then // no scroll button needed
begin
btnSize := 0; btnDelta := 0; maxSrcOffset := 0;
end else
@@ -618,7 +630,7 @@ procedure TBaseImgPanel.UpdateOffsetDelta(resetOrigin: Boolean);
with fScrollbarHorz do
begin
if resetOrigin then srcOffset := 0;
- if (scaledW < innerClientW + tolerance) then //no scroll button needed
+ if (scaledW < innerClientW + tolerance) then // no scroll button needed
begin
btnSize := 0; btnDelta := 0; maxSrcOffset := 0;
end else
@@ -705,32 +717,26 @@ function TBaseImgPanel.ImageToClient(const surfacePt: TPoint): TPoint;
function TBaseImgPanel.RecenterImageAt(const imagePt: TPoint): Boolean;
var
- scaledW, scaledH: Double;
marg, innerW, innerH: Integer;
- pt1, pt2: TPoint;
- q, maxOffset: double;
+ pt2: TPoint;
+ q: double;
begin
Result := (fScrollbarHorz.maxSrcOffset > 0) or
(fScrollbarVert.maxSrcOffset = 0);
if not Result then Exit;
- scaledW := fImageSize.cx * fScale;
- scaledH := fImageSize.cy * fScale;
marg := GetInnerMargin;
innerW := ClientWidth - marg*2;
innerH := ClientHeight - marg*2;
- pt1 := imagePt;
pt2 := ClientToImage(Types.Point(marg + innerW div 2, marg + innerH div 2));
with fScrollbarHorz do
begin
- q := (pt1.X - pt2.X);
- maxOffset := (scaledW - innerW) / fScale;
- srcOffset := Round(Max(0,Min(maxOffset, q)));
+ q := (imagePt.X - pt2.X);
+ srcOffset := EnsureRange(Round(srcOffset + q), 0, Round(maxSrcOffset));
end;
with fScrollbarVert do
begin
- q := (pt1.Y - pt2.Y);
- maxOffset := (scaledH - innerH) / fScale;
- srcOffset := Round(Max(0,Min(maxOffset, q)));
+ q := (imagePt.Y - pt2.Y);
+ srcOffset := EnsureRange(Round(srcOffset + q), 0, Round(maxSrcOffset));
end;
Invalidate;
end;
@@ -774,7 +780,7 @@ procedure TBaseImgPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
inDrawRegion: Boolean;
begin
rec := GetInnerClientRect;
- inDrawRegion := PtInRect(rec, Types.Point(X,Y));
+ inDrawRegion := Windows.PtInRect(rec, Types.Point(X,Y));
if inDrawRegion and
not (fScrollbarHorz.MouseDown or fScrollbarVert.MouseDown) then
begin
@@ -784,10 +790,11 @@ procedure TBaseImgPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
fScrollbarHorz.MouseOver := false;
fScrollbarVert.MouseOver := false;
end;
- cursor := crDefault;
+ inherited cursor := fCursor;
inherited;
Exit;
end;
+
if not fMouseDown or
not (fAllowScrnScroll or fAllowKeyScroll) then
begin
@@ -799,19 +806,19 @@ procedure TBaseImgPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
if (Y < rec.Bottom) then
begin
- cursor := crSizeNS;
+ inherited cursor := crSizeNS;
if not fScrollbarVert.MouseOver then Invalidate;
fScrollbarVert.MouseOver := true;
end else
- cursor := crDefault;
+ inherited cursor := fCursor;
end
else if (Y >= rec.Bottom) and (fScrollbarHorz.btnSize > 0) then
begin
- Cursor := crSizeWE;
+ inherited cursor := crSizeWE;
if not fScrollbarHorz.MouseOver then Invalidate;
fScrollbarHorz.MouseOver := true;
end else
- cursor := crDefault;
+ inherited cursor := fCursor;
end;
Exit;
end;
@@ -820,7 +827,7 @@ procedure TBaseImgPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
if not (fAllowScrnScroll or fAllowKeyScroll) then Exit;
if fScrollbarVert.MouseDown then
begin
- //dragging vertical scrollbar
+ // dragging vertical scrollbar
with fScrollbarVert do
begin
inc(srcOffset, Round((Y - MouseDownPos) / btnDelta));
@@ -829,7 +836,7 @@ procedure TBaseImgPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
end
else if fScrollbarHorz.MouseDown then
begin
- //dragging horizontal scrollbar
+ // dragging horizontal scrollbar
with fScrollbarHorz do
begin
inc(srcOffset, Round((X - MouseDownPos) / btnDelta));
@@ -837,7 +844,7 @@ procedure TBaseImgPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
end;
end else if fAllowScrnScroll then
begin
- //click and drag the drawing image
+ // click and drag the drawing image
with fScrollbarVert do if btnDelta > 0 then
begin
dec(srcOffset, Round((Y - MouseDownPos) / fScale));
@@ -849,11 +856,10 @@ procedure TBaseImgPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
MouseDownPos := X;
end;
end else
- begin
- Exit; //ie exit here if NOT scrolling
- end;
+ Exit; // ie exit here if NOT scrolling
if assigned(fOnScrolling) then fOnScrolling(self);
Invalidate;
+ inherited;
end;
//------------------------------------------------------------------------------
@@ -892,11 +898,11 @@ procedure TBaseImgPanel.CMFocusChanged(var Message: TMessage);
procedure TBaseImgPanel.WMEraseBkgnd(var message: TMessage);
begin
- message.Result := 0; //ie don't bother erasing background
+ message.Result := 0; // ie don't bother erasing background
end;
//------------------------------------------------------------------------------
-type TControl = class(Controls.TControl); //access protected Color property
+type TWinControl = class(Controls.TWinControl); // access protected Color property
procedure TBaseImgPanel.DrawToPanelCanvas(const srcRect, dstRect: TRect);
begin
@@ -956,7 +962,7 @@ procedure TBaseImgPanel.Paint;
backgroundPainted: Boolean;
pt: TPoint;
begin
- //calculate un-scaled source rectangle that corresponds with dstRec
+ // calculate un-scaled source rectangle that corresponds with dstRec
marg := GetInnerMargin;
innerRec := GetInnerClientRect;
dpiAwareBW := DpiAware(BorderWidth);
@@ -964,7 +970,7 @@ procedure TBaseImgPanel.Paint;
srcRec := dstRec;
TranslateRect(srcRec, -marg, -marg);
ScaleRect(srcRec, 1/fScale);
- //if the scaled drawing is smaller than InnerClientRect then center it
+ // if the scaled drawing is smaller than InnerClientRect then center it
pt := GetDstOffset;
if pt.X > 0 then
begin
@@ -980,7 +986,7 @@ procedure TBaseImgPanel.Paint;
srcRec.Top := 0;
srcRec.Bottom := fImageSize.cy;
end;
- //calc offsets
+ // calc offsets
with fScrollbarHorz do
if (srcOffset < 0) or (btnSize = 0) then srcOffset := 0;
with fScrollbarVert do
@@ -990,7 +996,7 @@ procedure TBaseImgPanel.Paint;
if fScrollbarHorz.srcOffset > fScrollbarHorz.maxSrcOffset then
fScrollbarHorz.srcOffset := Round(fScrollbarHorz.maxSrcOffset);
TranslateRect(srcRec, fScrollbarHorz.srcOffset, fScrollbarVert.srcOffset);
- //paint innerRec background
+ // paint innerRec background
backgroundPainted := ParentBackground and
{$IFDEF STYLESERVICES}
StyleServices.Enabled and (seClient in StyleElements) and
@@ -1001,7 +1007,7 @@ procedure TBaseImgPanel.Paint;
if (csDesigning in ComponentState) or not backgroundPainted then
begin
if ParentColor then
- Canvas.Brush.Color := TControl(parent).Color else
+ Canvas.Brush.Color := TWinControl(parent).Color else
Canvas.Brush.Color := self.Color;
Canvas.FillRect(innerRec);
end;
@@ -1010,25 +1016,25 @@ procedure TBaseImgPanel.Paint;
begin
DrawChessBoard(innerRec);
end;
- //draw the image
+ // draw the image
DrawToPanelCanvas(srcRec, dstRec);
- //prevent recursive paints (in case Invalidate etc called in fOnDrawImage)
+ // prevent recursive paints (in case Invalidate etc called in fOnDrawImage)
RedrawWindow(Handle, nil, 0, RDW_NOERASE or RDW_NOINTERNALPAINT or RDW_VALIDATE);
- //Exit;//////////////////
- //paint the outer bevel
+ // Exit;//////////////////
+ // paint the outer bevel
tmpRec := ClientRect;
case BevelOuter of
bvLowered: DrawFrame(tmpRec, clBtnShadow, clBtnHighlight, BevelWidth);
bvRaised: DrawFrame(tmpRec, clBtnHighlight, clBtnShadow, BevelWidth);
end;
- //paint the border
+ // paint the border
InflateRect(tmpRec, integer(-BevelWidth), integer(-BevelWidth));
if Focused then
DrawFrame(tmpRec, fFocusedColor, fFocusedColor, dpiAwareBW)
else
DrawFrame(tmpRec, fUnfocusedColor, fUnfocusedColor, dpiAwareBW);
InflateRect(tmpRec, integer(-dpiAwareBW), integer(-dpiAwareBW));
- //paint the inner bevel
+ // paint the inner bevel
case BevelInner of
bvLowered: DrawFrame(tmpRec, clBtnShadow, clBtnHighlight, BevelWidth);
bvRaised: DrawFrame(tmpRec, clBtnHighlight, clBtnShadow, BevelWidth);
@@ -1039,7 +1045,7 @@ procedure TBaseImgPanel.Paint;
(Focused and (fShowScrollBtns = ssbFocused))) then
begin
btnMin := GetMinScrollBtnSize;
- //draw vertical scrollbar
+ // draw vertical scrollbar
with fScrollbarVert do
if (btnSize > 0) then
begin
@@ -1052,7 +1058,7 @@ procedure TBaseImgPanel.Paint;
else Canvas.Brush.Color := MakeDarker(Color, 20);
DrawScrollButton(tmpRec);
end;
- //draw horizontal scrollbar
+ // draw horizontal scrollbar
with fScrollbarHorz do
if (btnSize > 0) then
begin
@@ -1069,6 +1075,13 @@ procedure TBaseImgPanel.Paint;
end;
//------------------------------------------------------------------------------
+procedure TBaseImgPanel.Resize;
+begin
+ UpdateOffsetDelta(true);
+ inherited;
+end;
+//------------------------------------------------------------------------------
+
{$IFDEF GESTURES}
procedure TBaseImgPanel.Gesture(Sender: TObject;
const EventInfo: TGestureEventInfo; var Handled: Boolean);
@@ -1151,6 +1164,14 @@ procedure TBaseImgPanel.WMMouseHWheel(var Message: TCMMouseWheel);
end;
//------------------------------------------------------------------------------
+procedure TBaseImgPanel.SetCursor(cursor: TCursor);
+begin
+ if cursor = inherited Cursor then Exit;
+ inherited Cursor := cursor;
+ fCursor := cursor;
+end;
+//------------------------------------------------------------------------------
+
function TBaseImgPanel.DoMouseHWheel(Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint): Boolean;
begin
@@ -1194,7 +1215,7 @@ procedure TBaseImgPanel.WMKeyDown(var Message: TWMKey);
if ssCtrl in shiftState then
begin
if not fAllowZoom then Exit;
- //zoom in and out with CTRL+UP and CTRL+DOWN respectively
+ // zoom in and out with CTRL+UP and CTRL+DOWN respectively
midPoint := Types.Point(ClientWidth div 2, ClientHeight div 2);
case Message.CharCode of
VK_UP: ScaleAtPoint(1.1, midPoint);
@@ -1204,9 +1225,9 @@ procedure TBaseImgPanel.WMKeyDown(var Message: TWMKey);
end else
begin
if not fAllowKeyScroll then Exit;
- //otherwise scroll the image with the arrow keys
+ // otherwise scroll the image with the arrow keys
if ssShift in shiftState then
- mul := 5 else //ie scrolls 5 times faster with Shift key down
+ mul := 5 else // ie scrolls 5 times faster with Shift key down
mul := 1;
case Message.CharCode of
VK_LEFT:
@@ -1271,6 +1292,7 @@ constructor TImage32Panel.Create(AOwner: TComponent);
fImage.SetSize(200,200);
fAllowCopy := true;
fAllowPaste := true;
+ DoubleBuffered := true;
end;
//------------------------------------------------------------------------------
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas b/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas
index d708832..606bed1 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas
@@ -2,12 +2,12 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 2 May 2024 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2024 *
+* Version : 4.8 *
+* Date : 10 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* Purpose : For image transformations (scaling, rotating etc.) *
-* License : http://www.boost.org/LICENSE_1_0.txt *
+* License : https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -17,6 +17,10 @@ interface
uses
SysUtils, Classes, Math, Img32;
+// Premultiplies the alpha channel into the color channels from pSrc and stores
+// it into pDst. pSrc and pDst can be the same pointer.
+procedure PremultiplyAlpha(pSrc, pDst: PARGB; count: nativeint); overload;
+
// BoxDownSampling: As the name implies, is only intended for image
// down-sampling (ie shrinking images) where it performs a little better
// than other resamplers which tend toward pixelation. Nevertheless, this
@@ -26,6 +30,14 @@ interface
procedure BoxDownSampling(Image: TImage32; scale: double); overload;
procedure BoxDownSampling(Image: TImage32; scaleX, scaleY: double); overload;
procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer); overload;
+procedure BoxDownSampling(Image, TargetImage: TImage32; scale: double); overload;
+procedure BoxDownSampling(Image, TargetImage: TImage32; scaleX, scaleY: double); overload;
+procedure BoxDownSampling(Image, TargetImage: TImage32; newWidth, newHeight: Integer); overload;
+
+procedure NearestNeighborResize(Image: TImage32; newWidth, newHeight: Integer); overload;
+procedure NearestNeighborResize(Image, TargetImage: TImage32; newWidth, newHeight: Integer); overload;
+procedure ResamplerResize(Image: TImage32; newWidth, newHeight: Integer); overload;
+procedure ResamplerResize(Image, TargetImage: TImage32; newWidth, newHeight: Integer); overload;
// The following general purpose resamplers are registered below:
// function NearestResampler(img: TImage32; x, y: double): TColor32;
@@ -63,7 +75,7 @@ function BilinearResample(img: TImage32; x, y: double): TColor32;
var
iw, ih: integer;
xx, yy, xR, yB: integer;
- weight: Cardinal;
+ weight: integer;
pixels: TArrayOfColor32;
weightedColor: TWeightedColor;
xf, yf: double;
@@ -167,7 +179,7 @@ function WeightedBilinearResample(img: TImage32; x, y: double): TColor32;
var
iw, ih: integer;
xx, yy, xR, yB: integer;
- weight: Cardinal;
+ weight: integer;
pixels: TArrayOfColor32;
weightedColor: TWeightedColor;
xf, yf: double;
@@ -374,7 +386,7 @@ function CubicInterpolate(aclr: PColor32;
// let m2 = slope at pixel_c (using slope of pixel_d - pixel_b)
// then t(0) = aa(0^3) + bb(0^2) + cc(0) + dd = dd
// then t(1) = aa(1^3) + bb(1^2) + cc(1) + dd = aa + bb + cc + dd
- // differentiating parametic equation at t'(0) and t'(1) ...
+ // differentiating parametric equation at t'(0) and t'(1) ...
// t'(0) = m0 = 3*aa(0^2) + 2*bb(0) + cc = cc
// t'(1) = m1 = 3*aa(1^2) + 2*bb(1) + cc = 3*aa + 2*bb + cc
// t(0) = dd ::EQ1
@@ -509,6 +521,109 @@ function BicubicResample(img: TImage32; x, y: double): TColor32;
Result := CubicInterpolate(@c[0], yFrac, bceY);
end;
+//------------------------------------------------------------------------------
+//------------------------------------------------------------------------------
+
+{$RANGECHECKS OFF} // negative index usage for Delphi 7-2007
+procedure PremultiplyAlpha(pSrc, pDst: PARGB; count: nativeint);
+var
+ a: byte;
+ tab: PByteArray;
+ c: TColor32;
+ s, d: PColor32Array;
+begin
+ if count = 0 then exit;
+
+ // Use negative index trick
+ inc(pSrc, count);
+ inc(pDst, count);
+ count := -count;
+
+ // This function is optimized with the assumption that if a pixel has a certain
+ // alpha channel, then the probability that the following pixels have the same
+ // alpha channel, is very high.
+
+ c := PColor32Array(pSrc)[count];
+ a := c shr 24;
+ while True do
+ begin
+ case a of
+ 0: // Special handling for 0 => color becomes black
+ begin
+ // Win32: Load stack variable into CPU register
+ s := PColor32Array(pSrc);
+ d := PColor32Array(pDst);
+ while True do
+ begin
+ d[count] := 0;
+ inc(count);
+ if count = 0 then exit;
+ c := s[count];
+ a := c shr 24;
+ if a <> 0 then break;
+ end;
+ end;
+
+ 255: // Special handling for 255 => no color change
+ begin
+ // Win32: Load stack variable into CPU register
+ s := PColor32Array(pSrc);
+ d := PColor32Array(pDst);
+ if s = d then // if source=dest, we can skip writing to d
+ begin
+ while True do
+ begin
+ //d[count] := c; // skip the write
+ inc(count);
+ if count = 0 then exit;
+ c := s[count];
+ a := c shr 24;
+ if a <> 255 then break;
+ end;
+ end
+ else
+ begin
+ while True do
+ begin
+ d[count] := c;
+ inc(count);
+ if count = 0 then exit;
+ c := s[count];
+ a := c shr 24;
+ if a <> 255 then break;
+ end;
+ end;
+ end;
+
+ else
+ // Premultiply the alpha channel
+
+ // Win32: Load stack variable into CPU register
+ s := PColor32Array(pSrc);
+ // Win32: This line "breaks" Delphi's register allocator
+ //d := PColor32Array(pDst);
+ while True do
+ begin
+ tab := @MulTable[a];
+ c := (c and $FF000000) or
+ (tab[Byte(c shr 16)] shl 16) or
+ (tab[Byte(c shr 8)] shl 8) or
+ (tab[Byte(c )] );
+ //d[count] := c;
+ PColor32Array(pDst)[count] := c;
+ inc(count);
+ if count = 0 then exit;
+ c := s[count];
+ a := c shr 24;
+ if (a = 0) or (a = 255) then break;
+ end;
+ end;
+ end;
+end;
+{$IFDEF RANGECHECKS_ENABLED}
+{$RANGECHECKS ON}
+{$ENDIF RANGECHECKS_ENABLED}
+
//------------------------------------------------------------------------------
// BoxDownSampling and related functions
//------------------------------------------------------------------------------
@@ -579,33 +694,51 @@ function GetWeightedColor(const srcBits: TArrayOfColor32;
procedure BoxDownSampling(Image: TImage32; scaleX, scaleY: double);
begin
- BoxDownSampling(Image,
+ BoxDownSampling(Image, Image, scaleX, scaleY);
+end;
+//------------------------------------------------------------------------------
+
+procedure BoxDownSampling(Image: TImage32; scale: double);
+begin
+ BoxDownSampling(Image, Image, scale);
+end;
+//------------------------------------------------------------------------------
+
+procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer);
+begin
+ BoxDownSampling(Image, Image, newWidth, newHeight);
+end;
+//------------------------------------------------------------------------------
+
+procedure BoxDownSampling(Image, TargetImage: TImage32; scaleX, scaleY: double);
+begin
+ BoxDownSampling(Image, TargetImage,
Max(1, Integer(Round(Image.Width * scaleX))),
Max(1, Integer(Round(Image.Height * scaleY))));
end;
//------------------------------------------------------------------------------
-procedure BoxDownSampling(Image: TImage32; scale: double);
+procedure BoxDownSampling(Image, TargetImage: TImage32; scale: double);
begin
- BoxDownSampling(Image,
+ BoxDownSampling(Image, TargetImage,
Max(1, Integer(Round(Image.Width * scale))),
Max(1, Integer(Round(Image.Height * scale))));
end;
//------------------------------------------------------------------------------
-procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer);
+procedure BoxDownSampling(Image, TargetImage: TImage32; newWidth, newHeight: Integer);
var
x,y, x256,y256,xx256,yy256: Integer;
sx,sy: double;
tmp: TArrayOfColor32;
pc: PColor32;
- scaledX: array of Integer;
+ scaledX: TArrayOfInteger;
begin
sx := Image.Width/newWidth * 256;
sy := Image.Height/newHeight * 256;
- SetLength(tmp, newWidth * newHeight);
+ NewColor32Array(tmp, newWidth * newHeight, True);
- SetLength(scaledX, newWidth +1); //+1 for fractional overrun
+ NewIntegerArray(scaledX, newWidth, True);
for x := 0 to newWidth -1 do
scaledX[x] := Round((x+1) * sx);
@@ -626,11 +759,75 @@ procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer);
y256 := yy256;
end;
- Image.BeginUpdate;
- Image.SetSize(newWidth, newHeight);
- Move(tmp[0], Image.Pixels[0], newWidth * newHeight * SizeOf(TColor32));
- Image.EndUpdate;
+ TargetImage.AssignPixelArray(tmp, newWidth, newHeight);
+end;
+//------------------------------------------------------------------------------
+
+procedure NearestNeighborResize(Image: TImage32; newWidth, newHeight: Integer);
+begin
+ NearestNeighborResize(Image, Image, newWidth, newHeight);
+end;
+//------------------------------------------------------------------------------
+
+procedure NearestNeighborResize(Image, TargetImage: TImage32; newWidth, newHeight: Integer);
+var
+ x, y, offset: Integer;
+ scaledXi, scaledYiOffset: TArrayOfInteger;
+ tmp: TArrayOfColor32;
+ pc: PColor32;
+ pixels: TArrayOfColor32;
+begin
+ //this NearestNeighbor code is slightly more efficient than
+ //the more general purpose one in Img32.Resamplers
+
+ if (newWidth = Image.Width) and (newHeight = Image.Height) then
+ begin
+ if TargetImage <> Image then TargetImage.Assign(Image);
+ Exit;
+ end;
+ NewColor32Array(tmp, newWidth * newHeight, True);
+
+ //get scaled X & Y values once only (storing them in lookup arrays) ...
+ NewIntegerArray(scaledXi, newWidth, True);
+ for x := 0 to newWidth -1 do
+ scaledXi[x] := (x * Image.Width) div newWidth;
+ NewIntegerArray(scaledYiOffset, newHeight, True);
+ SetLength(scaledYiOffset, newHeight);
+ for y := 0 to newHeight -1 do
+ //scaledYiOffset[y] := Round(y * Image.Height / newHeight) * Image.Width;
+ scaledYiOffset[y] := ((y * Image.Height) div newHeight) * Image.Width;
+
+ pc := @tmp[0];
+ pixels := Image.Pixels;
+ for y := 0 to newHeight - 1 do
+ begin
+ offset := scaledYiOffset[y];
+ for x := 0 to newWidth - 1 do
+ begin
+ pc^ := pixels[scaledXi[x] + offset];
+ inc(pc);
+ end;
+ end;
+
+ TargetImage.AssignPixelArray(tmp, newWidth, newHeight);
+end;
+//------------------------------------------------------------------------------
+
+procedure ResamplerResize(Image: TImage32; newWidth, newHeight: Integer);
+begin
+ ResamplerResize(Image, Image, newWidth, newHeight);
end;
+//------------------------------------------------------------------------------
+
+procedure ResamplerResize(Image, TargetImage: TImage32; newWidth, newHeight: Integer);
+var
+ mat: TMatrixD;
+begin
+ mat := IdentityMatrix;
+ MatrixScale(mat, newWidth/Image.Width, newHeight/Image.Height);
+ AffineTransformImage(Image, TargetImage, mat);
+end;
+
//------------------------------------------------------------------------------
//------------------------------------------------------------------------------
diff --git a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas
index afe6b31..520c7ac 100644
--- a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas
+++ b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas
@@ -2,16 +2,16 @@
(*******************************************************************************
* Author : Angus Johnson *
-* Version : 4.4 *
-* Date : 13 March 2024 *
-* Website : http://www.angusj.com *
-* Copyright : Angus Johnson 2019-2024 *
+* Version : 4.7 *
+* Date : 12 January 2025 *
+* Website : https://www.angusj.com *
+* Copyright : Angus Johnson 2019-2025 *
* *
* Purpose : Essential structures and functions to read SVG files *
* *
* License : Use, modification & distribution is subject to *
* Boost Software License Ver 1 *
-* http://www.boost.org/LICENSE_1_0.txt *
+* https://www.boost.org/LICENSE_1_0.txt *
*******************************************************************************)
interface
@@ -19,7 +19,7 @@ interface
{$I Img32.inc}
uses
- SysUtils, Classes, Types, Math,
+ SysUtils, Classes, Types, Math, StrUtils,
{$IFDEF XPLAT_GENERICS} Generics.Collections, Generics.Defaults,{$ENDIF}
Img32, Img32.Vector, Img32.Text, Img32.Transform;
@@ -76,6 +76,7 @@ interface
procedure Init;
function GetRectD(const relSize: TRectD; assumeRelValBelow: Double): TRectD; overload;
function GetRectD(relSize: double; assumeRelValBelow: Double): TRectD; overload;
+ function GetRectD(relSizeX, relSizeY: double; assumeRelValBelow: Double): TRectD; overload;
function GetRectWH(const relSize: TRectD; assumeRelValBelow: Double): TRectWH;
function IsValid: Boolean;
function IsEmpty: Boolean;
@@ -94,36 +95,49 @@ interface
TSvgItalicSyle = (sfsUndefined, sfsNone, sfsItalic);
TFontDecoration = (fdUndefined, fdNone, fdUnderline, fdStrikeThrough);
TSvgTextAlign = (staUndefined, staLeft, staCenter, staRight, staJustify);
+ TSpacesInText = (sitUndefined, sitIgnore, sitPreserve);
+
+ UTF8Strings = array of UTF8String;
TSVGFontInfo = record
- family : TTtfFontFamily;
- size : double;
- spacing : double;
- textLength : double;
- italic : TSvgItalicSyle;
- weight : Integer;
- align : TSvgTextAlign;
- decoration : TFontDecoration;
- baseShift : TValue;
+ family : TFontFamily;
+ familyNames : UTF8Strings;
+ size : double;
+ spacing : double;
+ spacesInText : TSpacesInText;
+ textLength : double;
+ italic : TSvgItalicSyle;
+ weight : Integer;
+ align : TSvgTextAlign;
+ decoration : TFontDecoration;
+ baseShift : TValue;
end;
//////////////////////////////////////////////////////////////////////
- // TClassStylesList: custom TStringList that stores ansistring objects
+ // TClassStylesList: Map that stores CSS selectors with their styles
//////////////////////////////////////////////////////////////////////
- PAnsStringiRec = ^TAnsiStringRec; //used internally by TClassStylesList
- TAnsiStringRec = record
- ansi : UTF8String;
+ PClassStyleListItem = ^TClassStyleListItem;
+ TClassStyleListItem = record //used internally by TClassStylesList
+ Hash : Cardinal;
+ Next : Integer;
+ Name : UTF8String;
+ Style : UTF8String;
end;
TClassStylesList = class
private
- fList : TStringList;
+ FNameHash: Cardinal;
+ FItems: array of TClassStyleListItem;
+ FBuckets: TArrayOfInteger;
+ FCount: Integer;
+ FMod: Cardinal;
+ procedure Grow(NewCapacity: Integer = -1);
+ function FindItemIndex(const Name: UTF8String): Integer;
public
- constructor Create;
- destructor Destroy; override;
- function AddAppendStyle(const classname: string; const ansi: UTF8String): integer;
- function GetStyle(const classname: UTF8String): UTF8String;
+ procedure Preallocate(AdditionalItemCount: Integer);
+ procedure AddAppendStyle(const Name, Style: UTF8String);
+ function GetStyle(const Name: UTF8String): UTF8String;
procedure Clear;
end;
@@ -165,8 +179,9 @@ TXmlEl = class //base element class
procedure Clear; virtual;
function ParseHeader(var c: PUTF8Char; endC: PUTF8Char): Boolean; virtual;
function ParseContent(var c: PUTF8Char; endC: PUTF8Char): Boolean; virtual;
- function ParseAttribName(var c: PUTF8Char; endC: PUTF8Char; attrib: PSvgAttrib): Boolean;
- function ParseAttribValue(var c: PUTF8Char; endC: PUTF8Char; attrib: PSvgAttrib): Boolean;
+ class function ParseAttribName(c, endC: PUTF8Char; attrib: PSvgAttrib): PUTF8Char; {$IFDEF CLASS_STATIC}static;{$ENDIF}
+ class function ParseAttribValue(c, endC: PUTF8Char; attrib: PSvgAttrib): PUTF8Char; {$IFDEF CLASS_STATIC}static;{$ENDIF}
+ class function ParseAttribNameAndValue(c, endC: PUTF8Char; attrib: PSvgAttrib): PUTF8Char; {$IFDEF CLASS_STATIC}static;{$ENDIF}
function ParseAttributes(var c: PUTF8Char; endC: PUTF8Char): Boolean; virtual;
procedure ParseStyleAttribute(const style: UTF8String);
property Attrib[index: integer]: PSvgAttrib read GetAttrib;
@@ -175,13 +190,13 @@ TXmlEl = class //base element class
TDocTypeEl = class(TXmlEl)
private
- procedure SkipWord(var c, endC: PUTF8Char);
+ function SkipWord(c, endC: PUTF8Char): PUTF8Char;
function ParseEntities(var c, endC: PUTF8Char): Boolean;
public
function ParseAttributes(var c: PUTF8Char; endC: PUTF8Char): Boolean; override;
end;
- TSvgTreeEl = class(TXmlEl)
+ TSvgXmlEl = class(TXmlEl)
public
constructor Create(owner: TSvgParser); override;
procedure Clear; override;
@@ -193,10 +208,10 @@ TSvgParser = class
svgStream : TMemoryStream;
procedure ParseUtf8Stream;
public
- classStyles :TClassStylesList;
+ classStyles : TClassStylesList;
xmlHeader : TXmlEl;
docType : TDocTypeEl;
- svgTree : TSvgTreeEl;
+ svgTree : TSvgXmlEl;
constructor Create;
destructor Destroy; override;
procedure Clear;
@@ -213,22 +228,37 @@ TSvgParser = class
//general parsing functions //////////////////////////////////////////
function ParseNextWord(var c: PUTF8Char; endC: PUTF8Char;
out word: UTF8String): Boolean;
- function ParseNextWordEx(var c: PUTF8Char; endC: PUTF8Char;
- out word: UTF8String): Boolean;
+ function ParseNextWordHash(var c: PUTF8Char; endC: PUTF8Char;
+ out hash: cardinal): Boolean; overload;
+ function ParseNextWordHash(c, endC: PUTF8Char): cardinal; overload;
+ function ParseNextWordExHash(var c: PUTF8Char; endC: PUTF8Char;
+ out hash: cardinal): Boolean;
function ParseNextNum(var c: PUTF8Char; endC: PUTF8Char;
skipComma: Boolean; out val: double): Boolean;
function ParseNextNumEx(var c: PUTF8Char; endC: PUTF8Char; skipComma: Boolean;
out val: double; out unitType: TUnitType): Boolean;
- function GetHash(const name: UTF8String): cardinal;
+ function GetHash(c: PUTF8Char; len: nativeint): cardinal; overload;
+ function GetHash(const name: UTF8String): cardinal; overload; {$IFDEF INLINE} inline; {$ENDIF}
function GetHashCaseSensitive(name: PUTF8Char; nameLen: integer): cardinal;
function ExtractRef(const href: UTF8String): UTF8String;
function IsNumPending(var c: PUTF8Char;
endC: PUTF8Char; ignoreComma: Boolean): Boolean;
function UTF8StringToColor32(const value: UTF8String; var color: TColor32): Boolean;
- function MakeDashArray(const dblArray: TArrayOfDouble; scale: double): TArrayOfInteger;
+ function ScaleDashArray(const dblArray: TArrayOfDouble; scale: double): TArrayOfDouble;
function Match(c: PUTF8Char; const compare: UTF8String): Boolean; overload;
function Match(const compare1, compare2: UTF8String): Boolean; overload;
- function ToUTF8String(var c: PUTF8Char; endC: PUTF8Char): UTF8String;
+ function PosEx(const subStr: utf8String; const text: Utf8String; startIdx: integer = 1): integer;
+ procedure ToUTF8String(c, endC: PUTF8Char; var S: UTF8String;
+ spacesInText: TSpacesInText = sitUndefined);
+ function TrimMultiSpacesUtf8(const text: Utf8String): Utf8String;
+ function TrimMultiSpacesUnicode(const text: UnicodeString): UnicodeString;
+ function ConvertNewlines(const s: UTF8String): UTF8String; overload;
+ function ConvertNewlines(const s: UnicodeString): UnicodeString; overload;
+ function StripNewlines(const s: UTF8String): UTF8String; overload;
+ function StripNewlines(const s: UnicodeString): UnicodeString; overload;
+ procedure ToAsciiLowerUTF8String(c, endC: PUTF8Char; var S: UTF8String);
+ procedure ToTrimmedUTF8String(c, endC: PUTF8Char; var S: UTF8String);
+ function IsSameUTF8String(const S1, S2: UTF8String): Boolean;
//special parsing functions //////////////////////////////////////////
procedure ParseStyleElementContent(const value: UTF8String; stylesList: TClassStylesList);
@@ -241,7 +271,11 @@ TSvgParser = class
function ClampRange(val, min, max: double): double;
function SkipBlanks(var c: PUTF8Char; endC: PUTF8Char): Boolean;
- function SkipBlanksAndComma(var current: PUTF8Char; currentEnd: PUTF8Char): Boolean;
+ function SkipBlanksEx(c: PUTF8Char; endC: PUTF8Char): PUTF8Char; {$IFDEF INLINE} inline; {$ENDIF}
+ function SkipBlanksAndComma(c, endC: PUTF8Char): PUTF8Char; {$IFDEF INLINE} inline; {$ENDIF}
+
+ function GetCommaSeparatedArray(const str: UTF8String): UTF8Strings;
+ function TrimQuotes(const str: UTF8String): UTF8String;
procedure ConvertUnicodeToUtf8(memStream: TMemoryStream);
@@ -252,9 +286,9 @@ TSvgParser = class
type
TSetOfUTF8Char = set of UTF8Char;
- UTF8Strings = array of UTF8String;
-function CharInSet(chr: UTF8Char; chrs: TSetOfUTF8Char): Boolean;
+function CharInSet(chr: UTF8Char; const chrs: TSetOfUTF8Char): Boolean;
+function DecodeUtf8ToUnicode(const utf8: UTF8String): UnicodeString;
const
clInvalid = $00010001;
@@ -263,27 +297,52 @@ function CharInSet(chr: UTF8Char; chrs: TSetOfUTF8Char): Boolean;
quote = '''';
dquote = '"';
space = #32;
+ comma = ',';
SvgDecimalSeparator = '.'; //do not localize
{$I Img32.SVG.HashConsts.inc}
var
- LowerCaseTable : array[#0..#255] of UTF8Char;
- ColorConstList : TStringList;
+ LowerCaseTable : array[#0..#$FF] of UTF8Char;
implementation
+//------------------------------------------------------------------------------
+// Color Constant HashMap
+//------------------------------------------------------------------------------
type
+ PColorConst = ^TColorConst;
TColorConst = record
- ColorName : string;
- ColorValue: Cardinal;
+ ColorName : UTF8String;
+ ColorValue: TColor32;
end;
- TColorObj = class
- cc: TColorConst;
+ PPColorConstMapItem = ^PColorConstMapItem;
+ PColorConstMapItem = ^TColorConstMapItem;
+ TColorConstMapItem = record
+ Hash: Cardinal;
+ Next: PColorConstMapItem;
+ Data: PColorConst;
end;
+ PColorConstMapItemArray = ^TColorConstMapItemArray;
+ TColorConstMapItemArray = array[0..MaxInt div SizeOf(TColorConstMapItem) - 1] of TColorConstMapItem;
+
+ TColorConstList = class(TObject)
+ private
+ FItems: array of TColorConstMapItem;
+ FBuckets: array of PColorConstMapItem;
+ FCount: Integer;
+ FMod: Cardinal;
+ public
+ constructor Create(Colors: PColorConst; Count: Integer);
+ function GetColorValue(const ColorName: UTF8String; var Color: TColor32): Boolean;
+ end;
+
+var
+ ColorConstList : TColorConstList;
+
const
buffSize = 8;
@@ -371,6 +430,24 @@ function Base64Decode(const str: PAnsiChar; len: integer; memStream: TMemoryStre
// Miscellaneous functions ...
//------------------------------------------------------------------------------
+function NewSvgAttrib(): PSvgAttrib; {$IFDEF INLINE} inline; {$ENDIF}
+begin
+ // New(Result) uses RTTI to initialize the UTF8String fields to nil.
+ // By allocating zero'ed memory we can achieve that much faster.
+ Result := AllocMem(SizeOf(TSvgAttrib));
+end;
+//------------------------------------------------------------------------------
+
+procedure DisposeSvgAttrib(attrib: PSvgAttrib); {$IFDEF INLINE} inline; {$ENDIF}
+begin
+ // Dispose(Result) uses RTTI to set the UTF8String fields to nil.
+ // By clearing them outself we can achieve that much faster.
+ attrib.name := '';
+ attrib.value := '';
+ FreeMem(attrib);
+end;
+//------------------------------------------------------------------------------
+
function GetScale(src, dst: double): double;
begin
Result := dst / src;
@@ -389,6 +466,7 @@ function GetScaleForBestFit(srcW, srcH, dstW, dstH: double): double;
Result := 1 else
Result := sx;
end;
+//------------------------------------------------------------------------------
function ClampRange(val, min, max: double): double;
{$IFDEF INLINE} inline; {$ENDIF}
@@ -399,7 +477,96 @@ function ClampRange(val, min, max: double): double;
end;
//------------------------------------------------------------------------------
-function CharInSet(chr: UTF8Char; chrs: TSetOfUTF8Char): Boolean;
+function IsSameAsciiUTF8String(const S1, S2: UTF8String): Boolean;
+var
+ Len: Integer;
+ I: Integer;
+ Ch1, Ch2: UTF8Char;
+begin
+ Len := Length(S1);
+ Result := Len = Length(S2);
+ if Result then
+ begin
+ Result := False;
+ I := 1;
+ while True do
+ begin
+ if I > Len then
+ Break;
+
+ Ch1 := S1[I];
+ Ch2 := S2[I];
+ if Ch1 = Ch2 then
+ begin
+ Inc(I);
+ Continue;
+ end;
+
+ case Ch1 of
+ 'A'..'Z', 'a'..'z':
+ ch1 := UTF8Char(Ord(ch1) xor $20); // toggle upper/lower
+ end;
+
+ if Ch1 <> Ch2 then
+ Exit;
+ Inc(I);
+ end;
+ Result := True;
+ end;
+end;
+//------------------------------------------------------------------------------
+
+function IsSameUTF8StringSlow(const S1, S2: UTF8String): Boolean;
+begin
+ Result := AnsiSameText(string(S1), string(S2));
+end;
+//------------------------------------------------------------------------------
+
+function IsSameUTF8String(const S1, S2: UTF8String): Boolean;
+var
+ Len: Integer;
+ I: Integer;
+ Ch1, Ch2: UTF8Char;
+begin
+ Len := Length(S1);
+ Result := Len = Length(S2);
+ if Result then
+ begin
+ Result := False;
+ I := 1;
+ Ch1 := #0;
+ Ch2 := #0;
+ while True do
+ begin
+ if I > Len then
+ Break;
+
+ Ch1 := S1[I];
+ Ch2 := S2[I];
+ if Ch1 = Ch2 then
+ begin
+ Inc(I);
+ Continue;
+ end;
+
+ case Ch1 of
+ 'A'..'Z', 'a'..'z':
+ ch1 := UTF8Char(Ord(ch1) xor $20); // toggle upper/lower
+ end;
+
+ if Ch1 <> Ch2 then
+ Break;
+ Inc(I);
+ end;
+ if Ch1 = Ch2 then
+ Result := True
+ else if (Ord(Ch1) or Ord(Ch2)) and $80 <> 0 then // we found non-matching, non-ASCII characters
+ Result := IsSameUTF8StringSlow(S1, S2);
+ end;
+end;
+//------------------------------------------------------------------------------
+
+function CharInSet(chr: UTF8Char; const chrs: TSetOfUTF8Char): Boolean;
begin
Result := chr in chrs;
end;
@@ -412,8 +579,7 @@ function Match(c: PUTF8Char; const compare: UTF8String): Boolean;
Result := false;
for i := 1 to Length(compare) do
begin
- if LowerCaseTable[c^] <> compare[i] then Exit;
- inc(c);
+ if LowerCaseTable[c[i - 1]] <> compare[i] then Exit;
end;
Result := true;
end;
@@ -430,8 +596,7 @@ function Match(const compare1, compare2: UTF8String): Boolean;
c1 := @compare1[1]; c2 := @compare2[1];
for i := 1 to len do
begin
- if LowerCaseTable[c1^] <> LowerCaseTable[c2^] then Exit;
- inc(c1); inc(c2);
+ if LowerCaseTable[c1[i - 1]] <> LowerCaseTable[c2[i - 1]] then Exit;
end;
Result := true;
end;
@@ -444,23 +609,70 @@ function Split(const str: UTF8String): UTF8Strings;
spcCnt := 0;
i := 1;
len := Length(str);
- while (len > 0) and (str[len] <= #32) do dec(len);
- while (i <= len) and (str[i] <= #32) do inc(i);
+ while (len > 0) and (str[len] <= space) do dec(len);
+ while (i <= len) and (str[i] <= space) do inc(i);
for j := i + 1 to len do
- if (str[j] <= #32) and (str[j -1] > #32) then inc(spcCnt);
+ if (str[j] <= space) and (str[j -1] > space) then inc(spcCnt);
SetLength(Result, spcCnt +1);
for k := 0 to spcCnt do
begin
j := i;
- while (j <= len) and (str[j] > #32) do inc(j);
+ while (j <= len) and (str[j] > space) do inc(j);
SetLength(Result[k], j -i);
- Move(str[i], Result[k][1], j -i);
- while (j <= len) and (str[j] <= #32) do inc(j);
+ if j > i then
+ Move(str[i], Result[k][1], j -i);
+ while (j <= len) and (str[j] <= space) do inc(j);
i := j;
end;
end;
//------------------------------------------------------------------------------
+function TrimQuotes(const str: UTF8String): UTF8String;
+var
+ i, len: integer;
+ savedQuote: UTF8Char;
+begin
+ len := Length(str);
+ i := 1;
+ while (i < len) and (str[i] <= space) do inc(i);
+ if (i < len) and (str[i] in [quote, dquote]) then
+ begin
+ savedQuote := str[i];
+ inc(i);
+ while (len > i) and (str[len] <= space) do dec(len);
+ if (len = i) or (str[len] <> savedQuote) then
+ Result := str else // oops!
+ Result := Copy(str, i, len - i);
+ end
+ else
+ Result := str
+end;
+//------------------------------------------------------------------------------
+
+function GetCommaSeparatedArray(const str: UTF8String): UTF8Strings;
+var
+ i,j,k, cnt, len: integer;
+begin
+ // precondition: commas CANNOT be embedded
+ len := Length(str);
+ cnt := 1;
+ for i := 1 to len do
+ if (str[i] = comma) then inc(cnt);
+ SetLength(Result, cnt);
+ j := 0;
+ k := 1;
+ for i := 1 to len do
+ begin
+ if (str[i] <> comma) then Continue;
+ Result[j] := TrimQuotes(Copy(str, k, i-k));
+ inc(j);
+ k := i + 1;
+ end;
+ if len >= k then
+ Result[j] := TrimQuotes(Copy(str, k, len-k +1));
+end;
+//------------------------------------------------------------------------------
+
function GetXmlEncoding(memory: Pointer; len: integer): TSvgEncoding;
var
p, p1: PUTF8Char;
@@ -483,141 +695,252 @@ function GetXmlEncoding(memory: Pointer; len: integer): TSvgEncoding;
//------------------------------------------------------------------------------
function SkipBlanks(var c: PUTF8Char; endC: PUTF8Char): Boolean;
+var
+ cc: PUTF8Char;
+begin
+ cc := c;
+ if (cc < endC) and (cc^ <= space) then
+ begin
+ inc(cc);
+ while (cc < endC) and (cc^ <= space) do inc(cc);
+ c := cc;
+ end;
+ Result := (cc < endC);
+end;
+//------------------------------------------------------------------------------
+
+function SkipBlanksEx(c: PUTF8Char; endC: PUTF8Char): PUTF8Char;
begin
while (c < endC) and (c^ <= space) do inc(c);
- Result := (c < endC);
+ Result := c;
end;
//------------------------------------------------------------------------------
-function SkipBlanksAndComma(var current: PUTF8Char; currentEnd: PUTF8Char): Boolean;
+function SkipBlanksAndComma(c, endC: PUTF8Char): PUTF8Char;
begin
- Result := SkipBlanks(current, currentEnd);
- if not Result or (current^ <> ',') then Exit;
- inc(current);
- Result := SkipBlanks(current, currentEnd);
+ Result := SkipBlanksEx(c, endC);
+ if (Result >= endC) or (Result^ <> ',') then Exit;
+ Result := SkipBlanksEx(Result + 1, endC);
end;
//------------------------------------------------------------------------------
-function SkipStyleBlanks(var c: PUTF8Char; endC: PUTF8Char): Boolean;
+function SkipStyleBlanks(c, endC: PUTF8Char): PUTF8Char;
var
inComment: Boolean;
+ ch: UTF8Char;
begin
//style content may include multi-line comment blocks
inComment := false;
while (c < endC) do
begin
+ ch := c^;
if inComment then
begin
- if (c^ = '*') and ((c +1)^ = '/') then
+ if (ch = '*') and ((c +1)^ = '/') then
begin
inComment := false;
inc(c);
end;
end
- else if (c^ > space) then
+ else if (ch > space) then
begin
- inComment := (c^ = '/') and ((c +1)^ = '*');
+ inComment := (ch = '/') and ((c +1)^ = '*');
if not inComment then break;
+ inc(c);
end;
inc(c);
end;
- Result := (c < endC);
+ Result := c;
+end;
+//------------------------------------------------------------------------------
+
+function IsDigit(c: UTF8Char): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
+begin
+ case c of
+ '0'..'9': Result := True;
+ else Result := False;
+ end;
+end;
+//------------------------------------------------------------------------------
+
+function IsQuoteChar(c: UTF8Char): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
+begin
+ Result := (c = quote) or (c = dquote);
end;
//------------------------------------------------------------------------------
function IsAlpha(c: UTF8Char): Boolean; {$IFDEF INLINE} inline; {$ENDIF}
begin
- Result := CharInSet(c, ['A'..'Z','a'..'z']);
+ case c of
+ 'A'..'Z', 'a'..'z': Result := True;
+ else Result := False;
+ end;
end;
//------------------------------------------------------------------------------
-function ParseStyleNameLen(var c: PUTF8Char; endC: PUTF8Char): integer;
+function ParseStyleNameLen(c, endC: PUTF8Char): PUTF8Char;
var
c2: PUTF8Char;
-const
- validNonFirstChars = ['0'..'9','A'..'Z','a'..'z','-'];
begin
- Result := 0;
+ Result := c;
//nb: style names may start with a hyphen
- if (c^ = '-') then
- begin
- if not IsAlpha((c+1)^) then Exit;
- end
- else if not IsAlpha(c^) then Exit;
+ c2 := Result;
+ if (c2^ = '-') then inc(c2);
+ if not IsAlpha(c2^) then Exit;
- c2 := c; inc(c);
- while (c < endC) and CharInSet(c^, validNonFirstChars) do inc(c);
- Result := c - c2;
+ Result := c2 + 1;
+ while Result < endC do
+ begin
+ case Result^ of
+ '0'..'9', 'A'..'Z', 'a'..'z', '-': inc(Result);
+ else break;
+ end;
+ end;
end;
//------------------------------------------------------------------------------
function ParseNextWord(var c: PUTF8Char; endC: PUTF8Char; out word: UTF8String): Boolean;
+var
+ c2, cc: PUTF8Char;
+begin
+ cc := SkipBlanksAndComma(c, endC);
+ if cc >= endC then
+ begin
+ c := cc;
+ Result := False;
+ Exit;
+ end;
+
+ c2 := cc;
+ while cc < endC do
+ begin
+ case cc^ of
+ 'A'..'Z', 'a'..'z': inc(cc);
+ else break;
+ end;
+ end;
+ c := cc;
+ ToUTF8String(c2, cc, word);
+ Result := True;
+end;
+//------------------------------------------------------------------------------
+
+function ParseNextWordHash(var c: PUTF8Char; endC: PUTF8Char; out hash: cardinal): Boolean;
+var
+ c2, cc: PUTF8Char;
+begin
+ cc := SkipBlanksAndComma(c, endC);
+ if cc >= endC then
+ begin
+ c := cc;
+ hash := 0;
+ Result := False;
+ Exit;
+ end;
+
+ c2 := cc;
+ while cc < endC do
+ begin
+ case cc^ of
+ 'A'..'Z', 'a'..'z': inc(cc);
+ else break;
+ end;
+ end;
+ c := cc;
+ hash := GetHash(c2, cc - c2);
+ Result := True;
+end;
+//------------------------------------------------------------------------------
+
+function ParseNextWordHash(c, endC: PUTF8Char): cardinal;
var
c2: PUTF8Char;
begin
- Result := SkipBlanksAndComma(c, endC);
- if not Result then Exit;
+ c := SkipBlanksAndComma(c, endC);
+ if c >= endC then
+ begin
+ Result := 0;
+ Exit;
+ end;
+
c2 := c;
- while (c < endC) and
- (LowerCaseTable[c^] >= 'a') and (LowerCaseTable[c^] <= 'z') do
- inc(c);
- word := ToUTF8String(c2, c);
+ while c < endC do
+ begin
+ case c^ of
+ 'A'..'Z', 'a'..'z': inc(c);
+ else break;
+ end;
+ end;
+ Result := GetHash(c2, c - c2);
end;
//------------------------------------------------------------------------------
-function ParseNextWordEx(var c: PUTF8Char; endC: PUTF8Char;
- out word: UTF8String): Boolean;
+function ParseNextWordExHash(var c: PUTF8Char; endC: PUTF8Char;
+ out hash: cardinal): Boolean;
var
- isQuoted: Boolean;
- c2: PUTF8Char;
+ c2, cc: PUTF8Char;
begin
- Result := SkipBlanksAndComma(c, endC);
- if not Result then Exit;
- isQuoted := (c^) = quote;
- if isQuoted then
+ cc := SkipBlanksAndComma(c, endC);
+ if cc >= endC then
+ begin
+ c := cc;
+ hash := 0;
+ Result := False;
+ Exit;
+ end;
+
+ if cc^ = quote then
begin
inc(c);
- c2 := c;
- while (c < endC) and (c^ <> quote) do inc(c);
- word := ToUTF8String(c2, c);
- inc(c);
+ c2 := cc;
+ while (cc < endC) and (cc^ <> quote) do inc(cc);
+ hash := GetHash(c2, cc - c2);
+ inc(cc);
end else
begin
- Result := CharInSet(LowerCaseTable[c^], ['A'..'Z', 'a'..'z']);
- if not Result then Exit;
- c2 := c;
- inc(c);
- while (c < endC) and
- CharInSet(LowerCaseTable[c^], ['A'..'Z', 'a'..'z', '-', '_']) do inc(c);
- word := ToUTF8String(c2, c);
+ if not IsAlpha(cc^) then
+ begin
+ hash := 0;
+ Result := False;
+ Exit;
+ end;
+ c2 := cc;
+ inc(cc);
+ while cc < endC do
+ case cc^ of
+ 'A'..'Z', 'a'..'z', '-', '_': inc(cc);
+ else break;
+ end;
+ hash := GetHash(c2, cc - c2);
end;
+ c := cc;
+ Result := True;
end;
//------------------------------------------------------------------------------
-function ParseNameLength(var c: PUTF8Char; endC: PUTF8Char): integer; overload;
-var
- c2: PUTF8Char;
-const
- validNonFirstChars = ['0'..'9','A'..'Z','a'..'z','_',':','-'];
+function ParseNameLength(c: PUTF8Char; endC: PUTF8Char): PUTF8Char;
begin
- c2 := c;
inc(c);
- while (c < endC) and CharInSet(c^, validNonFirstChars) do inc(c);
- Result := c - c2;
+ while c < endC do
+ begin
+ case c^ of
+ '0'..'9', 'A'..'Z', 'a'..'z', '_', ':', '-': inc(c);
+ else break;
+ end;
+ end;
+ Result := c;
end;
//------------------------------------------------------------------------------
{$OVERFLOWCHECKS OFF}
-function GetHash(const name: UTF8String): cardinal;
+function GetHash(c: PUTF8Char; len: nativeint): cardinal;
var
i: integer;
- c: PUTF8Char;
begin
//https://en.wikipedia.org/wiki/Jenkins_hash_function
- c := PUTF8Char(name);
Result := 0;
if c = nil then Exit;
- for i := 1 to Length(name) do
+ for i := 1 to len do
begin
Result := (Result + Ord(LowerCaseTable[c^]));
Result := Result + (Result shl 10);
@@ -628,7 +951,16 @@ function GetHash(const name: UTF8String): cardinal;
Result := Result xor (Result shr 11);
Result := Result + (Result shl 15);
end;
-{$OVERFLOWCHECKS ON}
+{$IFDEF OVERFLOWCHECKS_ENABLED}
+ {$OVERFLOWCHECKS ON}
+{$ENDIF}
+//------------------------------------------------------------------------------
+
+function GetHash(const name: UTF8String): cardinal;
+begin
+ // skip function call by directly casting it to Pointer
+ Result := GetHash(PUTF8Char(Pointer(name)), Length(name));
+end;
//------------------------------------------------------------------------------
{$OVERFLOWCHECKS OFF}
@@ -648,231 +980,529 @@ function GetHashCaseSensitive(name: PUTF8Char; nameLen: integer): cardinal;
Result := Result xor (Result shr 11);
Result := Result + (Result shl 15);
end;
-{$OVERFLOWCHECKS ON}
+{$IFDEF OVERFLOWCHECKS_ENABLED}
+ {$OVERFLOWCHECKS ON}
+{$ENDIF}
//------------------------------------------------------------------------------
function ParseNextWordHashed(var c: PUTF8Char; endC: PUTF8Char): cardinal;
var
c2: PUTF8Char;
- name: UTF8String;
+ len: integer;
begin
c2 := c;
- ParseNameLength(c, endC);
- name := ToUTF8String(c2, c);
- if name = '' then Result := 0
- else Result := GetHash(name);
+ c := ParseNameLength(c2, endC);
+ len := c - c2;
+ if len <= 0 then Result := 0
+ else Result := GetHash(c2, len);
+end;
+//------------------------------------------------------------------------------
+
+function ParseExpDigits(c, endC: PUTF8Char; out val: Integer): PUTF8Char; {$IFDEF INLINE} inline; {$ENDIF}
+var
+ v32: Cardinal;
+ Digit: Integer;
+begin
+ Result := c;
+ v32 := 0;
+ while Result < endC do
+ begin
+ Digit := Integer(Ord(Result^)) - Ord('0');
+ if Cardinal(Digit) >= 10 then break;
+ {$IFDEF FPC} // Something Delphi can optimize but FPC can't (yet?)
+ v32 := (v32 shl 3) + (v32 shl 1) + Cardinal(Digit); // Delphi's code is even better than this
+ {$ELSE}
+ v32 := v32 * 10 + Cardinal(Digit);
+ {$ENDIF FPC}
+ inc(Result);
+ end;
+ val := v32;
+end;
+//------------------------------------------------------------------------------
+
+function ParseDigitsToDouble(c, endC: PUTF8Char; out val: double): PUTF8Char;
+var
+ v32: Cardinal;
+ v64: Int64;
+ Digit: Integer;
+ blockEndC: PUTF8Char;
+begin
+ // skip leading zeros
+ while (c < endC) and (c^ = '0') do inc(c);
+
+ // Use Int32 first as it is fast for 64bit and 32bit CPUs
+ Result := c;
+ v32 := 0;
+
+ blockEndC := c + 9; // log10(2^31) = 9.33
+ if blockEndC > endC then
+ blockEndC := endC;
+ while Result < blockEndC do
+ begin
+ Digit := Integer(Ord(Result^)) - Ord('0');
+ if Cardinal(Digit) >= 10 then break;
+ {$IFDEF FPC} // Something Delphi can optimize but FPC can't (yet?)
+ v32 := (v32 shl 3) + (v32 shl 1) + Cardinal(Digit);
+ {$ELSE}
+ v32 := v32 * 10 + Cardinal(Digit);
+ {$ENDIF FPC}
+ inc(Result);
+ end;
+
+ if (Result < endC) and (Result >= blockEndC) then
+ begin
+ v64 := v32;
+
+ blockEndC := c + 18; // log10(2^63) = 18.96
+ if blockEndC > endC then
+ blockEndC := endC;
+ while Result < blockEndC do
+ begin
+ Digit := Integer(Ord(Result^)) - Ord('0');
+ if Cardinal(Digit) >= 10 then break;
+ {$IF (SizeOf(Pointer) = 4) or defined(FPC)} // neither Delphi 32bit nor FPC can optimize this
+ v64 := (v64 shl 3) + (v64 shl 1) + Cardinal(Digit);
+ {$ELSE}
+ v64 := v64 * 10 + Cardinal(Digit);
+ {$IFEND}
+ inc(Result);
+ end;
+
+ val := v64;
+ // Use Double for the remaining digits and loose precision (we are beyond 16 digits anyway)
+ if (Result < endC) and (Result >= blockEndC) then
+ begin
+ while Result < endC do
+ begin
+ Digit := Integer(Ord(Result^)) - Ord('0');
+ if Cardinal(Digit) >= 10 then break;
+ val := val * 10 + Digit;
+ inc(Result);
+ end;
+ end;
+ end
+ else
+ val := v32;
end;
//------------------------------------------------------------------------------
function ParseNextNumEx(var c: PUTF8Char; endC: PUTF8Char; skipComma: Boolean;
out val: double; out unitType: TUnitType): Boolean;
+const
+ Power10: array[0..18] of Double = (
+ 1E0, 1E1, 1E2, 1E3, 1E4, 1E5, 1E6, 1E7, 1E8, 1E9,
+ 1E10, 1E11, 1E12, 1E13, 1E14, 1E15, 1E16, 1E17, 1E18
+ );
+ Power10Reciprocal: array[0..18] of Double = (
+ 1/1E0, 1/1E1, 1/1E2, 1/1E3, 1/1E4, 1/1E5, 1/1E6, 1/1E7, 1/1E8, 1/1E9,
+ 1/1E10, 1/1E11, 1/1E12, 1/1E13, 1/1E14, 1/1E15, 1/1E16, 1/1E17, 1/1E18
+ );
var
- decPos,exp: integer;
+ exp: integer;
isNeg, expIsNeg: Boolean;
- start: PUTF8Char;
+ start, decStart, cc: PUTF8Char;
+ decimals: Double;
begin
Result := false;
unitType := utNumber;
+ cc := c;
+
//skip white space +/- single comma
if skipComma then
begin
- while (c < endC) and (c^ <= space) do inc(c);
- if (c^ = ',') then inc(c);
+ while (cc < endC) and (cc^ <= space) do inc(cc);
+ if (cc^ = ',') then inc(cc);
+ end;
+ while (cc < endC) and (cc^ <= space) do inc(cc);
+ if (cc = endC) then
+ begin
+ c := cc;
+ Exit;
end;
- while (c < endC) and (c^ <= space) do inc(c);
- if (c = endC) then Exit;
- decPos := -1; exp := Invalid; expIsNeg := false;
- isNeg := c^ = '-';
- if isNeg then inc(c);
+ exp := Invalid; expIsNeg := false;
+ isNeg := cc^ = '-';
+ if isNeg then inc(cc);
- val := 0;
- start := c;
- while c < endC do
+ start := cc;
+
+ // Use fast parsing
+ cc := ParseDigitsToDouble(cc, endC, val);
+ if cc < endC then
begin
- if Ord(c^) = Ord(SvgDecimalSeparator) then
+ // Decimals
+ if Ord(cc^) = Ord(SvgDecimalSeparator) then
begin
- if decPos >= 0 then break;
- decPos := 0;
- end
- else if (LowerCaseTable[c^] = 'e') and
- (CharInSet((c+1)^, ['-','0'..'9'])) then
- begin
- if (c +1)^ = '-' then expIsNeg := true;
- inc(c);
- exp := 0;
- end
- else if (c^ < '0') or (c^ > '9') then
- break
- else if IsValid(exp) then
- begin
- exp := exp * 10 + (Ord(c^) - Ord('0'))
- end else
+ inc(cc);
+ decStart := cc;
+ cc := ParseDigitsToDouble(cc, endC, decimals);
+ if cc > decStart then
+ begin
+ if cc - decStart <= 18 then
+ val := val + (decimals * Power10Reciprocal[(cc - decStart)])
+ else
+ val := val + (decimals * Power(10, -(cc - decStart)))
+ end;
+ end;
+
+ // Exponent
+ if (cc < endC) and ((cc^ = 'e') or (cc^ = 'E')) then
begin
- val := val *10 + Ord(c^) - Ord('0');
- if decPos >= 0 then inc(decPos);
+ case (cc+1)^ of
+ '-', '0'..'9':
+ begin
+ inc(cc);
+ if cc^ = '-' then
+ begin
+ expIsNeg := true;
+ inc(cc);
+ end;
+ cc := ParseExpDigits(cc, endC, exp);
+ end;
+ end;
end;
- inc(c);
end;
- Result := c > start;
- if not Result then Exit;
+ Result := cc > start;
+ if not Result then
+ begin
+ c := cc;
+ Exit;
+ end;
- if decPos > 0 then val := val * Power(10, -decPos);
if isNeg then val := -val;
if IsValid(exp) then
begin
- if expIsNeg then
- val := val * Power(10, -exp) else
- val := val * Power(10, exp);
+ if exp <= 18 then
+ begin
+ if expIsNeg then
+ val := val * Power10Reciprocal[exp] else
+ val := val * Power10[exp];
+ end
+ else
+ begin
+ if expIsNeg then
+ val := val * Power(10, -exp) else
+ val := val * Power(10, exp);
+ end;
end;
//https://oreillymedia.github.io/Using_SVG/guide/units.html
- case c^ of
+ case cc^ of
'%':
begin
- inc(c);
+ inc(cc);
unitType := utPercent;
end;
'c': //convert cm to pixels
- if ((c+1)^ = 'm') then
+ if ((cc+1)^ = 'm') then
begin
- inc(c, 2);
+ inc(cc, 2);
unitType := utCm;
end;
'd': //ignore deg
- if ((c+1)^ = 'e') and ((c+2)^ = 'g') then
+ if ((cc+1)^ = 'e') and ((cc+2)^ = 'g') then
begin
- inc(c, 3);
+ inc(cc, 3);
unitType := utDegree;
end;
'e': //convert cm to pixels
- if ((c+1)^ = 'm') then
+ if ((cc+1)^ = 'm') then
begin
- inc(c, 2);
+ inc(cc, 2);
unitType := utEm;
end
- else if ((c+1)^ = 'x') then
+ else if ((cc+1)^ = 'x') then
begin
- inc(c, 2);
+ inc(cc, 2);
unitType := utEx;
end;
'i': //convert inchs to pixels
- if ((c+1)^ = 'n') then
+ if ((cc+1)^ = 'n') then
begin
- inc(c, 2);
+ inc(cc, 2);
unitType := utInch;
end;
'm': //convert mm to pixels
- if ((c+1)^ = 'm') then
+ if ((cc+1)^ = 'm') then
begin
- inc(c, 2);
+ inc(cc, 2);
unitType := utMm;
end;
'p':
- case (c+1)^ of
+ case (cc+1)^ of
'c':
begin
- inc(c, 2);
+ inc(cc, 2);
unitType := utPica;
end;
't':
begin
- inc(c, 2);
+ inc(cc, 2);
unitType := utPt;
end;
'x':
begin
- inc(c, 2);
+ inc(cc, 2);
unitType := utPixel;
end;
end;
'r': //convert radian angles to degrees
- if Match(c, 'rad') then
+ if Match(cc, 'rad') then
begin
- inc(c, 3);
+ inc(cc, 3);
unitType := utRadian;
end;
end;
+ c := cc;
+end;
+//------------------------------------------------------------------------------
+
+function ParseNextNum(var c: PUTF8Char; endC: PUTF8Char;
+ skipComma: Boolean; out val: double): Boolean;
+var
+ tmp: TValue;
+begin
+ tmp.Init;
+ Result := ParseNextNumEx(c, endC, skipComma, tmp.rawVal, tmp.unitType);
+ val := tmp.GetValue(1, 1);
+end;
+//------------------------------------------------------------------------------
+
+function ExtractRef(const href: UTF8String): UTF8String; {$IFDEF INLINE} inline; {$ENDIF}
+var
+ c, c2, endC: PUTF8Char;
+begin
+ c := PUTF8Char(href);
+ endC := c + Length(href);
+ if Match(c, 'url(') then
+ begin
+ inc(c, 4);
+ dec(endC); // avoid trailing ')'
+ end;
+ if c^ = '#' then inc(c);
+ c2 := c;
+ while (c < endC) and (c^ <> ')') do inc(c);
+ ToUTF8String(c2, c, Result);
+end;
+//------------------------------------------------------------------------------
+
+function ParseNextChar(var c: PUTF8Char; endC: PUTF8Char): UTF8Char;
+var
+ cc: PUTF8Char;
+begin
+ cc := SkipBlanksEx(c, endC);
+ if cc >= endC then
+ Result := #0
+ else
+ begin
+ Result := cc^;
+ c := cc + 1;
+ end;
+end;
+//------------------------------------------------------------------------------
+
+procedure ToTrimmedUTF8String(c, endC: PUTF8Char; var S: UTF8String);
+var
+ len: integer;
+begin
+ // trim left
+ while (c < endC) and (c^ <= space) do Inc(c);
+ // trim right
+ while (endC > c) and (endC[-1] <= space) do Dec(endC);
+
+ len := endC - c;
+ SetLength(S, len);
+ if len = 0 then Exit;
+ Move(c^, PUTF8Char(S)^, len * SizeOf(UTF8Char));
+end;
+//------------------------------------------------------------------------------
+
+function PosEx(const subStr: UTF8String; const text: Utf8String; startIdx: integer): integer;
+var
+ i, maxI, len, subStrLen: integer;
+begin
+ len := Length(Text);
+ subStrLen := Length(subStr);
+ maxI := len - subStrLen +1;
+ for i := Max(1, startIdx) to maxI do
+ begin
+ if (text[i] <> subStr[1]) or
+ not CompareMem(@text[i], @subStr[1], subStrLen) then Continue;
+ Result := i;
+ Exit;
+ end;
+ Result := 0;
end;
//------------------------------------------------------------------------------
-function ParseNextNum(var c: PUTF8Char; endC: PUTF8Char;
- skipComma: Boolean; out val: double): Boolean;
+function ReversePosEx(utf8: utf8Char;
+ const text: Utf8String; startIdx: integer): integer; overload;
+{$IFDEF INLINE} inline; {$ENDIF}
+begin
+ Result := Max(0, Min(Length(text), startidx));
+ while (Result > 0) and (text[Result] <> utf8) do Dec(Result);
+end;
+//------------------------------------------------------------------------------
+
+function TrimMultiSpacesUtf8(const text: Utf8String): Utf8String;
var
- tmp: TValue;
+ i, len: integer;
begin
- tmp.Init;
- Result := ParseNextNumEx(c, endC, skipComma, tmp.rawVal, tmp.unitType);
- val := tmp.GetValue(1, 1);
+ Result := text;
+ len := Length(Result);
+ for i := 1 to len do
+ if Result[i] < #32 then Result[i] := #32;
+ i := ReversePosEx(space, Result, len);
+ while i > 1 do
+ begin
+ Dec(i);
+ while (i > 0) and (Result[i] = space) do
+ begin
+ Delete(Result, i, 1);
+ Dec(i);
+ end;
+ i := ReversePosEx(space, Result, i);
+ end;
end;
//------------------------------------------------------------------------------
-function ExtractRef(const href: UTF8String): UTF8String; {$IFDEF INLINE} inline; {$ENDIF}
+function ReversePosEx(c: WideChar;
+ const text: UnicodeString; startIdx: integer): integer; overload;
+{$IFDEF INLINE} inline; {$ENDIF}
+begin
+ Result := Max(0, Min(Length(text), startidx));
+ while (Result > 0) and (text[Result] <> c) do Dec(Result);
+end;
+//------------------------------------------------------------------------------
+
+function TrimMultiSpacesUnicode(const text: UnicodeString): UnicodeString;
var
- c, c2, endC: PUTF8Char;
+ i, len: integer;
begin
- c := PUTF8Char(href);
- endC := c + Length(href);
- if Match(c, 'url(') then
+ Result := text;
+ len := Length(Result);
+ for i := 1 to len do
+ if Result[i] < #32 then Result[i] := #32;
+ i := ReversePosEx(space, Result, len);
+ while i > 1 do
begin
- inc(c, 4);
- dec(endC); // avoid trailing ')'
+ Dec(i);
+ while (i > 0) and (Result[i] = space) do
+ begin
+ Delete(Result, i, 1);
+ Dec(i);
+ end;
+ i := ReversePosEx(space, Result, i);
end;
- if c^ = '#' then inc(c);
- c2 := c;
- while (c < endC) and (c^ <> ')') do inc(c);
- Result := ToUTF8String(c2, c);
end;
//------------------------------------------------------------------------------
-function ParseNextChar(var c: PUTF8Char; endC: PUTF8Char): UTF8Char;
+function StripNewlines(const s: UTF8String): UTF8String;
+var
+ i: integer;
begin
- Result := #0;
- if not SkipBlanks(c, endC) then Exit;
- Result := c^;
- inc(c);
+ Result := s;
+ i := Length(Result);
+ while i > 0 do
+ begin
+ if Result[i] < space then Delete(Result, i, 1);
+ Dec(i);
+ end;
end;
//------------------------------------------------------------------------------
-function ParseQuoteChar(var c: PUTF8Char; endC: PUTF8Char): UTF8Char;
+function StripNewlines(const s: UnicodeString): UnicodeString;
+var
+ i: integer;
begin
- if SkipBlanks(c, endC) and (c^ in [quote, dquote]) then
+ Result := s;
+ i := Length(Result);
+ while i > 0 do
begin
- Result := c^;
- inc(c);
- end else
- Result := #0;
+ if Result[i] < space then Delete(Result, i, 1);
+ Dec(i);
+ end;
end;
//------------------------------------------------------------------------------
-function AllTrim(var name: UTF8String): Boolean;
+function ConvertNewlines(const s: UTF8String): UTF8String; overload;
var
- i, len: integer;
+ i: integer;
begin
- len := Length(name);
- i := 0;
- while (len > 0) and (name[1] <= space) do
+ Result := s;
+ i := Length(Result);
+ while i > 0 do
begin
- inc(i); dec(len);
+ if Result[i] < space then
+ begin
+ if Result[i] = #10 then
+ Result[i] := space else
+ Delete(Result, i, 1);
+ end;
+ Dec(i);
+ end;
+end;
+//------------------------------------------------------------------------------
+
+function ConvertNewlines(const s: UnicodeString): UnicodeString; overload;
+var
+ i: integer;
+begin
+ Result := s;
+ i := Length(Result);
+ while i > 0 do
+ begin
+ if Result[i] < space then
+ begin
+ if Result[i] = #10 then
+ Result[i] := space else
+ Delete(Result, i, 1);
+ end;
+ Dec(i);
end;
- if i > 0 then Delete(name, 1, i);
- Result := len > 0;
- if not Result then Exit;
- while name[len] <= space do dec(len);
- SetLength(name, len);
end;
//------------------------------------------------------------------------------
-function ToUTF8String(var c: PUTF8Char; endC: PUTF8Char): UTF8String;
+procedure ToUTF8String(c, endC: PUTF8Char;
+ var S: UTF8String; spacesInText: TSpacesInText);
var
len: integer;
begin
len := endC - c;
- SetLength(Result, len);
+ SetLength(S, len);
+ if len = 0 then Exit;
+ Move(c^, PUTF8Char(S)^, len * SizeOf(UTF8Char));
+ if spacesInText <> sitPreserve then
+ S := TrimMultiSpacesUtf8(S);
+ S := ConvertNewlines(S);
+end;
+//------------------------------------------------------------------------------
+
+procedure ToAsciiLowerUTF8String(c, endC: PUTF8Char; var S: UTF8String);
+// Reads a UTF8String and converts all upper case 'A'..'Z' to lower case 'a'..'z'
+var
+ len: integer;
+ p: PUTF8Char;
+ ch: UTF8Char;
+begin
+ len := endC - c;
+ SetLength(S, len);
if len = 0 then Exit;
- Move(c^, Result[1], len * SizeOf(UTF8Char));
- c := endC;
+
+ // Use a pointer arithmetic trick to run forward by using a negative index
+ p := PUTF8Char(S) + len;
+ len := -len;
+ while len < 0 do
+ begin
+ ch := endC[len];
+ case ch of
+ 'A'..'Z':
+ ch := UTF8Char(Byte(ch) or $20);
+ end;
+ p[len] := ch;
+ inc(len);
+ end;
end;
//------------------------------------------------------------------------------
@@ -880,13 +1510,11 @@ function IsKnownEntity(owner: TSvgParser;
var c: PUTF8Char; endC: PUTF8Char; out entity: PSvgAttrib): boolean;
var
c2, c3: PUTF8Char;
- entityName: UTF8String;
begin
inc(c); //skip ampersand.
c2 := c; c3 := c;
- ParseNameLength(c3, endC);
- entityName := ToUTF8String(c2, c3);
- entity := owner.FindEntity(GetHash(entityName));
+ c3 := ParseNameLength(c3, endC);
+ entity := owner.FindEntity(GetHash(c2, c3 - c2));
Result := (c3^ = ';') and Assigned(entity);
//nb: increments 'c' only if the entity is found.
if Result then c := c3 +1 else dec(c);
@@ -905,7 +1533,7 @@ function ParseQuotedString(var c: PUTF8Char; endC: PUTF8Char;
while (c < endC) and (c^ <> quote) do inc(c);
Result := (c < endC);
if not Result then Exit;
- quotStr := ToUTF8String(c2, c);
+ ToUTF8String(c2, c, quotStr);
inc(c);
end;
//------------------------------------------------------------------------------
@@ -929,7 +1557,7 @@ function IsNumPending(var c: PUTF8Char;
c2 := c;
if (c2^ = '-') then inc(c2);
if (c2^ = SvgDecimalSeparator) then inc(c2);
- Result := (c2 < endC) and (c2^ >= '0') and (c2^ <= '9');
+ Result := (c2 < endC) and IsDigit(c2^);
end;
//------------------------------------------------------------------------------
@@ -1004,7 +1632,7 @@ function ParseTransform(const transform: UTF8String): TMatrixD;
MatrixSkew(mat, 0, DegToRad(values[0]));
end;
end;
- Result := MatrixMultiply(Result, mat);
+ MatrixMultiply2(mat, Result);
end;
end;
//------------------------------------------------------------------------------
@@ -1026,12 +1654,12 @@ procedure GetSvgFontInfo(const value: UTF8String; var fontInfo: TSVGFontInfo);
begin
hash := ParseNextWordHashed(c, endC);
case hash of
- hSans_045_Serif : fontInfo.family := ttfSansSerif;
- hSerif : fontInfo.family := ttfSerif;
- hMonospace : fontInfo.family := ttfMonospace;
+ hSans_045_Serif : fontInfo.family := tfSansSerif;
+ hSerif : fontInfo.family := tfSerif;
+ hMonospace : fontInfo.family := tfMonospace;
hBold : fontInfo.weight := 600;
hItalic : fontInfo.italic := sfsItalic;
- hNormal :
+ hNormal :
begin
fontInfo.weight := 400;
fontInfo.italic := sfsNone;
@@ -1051,6 +1679,7 @@ function HtmlDecode(const html: UTF8String): UTF8String;
var
val, len: integer;
c,ce,endC: PUTF8Char;
+ ch: UTF8Char;
begin
len := Length(html);
SetLength(Result, len*3);
@@ -1082,14 +1711,15 @@ function HtmlDecode(const html: UTF8String): UTF8String;
inc(c, 3);
while c < ce do
begin
- if (c^ >= 'a') and (c^ <= 'f') then
- val := val * 16 + Ord(c^) - 87
- else if (c^ >= 'A') and (c^ <= 'F') then
- val := val * 16 + Ord(c^) - 55
- else if (c^ >= '0') and (c^ <= '9') then
- val := val * 16 + Ord(c^) - 48
+ ch := c^;
+ case ch of
+ 'a'..'f':
+ val := val * 16 + Ord(ch) - 87;
+ 'A'..'F':
+ val := val * 16 + Ord(ch) - 55;
+ '0'..'9':
+ val := val * 16 + Ord(ch) - 48;
else
- begin
val := -1;
break;
end;
@@ -1210,16 +1840,16 @@ function UTF8StringToColor32(const value: UTF8String; var color: TColor32): Bool
if mus[i] = utPercent then
vals[i] := vals[i] * 255 / 100;
- if ParseNextNumEx(c, endC, true, vals[3], mus[3]) then
+ if (c < endC) and (c^ <> ')') and ParseNextNumEx(c, endC, true, vals[3], mus[3]) then
alpha := 255 else //stops further alpha adjustment
vals[3] := 255;
if ParseNextChar(c, endC) <> ')' then Exit;
for i := 0 to 3 do if IsFraction(vals[i]) then
vals[i] := vals[i] * 255;
- color := ClampByte(Round(vals[3])) shl 24 +
- ClampByte(Round(vals[0])) shl 16 +
- ClampByte(Round(vals[1])) shl 8 +
- ClampByte(Round(vals[2]));
+ color := ClampByte(Integer(Round(vals[3]))) shl 24 +
+ ClampByte(Integer(Round(vals[0]))) shl 16 +
+ ClampByte(Integer(Round(vals[1]))) shl 8 +
+ ClampByte(Integer(Round(vals[2])));
end
else if (c^ = '#') then //#RRGGBB or #RGB
begin
@@ -1281,9 +1911,8 @@ function UTF8StringToColor32(const value: UTF8String; var color: TColor32): Bool
color := clr;
end else //color name lookup
begin
- i := ColorConstList.IndexOf(string(value));
- if i < 0 then Exit;
- color := TColorObj(ColorConstList.Objects[i]).cc.ColorValue;
+ if not ColorConstList.GetColorValue(value, color) then
+ Exit;
end;
//and in case the opacity has been set before the color
@@ -1296,28 +1925,21 @@ function UTF8StringToColor32(const value: UTF8String; var color: TColor32): Bool
end;
//------------------------------------------------------------------------------
-function MakeDashArray(const dblArray: TArrayOfDouble; scale: double): TArrayOfInteger;
+function ScaleDashArray(const dblArray: TArrayOfDouble; scale: double): TArrayOfDouble;
var
i, len: integer;
- dist: double;
begin
- dist := 0;
len := Length(dblArray);
SetLength(Result, len);
+ if len = 0 then Exit;
+
for i := 0 to len -1 do
- begin
- Result[i] := Ceil(dblArray[i] * scale);
- dist := Result[i] + dist;
- end;
+ Result[i] := dblArray[i] * scale;
- if dist = 0 then
- begin
- Result := nil;
- end
- else if Odd(len) then
+ if Odd(len) then
begin
SetLength(Result, len *2);
- Move(Result[0], Result[len], len * SizeOf(integer));
+ Move(Result[0], Result[len], len * SizeOf(double));
end;
end;
//------------------------------------------------------------------------------
@@ -1334,9 +1956,9 @@ procedure ParseStyleElementContent(const value: UTF8String;
stylesList: TClassStylesList);
var
len, cap: integer;
- names: array of string;
+ names: array of UTF8String;
- procedure AddName(const name: string);
+ procedure AddName(const name: UTF8String);
begin
if len = cap then
begin
@@ -1362,40 +1984,52 @@ procedure ParseStyleElementContent(const value: UTF8String;
c := @value[1];
endC := c + Length(value);
- SkipBlanks(c, endC);
+ c := SkipBlanksEx(c, endC);
+ if c >= endC then Exit;
+
if Match(c, '= endC then Break;
+
+ case c^ of
+ SvgDecimalSeparator, '#', 'A'..'Z', 'a'..'z': ;
+ else break;
+ end;
+
//get one or more class names for each pending style
c2 := c;
- ParseNameLength(c, endC);
- aclassName := ToUTF8String(c2, c);
+ c := ParseNameLength(c, endC);
+ ToAsciiLowerUTF8String(c2, c, aclassName);
- AddName(Lowercase(String(aclassName)));
- if PeekNextChar(c, endC) = ',' then
+ AddName(aclassName);
+
+ c := SkipStyleBlanks(c, endC);
+ if (c < endC) and (c^ = ',') then
begin
inc(c);
Continue;
end;
if len = 0 then break;
- SetLength(names, len); //ie no more comma separated names
//now get the style
- if PeekNextChar(c, endC) <> '{' then Break;
+ if (c >= endC) or (c^ <> '{') then Break;
inc(c);
c2 := c;
while (c < endC) and (c^ <> '}') do inc(c);
if (c = endC) then break;
- aStyle := ToUTF8String(c2, c);
-
- //finally, for each class name add (or append) this style
- for i := 0 to High(names) do
- stylesList.AddAppendStyle(names[i], aStyle);
- names := nil;
- len := 0; cap := 0;
+ ToTrimmedUTF8String(c2, c, aStyle);
+ if aStyle <> '' then
+ begin
+ stylesList.Preallocate(len);
+ //finally, for each class name add (or append) this style
+ for i := 0 to len - 1 do
+ stylesList.AddAppendStyle(names[i], aStyle);
+ end;
+ // Reset the used names array length, so we can reuse it to reduce the amount of SetLength calls
+ len := 0;
inc(c);
end;
end;
@@ -1432,7 +2066,7 @@ procedure TXmlEl.Clear;
i: integer;
begin
for i := 0 to attribs.Count -1 do
- Dispose(PSvgAttrib(attribs[i]));
+ DisposeSvgAttrib(PSvgAttrib(attribs.List[i]));
attribs.Clear;
for i := 0 to childs.Count -1 do
@@ -1441,69 +2075,73 @@ procedure TXmlEl.Clear;
end;
//------------------------------------------------------------------------------
-function TagNameToLower(const tagName: UTF8String): UTF8String;
-var
- i: integer;
-begin
- Result := tagName;
- for i := 1 to Length(Result) do
- if (Result[i] >= 'A') and (Result[i] <= 'Z') then
- Result[i] := AnsiChar(Ord(Result[i]) + 32);
-end;
-//------------------------------------------------------------------------------
-
function TXmlEl.ParseHeader(var c: PUTF8Char; endC: PUTF8Char): Boolean;
var
style: UTF8String;
c2: PUTF8Char;
begin
- SkipBlanks(c, endC);
- c2 := c;;
- ParseNameLength(c, endC);
- name := TagNameToLower(ToUTF8String(c2, c));
+ c2 := SkipBlanksEx(c, endC);
+ c := ParseNameLength(c2, endC);
+ ToAsciiLowerUTF8String(c2, c, name);
//load the class's style (ie undotted style) if found.
style := owner.classStyles.GetStyle(name);
if style <> '' then ParseStyleAttribute(style);
-
Result := ParseAttributes(c, endC);
end;
//------------------------------------------------------------------------------
-function TXmlEl.ParseAttribName(var c: PUTF8Char;
- endC: PUTF8Char; attrib: PSvgAttrib): Boolean;
-var
- c2: PUTF8Char;
- //attribName: UTF8String;
+class function TXmlEl.ParseAttribName(c: PUTF8Char;
+ endC: PUTF8Char; attrib: PSvgAttrib): PUTF8Char;
begin
- Result := SkipBlanks(c, endC);
- if not Result then Exit;
- c2 := c;
- ParseNameLength(c, endC);
- attrib.Name := ToUTF8String(c2, c);
+ Result := SkipBlanksEx(c, endC);
+ if Result >= endC then Exit;
+ c := Result;
+ Result := ParseNameLength(Result, endC);
+ ToUTF8String(c, Result, attrib.Name);
attrib.hash := GetHash(attrib.Name);
end;
//------------------------------------------------------------------------------
-function TXmlEl.ParseAttribValue(var c: PUTF8Char;
- endC: PUTF8Char; attrib: PSvgAttrib): Boolean;
+class function TXmlEl.ParseAttribValue(c, endC: PUTF8Char;
+ attrib: PSvgAttrib): PUTF8Char;
+// Parse: [Whitespaces] "=" [Whitespaces] ("'" | "\"") ("'" | "\"")
var
- quoteChar : UTF8Char;
- c2, c3: PUTF8Char;
+ quoteChar: UTF8Char;
+ c2: PUTF8Char;
begin
- Result := ParseNextChar(c, endC) = '=';
- if not Result then Exit;
- quoteChar := ParseQuoteChar(c, endC);
- if quoteChar = #0 then Exit;
- //trim leading and trailing spaces
- while (c < endC) and (c^ <= space) do inc(c);
- c2 := c;
- while (c < endC) and (c^ <> quoteChar) do inc(c);
- c3 := c;
- while (c3 > c2) and ((c3 -1)^ <= space) do
- dec(c3);
- attrib.value := ToUTF8String(c2, c3);
- inc(c); //skip end quote
+ Result := endC;
+
+ // ParseNextChar:
+ c := SkipBlanksEx(c, endC);
+ if (c >= endC) or (c^ <> '=') then Exit;
+ inc(c); // '=' parsed
+
+ // ParseQuoteChar:
+ c := SkipBlanksEx(c, endC);
+ if c >= endC then Exit;
+ quoteChar := c^;
+ if not (quoteChar in [quote, dquote]) then Exit;
+ inc(c); // quote parsed
+
+ //trim leading and trailing spaces in the actual value
+ c := SkipBlanksEx(c, endC);
+ // find value end
+ Result := c;
+ while (Result < endC) and (Result^ <> quoteChar) do inc(Result);
+ c2 := Result;
+ while (c2 > c) and ((c2 -1)^ <= space) do dec(c2);
+
+ ToUTF8String(c, c2, attrib.value, sitPreserve);
+ inc(Result); //skip end quote
+end;
+//------------------------------------------------------------------------------
+
+class function TXmlEl.ParseAttribNameAndValue(c, endC: PUTF8Char; attrib: PSvgAttrib): PUTF8Char;
+begin
+ Result := ParseAttribName(c, endC, attrib);
+ if (Result < endC) then
+ Result := ParseAttribValue(Result, endC, attrib);
end;
//------------------------------------------------------------------------------
@@ -1519,32 +2157,38 @@ function TXmlEl.ParseAttributes(var c: PUTF8Char; endC: PUTF8Char): Boolean;
while SkipBlanks(c, endC) do
begin
- if CharInSet(c^, ['/', '?', '>']) then
- begin
- if (c^ <> '>') then
- begin
- inc(c);
- if (c^ <> '>') then Exit; //error
- selfClosed := true;
- end;
- inc(c);
- Result := true;
- break;
- end
- else if (c^ = 'x') and Match(c, 'xml:') then
- begin
- inc(c, 4); //ignore xml: prefixes
+ case c^ of
+ '/', '?':
+ begin
+ inc(c);
+ if (c^ <> '>') then Exit; //error
+ selfClosed := true;
+ inc(c);
+ Result := true;
+ break;
+ end;
+ '>':
+ begin
+ inc(c);
+ Result := true;
+ break;
+ end;
+ 'x':
+ if Match(c, 'xml:') then
+ begin
+ inc(c, 4); //ignore xml: prefixes
+ end;
end;
- New(attrib);
- if not ParseAttribName(c, endC, attrib) or
- not ParseAttribValue(c, endC, attrib) then
+ attrib := NewSvgAttrib();
+ c := ParseAttribNameAndValue(c, endC, attrib);
+ if c >= endC then
begin
- Dispose(attrib);
+ DisposeSvgAttrib(attrib);
Exit;
end;
- attribs.Add(attrib);
+ attribs.Add(attrib);
case attrib.hash of
hId : idAttrib := attrib;
hClass : classAttrib := attrib;
@@ -1588,31 +2232,38 @@ procedure TXmlEl.ParseStyleAttribute(const style: UTF8String);
attrib: PSvgAttrib;
begin
//there are 4 ways to load styles (in ascending precedence) -
- //1. a class element style (called during element contruction)
+ //1. a class element style (called during element construction)
//2. a non-element class style (called via a class attribute)
//3. an inline style (called via a style attribute)
//4. an id specific class style
c := PUTF8Char(style);
endC := c + Length(style);
- while SkipStyleBlanks(c, endC) do
+ while True do
begin
+ c := SkipStyleBlanks(c, endC);
+ if c >= endC then Break;
+
c2 := c;
- ParseStyleNameLen(c, endC);
- styleName := ToUTF8String(c2, c);
+ c := ParseStyleNameLen(c, endC);
+ ToUTF8String(c2, c, styleName);
if styleName = '' then Break;
- if (ParseNextChar(c, endC) <> ':') or //syntax check
- not SkipBlanks(c,endC) then Break;
+ // ParseNextChar
+ c := SkipStyleBlanks(c, endC);
+ if (c >= endC) or (c^ <> ':') then Break; //syntax check
+ inc(c);
+
+ c := SkipBlanksEx(c, endC);
+ if c >= endC then Break;
c2 := c;
inc(c);
while (c < endC) and (c^ <> ';') do inc(c);
- styleVal := ToUTF8String(c2, c);
- AllTrim(styleVal);
+ ToTrimmedUTF8String(c2, c, styleVal);
inc(c);
- new(attrib);
+ attrib := NewSvgAttrib();
attrib.name := styleName;
attrib.value := styleVal;
attrib.hash := GetHash(attrib.name);
@@ -1633,14 +2284,28 @@ function TXmlEl.GetAttrib(index: integer): PSvgAttrib;
end;
//------------------------------------------------------------------------------
+function IsTextAreaTbreak(var c: PUTF8Char; endC: PUTF8Char): Boolean;
+const
+ // https://www.w3.org/TR/SVGTiny12/text.html#tbreakElement
+ tbreak: PUTF8Char = '';
+begin
+ Result := (c + 9 < endC) and CompareMem(c, tbreak, 9);
+ if Result then inc(c, 8);
+end;
+//------------------------------------------------------------------------------
+
function TXmlEl.ParseContent(var c: PUTF8Char; endC: PUTF8Char): Boolean;
var
- child: TSvgTreeEl;
- entity: PSvgAttrib;
- c2, tmpC, tmpEndC: PUTF8Char;
+ child : TSvgXmlEl;
+ entity : PSvgAttrib;
+ c2, cc : PUTF8Char;
+ tmpC, tmpEndC : PUTF8Char;
begin
Result := false;
- while SkipBlanks(c, endC) do
+ // note: don't trim spaces at the start of text content.
+ // Text space trimming will be done later IF and when required.
+ while (hash = hText) or (hash = hTSpan) or
+ (hash = hTextArea) or SkipBlanks(c, endC) do
begin
if (c^ = '<') then
begin
@@ -1648,49 +2313,53 @@ function TXmlEl.ParseContent(var c: PUTF8Char; endC: PUTF8Char): Boolean;
case c^ of
'!':
begin
- if Match(c, '!--') then //start comment
+ cc := c;
+ if Match(cc, '!--') then //start comment
begin
- inc(c, 3);
- while (c < endC) and ((c^ <> '-') or
- not Match(c, '-->')) do inc(c); //end comment
- inc(c, 3);
+ inc(cc, 3);
+ while (cc < endC) and ((cc^ <> '-') or
+ not Match(cc, '-->')) do inc(cc); //end comment
+ inc(cc, 3);
end else
begin
//it's very likely ']') or not Match(c, ']]>')) do
- inc(c);
- text := ToUTF8String(c2, c);
- inc(c, 3);
+ while (cc < endC) and ((cc^ <> ']') or not Match(cc, ']]>')) do
+ inc(cc);
+ ToUTF8String(c2, cc, text);
+ inc(cc, 3);
if (hash = hStyle) then
ParseStyleElementContent(text, owner.classStyles);
end else
begin
- while (c < endC) and (c^ <> '<') do inc(c);
- text := ToUTF8String(c2, c);
+ while (cc < endC) and (cc^ <> '<') do inc(cc);
+ ToUTF8String(c2, cc, text);
end;
end;
+ c := cc;
end;
'/', '?':
begin
//element closing tag
- inc(c);
- if Match(c, name) then
+ cc := c;
+ inc(cc);
+ if Match(cc, name) then
begin
- inc(c, Length(name));
+ inc(cc, Length(name));
//very rarely there's a space before '>'
- SkipBlanks(c, endC);
- Result := c^ = '>';
- inc(c);
+ cc := SkipBlanksEx(cc, endC);
+ Result := cc^ = '>';
+ inc(cc);
end;
+ c := cc;
Exit;
end;
else
begin
//starting a new element
- child := TSvgTreeEl.Create(owner);
+ child := TSvgXmlEl.Create(owner);
childs.Add(child);
if not child.ParseHeader(c, endC) then break;
if not child.selfClosed then
@@ -1710,28 +2379,34 @@ function TXmlEl.ParseContent(var c: PUTF8Char; endC: PUTF8Char): Boolean;
end
else if (hash = hTSpan) or (hash = hText) or (hash = hTextPath) then
begin
- //text content: and because text can be mixed with one or more
- // elements we need to create sub-elements for each text block.
- //And elements can even have sub-elements.
- tmpC := c;
- //preserve a leading space
- if (tmpC -1)^ = space then dec(tmpC);
- while (c < endC) and (c^ <> '<') do inc(c);
- if (hash = hTextPath) then
- begin
- text := ToUTF8String(tmpC, c);
- end else
- begin
- child := TSvgTreeEl.Create(owner);
- childs.Add(child);
- child.text := ToUTF8String(tmpC, c);
- end;
+ // assume this is text content, and because text can also be mixed
+ // with any number of nested elements, always put text
+ // content inside a pseudo 'self closed' element
+ cc := c;
+ while (cc < endC) and (cc^ <> '<') do inc(cc);
+ child := TSvgXmlEl.Create(owner);
+ child.name := 'tspan';
+ child.hash := GetHash('tspan');
+ child.selfClosed := true; ////////////////////// :)))
+ childs.Add(child);
+ ToUTF8String(c, cc, child.text, sitPreserve);
+ c := cc;
+ end
+ else if (hash = hTextArea) then
+ begin
+ // also assume this is text content, but don't create
+ // pseudo elements inside