diff --git a/Demo/SvgViewer/SvgViewer.dproj b/Demo/SvgViewer/SvgViewer.dproj index a2447b3..79f121a 100644 --- a/Demo/SvgViewer/SvgViewer.dproj +++ b/Demo/SvgViewer/SvgViewer.dproj @@ -1,7 +1,7 @@  {AD7AD52D-F991-4DFE-95E0-FDDC2564C73C} - 20.1 + 20.2 VCL SvgViewer.dpr True @@ -46,23 +46,11 @@ Base true - - true - Cfg_2 - true - true - - - true - Cfg_2 - true - true - - 1049 + 1033 ..\..\svg;..\..\source;..\..\Image32\Source;..\..\Skia4Delphi\Source;..\..\Skia4Delphi\Source\Vcl;$(DCC_UnitSearchPath) - $(BDS)\bin\delphi_PROJECTICON.ico - CompanyName=;FileDescription=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=1.0.0.0;Comments= + Viewer_Icon.ico + CompanyName=Ethea S.r.l.;FileDescription=SVG file Viewer;FileVersion=4.2.0.0;InternalName=SVGViewer;LegalCopyright=Copyright (c) 2020-2024 Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=;ProductVersion=4.2;Comments= SvgViewer .\$(Platform)\$(Config) ..\Bin @@ -71,29 +59,19 @@ false false false - Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;$(DCC_Namespace) SKIA;$(DCC_Define) + true + 4 + 2 + Winapi;System.Win;Xml.Win;System;Xml;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Shell;$(DCC_Namespace) - 1033 $(BDS)\bin\default_app.manifest - true - DBXSqliteDriver;RESTComponents;DataSnapServerMidas;DBXDb2Driver;DBXInterBaseDriver;vclactnband;vclFireDAC;emsclientfiredac;DataSnapFireDAC;svnui;tethering;FireDACADSDriver;DBXMSSQLDriver;DatasnapConnectorsFreePascal;FireDACMSSQLDriver;vcltouch;vcldb;bindcompfmx;svn;DBXOracleDriver;inetdb;emsedge;FireDACIBDriver;fmx;fmxdae;FireDACDBXDriver;dbexpress;IndyCore;vclx;dsnap;DataSnapCommon;emsclient;FireDACCommon;RESTBackendComponents;DataSnapConnectors;VCLRESTComponents;soapserver;vclie;bindengine;DBXMySQLDriver;FireDACOracleDriver;CloudService;FireDACMySQLDriver;DBXFirebirdDriver;FireDACCommonODBC;FireDACCommonDriver;DataSnapClient;inet;bindcompdbx;IndyIPCommon;vcl;DBXSybaseASEDriver;IndyIPServer;IndySystem;FireDACDb2Driver;dsnapcon;FireDACMSAccDriver;fmxFireDAC;FireDACInfxDriver;vclimg;FireDAC;emshosting;FireDACSqliteDriver;FireDACPgDriver;FireDACASADriver;DBXOdbcDriver;FireDACTDataDriver;soaprtl;DbxCommonDriver;DataSnapServer;xmlrtl;soapmidas;DataSnapNativeClient;fmxobj;vclwinx;FireDACDSDriver;rtl;DbxClientDriver;DBXSybaseASADriver;CustomIPTransport;vcldsnap;bindcomp;appanalytics;DBXInformixDriver;IndyIPClient;bindcompvcl;dbxcds;VclSmp;adortl;FireDACODBCDriver;DataSnapIndy10ServerTransport;dsnapxml;DataSnapProviderClient;dbrtl;inetdbxpress;FireDACMongoDBDriver;IndyProtocols;fmxase;$(DCC_UsePackage) - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png - Viewer_Icon.ico + PerMonitorV2 $(BDS)\bin\default_app.manifest - true - 1033 - DBXSqliteDriver;RESTComponents;DataSnapServerMidas;DBXDb2Driver;DBXInterBaseDriver;vclactnband;vclFireDAC;emsclientfiredac;DataSnapFireDAC;tethering;FireDACADSDriver;DBXMSSQLDriver;DatasnapConnectorsFreePascal;FireDACMSSQLDriver;vcltouch;vcldb;bindcompfmx;DBXOracleDriver;inetdb;emsedge;FireDACIBDriver;fmx;fmxdae;FireDACDBXDriver;dbexpress;IndyCore;vclx;dsnap;DataSnapCommon;emsclient;FireDACCommon;RESTBackendComponents;DataSnapConnectors;VCLRESTComponents;soapserver;vclie;bindengine;DBXMySQLDriver;FireDACOracleDriver;CloudService;FireDACMySQLDriver;DBXFirebirdDriver;FireDACCommonODBC;FireDACCommonDriver;DataSnapClient;inet;bindcompdbx;IndyIPCommon;vcl;DBXSybaseASEDriver;IndyIPServer;IndySystem;FireDACDb2Driver;dsnapcon;FireDACMSAccDriver;fmxFireDAC;FireDACInfxDriver;vclimg;FireDAC;emshosting;FireDACSqliteDriver;FireDACPgDriver;FireDACASADriver;DBXOdbcDriver;FireDACTDataDriver;soaprtl;DbxCommonDriver;DataSnapServer;xmlrtl;soapmidas;DataSnapNativeClient;fmxobj;vclwinx;FireDACDSDriver;rtl;DbxClientDriver;DBXSybaseASADriver;CustomIPTransport;vcldsnap;bindcomp;appanalytics;DBXInformixDriver;IndyIPClient;bindcompvcl;dbxcds;VclSmp;adortl;FireDACODBCDriver;DataSnapIndy10ServerTransport;dsnapxml;DataSnapProviderClient;dbrtl;inetdbxpress;FireDACMongoDBDriver;IndyProtocols;fmxase;$(DCC_UsePackage) - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png - Viewer_Icon.ico - System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - Debug - CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= + PerMonitorV2 DEBUG;$(DCC_Define) @@ -104,41 +82,16 @@ true - 1033 - true - true - false Debug - PerMonitor - Viewer_Icon.ico - true - 1033 - true Debug - PerMonitorV2 - Viewer_Icon.ico false RELEASE;$(DCC_Define) 0 - - true - 1033 - true - PerMonitor - Viewer_Icon.ico - - - true - 1033 - true - PerMonitorV2 - Viewer_Icon.ico - MainSource @@ -171,1040 +124,8 @@ SvgViewer.dpr - - Microsoft Office XP Sample Automation Server Wrapper Components - Ethea InstantSolutions 6 ReportBuilder Components - Ethea InstantSolutions 6 Rtl Library - Ethea InstantSolutions 6 Vcl Library - Ethea InstantSolutions 6 LibreOffice/OpenOffice Components - Ethea InstantSolutions 6 Framework Library - Microsoft Office 2000 Sample Automation Server Wrapper Components - + - - - - .\ - 0 - sk4d.dll - true - - - - - .\ - 0 - sk4d.dll - true - - - - - .\ - 0 - sk4d.dll - true - - - - - .\ - 0 - sk4d.dll - true - - - - - .\ - 0 - sk4d.dll - true - - - - - .\ - 0 - sk4d.dll - true - - - - - .\ - 0 - sk4d.dll - true - - - - - .\ - 0 - sk4d.dll - true - - - - - - 1 - - - Contents\MacOS - 1 - - - 0 - - - - - classes - 64 - - - classes - 64 - - - - - res\xml - 1 - - - res\xml - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - library\lib\armeabi - 1 - - - library\lib\armeabi - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - library\lib\mips - 1 - - - library\lib\mips - 1 - - - - - library\lib\armeabi-v7a - 1 - - - library\lib\arm64-v8a - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable-anydpi-v21 - 1 - - - res\drawable-anydpi-v21 - 1 - - - - - res\values - 1 - - - res\values - 1 - - - - - res\values-v21 - 1 - - - res\values-v21 - 1 - - - - - res\values-v31 - 1 - - - res\values-v31 - 1 - - - - - res\drawable-anydpi-v26 - 1 - - - res\drawable-anydpi-v26 - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable-anydpi-v33 - 1 - - - res\drawable-anydpi-v33 - 1 - - - - - res\values - 1 - - - res\values - 1 - - - - - res\values-night-v21 - 1 - - - res\values-night-v21 - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable-xxhdpi - 1 - - - res\drawable-xxhdpi - 1 - - - - - res\drawable-xxxhdpi - 1 - - - res\drawable-xxxhdpi - 1 - - - - - res\drawable-ldpi - 1 - - - res\drawable-ldpi - 1 - - - - - res\drawable-mdpi - 1 - - - res\drawable-mdpi - 1 - - - - - res\drawable-hdpi - 1 - - - res\drawable-hdpi - 1 - - - - - res\drawable-xhdpi - 1 - - - res\drawable-xhdpi - 1 - - - - - res\drawable-mdpi - 1 - - - res\drawable-mdpi - 1 - - - - - res\drawable-hdpi - 1 - - - res\drawable-hdpi - 1 - - - - - res\drawable-xhdpi - 1 - - - res\drawable-xhdpi - 1 - - - - - res\drawable-xxhdpi - 1 - - - res\drawable-xxhdpi - 1 - - - - - res\drawable-xxxhdpi - 1 - - - res\drawable-xxxhdpi - 1 - - - - - res\drawable-small - 1 - - - res\drawable-small - 1 - - - - - res\drawable-normal - 1 - - - res\drawable-normal - 1 - - - - - res\drawable-large - 1 - - - res\drawable-large - 1 - - - - - res\drawable-xlarge - 1 - - - res\drawable-xlarge - 1 - - - - - res\values - 1 - - - res\values - 1 - - - - - res\drawable-anydpi-v24 - 1 - - - res\drawable-anydpi-v24 - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable-night-anydpi-v21 - 1 - - - res\drawable-night-anydpi-v21 - 1 - - - - - res\drawable-anydpi-v31 - 1 - - - res\drawable-anydpi-v31 - 1 - - - - - res\drawable-night-anydpi-v31 - 1 - - - res\drawable-night-anydpi-v31 - 1 - - - - - 1 - - - Contents\MacOS - 1 - - - 0 - - - - - Contents\MacOS - 1 - .framework - - - Contents\MacOS - 1 - .framework - - - Contents\MacOS - 1 - .framework - - - 0 - - - - - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 0 - .dll;.bpl - - - - - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 0 - .bpl - - - - - 0 - - - 0 - - - 0 - - - 0 - - - 0 - - - Contents\Resources\StartUp\ - 0 - - - Contents\Resources\StartUp\ - 0 - - - Contents\Resources\StartUp\ - 0 - - - 0 - - - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - ..\ - 1 - - - - - Contents - 1 - - - Contents - 1 - - - Contents - 1 - - - - - Contents\Resources - 1 - - - Contents\Resources - 1 - - - Contents\Resources - 1 - - - - - library\lib\armeabi-v7a - 1 - - - library\lib\arm64-v8a - 1 - - - 1 - - - 1 - - - 1 - - - 1 - - - Contents\MacOS - 1 - - - Contents\MacOS - 1 - - - Contents\MacOS - 1 - - - 0 - - - - - library\lib\armeabi-v7a - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - ..\ - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).launchscreen - 64 - - - ..\$(PROJECTNAME).launchscreen - 64 - - - - - 1 - - - 1 - - - 1 - - - - - Assets - 1 - - - Assets - 1 - - - - - Assets - 1 - - - Assets - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - - - - - - - - - - - - True True @@ -1214,5 +135,4 @@ - diff --git a/Image32/ChangeLog.txt b/Image32/ChangeLog.txt index fce3fff..88db527 100644 --- a/Image32/ChangeLog.txt +++ b/Image32/ChangeLog.txt @@ -1,17 +1,23 @@ Image32 - 2D graphics library for Delphi Pascal -Latest version: 4.3 -Released: 27 September 2022 +Latest version: 4.6 +Released: 18 September 2024 -Copyright © 2019-2022 Angus Johnson +Copyright © 2019-2024 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.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/Image32/source/Clipper.Core.pas b/Image32/source/Clipper.Core.pas index fbe80c7..284fc58 100644 --- a/Image32/source/Clipper.Core.pas +++ b/Image32/source/Clipper.Core.pas @@ -2,7 +2,7 @@ (******************************************************************************* * Author : Angus Johnson * -* Date : 12 August 2024 * +* Date : 17 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2010-2024 * * Purpose : Core Clipper Library module * @@ -18,16 +18,12 @@ interface SysUtils, Classes, Math; type -{$IFDEF USINGZ} - Ztype = type double;//Int64;// - PZtype = ^Ztype; -{$ENDIF} PPoint64 = ^TPoint64; TPoint64 = record X, Y: Int64; {$IFDEF USINGZ} - Z: Ztype; + Z: Int64; {$ENDIF} end; @@ -35,7 +31,7 @@ TPoint64 = record TPointD = record X, Y: double; {$IFDEF USINGZ} - Z: Ztype; + Z: Int64; {$ENDIF} end; @@ -133,6 +129,7 @@ TListEx = class constructor Create(capacity: integer = 0); virtual; destructor Destroy; override; procedure Clear; virtual; + procedure DeleteLast; function Add(item: Pointer): integer; procedure Swap(idx1, idx2: integer); procedure Sort(Compare: TListSortCompare); @@ -141,7 +138,7 @@ TListEx = class 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); @@ -190,11 +187,11 @@ function PointsNearEqual(const pt1, pt2: TPointD; distanceSqrd: double): Boolean {$IFDEF INLINING} inline; {$ENDIF} {$IFDEF USINGZ} -function Point64(const X, Y: Int64; Z: ZType = 0): TPoint64; overload; +function Point64(const X, Y: Int64; Z: Int64 = 0): TPoint64; overload; {$IFDEF INLINING} inline; {$ENDIF} -function Point64(const X, Y: Double; Z: ZType = 0): TPoint64; overload; +function Point64(const X, Y: Double; Z: Int64 = 0): TPoint64; overload; {$IFDEF INLINING} inline; {$ENDIF} -function PointD(const X, Y: Double; Z: ZType = 0): TPointD; overload; +function PointD(const X, Y: Double; Z: Int64 = 0): TPointD; overload; {$IFDEF INLINING} inline; {$ENDIF} {$ELSE} function Point64(const X, Y: Int64): TPoint64; overload; {$IFDEF INLINING} inline; {$ENDIF} @@ -547,6 +544,12 @@ procedure TListEx.Clear; end; //------------------------------------------------------------------------------ +procedure TListEx.DeleteLast; +begin + dec(fCount); +end; +//------------------------------------------------------------------------------ + function TListEx.Add(item: Pointer): integer; begin if fCount = fCapacity then @@ -1387,7 +1390,7 @@ function ArrayOfPathsToPaths(const ap: TArrayOfPaths): TPaths64; //------------------------------------------------------------------------------ {$IFDEF USINGZ} -function Point64(const X, Y: Int64; Z: ZType): TPoint64; +function Point64(const X, Y: Int64; Z: Int64): TPoint64; begin Result.X := X; Result.Y := Y; @@ -1395,7 +1398,7 @@ function Point64(const X, Y: Int64; Z: ZType): TPoint64; end; //------------------------------------------------------------------------------ -function Point64(const X, Y: Double; Z: ZType): TPoint64; +function Point64(const X, Y: Double; Z: Int64): TPoint64; begin Result.X := Round(X); Result.Y := Round(Y); @@ -1403,7 +1406,7 @@ function Point64(const X, Y: Double; Z: ZType): TPoint64; end; //------------------------------------------------------------------------------ -function PointD(const X, Y: Double; Z: ZType): TPointD; +function PointD(const X, Y: Double; Z: Int64): TPointD; begin Result.X := X; Result.Y := Y; diff --git a/Image32/source/Clipper.Engine.pas b/Image32/source/Clipper.Engine.pas index 2d10cb4..5bca730 100644 --- a/Image32/source/Clipper.Engine.pas +++ b/Image32/source/Clipper.Engine.pas @@ -2,7 +2,7 @@ (******************************************************************************* * Author : Angus Johnson * -* Date : 12 August 2024 * +* Date : 17 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2010-2024 * * Purpose : This is the main polygon clipping module * @@ -2845,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; diff --git a/Image32/source/Clipper.pas b/Image32/source/Clipper.pas index 0c2fe87..1520c67 100644 --- a/Image32/source/Clipper.pas +++ b/Image32/source/Clipper.pas @@ -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; diff --git a/Image32/source/Img32.CQ.pas b/Image32/source/Img32.CQ.pas index 8acea08..d2a8fd2 100644 --- a/Image32/source/Img32.CQ.pas +++ b/Image32/source/Img32.CQ.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.4 * -* Date : 10 April 2024 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2024 * * Purpose : Color reduction for TImage32 * diff --git a/Image32/source/Img32.Clipper2.pas b/Image32/source/Img32.Clipper2.pas index 4fa6708..e854b65 100644 --- a/Image32/source/Img32.Clipper2.pas +++ b/Image32/source/Img32.Clipper2.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.3 * -* Date : 27 September 2022 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * Purpose : Wrapper module for the Clipper library * diff --git a/Image32/source/Img32.Draw.pas b/Image32/source/Img32.Draw.pas index 252d396..f03a328 100644 --- a/Image32/source/Img32.Draw.pas +++ b/Image32/source/Img32.Draw.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.5 * -* Date : 5 July 2024 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2024 * * * diff --git a/Image32/source/Img32.Extra.pas b/Image32/source/Img32.Extra.pas index b0e7f62..db21fc3 100644 --- a/Image32/source/Img32.Extra.pas +++ b/Image32/source/Img32.Extra.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.4 * -* Date : 18 August 2024 * +* Version : 4.6 * +* Date : 12 October 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2024 * * Purpose : Miscellaneous routines that don't belong in other modules. * @@ -2248,43 +2248,63 @@ function SmoothPaths(const paths: TPathsD; isClosedPath: Boolean; procedure GaussianBlur(img: TImage32; rec: TRect; radius: Integer); var - i, w,h, x,y,yy,z: Integer; + i, w,h, highX, x,y,yy,z,startz: Integer; gaussTable: array [-MaxBlur .. MaxBlur] of Cardinal; wc: TWeightedColor; wca: TArrayOfWeightedColor; + wcaColor: TArrayOfColor32; row: PColor32Array; wcRow: PWeightedColorArray; + imgWidth: Integer; + dst, pc: PColor32; 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 + + gaussTable[0] := {Sqr}(Radius +1); + for i := 1 to radius do begin - gaussTable[i] := Sqr(Radius - i +1); + gaussTable[i] := {Sqr}(Radius - i +1); 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; @@ -2323,7 +2343,7 @@ procedure FastGaussianBlur(img: TImage32; end; //------------------------------------------------------------------------------ -procedure BoxBlurH(var src, dst: TArrayOfColor32; w,h, stdDev: integer); +procedure BoxBlurH(const src, dst: TArrayOfColor32; w,h, stdDev: integer); var i,j, ti, li, ri, re, ovr: integer; fv, val: TWeightedColor; @@ -2336,7 +2356,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 - lastColor := 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 @@ -2344,9 +2363,9 @@ 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(lastColor) 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 @@ -2367,7 +2386,8 @@ procedure BoxBlurH(var src, dst: TArrayOfColor32; w,h, stdDev: integer); inc(ri); inc(li); end; - dst[ti] := lastColor; inc(ti); + dst[ti] := lastColor; + inc(ti); end; while ti <= re do begin @@ -2382,7 +2402,7 @@ procedure BoxBlurH(var src, dst: TArrayOfColor32; w,h, stdDev: integer); 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; @@ -2395,7 +2415,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 - lastColor := 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 @@ -2403,9 +2422,9 @@ 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(lastColor) 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 @@ -2426,7 +2445,8 @@ procedure BoxBlurV(var src, dst: TArrayOfColor32; w, h, stdDev: integer); inc(ri, w); inc(li, w); end; - dst[ti] := lastColor; inc(ti, w); + dst[ti] := lastColor; + inc(ti, w); end; while ti <= re do begin diff --git a/Image32/source/Img32.FMX.pas b/Image32/source/Img32.FMX.pas index a2cf921..2ada3ea 100644 --- a/Image32/source/Img32.FMX.pas +++ b/Image32/source/Img32.FMX.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.4 * -* Date : 3 September 2023 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2023 * * Purpose : Image file format support for TImage32 and FMX * diff --git a/Image32/source/Img32.Fmt.BMP.pas b/Image32/source/Img32.Fmt.BMP.pas index 80c1a3e..f3c304b 100644 --- a/Image32/source/Img32.Fmt.BMP.pas +++ b/Image32/source/Img32.Fmt.BMP.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.4 * -* Date : 8 May 2024 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2024 * * Purpose : BMP file format extension for TImage32 * diff --git a/Image32/source/Img32.Fmt.GIF.pas b/Image32/source/Img32.Fmt.GIF.pas index ea92178..b116e5c 100644 --- a/Image32/source/Img32.Fmt.GIF.pas +++ b/Image32/source/Img32.Fmt.GIF.pas @@ -1,8 +1,8 @@ unit Img32.Fmt.GIF; (******************************************************************************* * Author : Angus Johnson * -* Version : 4.4 * -* Date : 12 March 2023 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2023 * * Purpose : GIF file format extension for TImage32 * diff --git a/Image32/source/Img32.Fmt.JPG.pas b/Image32/source/Img32.Fmt.JPG.pas index 4d9a97f..df84ee0 100644 --- a/Image32/source/Img32.Fmt.JPG.pas +++ b/Image32/source/Img32.Fmt.JPG.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.4 * -* Date : 12 March 2023 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2023 * * Purpose : JPG/JPEG file format extension for TImage32 * diff --git a/Image32/source/Img32.Fmt.PNG.pas b/Image32/source/Img32.Fmt.PNG.pas index 2e02836..cce6ad0 100644 --- a/Image32/source/Img32.Fmt.PNG.pas +++ b/Image32/source/Img32.Fmt.PNG.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.4 * -* Date : 9 May 2023 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2023 * * Purpose : PNG file format extension for TImage32 * diff --git a/Image32/source/Img32.Fmt.QOI.pas b/Image32/source/Img32.Fmt.QOI.pas index 303ffe4..dd047d1 100644 --- a/Image32/source/Img32.Fmt.QOI.pas +++ b/Image32/source/Img32.Fmt.QOI.pas @@ -1,8 +1,8 @@ unit Img32.Fmt.QOI; (******************************************************************************* * Author : Angus Johnson * -* Version : 4.4 * -* Date : 12 March 2023 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2023 * * Purpose : QOI file format extension for TImage32 * diff --git a/Image32/source/Img32.Fmt.SVG.pas b/Image32/source/Img32.Fmt.SVG.pas index 0617c67..dbe218c 100644 --- a/Image32/source/Img32.Fmt.SVG.pas +++ b/Image32/source/Img32.Fmt.SVG.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.4 * -* Date : 16 March 2024 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2024 * * Purpose : SVG file format extension for TImage32 * diff --git a/Image32/source/Img32.Layers.pas b/Image32/source/Img32.Layers.pas index 4af414f..fffde8c 100644 --- a/Image32/source/Img32.Layers.pas +++ b/Image32/source/Img32.Layers.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.5 * -* Date : 26 July 2024 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2024 * * Purpose : Layered images support * diff --git a/Image32/source/Img32.Panels.pas b/Image32/source/Img32.Panels.pas index acfb92c..1573921 100644 --- a/Image32/source/Img32.Panels.pas +++ b/Image32/source/Img32.Panels.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.4 * -* Date : 24 April 2024 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2024 * * Purpose : Component that displays images on a TPanel descendant * diff --git a/Image32/source/Img32.Resamplers.pas b/Image32/source/Img32.Resamplers.pas index 4beeb65..3630e59 100644 --- a/Image32/source/Img32.Resamplers.pas +++ b/Image32/source/Img32.Resamplers.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.4 * -* Date : 3 July 2024 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2024 * * Purpose : For image transformations (scaling, rotating etc.) * diff --git a/Image32/source/Img32.SVG.Core.pas b/Image32/source/Img32.SVG.Core.pas index 1c66757..5452027 100644 --- a/Image32/source/Img32.SVG.Core.pas +++ b/Image32/source/Img32.SVG.Core.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.5 * -* Date : 17 July 2024 * +* Version : 4.6 * +* Date : 18 September 2024 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2024 * * * @@ -108,22 +108,29 @@ TSVGFontInfo = record 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; + FItems: array of TClassStyleListItem; + FBuckets: TArrayOfInteger; + FCount: Integer; + FMod: Cardinal; + procedure Grow(NewCapacity: Integer = -1); + function FindItemIndex(Hash: Cardinal; 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 +172,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,7 +183,7 @@ 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; @@ -193,7 +201,7 @@ TSvgParser = class svgStream : TMemoryStream; procedure ParseUtf8Stream; public - classStyles :TClassStylesList; + classStyles : TClassStylesList; xmlHeader : TXmlEl; docType : TDocTypeEl; svgTree : TSvgTreeEl; @@ -213,13 +221,17 @@ 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; @@ -228,8 +240,10 @@ TSvgParser = class 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 ToTrimmedUTF8String(var c: PUTF8Char; endC: PUTF8Char): UTF8String; + procedure ToUTF8String(c, endC: PUTF8Char; var S: UTF8String); + 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); @@ -242,7 +256,8 @@ 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} procedure ConvertUnicodeToUtf8(memStream: TMemoryStream); @@ -255,7 +270,7 @@ TSvgParser = class TSetOfUTF8Char = set of UTF8Char; UTF8Strings = array of UTF8String; -function CharInSet(chr: UTF8Char; chrs: TSetOfUTF8Char): Boolean; +function CharInSet(chr: UTF8Char; const chrs: TSetOfUTF8Char): Boolean; const clInvalid = $00010001; @@ -269,22 +284,46 @@ function CharInSet(chr: UTF8Char; chrs: TSetOfUTF8Char): Boolean; {$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; + + PPColorConstMapItem = ^PColorConstMapItem; + PColorConstMapItem = ^TColorConstMapItem; + TColorConstMapItem = record + Hash: Cardinal; + Next: PColorConstMapItem; + Data: PColorConst; end; - TColorObj = class - cc: TColorConst; + 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; @@ -372,6 +411,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; @@ -390,6 +447,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} @@ -400,7 +458,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; @@ -413,8 +560,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; @@ -431,8 +577,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; @@ -484,141 +629,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); @@ -629,7 +885,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} @@ -649,152 +914,281 @@ 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 beyong 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; //------------------------------------------------------------------------------ @@ -823,61 +1217,76 @@ function ExtractRef(const href: UTF8String): UTF8String; {$IFDEF INLINE} inline; if c^ = '#' then inc(c); c2 := c; while (c < endC) and (c^ <> ')') do inc(c); - Result := ToUTF8String(c2, c); + ToUTF8String(c2, c, Result); end; //------------------------------------------------------------------------------ function ParseNextChar(var c: PUTF8Char; endC: PUTF8Char): UTF8Char; +var + cc: PUTF8Char; begin - Result := #0; - if not SkipBlanks(c, endC) then Exit; - Result := c^; - inc(c); + cc := SkipBlanksEx(c, endC); + if cc >= endC then + Result := #0 + else + begin + Result := cc^; + c := cc + 1; + end; end; //------------------------------------------------------------------------------ -function ParseQuoteChar(var c: PUTF8Char; endC: PUTF8Char): UTF8Char; +procedure ToTrimmedUTF8String(c, endC: PUTF8Char; var S: UTF8String); +var + len: integer; begin - if SkipBlanks(c, endC) and (c^ in [quote, dquote]) then - begin - Result := c^; - inc(c); - end else - Result := #0; + // trim left + while (c < endC) and (c^ <= #32) do Inc(c); + // trim right + while (endC > c) and (endC[-1] <= #32) do Dec(endC); + + len := endC - c; + SetLength(S, len); + if len = 0 then Exit; + Move(c^, PUTF8Char(S)^, len * SizeOf(UTF8Char)); end; //------------------------------------------------------------------------------ -function ToTrimmedUTF8String(var c: PUTF8Char; endC: PUTF8Char): UTF8String; +procedure ToUTF8String(c, endC: PUTF8Char; var S: UTF8String); var len: integer; - start: PUTF8Char; begin - start := c; - c := endC; - if endC > start then - begin - // trim left - while (start < endC) and (start^ <= #32) do Inc(start); - // trim right - while (endC > start) and (endC[-1] <= #32) do Dec(endC); - end; - - len := endC - start; - SetLength(Result, len); + len := endC - c; + SetLength(S, len); if len = 0 then Exit; - Move(start^, Result[1], len * SizeOf(UTF8Char)); + Move(c^, PUTF8Char(S)^, len * SizeOf(UTF8Char)); end; //------------------------------------------------------------------------------ -function ToUTF8String(var c: PUTF8Char; endC: PUTF8Char): UTF8String; +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(Result, len); + 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; //------------------------------------------------------------------------------ @@ -885,13 +1294,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); @@ -910,7 +1317,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; //------------------------------------------------------------------------------ @@ -934,7 +1341,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; //------------------------------------------------------------------------------ @@ -1056,6 +1463,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); @@ -1087,14 +1495,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; @@ -1215,16 +1624,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 @@ -1286,9 +1695,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 @@ -1332,9 +1740,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 @@ -1360,42 +1768,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(aclassName); - AddName(Lowercase(String(aclassName))); - if PeekNextChar(c, endC) = ',' then + 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 := ToTrimmedUTF8String(c2, c); + 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 High(names) do + for i := 0 to len - 1 do stylesList.AddAppendStyle(names[i], aStyle); end; - names := nil; - len := 0; cap := 0; + // 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 +1850,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,26 +1859,14 @@ 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); @@ -1470,40 +1876,57 @@ function TXmlEl.ParseHeader(var c: PUTF8Char; endC: PUTF8Char): Boolean; 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); + 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,28 +1942,34 @@ 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; @@ -1595,23 +2024,31 @@ procedure TXmlEl.ParseStyleAttribute(const style: UTF8String); 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 := ToTrimmedUTF8String(c2, c); + ToTrimmedUTF8String(c2, c, styleVal); inc(c); - new(attrib); + attrib := NewSvgAttrib(); attrib.name := styleName; attrib.value := styleVal; attrib.hash := GetHash(attrib.name); @@ -1636,7 +2073,7 @@ function TXmlEl.ParseContent(var c: PUTF8Char; endC: PUTF8Char): Boolean; var child: TSvgTreeEl; entity: PSvgAttrib; - c2, tmpC, tmpEndC: PUTF8Char; + c2, cc, tmpC, tmpEndC: PUTF8Char; begin Result := false; while SkipBlanks(c, endC) do @@ -1647,43 +2084,47 @@ 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 @@ -1712,24 +2153,28 @@ function TXmlEl.ParseContent(var c: PUTF8Char; endC: PUTF8Char): Boolean; //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; + cc := c; + tmpC := cc; //preserve a leading space if (tmpC -1)^ = space then dec(tmpC); - while (c < endC) and (c^ <> '<') do inc(c); + while (cc < endC) and (cc^ <> '<') do inc(cc); if (hash = hTextPath) then begin - text := ToUTF8String(tmpC, c); + ToUTF8String(tmpC, cc, text); end else begin child := TSvgTreeEl.Create(owner); childs.Add(child); - child.text := ToUTF8String(tmpC, c); + ToUTF8String(tmpC, cc, child.text); end; + c := cc; end else begin - tmpC := c; - while (c < endC) and (c^ <> '<') do inc(c); - text := ToUTF8String(tmpC, c); + cc := c; + tmpC := cc; + while (cc < endC) and (cc^ <> '<') do inc(cc); + ToUTF8String(tmpC, cc, text); + c := cc; //if

SVGIconImageList License

Three engines to render SVG (Delphi Image32, Skia4Delphi, Direct2D wrapper) and four components to simplify use of SVG images (resize, fixedcolor, grayscale…)

-

Actual official version 4.1.9 (VCL+FMX)

+

Actual official version 4.2.0 (VCL+FMX)

@@ -126,6 +126,11 @@

DOCUMENTATION

Other similar library

A similar project made by Ethea for Icon Fonts: https://github.com/EtheaDev/IconFontsImageList

RELEASE NOTES

+

12 Oct 2024: versione 4.2.0 (VCL+FMX)

+
    +
  • Updated to Image32 4.6 Released 12 Oct 2024 to fix some drawing issue
    • +
  • Added components info into About and Splash Screen
    • +

14 Sep 2024: version 4.1.9 (VCL+FMX)

  • Aligned to Image32 4.5 Version of 14 September 2024
    • diff --git a/README.md b/README.md index 63732df..921af0e 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ ## Three engines to render SVG (Delphi Image32, Skia4Delphi, Direct2D wrapper) and four components to simplify use of SVG images (resize, fixedcolor, grayscale...) -### Actual official version 4.1.9 (VCL+FMX) +### Actual official version 4.2.0 (VCL+FMX) | Component | Description | | - | - | @@ -90,6 +90,10 @@ Follow the [guide in Wiki section](https://github.com/EtheaDev/SVGIconImageList/ A similar project made by Ethea for Icon Fonts: [https://github.com/EtheaDev/IconFontsImageList](https://github.com/EtheaDev/IconFontsImageList) ### RELEASE NOTES +12 Oct 2024: versione 4.2.0 (VCL+FMX) +- Updated to Image32 4.6 Released 12 Oct 2024 to fix some drawing issue +- Added components info into About and Splash Screen + 14 Sep 2024: version 4.1.9 (VCL+FMX) - Aligned to Image32 4.5 Version of 14 September 2024 - Fixed Range Error rendering some icons (Image32 engine) diff --git a/Source/FMX.SVGIconImageList.pas b/Source/FMX.SVGIconImageList.pas index 5673af6..712d6cc 100644 --- a/Source/FMX.SVGIconImageList.pas +++ b/Source/FMX.SVGIconImageList.pas @@ -47,7 +47,7 @@ interface ; const - SVGIconImageListVersion = '4.1.9'; + SVGIconImageListVersion = '4.2.0'; DEFAULT_SIZE = 32; ZOOM_DEFAULT = 100; SVG_INHERIT_COLOR = TAlphaColors.Null; diff --git a/Source/SVGIconImageListBase.pas b/Source/SVGIconImageListBase.pas index 28d634d..52fbe6b 100644 --- a/Source/SVGIconImageListBase.pas +++ b/Source/SVGIconImageListBase.pas @@ -48,7 +48,7 @@ interface SvgInterfaces; const - SVGIconImageListVersion = '4.1.9'; + SVGIconImageListVersion = '4.2.0'; DEFAULT_SIZE = 16; type
Component