diff --git a/Debug/Preview Handlers/PreviewHandler Host/PreviewHost.dproj b/Debug/Preview Handlers/PreviewHandler Host/PreviewHost.dproj index 115515b..4c80a4c 100644 --- a/Debug/Preview Handlers/PreviewHandler Host/PreviewHost.dproj +++ b/Debug/Preview Handlers/PreviewHandler Host/PreviewHost.dproj @@ -1,7 +1,7 @@  {4BBCE26D-2844-4147-BD21-3D736FC10602} - 19.3 + 19.5 VCL PreviewHost.dpr True @@ -45,6 +45,12 @@ Base true + + true + Cfg_2 + true + true + true Cfg_2 @@ -56,10 +62,10 @@ $(BDS)\bin\delphi_PROJECTICON.ico fmx;IndySystem;DBXInterBaseDriver;DataSnapClient;DataSnapCommon;DataSnapServer;DataSnapProviderClient;DbxCommonDriver;dbxcds;DBXOracleDriver;CustomIPTransport;dsnap;fmxase;IndyCore;CloudService;inetdbxpress;IPIndyImpl;bindcompfmx;rtl;dbrtl;DbxClientDriver;bindcomp;inetdb;xmlrtl;ibxpress;IndyProtocols;DBXMySQLDriver;bindengine;soaprtl;DBXInformixDriver;DBXFirebirdDriver;inet;fmxobj;DBXSybaseASADriver;fmxdae;dbexpress;DataSnapIndy10ServerTransport;$(DCC_UsePackage) .\$(Platform)\$(Config) - .\Bin PreviewHost 1040 CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) + D:\ETHEA\ShellControls\Source;$(DCC_UnitSearchPath) JvGlobus;JvMM;JvManagedThreads;JvDlgs;JvCrypt;vclib;inetdbbde;acntDelphiXE2_R;JvNet;JvDotNetCtrls;DBXSybaseASEDriver;vclimg;fmi;vclshlctrls;JvXPCtrls;vcldb;sample;vcldsnap;DBXDb2Driver;JvCore;vclribbon;vcl;DBXMSSQLDriver;JvAppFrm;JvDB;JvRuntimeDesign;webdsnap;JclDeveloperTools;JvDocking;adortl;JvWizards;mbColorLibDXE2;JvHMI;JvBands;vcldbx;JvPluginSystem;JclContainers;DBXOdbcDriver;JvCmp;JvSystem;svnui;SynEdit_RXE2;JvControls;JvTimeFramework;vclactnband;JvJans;JvPrintPreview;JvPageComps;bindcompvcl;JvStdCtrls;JvCustom;Jcl;vclie;vcltouch;websnap;VclSmp;DataSnapConnectors;dsnapcon;JclVcl;JvPascalInterpreter;vclx;svn;bdertl;EurekaLogCore;JvBDE;$(DCC_UsePackage) @@ -67,9 +73,9 @@ Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) 1033 $(BDS)\bin\default_app.manifest - true $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png PerMonitorV2 + .\Bin $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png @@ -83,6 +89,8 @@ 1033 $(BDS)\bin\default_app.manifest D:\ETHEA\SVGIconImageList\Demo\NewSydneyVectors + none + .\Bin64 DEBUG;$(DCC_Define) @@ -90,20 +98,18 @@ true true true - 1040 - CompanyName=;FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProductVersion=1.0.0.0;Comments=;ProgramID=com.embarcadero.$(MSBuildProjectName);FileDescription=$(MSBuildProjectName);ProductName=$(MSBuildProjectName) false Debug true 1033 - true - D:\ETHEA\ShellControls\Source;$(DCC_UnitSearchPath) - true PerMonitorV2 + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= false @@ -111,9 +117,15 @@ 0 0 + + true + 1033 + - true PerMonitorV2 + true + 1033 + CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= @@ -168,15 +180,12 @@ 1.0.0.0 - - Microsoft Office 2000 Sample Automation Server Wrapper Components - Microsoft Office XP Sample Automation Server Wrapper Components - + PreviewHost.dpr - + True True diff --git a/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas b/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas index 95fa0c7..5f1e192 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.CQ.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 22 December 2021 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2021 * * Purpose : Color reduction for TImage32 * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Clipper.pas b/Ext/SVGIconImageList/Image32/source/Img32.Clipper2.pas similarity index 81% rename from Ext/SVGIconImageList/Image32/source/Img32.Clipper.pas rename to Ext/SVGIconImageList/Image32/source/Img32.Clipper2.pas index ef124bb..d4658c9 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Clipper.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Clipper2.pas @@ -1,11 +1,11 @@ -unit Img32.Clipper; +unit Img32.Clipper2; (******************************************************************************* * Author : Angus Johnson * -* Version : 2.24 * -* Date : 26 June 2021 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2021 * +* Copyright : Angus Johnson 2019-2022 * * Purpose : Wrapper module for the Clipper library * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) @@ -13,7 +13,6 @@ interface uses - Clipper, Clipper.Core, Clipper.Engine, Clipper.Offset, Img32, Img32.Draw, Img32.Vector; //nb: InflatePath assumes that there's consistent winding where @@ -48,14 +47,16 @@ function DifferencePolygons(const polygons1, polygons2: TPathsD; implementation +uses Clipper, Clipper.Core, Clipper.Engine, Clipper.Offset; + //------------------------------------------------------------------------------ //------------------------------------------------------------------------------ -function InflatePath(const path: TPathD; +function InflatePath(const path: Img32.TPathD; delta: Double; joinStyle: TJoinStyle; endStyle: TEndStyle; - miterLimit: double; arcTolerance: double; minEdgeLength: double): TPathsD; + miterLimit: double; arcTolerance: double; minEdgeLength: double): Img32.TPathsD; var - paths: TPathsD; + paths: Img32.TPathsD; begin setLength(paths, 1); paths[0] := path; @@ -64,9 +65,9 @@ function InflatePath(const path: TPathD; end; //------------------------------------------------------------------------------ -function InflatePaths(const paths: TPathsD; +function InflatePaths(const paths: Img32.TPathsD; delta: Double; joinStyle: TJoinStyle; endStyle: TEndStyle; - miterLimit: double; arcTolerance: double; minEdgeLength: double): TPathsD; + miterLimit: double; arcTolerance: double; minEdgeLength: double): Img32.TPathsD; var jt: Clipper.Offset.TJoinType; et: TEndType; @@ -89,7 +90,8 @@ function InflatePaths(const paths: TPathsD; end; //------------------------------------------------------------------------------ -function UnionPolygon(const polygon: TPathD; fillRule: TFillRule): TPathsD; +function UnionPolygon(const polygon: Img32.TPathD; + fillRule: Img32.Vector.TFillRule): Img32.TPathsD; begin with TClipperD.Create do try @@ -102,8 +104,8 @@ function UnionPolygon(const polygon: TPathD; fillRule: TFillRule): TPathsD; end; //------------------------------------------------------------------------------ -function UnionPolygons(const polygons: TPathsD; - fillRule: TFillRule): TPathsD; +function UnionPolygons(const polygons: Img32.TPathsD; + fillRule: Img32.Vector.TFillRule): Img32.TPathsD; begin with TClipperD.Create do try @@ -116,8 +118,8 @@ function UnionPolygons(const polygons: TPathsD; end; //------------------------------------------------------------------------------ -function UnionPolygons(const polygon1, polygon2: TPathD; - fillRule: TFillRule): TPathsD; +function UnionPolygons(const polygon1, polygon2: Img32.TPathD; + fillRule: Img32.Vector.TFillRule): Img32.TPathsD; begin with TClipperD.Create do try @@ -131,8 +133,8 @@ function UnionPolygons(const polygon1, polygon2: TPathD; end; //------------------------------------------------------------------------------ -function UnionPolygons(const polygons1, polygons2: TPathsD; - fillRule: TFillRule): TPathsD; +function UnionPolygons(const polygons1, polygons2: Img32.TPathsD; + fillRule: Img32.Vector.TFillRule): Img32.TPathsD; begin with TClipperD.Create do try @@ -146,8 +148,8 @@ function UnionPolygons(const polygons1, polygons2: TPathsD; end; //------------------------------------------------------------------------------ -function IntersectPolygons(const polygons1, polygons2: TPathsD; - fillRule: TFillRule): TPathsD; +function IntersectPolygons(const polygons1, polygons2: Img32.TPathsD; + fillRule: Img32.Vector.TFillRule): Img32.TPathsD; begin with TClipperD.Create do try @@ -161,8 +163,8 @@ function IntersectPolygons(const polygons1, polygons2: TPathsD; end; //------------------------------------------------------------------------------ -function DifferencePolygons(const polygons1, polygons2: TPathsD; - fillRule: TFillRule): TPathsD; +function DifferencePolygons(const polygons1, polygons2: Img32.TPathsD; + fillRule: Img32.Vector.TFillRule): Img32.TPathsD; begin with TClipperD.Create do try diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas b/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas index d4cded6..f6d9d3a 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Draw.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 22 December 2021 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2021 * * * @@ -21,8 +21,7 @@ interface {.$DEFINE MemCheck} //for debugging only (adds a minimal cost to performance) uses - SysUtils, Classes, Types, Math, Img32, Img32.Vector, - Img32.Transform; //experimental; + SysUtils, Classes, Types, Math, Img32, Img32.Vector; type TFillRule = Img32.Vector.TFillRule; @@ -1028,13 +1027,23 @@ procedure Rasterize(const paths: TPathsD; const clipRec: TRect; end; frPositive: begin +{$IFDEF REVERSE_ORIENTATION} + if accum < -0.002 then + byteBuffer[j] := Min(255, Round(-accum * 318)); +{$ELSE} if accum > 0.002 then byteBuffer[j] := Min(255, Round(accum * 318)); +{$ENDIF} end; frNegative: begin +{$IFDEF REVERSE_ORIENTATION} + if accum > 0.002 then + byteBuffer[j] := Min(255, Round(accum * 318)); +{$ELSE} if accum < -0.002 then byteBuffer[j] := Min(255, Round(-accum * 318)); +{$ENDIF} end; end; end; diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas b/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas index 9765399..60f9664 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Extra.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 22 December 2021 * +* Version : 4.2 * +* Date : 28 July 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2021 * * * @@ -16,7 +16,6 @@ *******************************************************************************) interface - {$I Img32.inc} uses @@ -97,6 +96,7 @@ procedure EraseColor(img: TImage32; color: TColor32); procedure RedEyeRemove(img: TImage32; const rect: TRect); procedure PencilEffect(img: TImage32; intensity: integer = 0); + procedure TraceContours(img: TImage32; intensity: integer); procedure EraseInsidePath(img: TImage32; @@ -135,20 +135,18 @@ function Vectorize(img: TImage32; compareColor: TColor32; function VectorizeMask(const mask: TArrayOfByte; maskWidth: integer): TPathsD; -//RamerDouglasPeucker: simplifies paths, recursively removing vertices where -//they deviate no more than 'epsilon' from their adjacent vertices. +// RamerDouglasPeucker: simplifies paths, recursively removing vertices where +// they deviate no more than 'epsilon' from their adjacent vertices. function RamerDouglasPeucker(const path: TPathD; epsilon: double): TPathD; overload; function RamerDouglasPeucker(const paths: TPathsD; epsilon: double): TPathsD; overload; -//SmoothToBezier: this function is based on - -//"An Algorithm for Automatically Fitting Digitized Curves" -//by Philip J. Schneider in "Graphics Gems", Academic Press, 1990 -function SmoothToBezier(const path: TPathD; closed: Boolean; - tolerance: double; minSegLength: double = 2): TPathD; overload; -function SmoothToBezier(const paths: TPathsD; closed: Boolean; - tolerance: double; minSegLength: double = 2): TPathsD; overload; +// SmoothToCubicBezier - produces a series of cubic bezier control points. +// This function is very useful in the following combination: +// RamerDouglasPeucker(), SmoothToCubicBezier(), FlattenCBezier(). +function SmoothToCubicBezier(const path: TPathD; + pathIsClosed: Boolean; maxOffset: integer = 0): TPathD; //InterpolatePoints: smooths a simple line chart. //Points should be left to right and equidistant along the X axis @@ -168,8 +166,10 @@ implementation uses {$IFNDEF MSWINDOWS} + {$IFNDEF FPC} Img32.FMX, {$ENDIF} + {$ENDIF} Img32.Transform; const @@ -179,11 +179,9 @@ implementation type PColor32Array = ^TColor32Array; TColor32Array = array [0.. maxint div SizeOf(TColor32) -1] of TColor32; - PWeightedColorArray = ^TWeightedColorArray; TWeightedColorArray = array [0.. $FFFFFF] of TWeightedColor; - //------------------------------------------------------------------------------ // Miscellaneous functions //------------------------------------------------------------------------------ @@ -214,16 +212,13 @@ function GetSymmetricCropTransparentRect(img: TImage32): TRect; end; if opaquePxlFound then break; end; - - //probably safeset not to resize empty images + // probably safeset not to resize empty images if not opaquePxlFound then Exit; - if y1 > 0 then begin inc(Result.Top, y1); dec(Result.Bottom, y1); end; - x1 := 0; h := RectHeight(Result); opaquePxlFound := false; @@ -243,7 +238,6 @@ function GetSymmetricCropTransparentRect(img: TImage32): TRect; end; if opaquePxlFound then break; end; - if not opaquePxlFound then Exit; inc(Result.Left, x1); dec(Result.Right, x1); @@ -282,7 +276,6 @@ procedure DrawEdge(img: TImage32; const rec: TRectD; bottomRightColor := c; penWidth := -penWidth; end; - if topLeftColor <> bottomRightColor then begin with rec do @@ -308,7 +301,6 @@ procedure DrawEdge(img: TImage32; const path: TPathD; const RadToDeg = 180/PI; begin - if penWidth = 0 then Exit else if penWidth < 0 then begin @@ -317,7 +309,6 @@ procedure DrawEdge(img: TImage32; const path: TPathD; bottomRightColor := c; penWidth := -penWidth; end; - highI := high(path); if highI < 2 then Exit; p := path; @@ -326,7 +317,6 @@ procedure DrawEdge(img: TImage32; const path: TPathD; AppendPath(p, p[0]); inc(highI); end; - for i := 1 to highI do begin deg := Round(GetAngle(p[i-1], p[i]) * RadToDeg); @@ -397,19 +387,16 @@ procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double; ss.Y := depth * yy; sX := Abs(Round(ss.X)); sY := Abs(Round(ss.Y)); - if rec.Left + ss.X < 0 then ss.X := -rec.Left else if rec.Right + ss.X > img.Width then ss.X := img.Width - rec.Right -1; if rec.Top + ss.Y < 0 then ss.Y := -rec.Top else if rec.Bottom + ss.Y > img.Height then ss.Y := img.Height -rec.Bottom -1; - tmpImg := TImage32.Create(sX*3 +1, sY*3 +1); try i := sX div 2; j := sY div 2; DrawPolygon(tmpImg, Rectangle(i,j,i+sX*2,j+sY*2), frNonZero, color); FastGaussianBlur(tmpImg, tmpImg.Bounds, Round(sX/4),Round(sY/4), 1); - - //t-l corner + // t-l corner if (ss.X < 0) or (ss.Y < 0) then begin tmpRec := Rect(0, 0, sX, sY); @@ -418,8 +405,7 @@ procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double; if ss.Y < 0 then dec(t, sY); img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY)); end; - - //t-r corner + // t-r corner if (ss.X > 0) or (ss.Y < 0) then begin tmpRec := Rect(sX*2+1, 0, sX*3+1, sY); @@ -428,8 +414,7 @@ procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double; if ss.Y < 0 then dec(t, sY); img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY)); end; - - //b-l corner + // b-l corner if (ss.X < 0) or (ss.Y > 0) then begin tmpRec := Rect(0, sY*2+1, sX, sY*3+1); @@ -438,8 +423,7 @@ procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double; if ss.Y < 0 then dec(t, sY); img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY)); end; - - //b-r corner + // b-r corner if (ss.X > 0) or (ss.Y > 0) then begin tmpRec := Rect(sX*2+1, sY*2+1, sX*3+1, sY*3+1); @@ -448,8 +432,7 @@ procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double; if ss.Y < 0 then dec(t, sY); img.Copy(tmpImg, tmpRec, Rect(l,t,l+sX,t+sY)); end; - - //l-edge + // l-edge if (ss.X < 0) then begin l := rec.Left; t := rec.Top+sY; b := rec.Bottom-1; @@ -460,8 +443,7 @@ procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double; FillColorVert(img, l-i, t, b, c); end; end; - - //t-edge + // t-edge if (ss.Y < 0) then begin l := rec.Left+sX; r := rec.Right-1; t := rec.Top; @@ -472,8 +454,7 @@ procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double; FillColorHorz(img, l, r, t-i, c); end; end; - - //r-edge + // r-edge if (ss.X > 0) then begin r := rec.Right-1; t := rec.Top+sY; b := rec.Bottom-1; @@ -484,8 +465,7 @@ procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double; FillColorVert(img, r+i, t, b, c); end; end; - - //b-edge + // b-edge if (ss.Y > 0) then begin l := rec.Left+sX; r := rec.Right-1; b := rec.Bottom-1; @@ -496,7 +476,6 @@ procedure DrawShadowRect(img: TImage32; const rec: TRect; depth: double; FillColorHorz(img, l, r, b+i, c); end; end; - finally tmpImg.Free; end; @@ -600,7 +579,6 @@ procedure TileImage(img: TImage32; dstRec, srcRec: TRect; begin if tile.IsEmpty or IsEmptyRect(tileRec) then Exit; - RectWidthHeight(rec, dstW,dstH); RectWidthHeight(tileRec, srcW, srcH); cnt := Ceil(dstW / srcW); @@ -611,11 +589,9 @@ procedure TileImage(img: TImage32; img.Copy(tile, tileRec, dstRec); Types.OffsetRect(dstRec, srcW, 0); end; - cnt := Ceil(dstH / srcH) -1; srcRec := Img32.Vector.Rect(rec.Left, rec.Top, rec.Right, rec.Top + srcH); - dstRec := srcRec; for i := 1 to cnt do begin @@ -638,8 +614,7 @@ procedure Sharpen(img: TImage32; radius: Integer; amount: Integer); radius := ClampRange(radius, 1, 10); for i := -255 to 255 do weightAmount[i] := Round(amt * i); - - bmpBlur := TImage32.Create(img); //clone self + bmpBlur := TImage32.Create(img); // clone self try pColor := PARGB(img.pixelBase); FastGaussianBlur(bmpBlur, bmpBlur.Bounds, radius, 2); @@ -755,7 +730,7 @@ function ColorDifference(color1, color2: TColor32): cardinal; c2: TARGB absolute color2; begin result := Abs(c1.R - c2.R) + Abs(c1.G - c2.G) + Abs(c1.B - c2.B); - result := (result * 341) shr 10; //divide by 3 + result := (result * 341) shr 10; // divide by 3 end; //------------------------------------------------------------------------------ @@ -782,7 +757,6 @@ procedure EraseColor(img: TImage32; color: TColor32); begin if fg.A = 0 then Exit; bg := PARGB(img.PixelBase); - for i := 0 to img.Width * img.Height -1 do begin if bg.A > 0 then @@ -822,30 +796,28 @@ procedure RedEyeRemove(img: TImage32; const rect: TRect); else k := 4; cutoutRec := rect; Img32.Vector.InflateRect(cutoutRec, k, k); - cutout := TImage32.Create(img, cutoutRec); mask := TImage32.Create(cutout.Width, cutout.Height); radGrad := TRadialGradientRenderer.Create; try - //fill behind the cutout with black also - //blurring the fill to soften its edges + // fill behind the cutout with black also + // blurring the fill to soften its edges rect3 := cutout.Bounds; Img32.Vector.InflateRect(rect3, -k, -k); path := Ellipse(rect3); DrawPolygon(mask, path, frNonZero, clBlack32); - //given the very small area and small radius of the blur, the - //speed improvement of BoxBlur over GaussianBlur is inconsequential. + // given the very small area and small radius of the blur, the + // speed improvement of BoxBlur over GaussianBlur is inconsequential. GaussianBlur(mask, mask.Bounds, k); img.CopyBlend(mask, mask.Bounds, cutoutRec, BlendToOpaque); - - //gradient fill to clNone32 a mask to soften cutout's edges + // gradient fill to clNone32 a mask to soften cutout's edges path := Ellipse(cutoutRec); radGrad.SetParameters(rect3, clBlack32, clNone32); DrawPolygon(mask, path, frNonZero, radGrad); cutout.CopyBlend(mask, mask.Bounds, cutout.Bounds, BlendMask); - //now remove red from the cutout + // now remove red from the cutout EraseColor(cutout, clRed32); - //finally replace the cutout ... + // finally replace the cutout ... img.CopyBlend(cutout, cutout.Bounds, cutoutRec, BlendToOpaque); finally mask.Free; @@ -948,7 +920,6 @@ procedure Draw3D(img: TImage32; const polygons: TPathsD; EraseOutsidePaths(tmp, paths, fillRule, tmp.Bounds); img.CopyBlend(tmp, tmp.Bounds, rec, BlendToAlpha); end; - if GetAlpha(colorDk) > 0 then begin tmp.Clear(colorDk); @@ -1030,11 +1001,9 @@ function DrawButton(img: TImage32; const pt: TPointD; if (size < 5) then Exit; radius := size * 0.5; lightSize := radius * 0.25; - rec := RectD(pt.X -radius, pt.Y -radius, pt.X +radius, pt.Y +radius); if baEraseBeneath in buttonAttributes then img.Clear(Rect(rec)); - case buttonShape of bsDiamond: begin @@ -1054,18 +1023,15 @@ function DrawButton(img: TImage32; const pt: TPointD; Result := Ellipse(rec); end; lightAngle := angle225; - img.BeginUpdate; try - //nb: only need to cutout the inside shadow if - //the pending color fill is semi-transparent + // nb: only need to cutout the inside shadow if + // the pending color fill is semi-transparent if baShadow in buttonAttributes then DrawShadow(img, Result, frNonZero, lightSize *2, (lightAngle + angle180), $AA000000, GetAlpha(color) < $FE); - if GetAlpha(color) > 2 then DrawPolygon(img, Result, frNonZero, color); - if ba3D in buttonAttributes then Draw3D(img, Result, frNonZero, lightSize*2, Ceil(lightSize), $CCFFFFFF, $AA000000, lightAngle); @@ -1073,7 +1039,6 @@ function DrawButton(img: TImage32; const pt: TPointD; finally img.EndUpdate; end; - end; //------------------------------------------------------------------------------ @@ -1166,7 +1131,6 @@ procedure TraceContours(img: TImage32; intensity: integer); end; inc(s); inc(d); end; - for j := 0 to w-1 do begin s := @tmp[j]; d := @tmp2[j]; @@ -1178,17 +1142,14 @@ procedure TraceContours(img: TImage32; intensity: integer); end; end; Move(tmp2[0], img.PixelBase^, w * h * sizeOf(TColor32)); - if intensity < 1 then Exit; if intensity > 10 then - intensity := 10; //range = 1-10 + intensity := 10; // range = 1-10 img.ScaleAlpha(intensity); end; - //------------------------------------------------------------------------------ // FLOODFILL - AND SUPPORT FUNCTIONS //------------------------------------------------------------------------------ - type PFloodFillRec = ^TFloodFillRec; TFloodFillRec = record @@ -1198,7 +1159,6 @@ TFloodFillRec = record dirY : Integer; next : PFloodFillRec; end; - TFloodFillStack = class first : PFloodFillRec; maxY : integer; @@ -1208,7 +1168,6 @@ TFloodFillStack = class procedure Pop(out xLeft, xRight,y, direction: Integer); function IsEmpty: Boolean; end; - TFloodFillMask = class private img : TImage32; @@ -1224,17 +1183,14 @@ TFloodFillMask = class procedure SetCurrentY(y: Integer); function IsMatch(x: Integer): Boolean; end; - //------------------------------------------------------------------------------ // TFloodFillStack methods //------------------------------------------------------------------------------ - constructor TFloodFillStack.Create(maxY: integer); begin self.maxY := maxY; end; //------------------------------------------------------------------------------ - destructor TFloodFillStack.Destroy; var ffr: PFloodFillRec; @@ -1282,7 +1238,6 @@ function TFloodFillStack.IsEmpty: Boolean; begin result := not assigned(first); end; - //------------------------------------------------------------------------------ // TFloodFillMask methods //------------------------------------------------------------------------------ @@ -1299,35 +1254,30 @@ function TFloodFillMask.Execute(imgIn, imgMaskOut: TImage32; x,y: integer; Result := Assigned(imgIn) and Assigned(imgMaskOut) and InRange(x,0,imgIn.Width -1) and InRange(y,0,imgIn.Height -1); if not Result then Exit; - w := imgIn.Width; h := imgIn.Height; - //make sure the mask is the size of the image + // make sure the mask is the size of the image imgMaskOut.SetSize(w,h); - img := imgIn; mask := imgMaskOut; compareFunc := compFunc; tolerance := aTolerance; maxX := w -1; - ffs := TFloodFillStack.create(h -1); try initialColor := imgIn.Pixel[x, y]; - xl := x; xr := x; SetCurrentY(y); IsMatch(x); - while (xl > 0) and IsMatch(xl -1) do dec(xl); while (xr < maxX) and IsMatch(xr +1) do inc(xr); - ffs.Push(xl, xr, y, -1); //down - ffs.Push(xl, xr, y, 1); //up + ffs.Push(xl, xr, y, -1); // down + ffs.Push(xl, xr, y, 1); // up while not ffs.IsEmpty do begin ffs.Pop(xl, xr, y, dirY); SetCurrentY(y); xr2 := xl; - //check left ... + // check left ... if IsMatch(xl) then begin while (xl > 0) and IsMatch(xl-1) do dec(xl); @@ -1339,7 +1289,7 @@ function TFloodFillMask.Execute(imgIn, imgMaskOut: TImage32; x,y: integer; ffs.Push(xr+2, xr2, y, -dirY); xl := xr2 +2; end; - //check right ... + // check right ... while (xl <= xr) and not IsMatch(xl) do inc(xl); while (xl <= xr) do begin @@ -1413,12 +1363,10 @@ procedure FloodFill(img: TImage32; x, y: Integer; newColor: TColor32; if tolerance = 0 then tolerance := FloodFillDefaultRGBTolerance; end; - mask := TImage32.Create; try if not GetFloodFillMask(img, mask, x, y, tolerance, compareFunc) then Exit; - pc := img.PixelBase; pm := mask.PixelBase; for i := 0 to img.Width * img.Height -1 do @@ -1430,7 +1378,6 @@ procedure FloodFill(img: TImage32; x, y: Integer; newColor: TColor32; mask.free; end; end; - //------------------------------------------------------------------------------ // EMBOSS - AND SUPPORT FUNCTIONS //------------------------------------------------------------------------------ @@ -1468,32 +1415,28 @@ procedure Emboss(img: TImage32; radius: Integer; b: byte; kernel: array [0 .. MaxBlur, 0 .. MaxBlur] of Integer; wca: TArrayOfWeightedColor; - pc0, pcf, pcb: PColor32; //pointers to pixels (forward & backward in kernel) - pw0, pw: PWeightedColor; //pointers to weight + pc0, pcf, pcb: PColor32; // pointers to pixels (forward & backward in kernel) + pw0, pw: PWeightedColor; // pointers to weight customGray: TColor32; pc: PColor32; const maxDepth = 50; begin - //grayscale luminance as percent where 0% is black and 100% is white + // grayscale luminance as percent where 0% is black and 100% is white //(luminance is ignored when preserveColor = true) luminance := ClampRange(luminance, 0, 100); b := luminance *255 div 100; customGray := $FF000000 + b shl 16 + b shl 8 + b; - ClampRange(radius, 1, 5); inc(depth); ClampRange(depth, 2, maxDepth); - kernel[0][0] := 1; for y := 1 to radius do for x := 1 to radius do kernel[y][x] := depth; - w := img.Width; h := img.Height; - //nb: dynamic arrays are zero-initialized (unless they're a function result) + // nb: dynamic arrays are zero-initialized (unless they're a function result) SetLength(wca, w * h); - pc0 := IncPColor32(img.PixelBase, radius * w); pw0 := @wca[radius * w]; for y := radius to h -1 - radius do @@ -1512,8 +1455,7 @@ procedure Emboss(img: TImage32; radius: Integer; pw^.Add(customGray, kernel[0,0]); pcf := IncPColor32(pc0, x + 1); end; - - //parse the kernel ... + // parse the kernel ... for yy := 1 to radius do begin for xx := 1 to radius do @@ -1529,7 +1471,6 @@ procedure Emboss(img: TImage32; radius: Integer; inc(pc0, img.Width); inc(pw0, img.Width); end; - pc := @img.Pixels[0]; pw := @wca[0]; for x := 0 to img.width * img.Height - 1 do begin @@ -1537,14 +1478,11 @@ procedure Emboss(img: TImage32; radius: Integer; inc(pc); inc(pw); end; end; - //------------------------------------------------------------------------------ // Structure and functions used by the Vectorize routine //------------------------------------------------------------------------------ - type TPt2Container = class; - TPt2 = class pt : TPointD; owner : TPt2Container; @@ -1560,7 +1498,6 @@ TPt2 = class function GetPoints: TPathD; property IsAscending: Boolean read isStart; end; - TPt2Container = class prevRight: integer; leftMostPt, rightMost: TPt2; @@ -1573,9 +1510,7 @@ TPt2Container = class function JoinDescAsc(path1, path2: TPt2): TPt2; procedure CheckRowEnds(pt2Left, pt2Right: TPt2); end; - //------------------------------------------------------------------------------ - destructor TPt2.Destroy; var startPt, endPt, pt: TPt2; @@ -1583,8 +1518,7 @@ destructor TPt2.Destroy; if not isStart then Exit; startPt := self; endPt := startPt.prevInPath; - - //remove 'endPt' from double linked list + // remove 'endPt' from double linked list if endPt = owner.rightMost then owner.rightMost := endPt.prevInRow else if assigned(endPt.nextInRow) then @@ -1593,18 +1527,15 @@ destructor TPt2.Destroy; owner.leftMostPt := endPt.nextInRow else if assigned(endPt.prevInRow) then endPt.prevInRow.nextInRow := endPt.nextInRow; - - //remove 'startPt' from double linked list + // remove 'startPt' from double linked list if startPt = owner.leftMostPt then owner.leftMostPt := startPt.nextInRow else if assigned(startPt.prevInRow) then startPt.prevInRow.nextInRow := startPt.nextInRow; if assigned(startPt.nextInRow) then startPt.nextInRow.prevInRow := startPt.prevInRow; - owner.AddToSolution(GetPoints); - - //now Free the entire path (except self) + // now Free the entire path (except self) pt := startPt.nextInPath; while pt <> startPt do begin @@ -1617,7 +1548,7 @@ destructor TPt2.Destroy; function IsColinear(const pt1, pt2, pt3: TPoint): Boolean; overload; begin - //cross product = 0 + // cross product = 0 result := (pt1.X - pt2.X)*(pt2.Y - pt3.Y) = (pt2.X - pt3.X)*(pt1.Y - pt2.Y); end; //------------------------------------------------------------------------------ @@ -1643,41 +1574,37 @@ procedure TPt2.Update(x, y: double); var newPt2: TPt2; begin - if isStart then begin - //just update self.pt when colinear + // just update self.pt when colinear if (x = pt.X) and (pt.X = nextInPath.pt.X) then begin pt := PointD(x,y); Exit; end; - - //self -> 2 -> 1 -> nip + // self -> 2 -> 1 -> nip CreatePt2After(self, pt); if (x <> pt.X) or (x <> nextInPath.pt.X) then begin - //add a pixel either below or beside + // add a pixel either below or beside if IsAscending then CreatePt2After(self, PointD(pt.X, y)) else CreatePt2After(self, PointD(x, pt.Y)); end; pt := PointD(x,y); - end else begin - //just update self.pt when colinear + // just update self.pt when colinear if (x = pt.X) and (pt.X = prevInPath.pt.X) then begin pt := PointD(x,y); Exit; end; - - //self <- 2 <- 1 <- pip + // self <- 2 <- 1 <- pip newPt2 := CreatePt2After(prevInPath, pt); if (x <> pt.X) or (x <> prevInPath.pt.X) then begin - //add a pixel either below or beside + // add a pixel either below or beside if IsAscending then CreatePt2After(newPt2, PointD(x, pt.Y)) else CreatePt2After(newPt2, PointD(pt.X, y)); @@ -1707,8 +1634,7 @@ function TPt2.GetPoints: TPathD; pt2: TPt2; begin Update(pt.X, pt.Y+1); - with prevInPath do Update(pt.X, pt.Y+1); //path 'end' - + with prevInPath do Update(pt.X, pt.Y+1); // path 'end' count := GetCount; SetLength(Result, count); pt2 := self; @@ -1742,23 +1668,20 @@ function TPt2Container.StartNewPath(insertBefore: TPt2; pt2Left.isStart := not isHole; pt2Left.isHole := isHole; pt2Left.pt := PointD(xLeft, y); - pt2Right := TPt2.Create; pt2Right.owner := self; pt2Right.isStart := isHole; pt2Right.isHole := isHole; pt2Right.pt := PointD(xRight, y); - pt2Left.nextInPath := pt2Right; pt2Left.prevInPath := pt2Right; pt2Right.nextInPath := pt2Left; pt2Right.prevInPath := pt2Left; - pt2Left.nextInRow := pt2Right; pt2Right.prevInRow := pt2Left; if not Assigned(insertBefore) then begin - //must be a new rightMost path + // must be a new rightMost path pt2Left.prevInRow := rightMost; if Assigned(rightMost) then rightMost.nextInRow := pt2Left; pt2Right.nextInRow := nil; @@ -1769,7 +1692,7 @@ function TPt2Container.StartNewPath(insertBefore: TPt2; pt2Right.nextInRow := insertBefore; if leftMostPt = insertBefore then begin - //must be a new leftMostPt path + // must be a new leftMostPt path leftMostPt := pt2Left; pt2Left.prevInRow := nil; end else @@ -1799,21 +1722,19 @@ function TPt2Container.JoinAscDesc(path1, path2: TPt2): TPt2; path1.Free; Exit; end; - with path1 do Update(pt.X, pt.Y+1); with path2 do Update(pt.X, pt.Y+1); path1.isStart := false; - //remove path1 from double linked list + // remove path1 from double linked list if assigned(path1.nextInRow) then path1.nextInRow.prevInRow := path1.prevInRow; if assigned(path1.prevInRow) then path1.prevInRow.nextInRow := path1.nextInRow; - //remove path2 from double linked list + // remove path2 from double linked list if assigned(path2.nextInRow) then path2.nextInRow.prevInRow := path2.prevInRow; if assigned(path2.prevInRow) then path2.prevInRow.nextInRow := path2.nextInRow; - path1.prevInPath.nextInPath := path2.nextInPath; path2.nextInPath.prevInPath := path1.prevInPath; path2.nextInPath := path1; @@ -1830,21 +1751,19 @@ function TPt2Container.JoinDescAsc(path1, path2: TPt2): TPt2; path2.Free; Exit; end; - with path1 do Update(pt.X, pt.Y+1); with path2 do Update(pt.X, pt.Y+1); path2.isStart := false; - //remove path1 'end' from double linked list + // remove path1 'end' from double linked list if assigned(path1.nextInRow) then path1.nextInRow.prevInRow := path1.prevInRow; if assigned(path1.prevInRow) then path1.prevInRow.nextInRow := path1.nextInRow; - //remove path2 'start' from double linked list + // remove path2 'start' from double linked list if assigned(path2.nextInRow) then path2.nextInRow.prevInRow := path2.prevInRow; if assigned(path2.prevInRow) then path2.prevInRow.nextInRow := path2.nextInRow; - path1.nextInPath.prevInPath := path2.prevInPath; path2.prevInPath.nextInPath := path1.nextInPath; path1.nextInPath := path2; @@ -1864,48 +1783,42 @@ procedure TPt2Container.AddRange(var current: TPt2; begin if (prevRight > 0) then begin - //nb: prevRight always ends a range (whether a hole or an outer) - - //check if we're about to start a hole + // nb: prevRight always ends a range (whether a hole or an outer) + // check if we're about to start a hole if xLeft < current.pt.X then begin //'current' must be descending and hence prevRight->xLeft a hole current := StartNewPath(current, prevRight, xLeft -1, y, true); prevRight := xRight; - Exit; //nb: it's possible for multiple holes + Exit; // nb: it's possible for multiple holes end; - - //check if we're passing under a pending join + // check if we're passing under a pending join while assigned(current) and assigned(current.nextInRow) and (prevRight > current.nextInRow.pt.X) do begin - //Assert(not current.IsAscending, 'oops!'); - //Assert(current.nextInRow.IsAscending, 'oops!'); + // Assert(not current.IsAscending, 'oops!'); + // Assert(current.nextInRow.IsAscending, 'oops!'); current := JoinDescAsc(current, current.nextInRow); end; - - //check again for a new hole + // check again for a new hole if (xLeft < current.pt.X) then begin current := StartNewPath(current, prevRight, xLeft -1, y, true); prevRight := xRight; Exit; end; - current.Update(prevRight, y); current := current.nextInRow; prevRight := 0; end; - - //check if we're passing under a pending join + // check if we're passing under a pending join while assigned(current) and assigned(current.nextInRow) and (xLeft > current.nextInRow.pt.X) do current := JoinAscDesc(current, current.nextInRow); - if not assigned(current) or (xRight < current.pt.X) then begin StartNewPath(current, xLeft, xRight -1, y, false); - //nb: current remains unchanged + // nb: current remains unchanged end else begin //'range' must somewhat overlap one or more paths above @@ -1916,7 +1829,6 @@ procedure TPt2Container.AddRange(var current: TPt2; current.Update(xLeft, y); current := current.nextInRow; end; - current.Update(xRight, y); current.Update(xLeft, y); if current.IsAscending then @@ -1944,7 +1856,6 @@ function VectorizeMask(const mask: TArrayOfByte; maskWidth: integer): TPathsD; len := Length(mask); if (len = 0) or (maskWidth = 0) or (len mod maskWidth <> 0) then Exit; height := len div maskWidth; - pt2Container := TPt2Container.Create; try for i := 0 to height -1 do @@ -1962,10 +1873,8 @@ function VectorizeMask(const mask: TArrayOfByte; maskWidth: integer): TPathsD; end else blockStart := j; end; - if blockStart >= 0 then pt2Container.AddRange(current, blockStart, maskWidth, i); - if (pt2Container.prevRight > 0) then begin while Assigned(current.nextInRow) and @@ -1980,7 +1889,6 @@ function VectorizeMask(const mask: TArrayOfByte; maskWidth: integer): TPathsD; current := current.nextInRow; pt2Container.prevRight := 0; end; - while assigned(current) do begin if current.isStart then @@ -1988,13 +1896,11 @@ function VectorizeMask(const mask: TArrayOfByte; maskWidth: integer): TPathsD; current := pt2Container.JoinDescAsc(current, current.nextInRow); end end; - with pt2Container do while Assigned(leftMostPt) do if leftMostPt.isStart then JoinAscDesc(leftMostPt, leftMostPt.nextInRow) else JoinDescAsc(leftMostPt, leftMostPt.nextInRow); - Result := pt2Container.solution; finally pt2Container.Free; @@ -2057,13 +1963,12 @@ function Vectorize(img: TImage32; compareColor: TColor32; end; SetLength(Result, j); end; - //------------------------------------------------------------------------------ // RamerDouglasPeucker - and support functions //------------------------------------------------------------------------------ procedure RDP(const path: TPathD; startIdx, endIdx: integer; - epsilonSqrd: double; const flags: TArrayOfInteger); + epsilonSqrd: double; var flags: TArrayOfInteger); var i, idx: integer; d, maxD: double; @@ -2072,7 +1977,7 @@ procedure RDP(const path: TPathD; startIdx, endIdx: integer; maxD := 0; for i := startIdx +1 to endIdx -1 do begin - //PerpendicularDistSqrd - avoids expensive Sqrt() + // PerpendicularDistSqrd - avoids expensive Sqrt() d := PerpendicularDistSqrd(path[i], path[startIdx], path[endIdx]); if d <= maxD then Continue; maxD := d; @@ -2097,8 +2002,7 @@ function RamerDouglasPeucker(const path: TPathD; result := Copy(path, 0, len); Exit; end; - SetLength(buffer, len); //buffer is zero initialized - + SetLength(buffer, len); // buffer is zero initialized buffer[0] := 1; buffer[len -1] := 1; RDP(path, 0, len -1, Sqr(epsilon), buffer); @@ -2124,88 +2028,11 @@ function RamerDouglasPeucker(const paths: TPathsD; setLength(Result, len); for i := 0 to len -1 do begin - Result[i] := RamerDouglasPeucker(paths[i], epsilon); - if Result[i] <> nil then inc(j); + Result[j] := RamerDouglasPeucker(paths[i], epsilon); + if Result[j] <> nil then inc(j); end; setLength(Result, j); end; - -//------------------------------------------------------------------------------ -// SmoothToBezier() support structures and functions -//------------------------------------------------------------------------------ - -type - PPt = ^TPt; - TPt = record - pt : TPointD; - vec : TPointD; - len : double; - next : PPt; - prev : PPt; - end; - - TFitCurveContainer = class - private - ppts : PPt; - solution : TPathD; - tolSqrd : double; - function Count(first, last: PPt): integer; - function AddPt(const pt: TPointD): PPt; - procedure Clear; - function ComputeLeftTangent(p: PPt): TPointD; - function ComputeRightTangent(p: PPt): TPointD; - function ComputeCenterTangent(p: PPt): TPointD; - function ChordLengthParameterize( - first: PPt; cnt: integer): TArrayOfDouble; - function GenerateBezier(first, last: PPt; cnt: integer; - const u: TArrayOfDouble; const firstTan, lastTan: TPointD): TPathD; - function Reparameterize(first: PPt; cnt: integer; - const u: TArrayOfDouble; const bezier: TPathD): TArrayOfDouble; - function NewtonRaphsonRootFind(const q: TPathD; - const pt: TPointD; u: double): double; - function ComputeMaxErrorSqrd(first, last: PPt; - const bezier: TPathD; const u: TArrayOfDouble; - out SplitPoint: PPt): double; - function FitCubic(first, last: PPt; - firstTan, lastTan: TPointD): Boolean; - procedure AppendSolution(const bezier: TPathD); - public - function FitCurve(const path: TPathD; closed: Boolean; - tolerance: double; minSegLength: double): TPathD; - end; - -//------------------------------------------------------------------------------ - -function Scale(const vec: TPointD; newLen: double): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result.X := vec.X * newLen; - Result.Y := vec.Y * newLen; -end; -//------------------------------------------------------------------------------ - -function Mul(const vec: TPointD; val: double): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result.X := vec.X * val; - Result.Y := vec.Y * val; -end; -//------------------------------------------------------------------------------ - -function AddVecs(const vec1, vec2: TPointD): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result.X := vec1.X + vec2.X; - Result.Y := vec1.Y + vec2.Y; -end; -//------------------------------------------------------------------------------ - -function SubVecs(const vec1, vec2: TPointD): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result.X := vec1.X - vec2.X; - Result.Y := vec1.Y - vec2.Y; -end; //------------------------------------------------------------------------------ function DotProdVecs(const vec1, vec2: TPointD): double; @@ -2215,572 +2042,64 @@ function DotProdVecs(const vec1, vec2: TPointD): double; end; //--------------------------------------------------------------------------- -function NormalizeVec(const vec: TPointD): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} +function SmoothToCubicBezier(const path: TPathD; + pathIsClosed: Boolean; maxOffset: integer): TPathD; var - len: double; + i, j, len, prev: integer; + vec: TPointD; + pl: TArrayOfDouble; + unitVecs: TPathD; + d, angle, d1,d2: double; begin - len := Sqrt(vec.X * vec.X + vec.Y * vec.Y); - if len <> 0 then + // SmoothToCubicBezier - returns cubic bezier control points + Result := nil; + len := Length(path); + if len < 3 then Exit; + + SetLength(Result, len *3 +1); + prev := len-1; + SetLength(pl, len); + SetLength(unitVecs, len); + pl[0] := Distance(path[prev], path[0]); + unitVecs[0] := GetUnitVector(path[prev], path[0]); + for i := 0 to len -1 do begin - Result.X := vec.X / len; - Result.Y := vec.Y / len; - end else - result := vec; -end; -//------------------------------------------------------------------------------ - -function NormalizeTPt(const pt: PPt): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - with pt^ do - if len <> 0 then + if i = prev then begin - Result.X := vec.X / len; - Result.Y := vec.Y / len; + j := 0; end else - result := vec; -end; -//------------------------------------------------------------------------------ - -function NegateVec(vec: TPointD): TPointD; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result.X := -vec.X; - Result.Y := -vec.Y; -end; -//------------------------------------------------------------------------------ - -function B0(u: double): double; {$IFDEF INLINE} inline; {$ENDIF} -var - tmp: double; -begin - tmp := 1.0 - u; - result := tmp * tmp * tmp; -end; -//------------------------------------------------------------------------------ - -function B1(u: double): double; {$IFDEF INLINE} inline; {$ENDIF} -var - tmp: double; -begin - tmp := 1.0 - u; - result := 3 * u * tmp * tmp; -end; -//------------------------------------------------------------------------------ - -function B2(u: double): double; {$IFDEF INLINE} inline; {$ENDIF} -begin - result := 3 * u * u * (1.0 - u); -end; -//------------------------------------------------------------------------------ - -function B3(u: double): double; {$IFDEF INLINE} inline; {$ENDIF} -begin - result := u * u * u; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.AddPt(const pt: TPointD): PPt; -begin - new(Result); - Result.pt := pt; - if not assigned(ppts) then - begin - Result.prev := Result; - Result.next := Result; - ppts := Result; - end else - begin - Result.prev := ppts.prev; - ppts.prev.next := Result; - ppts.prev := Result; - Result.next := ppts; - end; -end; -//------------------------------------------------------------------------------ - -procedure TFitCurveContainer.Clear; -var - p: PPt; -begin - solution := nil; - ppts.prev.next := nil; //break loop - while assigned(ppts) do - begin - p := ppts; - ppts := ppts.next; - Dispose(p); - end; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.Count(first, last: PPt): integer; -begin - if first = last then - result := 0 else - result := 1; - repeat - inc(Result); - first := first.next; - until (first = last); -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.ComputeLeftTangent(p: PPt): TPointD; -begin - Result := NormalizeTPt(p); -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.ComputeRightTangent(p: PPt): TPointD; -begin - Result := NegateVec(NormalizeTPt(p.prev)); -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.ComputeCenterTangent(p: PPt): TPointD; -var - v1, v2: TPointD; -begin - v1 := SubVecs(p.pt, p.prev.pt); - v2 := SubVecs(p.next.pt, p.pt); - Result := AddVecs(v1, v2); - Result := NormalizeVec(Result); -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.ChordLengthParameterize( - first: PPt; cnt: integer): TArrayOfDouble; -var - d: double; - i: integer; -begin - SetLength(Result, cnt); - Result[0] := 0; - d := 0; - for i := 1 to cnt -1 do - begin - d := d + first.len; - Result[i] := d; - first := first.next; - end; - for i := 1 to cnt -1 do - Result[i] := Result[i] / d; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.GenerateBezier(first, last: PPt; cnt: integer; - const u: TArrayOfDouble; const firstTan, lastTan: TPointD): TPathD; -var - i: integer; - p: PPt; - dist, epsilon: double; - v1,v2, tmp: TPointD; - a0, a1: TPathD; - c: array [0..1, 0..1] of double; - x: array [0..1] of double; - det_c0_c1, det_c0_x, det_x_c1, alphaL, alphaR: double; -begin - SetLength(a0, cnt); - SetLength(a1, cnt); - dist := Distance(first.pt, last.pt); - - for i := 0 to cnt -1 do - begin - v1 := Scale(firstTan, B1(u[i])); - v2 := Scale(lastTan, B2(u[i])); - a0[i] := v1; - a1[i] := v2; - end; - - FillChar(c[0][0], 4 * SizeOf(double), 0); - FillChar(x[0], 2 * SizeOf(double), 0); - - p := first; - for i := 0 to cnt -1 do - begin - c[0][0] := c[0][0] + DotProdVecs(a0[i], (a0[i])); - c[0][1] := c[0][1] + DotProdVecs(a0[i], (a1[i])); - c[1][0] := c[0][1]; - c[1][1] := c[1][1] + DotProdVecs(a1[i], (a1[i])); - - tmp := SubVecs(p.pt, - AddVecs(Mul(first.pt, B0(u[i])), - AddVecs(Mul(first.pt, B1(u[i])), - AddVecs(Mul(last.pt, B2(u[i])), - Mul(last.pt, B3(u[i])))))); - - x[0] := x[0] + DotProdVecs(a0[i], tmp); - x[1] := x[1] + DotProdVecs(a1[i], tmp); - p := p.next; - end; - - det_c0_c1 := c[0][0] * c[1][1] - c[1][0] * c[0][1]; - det_c0_x := c[0][0] * x[1] - c[1][0] * x[0]; - det_x_c1 := x[0] * c[1][1] - x[1] * c[0][1]; - - if det_c0_c1 = 0 then - alphaL := 0 else - alphaL := det_x_c1 / det_c0_c1; - - if det_c0_c1 = 0 then - alphaR := 0 else - alphaR := det_c0_x / det_c0_c1; - - //check for unlikely fit - if (alphaL > dist * 2) then alphaL := 0 - else if (alphaR > dist * 2) then alphaR := 0; - epsilon := 1.0e-6 * dist; - - SetLength(Result, 4); - Result[0] := first.pt; - Result[3] := last.pt; - if (alphaL < epsilon) or (alphaR < epsilon) then - begin - dist := dist / 3; - Result[1] := AddVecs(Result[0], Scale(firstTan, dist)); - Result[2] := AddVecs(Result[3], Scale(lastTan, dist)); - end else - begin - Result[1] := AddVecs(Result[0], Scale(firstTan, alphaL)); - Result[2] := AddVecs(Result[3], Scale(lastTan, alphaR)); - end; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.Reparameterize(first: PPt; cnt: integer; - const u: TArrayOfDouble; const bezier: TPathD): TArrayOfDouble; -var - i: integer; -begin - SetLength(Result, cnt); - for i := 0 to cnt -1 do - begin - Result[i] := NewtonRaphsonRootFind(bezier, first.pt, u[i]); - first := first.next; - end; -end; -//------------------------------------------------------------------------------ - -function BezierII(degree: integer; const v: array of TPointD; t: double): TPointD; -var - i,j: integer; - tmp: array[0..3] of TPointD; -begin - Move(v[0], tmp[0], (degree +1) * sizeOf(TPointD)); - for i := 1 to degree do - for j := 0 to degree - i do begin - tmp[j].x := (1.0 - t) * tmp[j].x + t * tmp[j+1].x; - tmp[j].y := (1.0 - t) * tmp[j].y + t * tmp[j+1].y; + j := i +1; + pl[j] := Distance(path[i], path[j]); + unitVecs[j] := GetUnitVector(path[i], path[j]); end; - Result := tmp[0]; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.ComputeMaxErrorSqrd(first, last: PPt; - const bezier: TPathD; const u: TArrayOfDouble; - out SplitPoint: PPt): double; -var - i: integer; - distSqrd: double; - pt: TPointD; - p: PPt; -begin - Result := 0; - i := 1; - SplitPoint := first.next; - p := first.next; - while p <> last do - begin - pt := BezierII(3, bezier, u[i]); - distSqrd := DistanceSqrd(pt, p.pt); - if (distSqrd >= Result) then - begin - Result := distSqrd; - SplitPoint := p; - end; - inc(i); - p := p.next; - end; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.NewtonRaphsonRootFind(const q: TPathD; - const pt: TPointD; u: double): double; -var - numerator, denominator: double; - qu, q1u, q2u: TPointD; - q1: array[0..2] of TPointD; - q2: array[0..1] of TPointD; -begin - - q1[0].x := (q[1].x - q[0].x) * 3.0; - q1[0].y := (q[1].y - q[0].y) * 3.0; - q1[1].x := (q[2].x - q[1].x) * 3.0; - q1[1].y := (q[2].y - q[1].y) * 3.0; - q1[2].x := (q[3].x - q[2].x) * 3.0; - q1[2].y := (q[3].y - q[2].y) * 3.0; - - q2[0].x := (q1[1].x - q1[0].x) * 2.0; - q2[0].y := (q1[1].y - q1[0].y) * 2.0; - q2[1].x := (q1[2].x - q1[1].x) * 2.0; - q2[1].y := (q1[2].y - q1[1].y) * 2.0; - - qu := BezierII(3, q, u); - q1u := BezierII(2, q1, u); - q2u := BezierII(1, q2, u); - - numerator := (qu.x - pt.x) * (q1u.x) + (qu.y - pt.y) * (q1u.y); - denominator := (q1u.x) * (q1u.x) + (q1u.y) * (q1u.y) + - (qu.x - pt.x) * (q2u.x) + (qu.y - pt.y) * (q2u.y); - - if (denominator = 0) then - Result := u else - Result := u - (numerator / denominator); -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.FitCubic(first, last: PPt; - firstTan, lastTan: TPointD): Boolean; -var - i, cnt: integer; - splitPoint: PPt; - centerTan: TPointD; - bezier: TPathD; - clps, uPrime: TArrayOfDouble; - maxErrorSqrd: double; -const - maxRetries = 4; -begin - Result := true; - cnt := Count(first, last); - if cnt = 2 then - begin - SetLength(bezier, 4); - bezier[0] := first.pt; - bezier[3] := last.pt; - bezier[1] := bezier[0]; - bezier[2] := bezier[3]; - AppendSolution(bezier); - Exit; - end - else if cnt = 3 then - begin - if TurnsLeft(first.prev.pt, first.pt, first.next.pt) = - TurnsLeft(first.pt, first.next.pt, last.pt) then - firstTan := ComputeCenterTangent(first); - if TurnsLeft(last.prev.pt, last.pt, last.next.pt) = - TurnsLeft(first.pt, first.next.pt, last.pt) then - lastTan := NegateVec(ComputeCenterTangent(last)); - end; - - - clps := ChordLengthParameterize(first, cnt); - bezier := GenerateBezier(first, last, cnt, clps, firstTan, lastTan); - maxErrorSqrd := ComputeMaxErrorSqrd(first, last, bezier, clps, splitPoint); - if (maxErrorSqrd < tolSqrd) then - begin - AppendSolution(bezier); - Exit; - end; - - if (maxErrorSqrd < tolSqrd * 4) then //close enough to try again - begin - for i := 1 to maxRetries do - begin - uPrime := Reparameterize(first, cnt, clps, bezier); - bezier := GenerateBezier(first, last, cnt, uPrime, firstTan, lastTan); - maxErrorSqrd := - ComputeMaxErrorSqrd(first, last, bezier, uPrime, splitPoint); - if (maxErrorSqrd < tolSqrd) then - begin - AppendSolution(bezier); - Exit; - end; - clps := uPrime; - end; - end; - - //We need to break the curve because it's too complex for a single Bezier. - //If we're changing direction then make this a 'hard' break (see below). - if TurnsLeft(splitPoint.prev.prev.pt, splitPoint.prev.pt, splitPoint.pt) <> - TurnsLeft(splitPoint.prev.pt, splitPoint.pt, splitPoint.next.pt) then - begin - centerTan := ComputeRightTangent(splitPoint); - FitCubic(first, splitPoint, firstTan, centerTan); - centerTan := ComputeLeftTangent(splitPoint); - FitCubic(splitPoint, last, centerTan, lastTan); - end else - begin - centerTan := ComputeCenterTangent(splitPoint); - FitCubic(first, splitPoint, firstTan, NegateVec(centerTan)); - FitCubic(splitPoint, last, centerTan, lastTan); - end; -end; -//------------------------------------------------------------------------------ - -function HardBreakCheck(ppt: PPt; compareLen: double): Boolean; -var - q: double; -const - longLen = 15; -begin - //A 'break' means starting a new Bezier. A 'hard' break avoids smoothing - //whereas a 'soft' break will still be smoothed. There is as much art as - //science in determining where to smooth and where not to. For example, - //long edges should generally remain straight but how long does an edge - //have to be to be considered a 'long' edge? - - if (ppt.prev.len * 4 < ppt.len) or (ppt.len * 4 < ppt.prev.len) then - begin - //We'll hard break whenever there's significant asymmetry between - //segment lengths because GenerateBezier() will perform poorly. - result := true; - end - else if ((ppt.prev.len > longLen) and (ppt.len > longLen)) then - begin - //hard break long segments only when turning by more than ~45 degrees - q := (Sqr(ppt.prev.len) + Sqr(ppt.len) - DistanceSqrd(ppt.prev.pt, ppt.next.pt)) / - (2 * ppt.prev.len * ppt.len); //Cosine Rule. - result := (1 - abs(q)) > 0.3; - end - else if ((TurnsLeft(ppt.prev.prev.pt, ppt.prev.pt, ppt.pt) = - TurnsRight(ppt.prev.pt, ppt.pt, ppt.next.pt)) and - (ppt.prev.len > compareLen) and (ppt.len > compareLen)) then - begin - //we'll also hard break whenever there's a significant inflection point - result := true; - end else - begin - //Finally, we'll also force a 'hard' break when there's a significant bend. - //Again uses the Cosine Rule. - q :=(Sqr(ppt.prev.len) + Sqr(ppt.len) - - DistanceSqrd(ppt.prev.pt, ppt.next.pt)) / (2 * ppt.prev.len * ppt.len); - Result := (q > -0.2); //ie more than 90% - end; -end; -//------------------------------------------------------------------------------ - -function TFitCurveContainer.FitCurve(const path: TPathD; - closed: Boolean; tolerance: double; minSegLength: double): TPathD; -var - i, highI: integer; - d: double; - p, p2, pEnd: PPt; -begin - //tolerance: specifies the maximum allowed variance between the existing - //vertices and the new Bezier curves. More tolerance will produce - //fewer Beziers and simpler paths, but at the cost of less precison. - tolSqrd := Sqr(Max(1, Min(10, tolerance))); //range 1..10 - - //minSegLength: Typically when vectorizing raster images, the produced - //vector paths will have many series of axis aligned segments that trace - //pixel boundaries. These paths will also contain many 1 unit segments at - //right angles to adjacent segments. Importantly, these very short segments - //will cause artifacts in the solution unless they are trimmed. - highI := High(path); - if closed then - while (highI > 0) and (Distance(path[highI], path[0]) < minSegLength) do - dec(highI); + vec := GetAvgUnitVector(unitVecs[i], unitVecs[j]); - p := AddPt(path[0]); - for i := 1 to highI do - begin - d := Distance(p.pt, path[i]); - //skip line segments with lengths less than 'minSegLength' - if d < minSegLength then Continue; - p := AddPt(path[i]); - p.prev.len := d; - p.prev.vec := SubVecs(p.pt, p.prev.pt); - end; - p.len := Distance(ppts.pt, p.pt); - p.vec := SubVecs(p.next.pt, p.pt); - p := ppts; - - if (p.next = p) or (closed and (p.next = p.prev)) then - begin - Clear; - result := nil; - Exit; - end; + angle := arccos(Max(-1,Min(1,(DotProdVecs(unitVecs[i], unitVecs[j]))))); + d := abs(Pi-angle)/TwoPi; + d1 := pl[i] * d; + d2 := pl[j] * d; - //for closed paths, find a good starting point - if closed then - begin - repeat - if HardBreakCheck(p, tolerance) then break; - p := p.next; - until p = ppts; - pEnd := p; - end else - pEnd := ppts.prev; - - p2 := p.next; - repeat - if HardBreakCheck(p2, tolerance) then + if maxOffset > 0 then begin - FitCubic(p, p2, ComputeLeftTangent(p), ComputeRightTangent(p2)); - p := p2; + d1 := Min(maxOffset, d1); + d2 := Min(maxOffset, d2); end; - p2 := p2.next; - until (p2 = pEnd); - FitCubic(p, p2, ComputeLeftTangent(p), ComputeRightTangent(p2)); - - Result := solution; - Clear; -end; -//------------------------------------------------------------------------------ -procedure TFitCurveContainer.AppendSolution(const bezier: TPathD); -var - i, len: integer; -begin - len := Length(solution); - if len > 0 then - begin - SetLength(solution, len + 3); - for i := 0 to 2 do - solution[len +i] := bezier[i +1]; - end else - solution := bezier; -end; -//------------------------------------------------------------------------------ - -function SmoothToBezier(const path: TPathD; closed: Boolean; - tolerance: double; minSegLength: double): TPathD; -var - paths, solution: TPathsD; -begin - SetLength(paths, 1); - paths[0] := path; - solution := SmoothToBezier(paths, closed, tolerance, minSegLength); - if solution <> nil then - Result := solution[0]; -end; -//------------------------------------------------------------------------------ - -function SmoothToBezier(const paths: TPathsD; closed: Boolean; - tolerance: double; minSegLength: double): TPathsD; -var - i,j, len: integer; -begin - j := 0; - len := Length(paths); - SetLength(Result, len); - with TFitCurveContainer.Create do - try - for i := 0 to len -1 do - if (paths[i] <> nil) and (Abs(Area(paths[i])) > Sqr(tolerance)) then - begin - Result[j] := FitCurve(paths[i], closed, tolerance, minSegLength); - inc(j); - end; - finally - Free; + if i = 0 then + Result[len*3-1] := OffsetPoint(path[0], -vec.X * d1, -vec.Y * d1) + else + Result[i*3-1] := OffsetPoint(path[i], -vec.X * d1, -vec.Y * d1); + Result[i*3] := path[i]; + Result[i*3+1] := OffsetPoint(path[i], vec.X * d2, vec.Y * d2); end; - SetLength(Result, j); + Result[len*3] := path[0]; + + if pathIsClosed then Exit; + Result[1] := Result[0]; + dec(len); + Result[len*3-1] := Result[len*3]; + SetLength(Result, Len*3 +1); end; //------------------------------------------------------------------------------ @@ -2790,8 +2109,8 @@ function HermiteInterpolation(y1, y2, y3, y4: double; m0,m1,mu2,mu3: double; a0,a1,a2,a3: double; begin - //http://paulbourke.net/miscellaneous/interpolation/ - //nb: optional bias toward left or right has been disabled. + // http://paulbourke.net/miscellaneous/interpolation/ + // nb: optional bias toward left or right has been disabled. mu2 := mu * mu; mu3 := mu2 * mu; m0 := (y2-y1)*(1-tension)/2; @@ -2827,7 +2146,6 @@ function InterpolatePoints(const points: TPathD; tension: integer): TPathD; begin if tension < -1 then tension := -1 else if tension > 1 then tension := 1; - Result := nil; len := Length(points); if len < 2 then Exit; @@ -2864,16 +2182,13 @@ procedure GaussianBlur(img: TImage32; rec: TRect; radius: Integer); 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 begin gaussTable[i] := Sqr(Radius - i +1); gaussTable[-i] := gaussTable[i]; end; - RectWidthHeight(rec, w, h); setLength(wca, w * h); - for y := 0 to h -1 do begin row := PColor32Array(@img.Pixels[(y + rec.Top) * img.Width + rec.Left]); @@ -2882,7 +2197,6 @@ procedure GaussianBlur(img: TImage32; rec: TRect; radius: Integer); for z := max(0, x - radius) to min(img.Width -1, x + radius) do wcRow[x].Add(row[z], gaussTable[x-z]); end; - for x := 0 to w -1 do begin for y := 0 to h -1 do @@ -2898,30 +2212,24 @@ procedure GaussianBlur(img: TImage32; rec: TRect; radius: Integer); end; end; end; - //------------------------------------------------------------------------------ // FastGaussian blur - and support functions //------------------------------------------------------------------------------ - //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); - wIdeal := Sqrt((12*stdDev*stdDev/boxCnt)+1); // Ideal averaging filter width wl := Floor(wIdeal); if not Odd(wl) then dec(wl); mIdeal := (-3*stdDev*stdDev +0.25*boxCnt*wl*wl +boxCnt*wl +0.75*boxCnt)/(wl+1); - - m := Floor(mIdeal) div 2; //nb: variation on Ivan Kutskir's code. + m := Floor(mIdeal) div 2; // nb: variation on Ivan Kutskir's code. wl := (wl -1) div 2; // It's better to do this here wu := wl+1; // than later in both BoxBlurH & BoxBlurV - for i := 0 to boxCnt -1 do if i < m then Result[i] := wl else @@ -2941,22 +2249,17 @@ procedure BoxBlurH(var src, dst: TArrayOfColor32; w,h, stdDev: integer); ti := i * w; li := ti; ri := ti +stdDev; - - re := ti +w -1; //idx of last pixel in row - rc := src[re]; //color of last pixel in row - + re := ti +w -1; // idx of last pixel in row + rc := src[re]; // color of last pixel in row fv.Reset; lv.Reset; val.Reset; - fv.Add(src[ti], 1); lv.Add(rc, 1); val.Add(src[ti], stdDev +1); - for j := 0 to stdDev -1 - ovr do val.Add(src[ti + j]); if ovr > 0 then val.Add(rc, ovr); - for j := 0 to stdDev do begin if ri > re then @@ -3001,22 +2304,17 @@ procedure BoxBlurV(var src, dst: TArrayOfColor32; w, h, stdDev: integer); ti := i; li := ti; ri := ti + stdDev * w; - fv.Reset; lv.Reset; val.Reset; - - re := ti +w *(h-1); //idx of last pixel in column - rc := src[re]; //color of last pixel in column - + re := ti +w *(h-1); // idx of last pixel in column + rc := src[re]; // color of last pixel in column fv.Add(src[ti]); lv.Add(rc, 1); val.Add(src[ti], stdDev +1); - for j := 0 to stdDev -1 -ovr do val.Add(src[ti + j *w]); if ovr > 0 then val.Add(rc, ovr); - for j := 0 to stdDev do begin if ri > re then @@ -3054,7 +2352,7 @@ function GaussCurve(cnt: integer): TArrayOfDouble; begin SetLength(Result, cnt); for i := 0 to cnt -1 do - Result[i] := exp(-Sqr(2*i/cnt)); //4 std devs --> array 1 >>> ~0 + Result[i] := exp(-Sqr(2*i/cnt)); // 4 std devs --> array 1 >>> ~0 end; //------------------------------------------------------------------------------ @@ -3080,21 +2378,18 @@ procedure FastGaussianBlur(img: TImage32; Types.IntersectRect(rec2, rec, img.Bounds); if IsEmptyRect(rec2) then Exit; blurFullImage := RectsEqual(rec2, img.Bounds); - 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); - if blurFullImage then begin - //copy the entire image into 'dst' + // copy the entire image into 'dst' Move(img.PixelBase^, dst[0], len * SizeOf(TColor32)); end else begin - //copy a rectangular region into 'dst' + // copy a rectangular region into 'dst' pSrc := img.PixelRow[rec2.Top]; inc(pSrc, rec2.Left); pDst := @dst[0]; @@ -3105,9 +2400,8 @@ procedure FastGaussianBlur(img: TImage32; inc(pDst, w); end; end; - - //do the blur - inc(repeats); //now represents total iterations + // do the blur + inc(repeats); // now represents total iterations boxesH := BoxesForGauss(stdDevX, repeats); if stdDevY = stdDevX then boxesV := boxesH else @@ -3117,8 +2411,7 @@ procedure FastGaussianBlur(img: TImage32; BoxBlurH(dst, src, w, h, boxesH[j]); BoxBlurV(src, dst, w, h, boxesV[j]); end; - - //copy dst array back to image rect + // copy dst array back to image rect img.BeginUpdate; try if blurFullImage then @@ -3129,7 +2422,6 @@ procedure FastGaussianBlur(img: TImage32; pDst := img.PixelRow[rec2.Top]; inc(pDst, rec2.Left); pSrc := @dst[0]; - for i := 0 to h -1 do begin Move(pSrc^, pDst^, w * SizeOf(TColor32)); diff --git a/Ext/SVGIconImageList/Image32/source/Img32.FMX.pas b/Ext/SVGIconImageList/Image32/source/Img32.FMX.pas index e5b6ea2..aa80934 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.FMX.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.FMX.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 10 January 2022 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * Purpose : Image file format support for TImage32 and FMX * @@ -88,7 +88,6 @@ function TImageFormat_FMX.LoadFromStream(stream: TStream; img32: TImage32): Bool (surf.PixelFormat = TPixelFormat.RGBA) then fPixelFormat := surf.PixelFormat else Exit; - img32.SetSize(surf.Width, surf.Height); Move(surf.Scanline[0]^, img32.PixelBase^, surf.Width * surf.Height * 4); result := true; @@ -199,6 +198,7 @@ procedure AssignImage32ToFmxBitmap(img: TImage32; bmp: TBitmap); src, dst: TBitmapData; //TBitmapData is a record. begin if not Assigned(img) or not Assigned(bmp) then Exit; + src := TBitmapData.Create(img.Width, img.Height, TPixelFormat.BGRA); src.Data := img.PixelBase; src.Pitch := img.Width * 4; diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas index c35a66e..2990eb9 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.BMP.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 3.0 * -* Date : 20 July 2021 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2021 * * Purpose : BMP file format extension for TImage32 * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.GIF.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.GIF.pas index a73d001..dc14806 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.GIF.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.GIF.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.1 * -* Date : 17 March 2022 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * Purpose : GIF file format extension for TImage32 * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.JPG.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.JPG.pas index 019f6a4..901fb30 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.JPG.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.JPG.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 22 December 2021 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2021 * * Purpose : JPG/JPEG file format extension for TImage32 * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.PNG.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.PNG.pas index eb4ad5f..659b7ff 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.PNG.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.PNG.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 10 January 2022 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * Purpose : PNG file format extension for TImage32 * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.QOI.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.QOI.pas index f34d328..aa65ab8 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.QOI.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.QOI.pas @@ -1,8 +1,8 @@ unit Img32.Fmt.QOI; (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 10 January 2022 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * Purpose : QOI file format extension for TImage32 * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas index a2e1225..106949b 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Fmt.SVG.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 10 January 2022 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * Purpose : SVG file format extension for TImage32 * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas b/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas index 2bb21f7..47f64e4 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Layers.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.01 * -* Date : 28 January 2022 * +* Version : 4.2 * +* Date : 28 July 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * * @@ -77,7 +77,9 @@ TLayer32 = class(TStorage) fBlendFunc : TBlendFunction; //defaults to BlendToAlpha fLayeredImage : TLayeredImage32; fClipPath : TPathsD; //used in conjunction with fClipImage +{$IFNDEF NO_STORAGE} fStreamingRec : TRectWH; +{$ENDIF} fDesignerLayer : Boolean; function GetMidPoint: TPointD; procedure SetVisible(value: Boolean); @@ -106,10 +108,12 @@ TLayer32 = class(TStorage) function GetInnerRectD: TRectD; function GetInnerBounds: TRectD; function GetOuterBounds: TRectD; +{$IFNDEF NO_STORAGE} procedure BeginRead; override; function ReadProperty(const propName, propVal: string): Boolean; override; procedure WriteProperties; override; procedure EndRead; override; +{$ENDIF} procedure SetOpacity(value: Byte); virtual; procedure ImageChanged(Sender: TImage32); virtual; procedure UpdateLayeredImage(newLayeredImage: TLayeredImage32); @@ -214,8 +218,10 @@ TRotLayer32 = class(THitTestLayer32) procedure SetAngle(newAngle: double); protected procedure SetPivotPt(const pivot: TPointD); virtual; +{$IFNDEF NO_STORAGE} function ReadProperty(const propName, propVal: string): Boolean; override; procedure WriteProperties; override; +{$ENDIF} public constructor Create(parent: TLayer32 = nil; const name: string = ''); override; function Rotate(angleDelta: double): Boolean; virtual; @@ -375,8 +381,10 @@ TLayeredImage32 = class(TStorage) procedure SetResampler(newSamplerId: integer); function GetRepaintNeeded: Boolean; protected +{$IFNDEF NO_STORAGE} function ReadProperty(const propName, propVal: string): Boolean; override; procedure WriteProperties; override; +{$ENDIF} property InvalidRect: TRectD read fInvalidRect; public constructor Create(parent: TStorage = nil; const name: string = ''); overload; override; @@ -458,7 +466,11 @@ function UpdateRotatingButtonGroup(rotateButton: TLayer32): double; implementation -{$IFNDEF MSWINDOWS} uses Img32.FMX;{$ENDIF} + {$IFNDEF MSWINDOWS} + {$IFNDEF FPC} + uses Img32.FMX; + {$ENDIF} + {$ENDIF} resourcestring rsRoot = 'root'; @@ -848,6 +860,7 @@ procedure TLayer32.SetOuterMargin(value: double); end; //------------------------------------------------------------------------------ +{$IFNDEF NO_STORAGE} procedure TLayer32.BeginRead; var stgParent: TStorage; @@ -906,6 +919,7 @@ procedure TLayer32.WriteProperties; if not Visible then WriteBoolProp('Visible', false); end; //------------------------------------------------------------------------------ +{$ENDIF} procedure TLayer32.SetOpacity(value: Byte); begin @@ -1593,6 +1607,7 @@ procedure TRotLayer32.SetAutoPivot(val: Boolean); end; //------------------------------------------------------------------------------ +{$IFNDEF NO_STORAGE} function TRotLayer32.ReadProperty(const propName, propVal: string): Boolean; begin Result := inherited ReadProperty(propName, propVal); @@ -1614,6 +1629,7 @@ procedure TRotLayer32.WriteProperties; WritePointDProp('PivotPt', PivotPt); WriteBoolProp('AutoPivot', AutoPivot) end; +{$ENDIF} //------------------------------------------------------------------------------ // TVectorLayer32 class @@ -2151,6 +2167,7 @@ constructor TLayeredImage32.Create(Width, Height: integer); end; //------------------------------------------------------------------------------ +{$IFNDEF NO_STORAGE} function TLayeredImage32.ReadProperty(const propName, propVal: string): Boolean; begin if propName = 'Resampler' then @@ -2175,6 +2192,7 @@ procedure TLayeredImage32.WriteProperties; WriteIntProp('Height', Height); end; //------------------------------------------------------------------------------ +{$ENDIF} procedure TLayeredImage32.SetSize(width, height: integer); begin @@ -2727,8 +2745,10 @@ initialization InitDashes; DefaultButtonSize := dpiAware1*10; +{$IFNDEF NO_STORAGE} RegisterStorageClass(TLayeredImage32); RegisterStorageClass(TLayer32); RegisterStorageClass(TGroupLayer32); +{$ENDIF} end. diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas b/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas index 7416a1c..213ee12 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Resamplers.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 3.0 * -* Date : 20 July 2021 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2021 * * Purpose : For image transformations (scaling, rotating etc.) * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas index 04c50b4..a8b1edc 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Core.pas @@ -2,10 +2,10 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 22 December 2021 * +* Version : 4.2 * +* Date : 2 July 2022 * * Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2021 * +* Copyright : Angus Johnson 2019-2022 * * * * Purpose : Essential structures and functions to read SVG files * * * @@ -266,13 +266,6 @@ function CharInSet(chr: UTF8Char; chrs: TSetOfUTF8Char): Boolean; implementation -uses - Img32.SVG.Path; - -resourcestring - rsSvgPathRangeError = 'TSvgPath.GetPath range error'; - rsSvgSubPathRangeError = 'TSvgSubPath.GetSeg range error'; - rsSvgSegmentRangeError = 'TSvgSegment.GetVal range error'; type TColorConst = record @@ -1187,9 +1180,9 @@ function UTF8StringToColor32(const value: UTF8String; var color: TColor32): Bool //and in case the opacity has been set before the color if (alpha < 255) then color := (color and $FFFFFF) or alpha shl 24; -{$IFDEF ANDROID} +{$IF DEFINED(ANDROID)} color := SwapRedBlue(color); -{$ENDIF} +{$IFEND} Result := true; end; //------------------------------------------------------------------------------ diff --git a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Path.pas b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Path.pas index 88c670b..2e3ffa2 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Path.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Path.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 28 December 2021 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2021 * * * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.SVG.PathDesign.pas b/Ext/SVGIconImageList/Image32/source/Img32.SVG.PathDesign.pas index 20859b9..2adfe95 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.SVG.PathDesign.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.SVG.PathDesign.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 10 January 2022 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Reader.pas b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Reader.pas index 258dc05..a9936b6 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Reader.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Reader.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 10 January 2022 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Writer.pas b/Ext/SVGIconImageList/Image32/source/Img32.SVG.Writer.pas deleted file mode 100644 index 5cd9f59..0000000 --- a/Ext/SVGIconImageList/Image32/source/Img32.SVG.Writer.pas +++ /dev/null @@ -1,1037 +0,0 @@ -unit Img32.SVG.Writer; - -(******************************************************************************* -* Author : Angus Johnson * -* Version : 3.3 * -* Date : 21 September 2021 * -* Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2021 * -* * -* Purpose : Write SVG ver 2 files * -* * -* This is just the very beginning, and very likely * -* sometime later it'll be merged with the SVG reader unit. * -* * -* License : Use, modification & distribution is subject to * -* Boost Software License Ver 1 * -* http://www.boost.org/LICENSE_1_0.txt * -*******************************************************************************) - -interface - -{$I Img32.inc} - -uses - SysUtils, Classes, Types, Math, - {$IFDEF XPLAT_GENERICS} Generics.Collections, Generics.Defaults,{$ENDIF} - Img32, Img32.SVG.Core, Img32.SVG.Path, Img32.Vector, Img32.Draw, - Img32.Transform, Img32.Text; -{$IFDEF ZEROBASEDSTR} - {$ZEROBASEDSTRINGS OFF} -{$ENDIF} - -type - - TSvgElWriterClass = class of TBaseElWriter; - - TBaseElWriter = class - private - {$IFDEF XPLAT_GENERICS} - fChilds : TList; - {$ELSE} - fChilds : TList; - {$ENDIF} - fParent : TBaseElWriter; - fIndent : string; - fElStr : string; - protected - Id : string; - function Write: string; virtual; - function WriteHeader: string; virtual; - function WriteContent: string; virtual; - property Indent: string read fIndent; - property Parent: TBaseElWriter read fParent; - public - constructor Create(parent: TBaseElWriter); virtual; - destructor Destroy; override; - function AddChild(childClass: TSvgElWriterClass): TBaseElWriter; - procedure DeleteChild(index: integer); - procedure Clear; virtual; - end; - - TSvgElWriter = class(TBaseElWriter) - private -// fwidth : integer; -// fheight : integer; - fViewbox : TRect; - protected - function WriteHeader: string; override; - public - constructor Create(parent: TBaseElWriter); override; -// property width: integer read fwidth write fwidth; -// property height: integer read fheight write fheight; - property Viewbox: TRect read fViewbox write fViewbox; - end; - - TExBaseElWriter = class(TBaseElWriter) - protected - fFillClr : TColor32; - fFillRule : TFillRule; - fStrokeClr : TColor32; - fStrokeWidth : double; - fDashes : TArrayOfDouble; - function WriteHeader: string; override; - public - Matrix : TMatrixD; - constructor Create(parent: TBaseElWriter); override; - procedure Rotate(const pivotPt: TPointD; angleRad: double); - procedure Translate(dx, dy: double); - procedure Skew(dx, dy: double); - property FillColor : TColor32 read fFillClr write fFillClr; - property StrokeColor : TColor32 read fStrokeClr write fStrokeClr; - property StrokeWidth : double read fStrokeWidth write fStrokeWidth; - property Dashes : TArrayOfDouble read fDashes write fDashes; - property FillRule : TFillRule read fFillRule write fFillRule; - end; - - TSvgGroupWriter = class(TExBaseElWriter) - public - constructor Create(parent: TBaseElWriter); override; - end; - - TSvgPathWriter = class(TExBaseElWriter) - private - fLastPt : TPointD; - fSvgPaths : TSvgPath; - function GetPathCount: integer; - function GetCurrentPath: TSvgSubPath; - function GetNewPath: TSvgSubPath; - protected - function WriteHeader: string; override; - public - constructor Create(parent: TBaseElWriter); override; - destructor Destroy; override; - procedure Clear; override; - procedure DeleteLastSegment(subPath: TSvgSubPath); - procedure MoveTo(X,Y: double); - procedure LineHTo(X: double); - procedure LineVTo(Y: double); - procedure LineTo(X,Y: double); - procedure ArcTo(const radii: TPointD; angle: double; - arcFlag, sweepFlag: Boolean; const endPt: TPointD); overload; - procedure ArcTo(const endPt: TPointD; const rec: TRectD; - angle: double; sweepFlag: Boolean); overload; - procedure CubicBezierTo(const ctrl1, ctrl2, endPt: TPointD); - procedure CubicSplineTo(const ctrl2, endPt: TPointD); - procedure QuadBezierTo(const ctrl, endPt: TPointD); - procedure QuadSplineTo(const endPt: TPointD); - procedure ClosePath; - property PathCount: integer read GetPathCount; - end; - - TSvgCircleWriter = class(TExBaseElWriter) - public - Origin : TPointD; - Radius : double; - constructor Create(parent: TBaseElWriter); override; - function WriteHeader: string; override; - end; - - TSvgEllipseWriter = class(TExBaseElWriter) - public - Origin : TPointD; - Radii : TSizeD; - constructor Create(parent: TBaseElWriter); override; - function WriteHeader: string; override; - end; - - TSvgRectWriter = class(TExBaseElWriter) - public - RecWH : TRectWH; - Radii : TSizeD; - constructor Create(parent: TBaseElWriter); override; - function WriteHeader: string; override; - end; - - TSvgPolygonWriter = class(TExBaseElWriter) - public - path : TPathD; - constructor Create(parent: TBaseElWriter); override; - procedure Clear; override; - function WriteHeader: string; override; - end; - - TSvgPolylineWriter = class(TSvgPolygonWriter) - public - constructor Create(parent: TBaseElWriter); override; - end; - - TSVGFontInfo = record - family : TTtfFontFamily; - size : double; - spacing : double; - textLength : double; - italic : boolean; - weight : integer; - align : TSvgTextAlign; - decoration : TFontDecoration; - baseShift : TValue; - end; - - TSvgTextWriter = class(TExBaseElWriter) - protected - fPosition: TPointD; - fOffset: TSizeD; - fFontInfo: TSVGFontInfo; - function Write: string; override; - function WriteHeader: string; override; - public - constructor Create(parent: TBaseElWriter); override; - procedure AddText(const aText: string; X,Y: double; font: TFontCache); - end; - - TSvgTSpanWriter = class(TSvgTextWriter) - public - constructor Create(parent: TBaseElWriter); override; - end; - - TSvgSubTextWriter = class(TBaseElWriter) - protected - text: string; - end; - - TSvgWriter = class - private - fSvgElememt : TSvgElWriter; - function WriteHeader: string; - public - constructor Create; - destructor Destroy; override; - procedure SaveToFile(const filename: string); - procedure SaveToStream(stream: TStream); - procedure Clear; - property Svg: TSvgElWriter read fSvgElememt; - end; - -function GetFontInfo(font: TFontCache): TSVGFontInfo; - -implementation - -const - indentSize = 2; - -//------------------------------------------------------------------------------ -// Miscellaneous routines -//------------------------------------------------------------------------------ - -function GetFontInfo(font: TFontCache): TSVGFontInfo; -begin - FillChar(Result, SizeOf(Result), 0); - Result.family := font.FontReader.FontFamily; - Result.size := font.FontHeight; - Result.italic := - msItalic in font.FontReader.FontInfo.macStyles; - Result.weight := font.FontReader.Weight; -end; -//------------------------------------------------------------------------------ - -procedure AppendStr(var s: string; const s2: string; omitSpace: Boolean = false); -begin - if omitSpace then - s := s + s2 else - s := Format('%s%s ',[s, s2]); -end; -//------------------------------------------------------------------------------ - -procedure AppendStrAttrib(var s: string; - const attribName, val: string); -begin - s := Format('%s%s="%s" ', [s, attribName, val]); -end; -//------------------------------------------------------------------------------ - -procedure AppendInt(var s: string; val: double); -begin - s := Format('%s%1.0f ',[s, val]); -end; -//------------------------------------------------------------------------------ - -function ValueToStr(val: double): string; -var - absVal: double; -begin - absVal := Abs(val); - if Frac(absVal) < 0.01 then - Result := Format('%1.0f', [val]) - else if Frac(absVal*10) < 0.01 then - Result := Format('%1.1f', [val]) - else - Result := Format('%1.2f', [val]); -end; -//------------------------------------------------------------------------------ - -procedure AppendFloat(var s: string; val: double); -begin - s := Format('%s%s ', [s, ValueToStr(val)]); -end; -//------------------------------------------------------------------------------ - -procedure AppendFloatAttrib(var s: string; - const attribName: string; val: double); -begin - s := Format('%s%s="%s" ', [s, attribName, ValueToStr(val)]); -end; -//------------------------------------------------------------------------------ - -procedure AppendPoint(var s: string; X, Y: double); overload; -begin - s := Format('%s%s,%s ',[s, ValueToStr(X), ValueToStr(Y)]); -end; -//------------------------------------------------------------------------------ - -procedure AppendPoint(var s: string; const pt: TPointD); overload; -begin - s := Format('%s%s,%s ',[s, ValueToStr(pt.X), ValueToStr(pt.Y)]); -end; -//------------------------------------------------------------------------------ - -procedure AppendPathSegType(var s: string; segType: TSvgPathSegType); -var - ch: UTF8Char; -begin - case segType of - stMove : ch := 'M'; - stLine : ch := 'L'; - stHorz : ch := 'H'; - stVert : ch := 'V'; - stArc : ch := 'A'; - stQBezier : ch := 'Q'; - stCBezier : ch := 'C'; - stQSpline : ch := 'T'; - stCSpline : ch := 'S'; - else ch := 'Z'; - end; - s := Format('%s%s ',[s, ch]); -end; -//------------------------------------------------------------------------------ - -function ColorToRGBA(color: TColor32): string; -begin - with TARGB(color) do - case A of - 0: - Result := 'none'; - 255: - begin - case Color of - clAqua32 : Result := 'aqua'; - clBlack32 : Result := 'black'; - clBlue32 : Result := 'blue'; - clFuchsia32 : Result := 'fuchsia'; - clGray32 : Result := 'gray'; - clGreen32 : Result := 'green'; - clLime32 : Result := 'lime'; - clMaroon32 : Result := 'maroon'; - clNavy32 : Result := 'navy'; - clOlive32 : Result := 'olive'; - clOrange32 : Result := 'orange'; - clPurple32 : Result := 'purple'; - clRed32 : Result := 'red'; - clSilver32 : Result := 'silver'; - clTeal32 : Result := 'teal'; - clWhite32 : Result := 'white'; - clYellow32 : Result := 'yellow'; - else Result := Format('rgb(%d, %d, %d)', [R, G, B]); - end; - end; - else - Result := Format('rgba(%d, %d, %d, %1.2n)', [R, G, B, A/255]); - end; -end; -//------------------------------------------------------------------------------ - -procedure AppendColorAttrib(var s: string; - const attribName: string; color: TColor32); -begin - s := format('%s%s="%s" ', [s, attribName, ColorToRGBA(color)]); -end; - -//------------------------------------------------------------------------------ -// TSvgElementWriter -//------------------------------------------------------------------------------ - -constructor TBaseElWriter.Create(parent: TBaseElWriter); -begin - fParent := parent; - if Assigned(parent) and (indentSize > 0) then - fIndent := parent.Indent + StringOfChar(#32, indentSize); - {$IFDEF XPLAT_GENERICS} - fChilds := TList.Create; - {$ELSE} - fChilds := TList.Create; - {$ENDIF} -end; -//------------------------------------------------------------------------------ - -destructor TBaseElWriter.Destroy; -begin - Clear; - fChilds.Free; -end; -//------------------------------------------------------------------------------ - -function TBaseElWriter.AddChild(childClass: TSvgElWriterClass): TBaseElWriter; -begin - Result := childClass.Create(self); - fChilds.Add(Result); -end; -//------------------------------------------------------------------------------ - -procedure TBaseElWriter.DeleteChild(index: integer); -begin - if (index < 0) or (index >= fChilds.Count) then - raise Exception.Create('TBaseElWriter.DeleteChild range error.'); - TBaseElWriter(fChilds[index]).Free; - fChilds.Delete(index); -end; -//------------------------------------------------------------------------------ - -procedure TBaseElWriter.Clear; -var - i: integer; -begin - for i := 0 to fChilds.Count -1 do - TBaseElWriter(fChilds[i]).Free; - fChilds.Clear; -end; -//------------------------------------------------------------------------------ - -function TBaseElWriter.Write: string; -begin - Result := Format(#10'%s<%s ',[indent, fElStr]); - AppendStr(Result, WriteHeader, true); - if fChilds.Count > 0 then - begin - AppendStr(Result, '> ', true); - AppendStr(Result, WriteContent, true); - AppendStr(Result, Format(#10'%s',[indent, fElStr]), true); - end else - AppendStr(Result, '/>', true); -end; -//------------------------------------------------------------------------------ - -function TBaseElWriter.WriteHeader: string; -begin - Result := ''; -end; -//------------------------------------------------------------------------------ - -function TBaseElWriter.WriteContent: string; -var - i: integer; -begin - Result := ''; - for i := 0 to fChilds.Count -1 do - AppendStr(Result, TBaseElWriter(fChilds[i]).Write, true); -end; - -//------------------------------------------------------------------------------ -// TExBaseElWriter -//------------------------------------------------------------------------------ - -constructor TExBaseElWriter.Create(parent: TBaseElWriter); -begin - inherited; - Matrix := IdentityMatrix; - fFillClr := clInvalid; - fStrokeClr := clInvalid; - fStrokeWidth := 1.0; -end; -//------------------------------------------------------------------------------ - -function TExBaseElWriter.WriteHeader: string; -var - i,j: integer; -begin - Result := inherited WriteHeader; - if fFillClr <> clInvalid then - begin - AppendColorAttrib(Result, 'fill', fFillClr); - if fFillRule = frEvenOdd then - AppendStr(Result, 'fill-rule="evenodd"', false) else - AppendStr(Result, 'fill-rule="nonzero"', false); - end; - if fStrokeClr <> clInvalid then - begin - AppendColorAttrib(Result, 'stroke', fStrokeClr); - AppendFloatAttrib(Result, 'stroke-width', fStrokeWidth); - end; - if Assigned(fDashes) then - begin - AppendStr(Result, 'stroke-dasharray="', true); - for i := 0 to High(fDashes) do - AppendFloat(Result, fDashes[i]); - AppendStr(Result, '"'); - end; - if not IsIdentityMatrix(Matrix) then - begin - AppendStr(Result, 'transform="matrix('); - for i := 0 to 1 do for j := 0 to 1 do - AppendFloat(Result, Matrix[i][j]); - AppendFloat(Result, Matrix[2][0]); - AppendFloat(Result, Matrix[2][1]); - AppendStr(Result, ')"'); - end; -end; -//------------------------------------------------------------------------------ - -procedure TExBaseElWriter.Rotate(const pivotPt: TPointD; angleRad: double); -begin - MatrixRotate(Matrix, pivotPt, angleRad); -end; -//------------------------------------------------------------------------------ - -procedure TExBaseElWriter.Translate(dx, dy: double); -begin - MatrixTranslate(Matrix, dx, dy); -end; -//------------------------------------------------------------------------------ - -procedure TExBaseElWriter.Skew(dx, dy: double); -begin - MatrixSkew(Matrix, dx, dy); -end; - -//------------------------------------------------------------------------------ -// TSvgSvgWriter -//------------------------------------------------------------------------------ - -constructor TSvgElWriter.Create(parent: TBaseElWriter); -begin - inherited; - fElStr := 'svg'; -end; -//------------------------------------------------------------------------------ - - -function TSvgElWriter.WriteHeader: string; -const - svgHeader = 'width="%2:dpx" height="%3:dpx" viewBox="%0:d %1:d %2:d %3:d"'; - svgHeader2 = 'version="1.1" xmlns="http://www.w3.org/2000/svg"'; -begin - Result := ''; - with fViewbox do - AppendStr(Result, Format(svgHeader, [left, top, right-left, bottom -top])); - AppendStr(Result, svgHeader2); -end; - -//------------------------------------------------------------------------------ -// TSvgGroupWriter -//------------------------------------------------------------------------------ - -constructor TSvgGroupWriter.Create(parent: TBaseElWriter); -begin - inherited; - fElStr := 'g'; -end; - -//------------------------------------------------------------------------------ -// TSvgPathWriter -//------------------------------------------------------------------------------ - -constructor TSvgPathWriter.Create(parent: TBaseElWriter); -begin - inherited; - fSvgPaths := TSvgPath.Create; - fElStr := 'path'; - fFillClr := clBlack32; -end; -//------------------------------------------------------------------------------ - -destructor TSvgPathWriter.Destroy; -begin - fSvgPaths.Free; - inherited; -end; -//------------------------------------------------------------------------------ - -function TSvgPathWriter.GetPathCount: integer; -begin - Result := fSvgPaths.Count; -end; -//------------------------------------------------------------------------------ - -function TSvgPathWriter.GetNewPath: TSvgSubPath; -begin - //don't get a new path if the old current path is still empty - Result := GetCurrentPath; - if (Result.Count > 0) then - Result := fSvgPaths.AddPath; -end; -//------------------------------------------------------------------------------ - -function TSvgPathWriter.GetCurrentPath: TSvgSubPath; -var - len: integer; -begin - len := fSvgPaths.Count; - if len = 0 then - Result := fSvgPaths.AddPath else - Result := fSvgPaths[len -1]; -end; -//------------------------------------------------------------------------------ - -function TSvgPathWriter.WriteHeader: string; -begin - Result := inherited WriteHeader; - Result := Result + - Format('d="%s"', [fSvgPaths.GetStringDef(true, 2)]); -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.Clear; -begin - inherited; - fSvgPaths := nil; - fLastPt := NullPointD; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.MoveTo(X,Y: double); -begin - fLastPt := PointD(X,Y); - GetNewPath; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.LineHTo(X: double); -var - currPath : TSvgSubPath; - lastSeg : TSvgPathSeg; - path : TPathD; -begin - currPath := GetCurrentPath; - lastSeg := currPath.GetLastSeg; - path := MakePath([X, fLastPt.Y]); - if Assigned(lastSeg) and (lastSeg is TSvgHSegment) then - lastSeg.ExtendSeg(path) else - currPath.AddHSeg(fLastPt, path); - fLastPt.X := X; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.LineVTo(Y: double); -var - currPath : TSvgSubPath; - lastSeg : TSvgPathSeg; - path : TPathD; -begin - currPath := GetCurrentPath; - lastSeg := currPath.GetLastSeg; - path := MakePath([fLastPt.X, Y]); - if Assigned(lastSeg) and (lastSeg is TSvgVSegment) then - lastSeg.ExtendSeg(path) else - currPath.AddVSeg(fLastPt, path); - fLastPt.Y := Y; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.LineTo(X,Y: double); -var - currPath : TSvgSubPath; - lastSeg : TSvgPathSeg; - path : TPathD; -begin - currPath := GetCurrentPath; - lastSeg := currPath.GetLastSeg; - path := MakePath([X, Y]); - if Assigned(lastSeg) and (lastSeg is TSvgLSegment) then - lastSeg.ExtendSeg(path) else - currPath.AddLSeg(fLastPt, path); - fLastPt := path[0]; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.ArcTo(const radii: TPointD; angle: double; - arcFlag, sweepFlag: Boolean; const endPt: TPointD); -var - currPath : TSvgSubPath; - rec : TRectD; -begin - rec := GetSvgArcInfoRect(fLastPt, endPt, radii, angle, arcFlag, sweepFlag); - if rec.IsEmpty then Exit; - currPath := GetCurrentPath; - currPath.AddASeg(fLastPt, endPt, rec, angle, sweepFlag); - fLastPt := endPt; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.ArcTo(const endPt: TPointD; const rec: TRectD; - angle: double; sweepFlag: Boolean); -var - currPath : TSvgSubPath; -begin - if rec.IsEmpty then Exit; - currPath := GetCurrentPath; - currPath.AddASeg(fLastPt, endPt, rec, angle, sweepFlag); - fLastPt := endPt; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.CubicBezierTo(const ctrl1, ctrl2, endPt: TPointD); -var - currPath : TSvgSubPath; - lastSeg : TSvgPathSeg; - path : TPathD; -begin - currPath := GetCurrentPath; - lastSeg := currPath.GetLastSeg; - SetLength(path, 3); - path[0] := ctrl1; path[1] := ctrl2; path[2] := endPt; - if Assigned(lastSeg) and (lastSeg is TSvgCSegment) then - lastSeg.ExtendSeg(path) else - currPath.AddCSeg(fLastPt, path); - fLastPt := endPt; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.CubicSplineTo(const ctrl2, endPt: TPointD); -var - currPath : TSvgSubPath; - lastSeg : TSvgPathSeg; - path : TPathD; -begin - currPath := GetCurrentPath; - lastSeg := currPath.GetLastSeg; - SetLength(path, 2); - path[0] := ctrl2; path[1] := endPt; - if Assigned(lastSeg) and (lastSeg is TSvgSSegment) then - lastSeg.ExtendSeg(path) else - currPath.AddSSeg(fLastPt, path); - fLastPt := endPt; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.QuadBezierTo(const ctrl, endPt: TPointD); -var - currPath : TSvgSubPath; - lastSeg : TSvgPathSeg; - path : TPathD; -begin - currPath := GetCurrentPath; - lastSeg := currPath.GetLastSeg; - SetLength(path, 2); - path[0] := ctrl; path[1] := endPt; - if Assigned(lastSeg) and (lastSeg is TSvgQSegment) then - lastSeg.ExtendSeg(path) else - currPath.AddQSeg(fLastPt, path); - fLastPt := endPt; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.QuadSplineTo(const endPt: TPointD); -var - currPath : TSvgSubPath; - lastSeg : TSvgPathSeg; - path : TPathD; -begin - currPath := GetCurrentPath; - lastSeg := currPath.GetLastSeg; - SetLength(path, 1); - path[0] := endPt; - if Assigned(lastSeg) and (lastSeg is TSvgTSegment) then - lastSeg.ExtendSeg(path) else - currPath.AddTSeg(fLastPt, path); - fLastPt := endPt; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.ClosePath; -var - currPath : TSvgSubPath; -begin - currPath := GetCurrentPath; - if (currPath.Count > 0) and not currPath.isClosed then - currPath.AddZSeg(fLastPt, currPath.GetFirstPt); -end; -//------------------------------------------------------------------------------ - -procedure TSvgPathWriter.DeleteLastSegment(subPath: TSvgSubPath); -begin - subPath.DeleteLastSeg; -end; - -//------------------------------------------------------------------------------ -// TSvgCircleWriter -//------------------------------------------------------------------------------ - -constructor TSvgCircleWriter.Create(parent: TBaseElWriter); -begin - inherited; - fElStr := 'circle'; -end; -//------------------------------------------------------------------------------ - -function TSvgCircleWriter.WriteHeader: string; -begin - Result := inherited WriteHeader; - AppendFloatAttrib(Result, 'cx', Origin.X); - AppendFloatAttrib(Result, 'cy', Origin.Y); - AppendFloatAttrib(Result, 'r', radius); -end; - -//------------------------------------------------------------------------------ -// TSvgEllipseWriter -//------------------------------------------------------------------------------ - -constructor TSvgEllipseWriter.Create(parent: TBaseElWriter); -begin - inherited; - fElStr := 'ellipse'; -end; -//------------------------------------------------------------------------------ - -function TSvgEllipseWriter.WriteHeader: string; -begin - Result := inherited WriteHeader; - AppendFloatAttrib(Result, 'cx', Origin.X); - AppendFloatAttrib(Result, 'cy', Origin.Y); - AppendFloatAttrib(Result, 'rx', radii.cx); - AppendFloatAttrib(Result, 'ry', radii.cy); -end; - -//------------------------------------------------------------------------------ -// TSvgRectWriter -//------------------------------------------------------------------------------ - -constructor TSvgRectWriter.Create(parent: TBaseElWriter); -begin - inherited; - fElStr := 'rect'; -end; -//------------------------------------------------------------------------------ - -function TSvgRectWriter.WriteHeader: string; -begin - Result := inherited WriteHeader; - AppendFloatAttrib(Result, 'x', RecWH.Left); - AppendFloatAttrib(Result, 'y', RecWH.Top); - AppendFloatAttrib(Result, 'width', RecWH.Width); - AppendFloatAttrib(Result, 'height', RecWH.Height); - if radii.cx > 0 then - AppendFloatAttrib(Result, 'rx', radii.cx); - if radii.cy > 0 then - AppendFloatAttrib(Result, 'ry', radii.cy); -end; - -//------------------------------------------------------------------------------ -// TSvgPolygonWriter -//------------------------------------------------------------------------------ - -constructor TSvgPolygonWriter.Create(parent: TBaseElWriter); -begin - inherited; - fElStr := 'polygon'; -end; -//------------------------------------------------------------------------------ - -procedure TSvgPolygonWriter.Clear; -begin - inherited; - path := nil; -end; -//------------------------------------------------------------------------------ - -function TSvgPolygonWriter.WriteHeader: string; -var - i, len: integer; - s: string; -begin - Result := inherited WriteHeader; - len := Length(path); - if len = 0 then Exit; - for i := 0 to len -1 do - AppendPoint(s, path[i]); - AppendStrAttrib(Result, 'points', s); -end; - -//------------------------------------------------------------------------------ -// TSvgPolylineWriter -//------------------------------------------------------------------------------ - -constructor TSvgPolylineWriter.Create(parent: TBaseElWriter); -begin - inherited; - fElStr := 'polyline'; -end; - -//------------------------------------------------------------------------------ -// TSvgTextWriter -//------------------------------------------------------------------------------ - -constructor TSvgTextWriter.Create(parent: TBaseElWriter); -begin - inherited; - fElStr := 'text'; - fOffset.cx := InvalidD; - fOffset.cy := InvalidD; -end; -//------------------------------------------------------------------------------ - -procedure TSvgTextWriter.AddText(const aText: string; X,Y: double; font: TFontCache); -begin - with AddChild(TSvgSubTextWriter) as TSvgSubTextWriter do - begin - text := atext; - fFontInfo := GetFontInfo(font); - fPosition := PointD(X,Y); - end; -end; -//------------------------------------------------------------------------------ - -function TSvgTextWriter.WriteHeader: string; -begin - Result := inherited WriteHeader; - with fFontInfo do - begin - case family of - ttfUnknown:; - ttfSerif : AppendStrAttrib(Result, 'font-family', 'serif'); - ttfSansSerif : AppendStrAttrib(Result, 'font-family', 'sans-serif'); - ttfMonospace : AppendStrAttrib(Result, 'font-family', 'monospace'); - end; - if size > 2 then - AppendFloatAttrib(Result, 'font-size', size); - if spacing <> 0 then - AppendFloatAttrib(Result, 'font-spacing', spacing); - if italic then - AppendStrAttrib(Result, 'font-style', 'italic') else - AppendStrAttrib(Result, 'font-style', 'normal'); - if (weight >= 100) and (weight <= 900) then - AppendFloatAttrib(Result, 'font-weight', weight); - case decoration of - fdNone: AppendStrAttrib(Result, 'text-decoration', 'none'); - fdUnderline: AppendStrAttrib(Result, 'text-decoration', 'underline'); - fdStrikeThrough: AppendStrAttrib(Result, 'text-decoration', 'line-through'); - end; - end; - if fPosition.X <> InvalidD then - AppendFloatAttrib(Result, 'x', fPosition.X); - if fPosition.Y <> InvalidD then - AppendFloatAttrib(Result, 'y', fPosition.Y); - if fOffset.cx <> InvalidD then - AppendFloatAttrib(Result, 'dx', fOffset.cx); - if fOffset.cy <> InvalidD then - AppendFloatAttrib(Result, 'dy', fOffset.cy); -end; -//------------------------------------------------------------------------------ - -function TSvgTextWriter.Write: string; -var - i: integer; -begin - if (Self is TSvgTSpanWriter) then - Result := Format('<%s ',[fElStr]) else - Result := Format(#10'%s<%s ',[indent, fElStr]); - AppendStr(Result, WriteHeader, true); - if fChilds.Count > 0 then - begin - AppendStr(Result, '>', true); - for i := 0 to fChilds.Count -1 do - if TBaseElWriter(fChilds[i]) is TSvgTSpanWriter then - AppendStr(Result, TBaseElWriter(fChilds[i]).Write, true) - else if TBaseElWriter(fChilds[i]) is TSvgSubTextWriter then - AppendStr(Result, TSvgSubTextWriter(fChilds[i]).text, true); - AppendStr(Result, Format('',[fElStr]), true); - end else - AppendStr(Result, '/>', true); -end; - -//------------------------------------------------------------------------------ -// TSvgTSpanWriter -//------------------------------------------------------------------------------ - -constructor TSvgTSpanWriter.Create(parent: TBaseElWriter); -begin - inherited; - fElStr := 'tspan'; - fPosition := InvalidPointD; -end; - -//------------------------------------------------------------------------------ -// TSvgWriter -//------------------------------------------------------------------------------ - -constructor TSvgWriter.Create; -begin - inherited; - fSvgElememt := TSvgElWriter.Create(nil); -end; -//------------------------------------------------------------------------------ - -destructor TSvgWriter.Destroy; -begin - Clear; - fSvgElememt.Free; - inherited; -end; -//------------------------------------------------------------------------------ - -procedure TSvgWriter.Clear; -begin - fSvgElememt.Clear; -end; -//------------------------------------------------------------------------------ - -function TSvgWriter.WriteHeader: string; -const - xmlHeader = ''; -begin - Result := xmlHeader; - AppendStr(Result, fSvgElememt.Write, true); -end; -//------------------------------------------------------------------------------ - -procedure TSvgWriter.SaveToFile(const filename: string); -var - str: string; -begin - str := WriteHeader; - with TStringList.Create do - try - {$IFDEF UNICODE} - text := str; - SaveToFile(filename, TEncoding.UTF8); - {$ELSE} - text := UTF8Encode(str); - SaveToFile(filename); - {$ENDIF} - finally - free; - end; -end; -//------------------------------------------------------------------------------ - -procedure TSvgWriter.SaveToStream(stream: TStream); -var - str: string; -begin - str := WriteHeader; - with TStringList.Create do - try - {$IFDEF UNICODE} - text := str; - SaveToStream (stream, TEncoding.UTF8); - {$ELSE} - text := UTF8Encode(str); - SaveToStream (stream); - {$ENDIF} - finally - free; - end; -end; - -//------------------------------------------------------------------------------ -//------------------------------------------------------------------------------ - -end. diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Storage.pas b/Ext/SVGIconImageList/Image32/source/Img32.Storage.pas index f31e38f..094f6f6 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Storage.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Storage.pas @@ -2,13 +2,11 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 28 January 2022 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * -* * * Purpose : Object persistence * -* * * License : http://www.boost.org/LICENSE_1_0.txt * *******************************************************************************) @@ -24,19 +22,23 @@ interface TStorage = class; TStorageClass = class of TStorage; +{$IFNDEF NO_STORAGE} TStorageManager = class; +{$ENDIF} TStorage = class(TInterfacedObj) private fParent : TStorage; +{$IFNDEF NO_STORAGE} fManager : TStorageManager; +{$ENDIF} fChilds : TList; fIndex : integer; fName : string; fStgState : TStorageState; fStgId : integer; function GetChildCount: integer; - function GetHasChildren: Boolean; + function GetHasChildren: Boolean; protected procedure SetName(const aName: string); virtual; function GetChild(index: integer): TStorage; @@ -44,9 +46,9 @@ TStorage = class(TInterfacedObj) procedure ReindexChilds(startFrom: integer); procedure CheckChildIndex(index: integer); virtual; function RemoveChildFromList(index: integer): TStorage; virtual; +{$IFNDEF NO_STORAGE} procedure BeginRead; virtual; function ReadProperty(const propName, propVal: string): Boolean; virtual; - //procedure EndReadProperties; virtual; procedure EndRead; virtual; procedure WriteProperties; virtual; procedure WriteStorageHeader(var objId: integer); @@ -64,6 +66,7 @@ TStorage = class(TInterfacedObj) procedure WriteExternalProp(const propName: string; propVal: TObject); procedure WriteEventProp(const propName: string; propVal: TNotifyEvent); procedure WriteStrProp(const propName, propVal: string); +{$ENDIF} public constructor Create(parent: TStorage = nil; const name: string = ''); virtual; destructor Destroy; override; @@ -74,11 +77,13 @@ TStorage = class(TInterfacedObj) procedure DeleteChild(index: integer); function IsOwnedBy(obj: TStorage): Boolean; overload; function IsOwnedBy(objClass: TStorageClass): Boolean; overload; +{$IFNDEF NO_STORAGE} function FindByName(const objName: string): TStorage; function FindById(const objId: integer): TStorage; function FindByClass(stgClass: TStorageClass): TStorage; function FindByClassAndName(stgClass: TStorageClass; const objName: string): TStorage; +{$ENDIF} property Child[index: integer]: TStorage read GetChild; property Childs: TList read fChilds; property ChildCount: integer read GetChildCount; @@ -87,10 +92,13 @@ TStorage = class(TInterfacedObj) property LoadId : integer read fStgId; property Name : string read fName write SetName; property Parent : TStorage read fParent write SetParent; +{$IFNDEF NO_STORAGE} property StorageManager: TStorageManager read fManager; +{$ENDIF} property StorageState : TStorageState read fStgState; end; +{$IFNDEF NO_STORAGE} TStorageManager = class(TStorage) private fDesignScreenRes : double; @@ -137,6 +145,7 @@ TStorageInfo = class(TStorage) function GetColorProp(const str: string; out success: Boolean): TColor32; function GetPointDProp(const str: string; out success: Boolean): TPointD; procedure RegisterStorageClass(storageClass: TStorageClass); +{$ENDIF} implementation @@ -159,6 +168,7 @@ TLoadPtrRec = record var classList : TStringList; +{$IFNDEF NO_STORAGE} objIdList : TList; const @@ -994,6 +1004,7 @@ procedure SaveUtf8StringToFile(const utf8: Utf8String; const filename: string); ms.Free; end; end; +{$ENDIF} //------------------------------------------------------------------------------ // TStorage @@ -1007,6 +1018,7 @@ constructor TStorage.Create(parent: TStorage; const name: string); begin fIndex := parent.fChilds.Add(self); fParent := parent; +{$IFNDEF NO_STORAGE} if Assigned(parent.fManager) then begin fManager := parent.fManager; @@ -1014,6 +1026,9 @@ constructor TStorage.Create(parent: TStorage; const name: string); end; end; if fStgState = ssLoading then BeginRead; +{$ELSE} + end; +{$ENDIF} end; //------------------------------------------------------------------------------ @@ -1077,6 +1092,7 @@ function TStorage.IsOwnedBy(objClass: TStorageClass): Boolean; end; //------------------------------------------------------------------------------ +{$IFNDEF NO_STORAGE} function TStorage.FindByName(const objName: string): TStorage; var i: integer; @@ -1300,6 +1316,7 @@ procedure TStorage.WriteProperties; if Name <> '' then WriteStrProp('Name', Name); end; //------------------------------------------------------------------------------ +{$ENDIF} function TStorage.GetHasChildren: Boolean; begin @@ -1382,8 +1399,9 @@ procedure TStorage.DeleteChild(index: integer); //may need to notify parents of properties before destruction TStorage(fChilds[index]).Free; end; -//------------------------------------------------------------------------------ +{$IFNDEF NO_STORAGE} +//------------------------------------------------------------------------------ // TStorageManager //------------------------------------------------------------------------------ @@ -1623,6 +1641,7 @@ procedure TStorageInfo.WriteProperties; WriteDoubleProp('DesignScale', StorageManager.fDesignFormScale); StorageManager.WriteCustomProperties; end; +{$ENDIF} //------------------------------------------------------------------------------ // Storage class registration @@ -1652,8 +1671,11 @@ procedure EndStorageClassRegister; initialization InitStorageClassRegister; +{$IFNDEF NO_STORAGE} RegisterStorageClass(TStorageInfo); +{$ENDIF} finalization EndStorageClassRegister; + end. diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Text.pas b/Ext/SVGIconImageList/Image32/source/Img32.Text.pas index a4278eb..ffc94e8 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Text.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Text.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 10 January 2022 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Transform.pas b/Ext/SVGIconImageList/Image32/source/Img32.Transform.pas index 7ecf3a0..81362f0 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Transform.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Transform.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.0 * -* Date : 22 December 2021 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2021 * * * diff --git a/Ext/SVGIconImageList/Image32/source/Img32.Vector.pas b/Ext/SVGIconImageList/Image32/source/Img32.Vector.pas index 6c874ee..696bc59 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.Vector.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.Vector.pas @@ -1,3553 +1,3688 @@ -unit Img32.Vector; -(******************************************************************************* -* Author : Angus Johnson * -* Version : 4.12 * -* Date : 4 March 2022 * -* Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2022 * -* * -* Purpose : Vector drawing for TImage32 * -* * -* License : Use, modification & distribution is subject to * -* Boost Software License Ver 1 * -* http://www.boost.org/LICENSE_1_0.txt * -*******************************************************************************) -interface -{$I Img32.inc} -uses - SysUtils, Classes, Math, Types, Img32; -type - TArrowStyle = (asNone, asSimple, asFancy, asDiamond, asCircle, asTail); - TJoinStyle = (jsAuto, jsSquare, jsMiter, jsRound); - TEndStyle = (esPolygon, esClosed = 0, esButt, esSquare, esRound); - TPathEnd = (peStart, peEnd, peBothEnds); - TSplineType = (stQuadratic, stCubic); - TFillRule = (frEvenOdd, frNonZero, frPositive, frNegative); - TSizeD = {$IFDEF RECORD_METHODS} record {$ELSE} object {$ENDIF} - cx : double; - cy : double; - function average: double; - property Width: Double read cx write cx; - property Height: Double read cy write cy; - end; - TRectWH = {$IFDEF RECORD_METHODS} record {$ELSE} object {$ENDIF} - public - Left, Top, Width, Height: double; - function IsEmpty: Boolean; - function IsValid: Boolean; - function Right: double; - function Bottom: double; - function Contains(const Pt: TPoint): Boolean; overload; - function Contains(const Pt: TPointD): Boolean; overload; - function MidPoint: TPointD; - function RectD: TRectD; - function Rect: TRect; - end; - function RectWH(left, top, width, height: integer): TRectWH; overload; - function RectWH(left, top, width, height: double ): TRectWH; overload; - function RectWH(const rec: TRectD): TRectWH; overload; - //InflateRect: missing in Delphi 7 - procedure InflateRect(var rec: TRect; dx, dy: integer); overload; - procedure InflateRect(var rec: TRectD; dx, dy: double); overload; - function NormalizeRect(var rect: TRect): Boolean; - function PrePendPoint(const pt: TPointD; const p: TPathD): TPathD; - function PrePendPoints(const pt1, pt2: TPointD; const p: TPathD): TPathD; - function Rectangle(const rec: TRect): TPathD; overload; - function Rectangle(const rec: TRectD): TPathD; overload; - function Rectangle(l, t, r, b: double): TPathD; overload; - function RoundRect(const rec: TRect; radius: integer): TPathD; overload; - function RoundRect(const rec: TRectD; radius: double): TPathD; overload; - function RoundRect(const rec: TRect; radius: TPoint): TPathD; overload; - function RoundRect(const rec: TRectD; radius: TPointD): TPathD; overload; - function Ellipse(const rec: TRect; steps: integer = 0): TPathD; overload; - function Ellipse(const rec: TRectD; steps: integer = 0): TPathD; overload; - function Ellipse(const rec: TRectD; pendingScale: double): TPathD; overload; - function RotatedEllipse(const rec: TRectD; angle: double; steps: integer = 0): TPathD; overload; - function RotatedEllipse(const rec: TRectD; angle: double; pendingScale: double): TPathD; overload; - function AngleToEllipticalAngle(const ellRec: TRectD; angle: double): double; - function EllipticalAngleToAngle(const ellRec: TRectD; angle: double): double; - function Circle(const pt: TPoint; radius: double): TPathD; overload; - function Circle(const pt: TPointD; radius: double): TPathD; overload; - function Circle(const pt: TPointD; radius: double; pendingScale: double): TPathD; overload; - function Star(const rec: TRectD; points: integer; indentFrac: double = 0.4): TPathD; overload; - function Star(const focalPt: TPointD; - innerRadius, outerRadius: double; points: integer): TPathD; overload; - function Arc(const rec: TRectD; - startAngle, endAngle: double; scale: double = 0): TPathD; - function Pie(const rec: TRectD; - StartAngle, EndAngle: double; scale: double = 0): TPathD; - function FlattenQBezier(const pt1, pt2, pt3: TPointD; - tolerance: double = 0.0): TPathD; overload; - function FlattenQBezier(const pts: TPathD; - tolerance: double = 0.0): TPathD; overload; - function FlattenQBezier(const firstPt: TPointD; const pts: TPathD; - tolerance: double = 0.0): TPathD; overload; - function GetPointInQuadBezier(const a,b,c: TPointD; t: double): TPointD; - function FlattenCBezier(const pt1, pt2, pt3, pt4: TPointD; - tolerance: double = 0.0): TPathD; overload; - function FlattenCBezier(const pts: TPathD; - tolerance: double = 0.0): TPathD; overload; - function FlattenCBezier(const firstPt: TPointD; const pts: TPathD; - tolerance: double = 0.0): TPathD; overload; - function GetPointInCubicBezier(const a,b,c,d: TPointD; t: double): TPointD; - //FlattenCSpline: Approximates the 'S' command inside the 'd' property of an - //SVG path. (See https://www.w3.org/TR/SVG/paths.html#DProperty) - function FlattenCSpline(const pts: TPathD; - tolerance: double = 0.0): TPathD; overload; - function FlattenCSpline(const priorCtrlPt, startPt: TPointD; - const pts: TPathD; tolerance: double = 0.0): TPathD; overload; - //FlattenQSpline: Approximates the 'T' command inside the 'd' property of an - //SVG path. (See https://www.w3.org/TR/SVG/paths.html#DProperty) - function FlattenQSpline(const pts: TPathD; - tolerance: double = 0.0): TPathD; overload; - function FlattenQSpline(const priorCtrlPt, startPt: TPointD; - const pts: TPathD; tolerance: double = 0.0): TPathD; overload; - //ArrowHead: The ctrlPt's only function is to control the angle of the arrow. - function ArrowHead(const arrowTip, ctrlPt: TPointD; size: double; - arrowStyle: TArrowStyle): TPathD; - function GetDefaultArrowHeadSize(lineWidth: double): double; - procedure AdjustPoint(var pt: TPointD; - const referencePt: TPointD; delta: double); - function ShortenPath(const path: TPathD; - pathEnd: TPathEnd; amount: double): TPathD; - - //GetDashPath: Returns a polyline (not polygons) - function GetDashedPath(const path: TPathD; - closed: Boolean; const pattern: TArrayOfInteger; - patternOffset: PDouble): TPathsD; - function GetDashedOutLine(const path: TPathD; - closed: Boolean; const pattern: TArrayOfInteger; - patternOffset: PDouble; lineWidth: double; - joinStyle: TJoinStyle; endStyle: TEndStyle): TPathsD; - function OffsetPoint(const pt: TPoint; dx, dy: integer): TPoint; overload; - function OffsetPoint(const pt: TPointD; dx, dy: double): TPointD; overload; - function OffsetPath(const path: TPathD; - dx, dy: double): TPathD; overload; - function OffsetPath(const paths: TPathsD; - dx, dy: double): TPathsD; overload; - function OffsetPath(const ppp: TArrayOfPathsD; - dx, dy: double): TArrayOfPathsD; overload; - //CopyPath: note that only dynamic string arrays are copy-on-write - function Paths(const path: TPathD): TPathsD; - {$IFDEF INLINING} inline; {$ENDIF} - function CopyPath(const path: TPathD): TPathD; - {$IFDEF INLINING} inline; {$ENDIF} - function CopyPaths(const paths: TPathsD): TPathsD; - function ScalePoint(const pt: TPointD; scale: double): TPointD; overload; - {$IFDEF INLINING} inline; {$ENDIF} - function ScalePoint(const pt: TPointD; sx, sy: double): TPointD; overload; - {$IFDEF INLINING} inline; {$ENDIF} - function ScalePath(const path: TPathD; - sx, sy: double): TPathD; overload; - function ScalePath(const path: TPathD; - scale: double): TPathD; overload; - function ScalePath(const paths: TPathsD; - sx, sy: double): TPathsD; overload; - function ScalePath(const paths: TPathsD; - scale: double): TPathsD; overload; - function ScaleRect(const rec: TRect; scale: double): TRect; overload; - function ScaleRect(const rec: TRectD; scale: double): TRectD; overload; - function ScaleRect(const rec: TRect; sx, sy: double): TRect; overload; - function ScaleRect(const rec: TRectD; sx, sy: double): TRectD; overload; - function ReversePath(const path: TPathD): TPathD; overload; - function ReversePath(const paths: TPathsD): TPathsD; overload; - function OpenPathToFlatPolygon(const path: TPathD): TPathD; - procedure AppendPoint(var path: TPathD; const extra: TPointD); - procedure AppendPath(var path: TPathD; const pt: TPointD); overload; - procedure AppendPath(var path1: TPathD; const path2: TPathD); overload; - procedure AppendPath(var paths: TPathsD; const extra: TPathD); overload; - procedure AppendPath(var paths: TPathsD; const extra: TPathsD); overload; - procedure AppendPath(var ppp: TArrayOfPathsD; const extra: TPathsD); overload; - function GetAngle(const origin, pt: TPoint): double; overload; - function GetAngle(const origin, pt: TPointD): double; overload; - function GetAngle(const a, b, c: TPoint): double; overload; - function GetAngle(const a, b, c: TPointD): double; overload; - procedure GetSinCos(angle: double; out sinA, cosA: double); - function GetPointAtAngleAndDist(const origin: TPointD; - angle, distance: double): TPointD; - function IntersectPoint(const ln1a, ln1b, ln2a, ln2b: TPointD): TPointD; overload; - function IntersectPoint(const ln1a, ln1b, ln2a, ln2b: TPointD; out ip: TPointD): Boolean; overload; - function SegmentIntersectPt(const ln1a, ln1b, ln2a, ln2b: TPointD): TPointD; - function SegmentsIntersect(const ln1a, ln1b, ln2a, ln2b: TPointD; - out ip: TPointD): Boolean; - procedure RotatePoint(var pt: TPointD; - const focalPoint: TPointD; sinA, cosA: double); overload; - procedure RotatePoint(var pt: TPointD; - const focalPoint: TPointD; angleRad: double); overload; - function RotatePath(const path: TPathD; - const focalPoint: TPointD; angleRads: double): TPathD; overload; - function RotatePath(const paths: TPathsD; - const focalPoint: TPointD; angleRads: double): TPathsD; overload; - function MakePath(const pts: array of integer): TPathD; overload; - function MakePath(const pts: array of double): TPathD; overload; - function GetBounds(const path: TPathD): TRect; overload; - function GetBounds(const paths: TPathsD): TRect; overload; - function GetBoundsD(const path: TPathD): TRectD; overload; - function GetBoundsD(const paths: TPathsD): TRectD; overload; - function GetRotatedRectBounds(const rec: TRect; angle: double): TRect; overload; - function GetRotatedRectBounds(const rec: TRectD; angle: double): TRectD; overload; - function Rect(const recD: TRectD): TRect; overload; - function Rect(const left,top,right,bottom: integer): TRect; overload; - function PtInRect(const rec: TRectD; const pt: TPointD): Boolean; overload; - function Size(cx, cy: integer): TSize; - function SizeD(cx, cy: double): TSizeD; - function IsClockwise(const path: TPathD): Boolean; - function Area(const path: TPathD): Double; - function RectsEqual(const rec1, rec2: TRect): Boolean; - procedure OffsetRect(var rec: TRectD; dx, dy: double); overload; - function MakeSquare(rec: TRect): TRect; - function IsValid(value: integer): Boolean; overload; - function IsValid(value: double): Boolean; overload; - function IsValid(const pt: TPoint): Boolean; overload; - function IsValid(const pt: TPointD): Boolean; overload; - function IsValid(const rec: TRect): Boolean; overload; - function Point(X,Y: Integer): TPoint; overload; - function Point(const pt: TPointD): TPoint; overload; - function PointsEqual(const pt1, pt2: TPointD): Boolean; overload; - {$IFDEF INLINING} inline; {$ENDIF} - function PointsNearEqual(const pt1, pt2: TPoint; - dist: integer): Boolean; overload; - function PointsNearEqual(const pt1, pt2: TPointD; - distSqrd: double): Boolean; overload; - {$IFDEF INLINING} inline; {$ENDIF} - function StripNearDuplicates(const path: TPathD; - minDist: double; isClosedPath: Boolean): TPathD; overload; - function StripNearDuplicates(const paths: TPathsD; - minLength: double; isClosedPaths: Boolean): TPathsD; overload; - function MidPoint(const rec: TRect): TPoint; overload; - function MidPoint(const rec: TRectD): TPointD; overload; - function MidPoint(const pt1, pt2: TPoint): TPoint; overload; - function MidPoint(const pt1, pt2: TPointD): TPointD; overload; - function Average(val1, val2: integer): integer; overload; - function Average(val1, val2: double): double; overload; - function ReflectPoint(const pt, pivot: TPointD): TPointD; - {$IFDEF INLINING} inline; {$ENDIF} - function RectsOverlap(const rec1, rec2: TRect): Boolean; - function IsSameRect(const rec1, rec2: TRect): Boolean; - function RectsIntersect(const rec1, rec2: TRect): Boolean; overload; - function RectsIntersect(const rec1, rec2: TRectD): Boolean; overload; - function IntersectRect(const rec1, rec2: TRectD): TRectD; overload; - //UnionRect: this behaves differently to types.UnionRect - //in that if either parameter is empty the other parameter is returned - function UnionRect(const rec1, rec2: TRect): TRect; overload; - function UnionRect(const rec1, rec2: TRectD): TRectD; overload; - //these 2 functions are only needed to support older versions of Delphi - function MakeArrayOfInteger(const ints: array of integer): TArrayOfInteger; - function MakeArrayOfDouble(const doubles: array of double): TArrayOfDouble; - function CrossProduct(const vector1, vector2: TPointD): double; overload; - {$IFDEF INLINING} inline; {$ENDIF} - function CrossProduct(const pt1, pt2, pt3: TPointD): double; overload; - {$IFDEF INLINING} inline; {$ENDIF} - function CrossProduct(const pt1, pt2, pt3, pt4: TPointD): double; overload; - {$IFDEF INLINING} inline; {$ENDIF} - function DotProduct(const vector1, vector2: TPointD): double; overload; - {$IFDEF INLINING} inline; {$ENDIF} - function DotProduct(const pt1, pt2, pt3: TPointD): double; overload; - {$IFDEF INLINING} inline; {$ENDIF} - function TurnsLeft(const pt1, pt2, pt3: TPointD): boolean; - {$IFDEF INLINING} inline; {$ENDIF} - function TurnsRight(const pt1, pt2, pt3: TPointD): boolean; - {$IFDEF INLINING} inline; {$ENDIF} - function IsPathConvex(const path: TPathD): Boolean; - //GetUnitVector: Used internally - function GetUnitVector(const pt1, pt2: TPointD): TPointD; - //GetUnitNormal: Used internally - function GetUnitNormal(const pt1, pt2: TPointD): TPointD; - //GetVectors: Used internally - function GetVectors(const path: TPathD): TPathD; - //GetNormals: Used internally - function GetNormals(const path: TPathD): TPathD; - //DistanceSqrd: Used internally - function DistanceSqrd(const pt1, pt2: TPoint): double; overload; - {$IFDEF INLINE} inline; {$ENDIF} - //DistanceSqrd: Used internally - function DistanceSqrd(const pt1, pt2: TPointD): double; overload; - {$IFDEF INLINE} inline; {$ENDIF} - function Distance(const pt1, pt2: TPoint): double; overload; - {$IFDEF INLINE} inline; {$ENDIF} - function Distance(const pt1, pt2: TPointD): double; overload; - {$IFDEF INLINE} inline; {$ENDIF} - function Distance(const path: TPathD; stopAt: integer = 0): double; overload; - function GetDistances(const path: TPathD): TArrayOfDouble; - function GetCumulativeDistances(const path: TPathD): TArrayOfDouble; - function PerpendicularDistSqrd(const pt, l1, line2: TPointD): double; - function PointInPolygon(const pt: TPointD; - const polygon: TPathD; fillRule: TFillRule): Boolean; - function PointInPolygons(const pt: TPointD; - const polygons: TPathsD; fillRule: TFillRule): Boolean; - function PerpendicularDist(const pt, line1, line2: TPointD): double; - function ClosestPointOnLine(const pt, linePt1, linePt2: TPointD): TPointD; - function ClosestPointOnSegment(const pt, segPt1, segPt2: TPointD): TPointD; - function IsPointInEllipse(const ellipseRec: TRect; const pt: TPoint): Boolean; - //GetIntersectsEllipseAndLine: Gets the intersection of an ellipse and - //a line. The function result = true when the line either touches - //tangentially or passes through the ellipse. If the line touches - //tangentially, the coordintates returned in pt1 and pt2 will match. - function GetLineEllipseIntersects(const ellipseRec: TRect; - var linePt1, linePt2: TPointD): Boolean; - function GetPtOnEllipseFromAngle(const ellipseRect: TRectD; angle: double): TPointD; - function GetPtOnRotatedEllipseFromAngle(const ellipseRect: TRectD; - ellipseRotAngle, angle: double): TPointD; - function GetEllipticalAngleFromPoint(const ellipseRect: TRectD; - const pt: TPointD): double; - function GetRotatedEllipticalAngleFromPoint(const ellipseRect: TRectD; - ellipseRotAngle: double; pt: TPointD): double; - function GetClosestPtOnRotatedEllipse(const ellipseRect: TRectD; - ellipseRotation: double; const pt: TPointD): TPointD; - function Outline(const line: TPathD; lineWidth: double; - joinStyle: TJoinStyle; endStyle: TEndStyle; - miterLimOrRndScale: double = 0): TPathsD; overload; - function Outline(const lines: TPathsD; lineWidth: double; - joinStyle: TJoinStyle; endStyle: TEndStyle; - miterLimOrRndScale: double = 0): TPathsD; overload; - //Grow: Offsets path by 'delta' (positive is away from the left of the path). - //With a positive delta, clockwise paths will expand and counter-clockwise - //ones will contract. The reverse happens with negative deltas. - function Grow(const path, normals: TPathD; delta: double; joinStyle: TJoinStyle; - miterLimOrRndScale: double; isOpen: Boolean = false): TPathD; - - function ValueAlmostZero(val: double; epsilon: double = 0.001): Boolean; - function ValueAlmostOne(val: double; epsilon: double = 0.001): Boolean; -const - Invalid = -MaxInt; - InvalidD = -Infinity; - NullPoint : TPoint = (X: 0; Y: 0); - NullPointD : TPointD = (X: 0; Y: 0); - InvalidPoint : TPoint = (X: -MaxInt; Y: -MaxInt); - InvalidPointD : TPointD = (X: -Infinity; Y: -Infinity); - NullRect : TRect = (left: 0; top: 0; right: 0; Bottom: 0); - NullRectD : TRectD = (left: 0; top: 0; right: 0; Bottom: 0); - InvalidRect : TRect = (left: MaxInt; top: MaxInt; right: 0; Bottom: 0); - BezierTolerance: double = 0.25; -var - //AutoWidthThreshold: When JoinStyle = jsAuto, this is the threshold at - //which line joins will be rounded instead of squared. With wider strokes, - //rounded joins generally look better, but as rounding is more complex it - //also requries more processing and hence is slower to execute. - AutoWidthThreshold: double = 5.0; - //When lines are too narrow, they become too faint to sensibly draw - MinStrokeWidth: double = 0.5; - //Miter limit avoids excessive spikes when line offsetting - DefaultMiterLimit: double = 4.0; - -resourcestring - rsInvalidMatrix = 'Invalid matrix.'; //nb: always start with IdentityMatrix - -implementation - -resourcestring - rsInvalidQBezier = 'Invalid number of control points for a QBezier'; - rsInvalidCBezier = 'Invalid number of control points for a CBezier'; - -const - BuffSize = 64; - -//------------------------------------------------------------------------------ -// TSizeD -//------------------------------------------------------------------------------ - -function TSizeD.average: double; -begin - Result := (cx + cy) * 0.5; -end; - -//------------------------------------------------------------------------------ -// TRectWH record/object. -//------------------------------------------------------------------------------ - -function TRectWH.IsEmpty: Boolean; -begin - Result := (Width <= 0) or (Height <= 0); -end; -//------------------------------------------------------------------------------ - -function TRectWH.IsValid: Boolean; -begin - Result := (Left <> InvalidD) and (Top <> InvalidD) - and (Width >= 0) and (Height >= 0); -end; -//------------------------------------------------------------------------------ - -function TRectWH.Right: double; -begin - Result := Left + Width; -end; -//------------------------------------------------------------------------------ - -function TRectWH.Bottom: double; -begin - Result := Top + Height; -end; -//------------------------------------------------------------------------------ - -function TRectWH.Contains(const Pt: TPoint): Boolean; -begin - Result := (pt.X >= Left) and (pt.X <= Left + Width) and - (pt.Y >= Top) and (pt.Y <= Top + Height) -end; -//------------------------------------------------------------------------------ - -function TRectWH.Contains(const Pt: TPointD): Boolean; -begin - Result := (pt.X >= Left) and (pt.X <= Left + Width) and - (pt.Y >= Top) and (pt.Y <= Top + Height) -end; -//------------------------------------------------------------------------------ - -function TRectWH.MidPoint: TPointD; -begin - Result := PointD(left + Width * 0.5, top + Height * 0.5); -end; -//------------------------------------------------------------------------------ - -function TRectWH.RectD: TRectD; -begin - Result := Img32.RectD(left, top, left + Width, top + Height); -end; -//------------------------------------------------------------------------------ - -function TRectWH.Rect: TRect; -begin - Result := Img32.Vector.Rect(RectD); -end; -//------------------------------------------------------------------------------ - -function RectWH(left, top, width, height: integer): TRectWH; -begin - Result.Left := left; - Result.Top := top; - Result.Width := width; - Result.Height := height; -end; -//------------------------------------------------------------------------------ - -function RectWH(left, top, width, height: double): TRectWH; -begin - Result.Left := left; - Result.Top := top; - Result.Width := width; - Result.Height := height; -end; -//------------------------------------------------------------------------------ - -function RectWH(const rec: TRectD): TRectWH; -begin - Result.Left := rec.left; - Result.Top := rec.top; - Result.Width := rec.width; - Result.Height := rec.height; -end; -//------------------------------------------------------------------------------ - -function RectsEqual(const rec1, rec2: TRect): Boolean; -begin - result := (rec1.Left = rec2.Left) and (rec1.Top = rec2.Top) and - (rec1.Right = rec2.Right) and (rec1.Bottom = rec2.Bottom); -end; -//------------------------------------------------------------------------------ - -function Rect(const left, top, right, bottom: integer): TRect; -begin - Result.Left := left; - Result.Top := top; - Result.Right := right; - Result.Bottom := bottom; -end; -//------------------------------------------------------------------------------ - -function IsValid(value: integer): Boolean; -begin - Result := value <> -MaxInt; -end; -//------------------------------------------------------------------------------ - -function IsValid(value: double): Boolean; -begin - Result := value <> InvalidD; -end; -//------------------------------------------------------------------------------ - -function IsValid(const pt: TPoint): Boolean; -begin - result := (pt.X <> Invalid) and (pt.Y <> Invalid); -end; -//------------------------------------------------------------------------------ - -function IsValid(const pt: TPointD): Boolean; -begin - result := (pt.X <> -Infinity) and (pt.Y <> -Infinity); -end; -//------------------------------------------------------------------------------ - -function IsValid(const rec: TRect): Boolean; -begin - result := (rec.Left <> MaxInt) and (rec.Top <> MaxInt); -end; -//------------------------------------------------------------------------------ - -function Point(X,Y: Integer): TPoint; -begin - result.X := X; - result.Y := Y; -end; -//------------------------------------------------------------------------------ - -function Point(const pt: TPointD): TPoint; -begin - result.X := Round(pt.x); - result.Y := Round(pt.y); -end; -//------------------------------------------------------------------------------ - -function PointsEqual(const pt1, pt2: TPointD): Boolean; -begin - result := (pt1.X = pt2.X) and (pt1.Y = pt2.Y); -end; -//------------------------------------------------------------------------------ - -function PointsNearEqual(const pt1, pt2: TPoint; dist: integer): Boolean; -begin - Result := (Abs(pt1.X - pt2.X) <= dist) and (Abs(pt1.Y - pt2.Y) < dist); -end; -//------------------------------------------------------------------------------ - -function PointsNearEqual(const pt1, pt2: TPointD; distSqrd: double): Boolean; -begin - Result := Sqr(pt1.X - pt2.X) + Sqr(pt1.Y - pt2.Y) < distSqrd; -end; -//------------------------------------------------------------------------------ - -function StripNearDuplicates(const path: TPathD; - minDist: double; isClosedPath: Boolean): TPathD; -var - i,j, len: integer; -begin - len := length(path); - SetLength(Result, len); - if len = 0 then Exit; - Result[0] := path[0]; - j := 0; - minDist := minDist * minDist; - for i := 1 to len -1 do - if not PointsNearEqual(Result[j], path[i], minDist) then - begin - inc(j); - Result[j] := path[i]; - end; - if isClosedPath and - PointsNearEqual(Result[j], Result[0], minDist) then dec(j); - SetLength(Result, j +1); -end; -//------------------------------------------------------------------------------ - -function StripNearDuplicates(const paths: TPathsD; - minLength: double; isClosedPaths: Boolean): TPathsD; -var - i, len: integer; -begin - len := Length(paths); - SetLength(Result, len); - for i := 0 to len -1 do - Result[i] := StripNearDuplicates(paths[i], minLength, isClosedPaths); -end; -//------------------------------------------------------------------------------ - -function ValueAlmostZero(val: double; epsilon: double = 0.001): Boolean; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result := Abs(val) < epsilon; -end; -//------------------------------------------------------------------------------ - -function ValueAlmostOne(val: double; epsilon: double = 0.001): Boolean; - {$IFDEF INLINE} inline; {$ENDIF} -begin - Result := Abs(val-1) < epsilon; -end; -//------------------------------------------------------------------------------ - -procedure GetSinCos(angle: double; out sinA, cosA: double); -{$IFDEF INLINE} inline; {$ENDIF} -{$IFNDEF FPC} -var s, c: extended; -{$ENDIF} -begin -{$IFDEF FPC} - Math.SinCos(angle, sinA, cosA); -{$ELSE} - Math.SinCos(angle, s, c); - sinA := s; cosA := c; -{$ENDIF} -end; -//------------------------------------------------------------------------------ - -function GetRotatedRectBounds(const rec: TRect; angle: double): TRect; -var - sinA, cosA: double; - w,h, recW, recH: integer; - mp: TPoint; -begin - NormalizeAngle(angle); - if angle <> 0 then - begin - GetSinCos(angle, sinA, cosA); //the sign of the angle isn't important - sinA := Abs(sinA); cosA := Abs(cosA); - RectWidthHeight(rec, recW, recH); - w := Ceil((recW *cosA + recH *sinA) /2); - h := Ceil((recW *sinA + recH *cosA) /2); - mp := MidPoint(rec); - Result := Rect(mp.X - w, mp.Y - h, mp.X + w, mp.Y +h); - end - else - Result := rec; -end; -//------------------------------------------------------------------------------ - -function GetRotatedRectBounds(const rec: TRectD; angle: double): TRectD; -var - sinA, cosA: double; - w,h: double; - mp: TPointD; -begin - NormalizeAngle(angle); - if angle <> 0 then - begin - GetSinCos(angle, sinA, cosA); //the sign of the angle isn't important - sinA := Abs(sinA); cosA := Abs(cosA); - w := (rec.Width *cosA + rec.Height *sinA) /2; - h := (rec.Width *sinA + rec.Height *cosA) /2; - mp := rec.MidPoint; - Result := RectD(mp.X - w, mp.Y - h, mp.X + w, mp.Y +h); - end - else - Result := rec; -end; -//------------------------------------------------------------------------------ - - -function Rect(const recD: TRectD): TRect; -begin - Result.Left := Floor(recD.Left); - Result.Top := Floor(recD.Top); - Result.Right := Ceil(recD.Right); - Result.Bottom := Ceil(recD.Bottom); -end; -//------------------------------------------------------------------------------ - -function PtInRect(const rec: TRectD; const pt: TPointD): Boolean; -begin - Result := (pt.X >= rec.Left) and (pt.X < rec.Right) and - (pt.Y >= rec.Top) and (pt.Y < rec.Bottom); -end; -//------------------------------------------------------------------------------ - -function Size(cx, cy: integer): TSize; -begin - Result.cx := cx; - Result.cy := cy; -end; -//------------------------------------------------------------------------------ - -function SizeD(cx, cy: double): TSizeD; -begin - Result.cx := cx; - Result.cy := cy; -end; -//------------------------------------------------------------------------------ - -function IsClockwise(const path: TPathD): Boolean; -begin - Result := Area(path) > 0; -end; -//------------------------------------------------------------------------------ - -function Area(const path: TPathD): Double; -var - i, j, highI: Integer; - d: Double; -begin - Result := 0.0; - highI := High(path); - if (highI < 2) then Exit; - j := highI; - for i := 0 to highI do - begin - d := (path[j].X + path[i].X); - Result := Result + d * (path[j].Y - path[i].Y); - j := i; - end; - Result := -Result * 0.5; -end; -//------------------------------------------------------------------------------ - -procedure OffsetRect(var rec: TRectD; dx, dy: double); -begin - rec.Left := rec.Left + dx; - rec.Top := rec.Top + dy; - rec.Right := rec.Right + dx; - rec.Bottom := rec.Bottom + dy; -end; -//------------------------------------------------------------------------------ - -function MakeSquare(rec: TRect): TRect; -var - i: integer; -begin - Result := rec; - i := ((rec.Right - rec.Left) + (rec.Bottom - rec.Top)) div 2; - Result.Right := Result.Left + i; - Result.Bottom := Result.Top + i; -end; -//------------------------------------------------------------------------------ - -function MidPoint(const rec: TRect): TPoint; -begin - Result.X := (rec.Left + rec.Right) div 2; - Result.Y := (rec.Top + rec.Bottom) div 2; -end; -//------------------------------------------------------------------------------ - -function MidPoint(const rec: TRectD): TPointD; -begin - Result.X := (rec.Left + rec.Right) * 0.5; - Result.Y := (rec.Top + rec.Bottom) * 0.5; -end; -//------------------------------------------------------------------------------ - -function MidPoint(const pt1, pt2: TPoint): TPoint; -begin - Result.X := (pt1.X + pt2.X) div 2; - Result.Y := (pt1.Y + pt2.Y) div 2; -end; -//------------------------------------------------------------------------------ - -function MidPoint(const pt1, pt2: TPointD): TPointD; -begin - Result.X := (pt1.X + pt2.X) * 0.5; - Result.Y := (pt1.Y + pt2.Y) * 0.5; -end; -//------------------------------------------------------------------------------ - -function Average(val1, val2: integer): integer; -begin - Result := (val1 + val2) div 2; -end; -//------------------------------------------------------------------------------ - -function Average(val1, val2: double): double; -begin - Result := (val1 + val2) * 0.5; -end; -//------------------------------------------------------------------------------ - -function RectsOverlap(const rec1, rec2: TRect): Boolean; -begin - Result := (rec1.Left < rec2.Right) and (rec1.Right > rec2.Left) and - (rec1.Top < rec2.Bottom) and (rec1.Bottom > rec2.Top); -end; -//------------------------------------------------------------------------------ - -function IsSameRect(const rec1, rec2: TRect): Boolean; -begin - Result := (rec1.Left = rec2.Left) and (rec1.Top = rec2.Top) and - (rec1.Right = rec2.Right) and (rec1.Bottom = rec2.Bottom); -end; -//------------------------------------------------------------------------------ - -function RectsIntersect(const rec1, rec2: TRect): Boolean; -var - dummy: TRect; -begin - Result := Types.IntersectRect(dummy, rec1, rec2); -end; -//------------------------------------------------------------------------------ - -function RectsIntersect(const rec1, rec2: TRectD): Boolean; -begin - Result := not IntersectRect(rec1, rec2).IsEmpty; -end; -//------------------------------------------------------------------------------ - -function IntersectRect(const rec1, rec2: TRectD): TRectD; -begin - result.Left := Max(rec1.Left, rec2.Left); - result.Top := Max(rec1.Top, rec2.Top); - result.Right := Min(rec1.Right, rec2.Right); - result.Bottom := Min(rec1.Bottom, rec2.Bottom); -end; -//------------------------------------------------------------------------------ - -function UnionRect(const rec1, rec2: TRect): TRect; -begin - if IsEmptyRect(rec1) then - Result := rec2 - else if IsEmptyRect(rec2) then - Result := rec1 - else - begin - result.Left := Min(rec1.Left, rec2.Left); - result.Top := Min(rec1.Top, rec2.Top); - result.Right := Max(rec1.Right, rec2.Right); - result.Bottom := Max(rec1.Bottom, rec2.Bottom); - end; -end; -//------------------------------------------------------------------------------ - -function UnionRect(const rec1, rec2: TRectD): TRectD; -begin - if IsEmptyRect(rec1) then - Result := rec2 - else if IsEmptyRect(rec2) then - Result := rec1 - else - begin - result.Left := Min(rec1.Left, rec2.Left); - result.Top := Min(rec1.Top, rec2.Top); - result.Right := Max(rec1.Right, rec2.Right); - result.Bottom := Max(rec1.Bottom, rec2.Bottom); - end; -end; -//------------------------------------------------------------------------------ - -function MakeArrayOfInteger(const ints: array of integer): TArrayOfInteger; -var - i, len: integer; -begin - len := Length(ints); - SetLength(Result, len); - for i := 0 to len -1 do Result[i] := ints[i]; -end; -//------------------------------------------------------------------------------ - -function MakeArrayOfDouble(const doubles: array of double): TArrayOfDouble; -var - i, len: integer; -begin - len := Length(doubles); - SetLength(Result, len); - for i := 0 to len -1 do Result[i] := doubles[i]; -end; -//------------------------------------------------------------------------------ - -function CrossProduct(const vector1, vector2: TPointD): double; -begin - result := vector1.X * vector2.Y - vector2.X * vector1.Y; -end; -//------------------------------------------------------------------------------ - -function CrossProduct(const pt1, pt2, pt3: TPointD): double; -var - x1,x2,y1,y2: double; -begin - x1 := pt2.X - pt1.X; - y1 := pt2.Y - pt1.Y; - x2 := pt3.X - pt2.X; - y2 := pt3.Y - pt2.Y; - result := (x1 * y2 - y1 * x2); -end; -//--------------------------------------------------------------------------- - -function CrossProduct(const pt1, pt2, pt3, pt4: TPointD): double; -var - x1,x2,y1,y2: double; -begin - x1 := pt2.X - pt1.X; - y1 := pt2.Y - pt1.Y; - x2 := pt4.X - pt3.X; - y2 := pt4.Y - pt3.Y; - result := (x1 * y2 - y1 * x2); -end; -//--------------------------------------------------------------------------- - -function DotProduct(const vector1, vector2: TPointD): double; -begin - result := vector1.X * vector2.X + vector1.Y * vector2.Y; -end; -//------------------------------------------------------------------------------ - -function DotProduct(const pt1, pt2, pt3: TPointD): double; -var - x1,x2,y1,y2: double; -begin - x1 := pt2.X - pt1.X; - y1 := pt2.Y - pt1.Y; - x2 := pt2.X - pt3.X; - y2 := pt2.Y - pt3.Y; - result := (x1 * x2 + y1 * y2); -end; -//------------------------------------------------------------------------------ - -function TurnsLeft(const pt1, pt2, pt3: TPointD): boolean; -begin - result := CrossProduct(pt1, pt2, pt3) < 0; -end; -//------------------------------------------------------------------------------ - -function TurnsRight(const pt1, pt2, pt3: TPointD): boolean; -begin - result := CrossProduct(pt1, pt2, pt3) > 0; -end; -//------------------------------------------------------------------------------ - -function IsPathConvex(const path: TPathD): Boolean; -var - i, pathLen: integer; - dir: boolean; -begin - result := false; - pathLen := length(path); - if pathLen < 3 then Exit; - //get the winding direction of the first angle - dir := TurnsRight(path[0], path[1], path[2]); - //check that each other angle has the same winding direction - for i := 1 to pathLen -1 do - if TurnsRight(path[i], path[(i+1) mod pathLen], - path[(i+2) mod pathLen]) <> dir then Exit; - result := true; -end; -//------------------------------------------------------------------------------ - -function GetUnitVector(const pt1, pt2: TPointD): TPointD; -var - dx, dy, inverseHypot: Double; -begin - if (pt1.x = pt2.x) and (pt1.y = pt2.y) then - begin - Result.X := 0; - Result.Y := 0; - Exit; - end; - dx := (pt2.X - pt1.X); - dy := (pt2.Y - pt1.Y); - inverseHypot := 1 / Hypot(dx, dy); - dx := dx * inverseHypot; - dy := dy * inverseHypot; - Result.X := dx; - Result.Y := dy; -end; -//------------------------------------------------------------------------------ - -function GetUnitNormal(const pt1, pt2: TPointD): TPointD; -var - dx, dy, inverseHypot: Double; -begin - if PointsNearEqual(pt1, pt2, 0.001) then - begin - Result.X := 0; - Result.Y := 0; - Exit; - end; - dx := (pt2.X - pt1.X); - dy := (pt2.Y - pt1.Y); - inverseHypot := 1 / Hypot(dx, dy); - dx := dx * inverseHypot; - dy := dy * inverseHypot; - Result.X := dy; - Result.Y := -dx -end; -//------------------------------------------------------------------------------ - -function Paths(const path: TPathD): TPathsD; -begin - SetLength(Result, 1); - result[0] := Copy(path, 0, length(path)); -end; -//------------------------------------------------------------------------------ - -function CopyPath(const path: TPathD): TPathD; -begin - Result := Copy(path, 0, Length(path)); -end; -//------------------------------------------------------------------------------ - -function CopyPaths(const paths: TPathsD): TPathsD; -var - i, len1: integer; -begin - len1 := length(paths); - setLength(result, len1); - for i := 0 to len1 -1 do - result[i] := Copy(paths[i], 0, length(paths[i])); -end; -//------------------------------------------------------------------------------ - -function OffsetPoint(const pt: TPoint; dx, dy: integer): TPoint; -begin - result.x := pt.x + dx; - result.y := pt.y + dy; -end; -//------------------------------------------------------------------------------ - -function OffsetPoint(const pt: TPointD; dx, dy: double): TPointD; -begin - result.x := pt.x + dx; - result.y := pt.y + dy; -end; -//------------------------------------------------------------------------------ - -function OffsetPath(const path: TPathD; dx, dy: double): TPathD; -var - i, len: integer; -begin - len := length(path); - setLength(result, len); - for i := 0 to len -1 do - begin - result[i].x := path[i].x + dx; - result[i].y := path[i].y + dy; - end; -end; -//------------------------------------------------------------------------------ - -function OffsetPath(const paths: TPathsD; - dx, dy: double): TPathsD; -var - i,len: integer; -begin - len := length(paths); - setLength(result, len); - for i := 0 to len -1 do - result[i] := OffsetPath(paths[i], dx, dy); -end; -//------------------------------------------------------------------------------ - -function OffsetPath(const ppp: TArrayOfPathsD; dx, dy: double): TArrayOfPathsD; -var - i,len: integer; -begin - len := length(ppp); - setLength(result, len); - for i := 0 to len -1 do - result[i] := OffsetPath(ppp[i], dx, dy); -end; -//------------------------------------------------------------------------------ - -function ScalePoint(const pt: TPointD; scale: double): TPointD; -begin - Result.X := pt.X * scale; - Result.Y := pt.Y * scale; -end; -//------------------------------------------------------------------------------ - -function ScalePoint(const pt: TPointD; sx, sy: double): TPointD; -begin - Result.X := pt.X * sx; - Result.Y := pt.Y * sy; -end; -//------------------------------------------------------------------------------ - -function ScalePath(const path: TPathD; sx, sy: double): TPathD; -var - i, len: integer; -begin - if (sx = 0) or (sy = 0) then - Result := nil - else if ((sx = 1) and (sy = 1)) then - begin - Result := Copy(path, 0, Length(path)); - end else - begin - len := length(path); - setLength(result, len); - for i := 0 to len -1 do - begin - result[i].x := path[i].x * sx; - result[i].y := path[i].y * sy; - end; - end; -end; -//------------------------------------------------------------------------------ - -function ScalePath(const path: TPathD; - scale: double): TPathD; -begin - result := ScalePath(path, scale, scale); -end; -//------------------------------------------------------------------------------ - -function ScalePath(const paths: TPathsD; - sx, sy: double): TPathsD; -var - i,len: integer; -begin - len := length(paths); - setLength(result, len); - for i := 0 to len -1 do - result[i] := ScalePath(paths[i], sx, sy); -end; -//------------------------------------------------------------------------------ - -function ScalePath(const paths: TPathsD; - scale: double): TPathsD; -begin - result := ScalePath(paths, scale, scale); -end; -//------------------------------------------------------------------------------ - -function ScaleRect(const rec: TRect; scale: double): TRect; -begin - result := rec; - Result.Left := Round(Result.Left * scale); - Result.Top := Round(Result.Top * scale); - Result.Right := Round(Result.Right * scale); - Result.Bottom := Round(Result.Bottom * scale); -end; -//------------------------------------------------------------------------------ - -function ScaleRect(const rec: TRect; sx, sy: double): TRect; -begin - result := rec; - Result.Left := Round(Result.Left * sx); - Result.Top := Round(Result.Top * sy); - Result.Right := Round(Result.Right * sx); - Result.Bottom := Round(Result.Bottom * sy); -end; -//------------------------------------------------------------------------------ - -function ScaleRect(const rec: TRectD; scale: double): TRectD; -begin - result := rec; - Result.Left := Result.Left * scale; - Result.Top := Result.Top * scale; - Result.Right := Result.Right * scale; - Result.Bottom := Result.Bottom * scale; -end; -//------------------------------------------------------------------------------ - -function ScaleRect(const rec: TRectD; sx, sy: double): TRectD; -begin - result := rec; - Result.Left := Result.Left * sx; - Result.Top := Result.Top * sy; - Result.Right := Result.Right * sx; - Result.Bottom := Result.Bottom * sy; -end; -//------------------------------------------------------------------------------ - -function ReversePath(const path: TPathD): TPathD; -var - i, highI: integer; -begin - highI := High(path); - SetLength(result, highI +1); - for i := 0 to highI do - result[i] := path[highI -i]; -end; -//------------------------------------------------------------------------------ - -function ReversePath(const paths: TPathsD): TPathsD; -var - i, len: integer; -begin - len := Length(paths); - SetLength(result, len); - for i := 0 to len -1 do - result[i] := ReversePath(paths[i]); -end; -//------------------------------------------------------------------------------ - -function OpenPathToFlatPolygon(const path: TPathD): TPathD; -var - i, len, len2: integer; -begin - len := Length(path); - len2 := Max(0, len - 2); - setLength(Result, len + len2); - if len = 0 then Exit; - Move(path[0], Result[0], len * SizeOf(TPointD)); - if len2 = 0 then Exit; - for i := 0 to len - 3 do - result[len + i] := path[len - 2 -i]; -end; -//------------------------------------------------------------------------------ - -function GetVectors(const path: TPathD): TPathD; -var - i,j, len: cardinal; - pt: TPointD; -begin - len := length(path); - setLength(result, len); - if len = 0 then Exit; - pt := path[0]; - //skip duplicates - i := len -1; - while (i > 0) and - (path[i].X = pt.X) and (path[i].Y = pt.Y) do dec(i); - if (i = 0) then - begin - //all points are equal! - for i := 0 to len -1 do result[i] := PointD(0,0); - Exit; - end; - result[i] := GetUnitVector(path[i], pt); - //fix up any duplicates at the end of the path - for j := i +1 to len -1 do - result[j] := result[j-1]; - //with at least one valid vector, we can now - //safely get the remaining vectors - pt := path[i]; - for i := i -1 downto 0 do - begin - if (path[i].X <> pt.X) or (path[i].Y <> pt.Y) then - begin - result[i] := GetUnitVector(path[i], pt); - pt := path[i]; - end else - result[i] := result[i+1] - end; -end; -//------------------------------------------------------------------------------ - -function GetNormals(const path: TPathD): TPathD; -var - i,highI,j, len: cardinal; - pt: TPointD; -begin - len := length(path); - setLength(result, len); - if len = 0 then Exit; - pt := path[0]; - //watch out for, and fix up duplicates at end of line - highI := len -1; - while (highI > 0) and PointsNearEqual(path[highI], pt, 0.001) do dec(highI); - if (highI = 0) then - begin - //all points are equal! - for i := 0 to len -1 do result[i] := PointD(0,0); - Exit; - end; - result[highI] := GetUnitNormal(path[highI], pt); - //now fix up any duplicates at the end of the path - for j := highI +1 to len -1 do result[j] := result[j-1]; - //with at least one valid vector, we can now - //safely get the remaining vectors - pt := path[highI]; - for i := highI -1 downto 0 do - begin - if (path[i].X <> pt.X) or (path[i].Y <> pt.Y) then - begin - result[i] := GetUnitNormal(path[i], pt); - if (Result[i].X = 0) and (Result[i].Y = 0) then - Result[i] := Result[i+1]; - pt := path[i]; - end else - result[i] := result[i+1] - end; -end; -//------------------------------------------------------------------------------ - -function DistanceSqrd(const pt1, pt2: TPoint): double; -begin - result := Sqr(pt1.X - pt2.X) + Sqr(pt1.Y - pt2.Y); -end; -//------------------------------------------------------------------------------ - -function DistanceSqrd(const pt1, pt2: TPointD): double; -begin - result := Sqr(pt1.X - pt2.X) + Sqr(pt1.Y - pt2.Y); -end; -//------------------------------------------------------------------------------ - -function Distance(const pt1, pt2: TPoint): double; -begin - Result := Sqrt(DistanceSqrd(pt1, pt2)); -end; -//------------------------------------------------------------------------------ - -function Distance(const pt1, pt2: TPointD): double; -begin - Result := Sqrt(DistanceSqrd(pt1, pt2)); -end; -//------------------------------------------------------------------------------ - -function Distance(const path: TPathD; stopAt: integer): double; -var - i, highI: integer; -begin - Result := 0; - highI := High(path); - if (stopAt > 0) and (stopAt < HighI) then highI := stopAt; - for i := 1 to highI do - Result := Result + Distance(path[i-1],path[i]); -end; -//------------------------------------------------------------------------------ - -function GetDistances(const path: TPathD): TArrayOfDouble; -var - i, len: integer; -begin - len := Length(path); - SetLength(Result, len); - if len = 0 then Exit; - Result[0] := 0; - for i := 1 to len -1 do - Result[i] := Distance(path[i-1], path[i]); -end; -//------------------------------------------------------------------------------ - -function GetCumulativeDistances(const path: TPathD): TArrayOfDouble; -var - i, len: integer; -begin - len := Length(path); - SetLength(Result, len); - if len = 0 then Exit; - Result[0] := 0; - for i := 1 to len -1 do - Result[i] := Result[i-1] + Distance(path[i-1], path[i]); -end; -//------------------------------------------------------------------------------ - -function PerpendicularDistSqrd(const pt, l1, line2: TPointD): double; -var - a,b,c,d: double; -begin - a := pt.X - l1.X; - b := pt.Y - l1.Y; - c := line2.X - l1.X; - d := line2.Y - l1.Y; - if (c = 0) and (d = 0) then - result := 0 else - result := Sqr(a * d - c * b) / (c * c + d * d); -end; -//------------------------------------------------------------------------------ - -function PointInPolyWindingCount(const pt: TPointD; - const path: TPathD; out PointOnEdgeDir: integer): integer; -var - i, len: integer; - prevPt: TPointD; - isAbove: Boolean; - crossProd: double; -begin - //nb: PointOnEdgeDir == 0 unless 'pt' is on 'path' - Result := 0; - PointOnEdgeDir := 0; - i := 0; - len := Length(path); - if len = 0 then Exit; - prevPt := path[len-1]; - while (i < len) and (path[i].Y = prevPt.Y) do inc(i); - if i = len then Exit; - isAbove := (prevPt.Y < pt.Y); - while (i < len) do - begin - if isAbove then - begin - while (i < len) and (path[i].Y < pt.Y) do inc(i); - if i = len then break - else if i > 0 then prevPt := path[i -1]; - crossProd := CrossProduct(prevPt, path[i], pt); - if crossProd = 0 then - begin - PointOnEdgeDir := -1; - //nb: could safely exit here with frNonZero or frEvenOdd fill rules - end - else if crossProd < 0 then dec(Result); - end else - begin - while (i < len) and (path[i].Y > pt.Y) do inc(i); - if i = len then break - else if i > 0 then prevPt := path[i -1]; - crossProd := CrossProduct(prevPt, path[i], pt); - if crossProd = 0 then - begin - PointOnEdgeDir := 1; - //nb: could safely exit here with frNonZero or frEvenOdd fill rules - end - else if crossProd > 0 then inc(Result); - end; - inc(i); - isAbove := not isAbove; - end; -end; -//------------------------------------------------------------------------------ - -function PointInPolygon(const pt: TPointD; - const polygon: TPathD; fillRule: TFillRule): Boolean; -var - wc: integer; - PointOnEdgeDir: integer; -begin - wc := PointInPolyWindingCount(pt, polygon, PointOnEdgeDir); - case fillRule of - frEvenOdd: result := (PointOnEdgeDir <> 0) or Odd(wc); - frNonZero: result := (PointOnEdgeDir <> 0) or (wc <> 0); - frPositive: result := (PointOnEdgeDir + wc > 0); - else {frNegative} result := (PointOnEdgeDir + wc < 0); - end; -end; -//------------------------------------------------------------------------------ - -function PointInPolysWindingCount(const pt: TPointD; - const paths: TPathsD; out PointOnEdgeDir: integer): integer; -var - i,j, len: integer; - p: TPathD; - prevPt: TPointD; - isAbove: Boolean; - crossProd: double; -begin - //nb: PointOnEdgeDir == 0 unless 'pt' is on 'path' - Result := 0; - PointOnEdgeDir := 0; - for i := 0 to High(paths) do - begin - j := 0; - p := paths[i]; - len := Length(p); - if len < 3 then Continue; - prevPt := p[len-1]; - while (j < len) and (p[j].Y = prevPt.Y) do inc(j); - if j = len then continue; - isAbove := (prevPt.Y < pt.Y); - while (j < len) do - begin - if isAbove then - begin - while (j < len) and (p[j].Y < pt.Y) do inc(j); - if j = len then break - else if j > 0 then prevPt := p[j -1]; - crossProd := CrossProduct(prevPt, p[j], pt); - if crossProd = 0 then PointOnEdgeDir := -1 - else if crossProd < 0 then dec(Result); - end else - begin - while (j < len) and (p[j].Y > pt.Y) do inc(j); - if j = len then break - else if j > 0 then prevPt := p[j -1]; - crossProd := CrossProduct(prevPt, p[j], pt); - if crossProd = 0 then PointOnEdgeDir := 1 - else if crossProd > 0 then inc(Result); - end; - inc(j); - isAbove := not isAbove; - end; - end; -end; -//------------------------------------------------------------------------------ - -function PointInPolygons(const pt: TPointD; - const polygons: TPathsD; fillRule: TFillRule): Boolean; -var - wc: integer; - PointOnEdgeDir: integer; -begin - wc := PointInPolysWindingCount(pt, polygons, PointOnEdgeDir); - case fillRule of - frEvenOdd: result := (PointOnEdgeDir <> 0) or Odd(wc); - frNonZero: result := (PointOnEdgeDir <> 0) or (wc <> 0); - frPositive: result := (PointOnEdgeDir + wc > 0); - else {frNegative} result := (PointOnEdgeDir + wc < 0); - end; -end; -//------------------------------------------------------------------------------ - -function PerpendicularDist(const pt, line1, line2: TPointD): double; -var - a,b,c,d: double; -begin - //given: cross product of 2 vectors = area of parallelogram - //and given: area of parallelogram = length base * height - //height (ie perpendic. dist.) = cross product of 2 vectors / length base - a := pt.X - line1.X; - b := pt.Y - line1.Y; - c := line2.X - line1.X; - d := line2.Y - line1.Y; - result := abs(a * d - c * b) / Sqrt(c * c + d * d); -end; -//------------------------------------------------------------------------------ - -function ClosestPoint(const pt, linePt1, linePt2: TPointD; - constrainToSegment: Boolean): TPointD; -var - q: double; -begin - if (linePt1.X = linePt2.X) and (linePt1.Y = linePt2.Y) then - begin - Result := linePt1; - end else - begin - q := ((pt.X-linePt1.X)*(linePt2.X-linePt1.X) + - (pt.Y-linePt1.Y)*(linePt2.Y-linePt1.Y)) / - (sqr(linePt2.X-linePt1.X) + sqr(linePt2.Y-linePt1.Y)); - if constrainToSegment then - begin - if q < 0 then q := 0 else if q > 1 then q := 1; - end; - Result.X := round((1-q)*linePt1.X + q*linePt2.X); - Result.Y := round((1-q)*linePt1.Y + q*linePt2.Y); - end; -end; -//------------------------------------------------------------------------------ - -function ClosestPointOnLine(const pt, linePt1, linePt2: TPointD): TPointD; -begin - result := ClosestPoint(pt, linePt1, linePt2, false); -end; -//------------------------------------------------------------------------------ - -function ClosestPointOnSegment(const pt, segPt1, segPt2: TPointD): TPointD; -begin - result := ClosestPoint(pt, segPt1, segPt2, true); -end; -//------------------------------------------------------------------------------ - -function GetPtOnEllipseFromAngle(const ellipseRect: TRectD; - angle: double): TPointD; -var - sn, co: double; -begin - NormalizeAngle(angle); - GetSinCos(angle, sn, co); - Result.X := ellipseRect.MidPoint.X + ellipseRect.Width/2 * co; - Result.Y := ellipseRect.MidPoint.Y + ellipseRect.Height/2 * sn; -end; -//------------------------------------------------------------------------------ - -function GetEllipticalAngleFromPoint(const ellipseRect: TRectD; - const pt: TPointD): double; -begin - with ellipseRect do - Result := ArcTan2(Width/Height * (pt.Y - MidPoint.Y), (pt.X - MidPoint.X)); -end; -//------------------------------------------------------------------------------ - -function GetRotatedEllipticalAngleFromPoint(const ellipseRect: TRectD; - ellipseRotAngle: double; pt: TPointD): double; -begin - Result := 0; - if ellipseRect.IsEmpty then Exit; - RotatePoint(pt, ellipseRect.MidPoint, -ellipseRotAngle); - Result := GetEllipticalAngleFromPoint(ellipseRect, pt); -end; -//------------------------------------------------------------------------------ - -function GetPtOnRotatedEllipseFromAngle(const ellipseRect: TRectD; - ellipseRotAngle, angle: double): TPointD; -begin - Result := GetPtOnEllipseFromAngle(ellipseRect, angle); - if ellipseRotAngle <> 0 then - img32.Vector.RotatePoint(Result, ellipseRect.MidPoint, ellipseRotAngle); -end; -//------------------------------------------------------------------------------ - -function GetClosestPtOnRotatedEllipse(const ellipseRect: TRectD; - ellipseRotation: double; const pt: TPointD): TPointD; -var - pt2: TPointD; - angle: double; -begin - pt2 := pt; - Img32.Vector.RotatePoint(pt2, ellipseRect.MidPoint, -ellipseRotation); - angle := GetEllipticalAngleFromPoint(ellipseRect, pt2); - Result := GetPtOnEllipseFromAngle(ellipseRect, angle); - Img32.Vector.RotatePoint(Result, ellipseRect.MidPoint, ellipseRotation); -end; -//------------------------------------------------------------------------------ - -function IsPointInEllipse(const ellipseRec: TRect; const pt: TPoint): Boolean; -var - rec: TRectD; - w,h: integer; - x,y, y2, a,b, dx,dy: double; -begin - RectWidthHeight(ellipseRec, w, h); - a := w * 0.5; - b := h * 0.5; - dx := ellipseRec.Left + a; - dy := ellipseRec.Top + b; - rec := RectD(ellipseRec); - OffsetRect(rec, -dx, -dy); - x := pt.X -dx; y := pt.Y -dy; - //first make sure pt is inside rect - Result := (abs(x) <= a) and (abs(y) <= b); - if not result then Exit; - //given (x*x)/(a*a) + (y*y)/(b*b) = 1 - //then y*y = b*b(1 - (x*x)/(a*a)) - //nb: contents of Sqrt below will always be positive - //since the substituted x must be within ellipseRec bounds - y2 := Sqrt((b*b*(1 - (x*x)/(a*a)))); - Result := (y >= -y2) and (y <= y2); -end; -//------------------------------------------------------------------------------ - -function GetLineEllipseIntersects(const ellipseRec: TRect; - var linePt1, linePt2: TPointD): Boolean; -var - dx, dy, m,a,b,c,q: double; - qa,qb,qc,qs: double; - rec: TRectD; - pt1, pt2: TPointD; -begin - rec := RectD(ellipseRec); - a := rec.Width *0.5; - b := rec.Height *0.5; - //offset ellipseRect so it's centered over the coordinate origin - dx := ellipseRec.Left + a; dy := ellipseRec.Top + b; - offsetRect(rec, -dx, -dy); - pt1 := OffsetPoint(linePt1, -dx, -dy); - pt2 := OffsetPoint(linePt2, -dx, -dy); - //equation of ellipse = (x*x)/(a*a) + (y*y)/(b*b) = 1 - //equation of line = y = mx + c; - if (pt1.X = pt2.X) then //vertical line (ie infinite slope) - begin - //given x = K, then y*y = b*b(1 - (x*x)/(a*a)) - q := (b*b)*(1 - Sqr(pt1.X)/(a*a)); - result := q >= 0; - if not result then Exit; - q := Sqrt(q); - pt1.Y := q; - pt2.Y := -q; - end else - begin - //using simultaneous equations and substitution - //given y = mx + c - m := (pt1.Y - pt2.Y)/(pt1.X - pt2.X); - c := pt1.Y - m * pt1.X; - //given (x*x)/(a*a) + (y*y)/(b*b) = 1 - //(x*x)/(a*a)*(b*b) + (y*y) = (b*b) - //(b*b)/(a*a) *(x*x) + Sqr(m*x +c) = (b*b) - //(b*b)/(a*a) *(x*x) + (m*m)*(x*x) + 2*m*x*c +c*c = b*b - //((b*b)/(a*a) +(m*m)) *(x*x) + 2*m*c*(x) + (c*c) - (b*b) = 0 - //solving quadratic equation - qa := ((b*b)/(a*a) +(m*m)); - qb := 2*m*c; - qc := (c*c) - (b*b); - qs := (qb*qb) - 4*qa*qc; - Result := qs >= 0; - if not result then Exit; - qs := Sqrt(qs); - pt1.X := (-qb +qs)/(2 * qa); - pt1.Y := m * pt1.X + c; - pt2.X := (-qb -qs)/(2 * qa); - pt2.Y := m * pt2.X + c; - end; - //finally reverse initial offset - linePt1 := OffsetPoint(pt1, dx, dy); - linePt2 := OffsetPoint(pt2, dx, dy); -end; -//------------------------------------------------------------------------------ - -function Sign(const value: Double): integer; {$IFDEF INLINE} inline; {$ENDIF} -begin - if value < 0 then Result := -1 - else if value > 0 then Result := 1 - else Result := 0; -end; -//------------------------------------------------------------------------------ - -function GetNormal(const pt, norm: TPointD; delta: double): TPointD; -begin - result := PointD(pt.X + norm.X * delta, pt.Y + norm.Y * delta); -end; -//------------------------------------------------------------------------------ - -function GetVector(const pt, norm: TPointD; delta: double): TPointD; -begin - result := PointD(pt.X - norm.Y * delta, pt.Y + norm.X * delta); -end; -//------------------------------------------------------------------------------ - -function GetParallelOffests(const path, norms: TPathD; - delta: double): TPathD; -var - i, highI, len: integer; -begin - len := Length(path); - highI := len -1; - SetLength(Result, len *2); - Result[0] := GetNormal(path[0], norms[0], delta); - for i := 1 to highI do - begin - Result[i*2-1] := GetNormal(path[i], norms[i-1], delta); - Result[i*2] := GetNormal(path[i], norms[i], delta); - end; - Result[highI*2+1] := GetNormal(path[0], norms[highI], delta); -end; -//------------------------------------------------------------------------------ - -type - TGrowRec = record - StepsPerRad : double; - StepSin : double; - StepCos : double; - Radius : double; - aSin : double; - aCos : double; - end; - -function DoRound(const pt, norm1, norm2: TPointD; - const growRec: TGrowRec): TPathD; -var - i, steps: Integer; - a: Double; - pt2: TPointD; -begin - a := ArcTan2(growRec.aSin, growRec.aCos); - steps := Round(growRec.StepsPerRad * Abs(a)); - SetLength(Result, steps +1); - - pt2 := PointD(norm1.x * growRec.Radius, norm1.y * growRec.Radius); - Result[0] := PointD(pt.x + pt2.x, pt.y + pt2.y); - with growRec do - for i := 1 to steps do - begin - pt2 := PointD(pt2.X * StepCos - StepSin * pt2.Y, - pt2.X * StepSin + pt2.Y * StepCos); - Result[i] := PointD(pt.X + pt2.X, pt.Y + pt2.Y); - end; -end; -//------------------------------------------------------------------------------ - -function CalcRoundingSteps(radius: double): double; -begin - //the results of this function have been derived empirically - //and may need further adjustment - if radius < 0.55 then result := 4 - else result := Pi * Sqrt(radius); -end; -//------------------------------------------------------------------------------ - -function Grow(const path, normals: TPathD; delta: double; - joinStyle: TJoinStyle; miterLimOrRndScale: double; isOpen: Boolean): TPathD; -var - resCnt, resCap: integer; - - procedure AddPoint(const pt: TPointD); - begin - if resCnt >= resCap then - begin - inc(resCap, 64); - setLength(result, resCap); - end; - result[resCnt] := pt; - inc(resCnt); - end; - - procedure AppendPath(const path: TPathD); - var - len: integer; - begin - len := Length(path); - if resCnt + len > resCap then - begin - inc(resCap, len); - setLength(result, resCap); - end; - Move(path[0], result[resCnt], len * SizeOf(TPointD)); - inc(resCnt, len); - end; - -var - i : cardinal; - prevI : cardinal; - len : cardinal; - highI : cardinal; - iLo,iHi : cardinal; - norms : TPathD; - ip : TPointD; - p : TPathD; - a : double; - growRec : TGrowRec; - absDelta : double; - pt1, pt2, pt3, pt4: TPointD; -begin - Result := nil; - if not Assigned(path) then exit; - len := Length(path); - if not isOpen then - while (len > 2) and - PointsNearEqual(path[len -1], path[0], 0.001) do - dec(len); - if len < 2 then Exit; - - absDelta := Abs(delta); - if absDelta < MinStrokeWidth/2 then - begin - if delta < 0 then - delta := -MinStrokeWidth/2 else - delta := MinStrokeWidth/2; - end; - if absDelta < 1 then - joinStyle := jsSquare - else if joinStyle = jsAuto then - begin - if delta < AutoWidthThreshold / 2 then - joinStyle := jsSquare else - joinStyle := jsRound; - end; - - if assigned(normals) then - norms := normals else - norms := GetNormals(path); - - highI := len -1; - p := GetParallelOffests(path, norms, delta); - - if joinStyle = jsRound then - begin - if miterLimOrRndScale <= 0 then miterLimOrRndScale := 1; - growRec.Radius := delta; - growRec.StepsPerRad := CalcRoundingSteps(growRec.Radius)/(Pi *2); - if delta < 0 then - GetSinCos(-1/growRec.StepsPerRad, growRec.StepSin, growRec.StepCos) else - GetSinCos(1/growRec.StepsPerRad, growRec.StepSin, growRec.StepCos); - end else - begin - if miterLimOrRndScale <= 0 then miterLimOrRndScale := DefaultMiterLimit - else if miterLimOrRndScale < 2 then miterLimOrRndScale := 2; - miterLimOrRndScale := 2 /(sqr(miterLimOrRndScale)); - growRec.StepsPerRad := 0; //stop compiler warning. - end; - - resCnt := 0; resCap := 0; - - if isOpen then - begin - iLo := 1; iHi := highI -1; - prevI := 0; - AddPoint(p[0]); - end else - begin - iLo := 0; iHi := highI; - prevI := highI; - end; - - for i := iLo to iHi do - begin - pt1 := p[prevI*2]; - pt2 := p[prevI*2+1]; - pt3 := p[i*2]; - pt4 := p[i*2+1]; - growRec.aSin := CrossProduct(norms[prevI], norms[i]); - growRec.aCos := DotProduct(norms[prevI], norms[i]); - - if (growRec.aSin < 0) = (delta > 0) then - begin //is concave - if SegmentsIntersect(pt1, pt2, pt3, pt4, ip) then - AddPoint(ip) else - begin - AddPoint(pt2); - AddPoint(pt3); - end; - end - else if (joinStyle = jsRound) and - (Abs(growRec.aSin) > 0.08) then //only round if angle > ~5 deg - begin - AppendPath(DoRound(path[i], norms[prevI], norms[i], growRec)); - end - else if (joinStyle = jsMiter) and - (1 + growRec.aCos > miterLimOrRndScale) then - begin - //within miter range - a := delta / (1 + growRec.aCos); - AddPoint(PointD(path[i].X + (norms[i].X + norms[prevI].X) * a, - path[i].Y + (norms[i].Y + norms[prevI].Y) * a)); - end - else if (growRec.aCos < -0.001) and (growRec.aCos > -0.999) then - begin - //see offset_triginometry5.svg - a := tan( ArcTan2(growRec.aSin, growRec.aCos)/4 ) * delta; - AddPoint(GetVector(pt2, norms[prevI], a)); - AddPoint(GetVector(pt3, norms[i], -a)); - end else - begin - AddPoint(pt2); - AddPoint(pt3); - end; - prevI := i; - end; - if isOpen then AddPoint(p[highI*2-1]); - SetLength(Result, resCnt); -end; -//------------------------------------------------------------------------------ - -procedure AppendPath(var path: TPathD; const pt: TPointD); -var - len: integer; -begin - len := length(path); - if (len > 0) and PointsEqual(pt, path[len -1]) then Exit; - setLength(path, len + 1); - path[len] := pt; -end; -//------------------------------------------------------------------------------ - -procedure AppendPath(var path1: TPathD; const path2: TPathD); -var - len1, len2: integer; -begin - len1 := length(path1); - len2 := length(path2); - if len2 = 0 then Exit; - if (len1 > 0) and PointsEqual(path2[0], path1[len1 -1]) then dec(len1); - setLength(path1, len1 + len2); - Move(path2[0], path1[len1], len2 * SizeOf(TPointD)); -end; -//------------------------------------------------------------------------------ - -procedure AppendPoint(var path: TPathD; const extra: TPointD); -var - len: integer; -begin - len := length(path); - SetLength(path, len +1); - path[len] := extra; -end; -//------------------------------------------------------------------------------ - -procedure AppendPath(var paths: TPathsD; - const extra: TPathD); -var - len1, len2: integer; -begin - len2 := length(extra); - if len2 = 0 then Exit; - len1 := length(paths); - setLength(paths, len1 + 1); - paths[len1] := Copy(extra, 0, len2); -end; -//------------------------------------------------------------------------------ - -procedure AppendPath(var paths: TPathsD; - const extra: TPathsD); -var - i, len1, len2: integer; -begin - len2 := length(extra); - if len2 = 0 then Exit; - len1 := length(paths); - setLength(paths, len1 + len2); - for i := 0 to len2 -1 do - paths[len1+i] := Copy(extra[i], 0, length(extra[i])); -end; -//------------------------------------------------------------------------------ - -procedure AppendPath(var ppp: TArrayOfPathsD; const extra: TPathsD); -var - len: integer; -begin - len := length(ppp); - setLength(ppp, len + 1); - if Assigned(extra) then - AppendPath(ppp[len], extra) else - ppp[len] := nil; -end; -//------------------------------------------------------------------------------ - -procedure RotatePoint(var pt: TPointD; - const focalPoint: TPointD; sinA, cosA: double); -var - tmpX, tmpY: double; -begin - tmpX := pt.X-focalPoint.X; - tmpY := pt.Y-focalPoint.Y; - pt.X := tmpX * cosA - tmpY * sinA + focalPoint.X; - pt.Y := tmpX * sinA + tmpY * cosA + focalPoint.Y; -end; -//------------------------------------------------------------------------------ - -procedure RotatePoint(var pt: TPointD; - const focalPoint: TPointD; angleRad: double); -var - sinA, cosA: double; -begin - if angleRad = 0 then Exit; - if not ClockwiseRotationIsAnglePositive then angleRad := -angleRad; - GetSinCos(angleRad, sinA, cosA); - RotatePoint(pt, focalPoint, sinA, cosA); -end; -//------------------------------------------------------------------------------ - -function RotatePathInternal(const path: TPathD; - const focalPoint: TPointD; sinA, cosA: double): TPathD; -var - i: integer; - x,y: double; -begin - SetLength(Result, length(path)); - for i := 0 to high(path) do - begin - x := path[i].X - focalPoint.X; - y := path[i].Y - focalPoint.Y; - Result[i].X := x * cosA - y * sinA + focalPoint.X; - Result[i].Y := x * sinA + y * cosA + focalPoint.Y; - end; -end; -//------------------------------------------------------------------------------ - -function RotatePath(const path: TPathD; - const focalPoint: TPointD; angleRads: double): TPathD; -var - sinA, cosA: double; -begin - if angleRads = 0 then - begin - Result := path; - Exit; - end; - if not ClockwiseRotationIsAnglePositive then angleRads := -angleRads; - GetSinCos(angleRads, sinA, cosA); - Result := RotatePathInternal(path, focalPoint, sinA, cosA); -end; -//------------------------------------------------------------------------------ - -function RotatePath(const paths: TPathsD; - const focalPoint: TPointD; angleRads: double): TPathsD; -var - i: integer; - sinA, cosA: double; - fp: TPointD; -begin - Result := paths; - if not IsValid(angleRads) then Exit; - NormalizeAngle(angleRads); - if angleRads = 0 then Exit; - if not ClockwiseRotationIsAnglePositive then - angleRads := -angleRads; - GetSinCos(angleRads, sinA, cosA); - SetLength(Result, length(paths)); - if IsValid(focalPoint) then - fp := focalPoint else - fp := GetBoundsD(paths).MidPoint; - for i := 0 to high(paths) do - Result[i] := RotatePathInternal(paths[i], fp, sinA, cosA); -end; -//------------------------------------------------------------------------------ - -function GetAngle(const origin, pt: TPoint): double; -var - x,y: double; -begin - x := pt.X - origin.X; - y := pt.Y - origin.Y; - if x = 0 then - begin - if y > 0 then result := angle90 - else result := -angle90; - end - else if y = 0 then - begin - if x > 0 then result := 0 - else result := angle180; - end else - result := arctan2(y, x); //range between -Pi and Pi - if not ClockwiseRotationIsAnglePositive then Result := -Result; -end; -//------------------------------------------------------------------------------ - -function GetAngle(const origin, pt: TPointD): double; -var - x,y: double; -begin - x := pt.X - origin.X; - y := pt.Y - origin.Y; - if x = 0 then - begin - if y > 0 then result := angle90 - else result := -angle90; - end - else if y = 0 then - begin - if x > 0 then result := 0 - else result := angle180; - end else - result := arctan2(y, x); //range between -Pi and Pi - if not ClockwiseRotationIsAnglePositive then Result := -Result; -end; -//------------------------------------------------------------------------------ - -function GetAngle(const a, b, c: TPoint): double; -var - ab, bc: TPointD; - dp, cp: double; -begin - //https://stackoverflow.com/a/3487062/359538 - ab := PointD(b.x - a.x, b.y - a.y); - bc := PointD(b.x - c.x, b.y - c.y); - dp := (ab.x * bc.x + ab.y * bc.y); - cp := (ab.x * bc.y - ab.y * bc.x); - Result := arctan2(cp, dp); //range between -Pi and Pi - if not ClockwiseRotationIsAnglePositive then Result := -Result; -end; -//------------------------------------------------------------------------------ - -function GetAngle(const a, b, c: TPointD): double; -var - ab, bc: TPointD; - dp, cp: double; -begin - //https://stackoverflow.com/a/3487062/359538 - ab := PointD(b.x - a.x, b.y - a.y); - bc := PointD(b.x - c.x, b.y - c.y); - dp := (ab.x * bc.x + ab.y * bc.y); - cp := (ab.x * bc.y - ab.y * bc.x); - Result := arctan2(cp, dp); //range between -Pi and Pi - if not ClockwiseRotationIsAnglePositive then Result := -Result; -end; -//------------------------------------------------------------------------------ - -function GetPointAtAngleAndDist(const origin: TPointD; - angle, distance: double): TPointD; -begin - Result := origin; - Result.X := Result.X + distance; - RotatePoint(Result, origin, angle); -end; -//------------------------------------------------------------------------------ - -function IntersectPoint(const ln1a, ln1b, ln2a, ln2b: TPointD): TPointD; -var - m1,b1,m2,b2: double; -begin - result := InvalidPointD; - //see http://astronomy.swin.edu.au/~pbourke/geometry/lineline2d/ - if (ln1B.X = ln1A.X) then - begin - if (ln2B.X = ln2A.X) then exit; //parallel lines - m2 := (ln2B.Y - ln2A.Y)/(ln2B.X - ln2A.X); - b2 := ln2A.Y - m2 * ln2A.X; - Result.X := ln1A.X; - Result.Y := m2*ln1A.X + b2; - end - else if (ln2B.X = ln2A.X) then - begin - m1 := (ln1B.Y - ln1A.Y)/(ln1B.X - ln1A.X); - b1 := ln1A.Y - m1 * ln1A.X; - Result.X := ln2A.X; - Result.Y := m1*ln2A.X + b1; - end else - begin - m1 := (ln1B.Y - ln1A.Y)/(ln1B.X - ln1A.X); - b1 := ln1A.Y - m1 * ln1A.X; - m2 := (ln2B.Y - ln2A.Y)/(ln2B.X - ln2A.X); - b2 := ln2A.Y - m2 * ln2A.X; - if m1 = m2 then exit; //parallel lines - Result.X := (b2 - b1)/(m1 - m2); - Result.Y := m1 * Result.X + b1; - end; -end; -//------------------------------------------------------------------------------ - -function IntersectPoint(const ln1a, ln1b, ln2a, ln2b: TPointD; - out ip: TPointD): Boolean; -begin - ip := IntersectPoint(ln1a, ln1b, ln2a, ln2b); - Result := IsValid(ip); -end; -//------------------------------------------------------------------------------ - -function SegmentIntersectPt(const ln1a, ln1b, ln2a, ln2b: TPointD): TPointD; -var - pqd,r,s : TPointD; //scalar vectors; - rs, t : double; -begin - //https://stackoverflow.com/a/565282/359538 - Result := InvalidPointD; - r := PointD(ln1b.X - ln1a.X, ln1b.Y - ln1a.Y); - s := PointD(ln2b.X - ln2a.X, ln2b.Y - ln2a.Y); - rs := CrossProduct(r,s); - if Abs(rs) < 1 then Exit; - pqd.X := ln2a.X - ln1a.X; - pqd.y := ln2a.Y - ln1a.Y; - t := CrossProduct(pqd, s) / rs; - if (t < -0.025) or (t > 1.025) then Exit; - Result.X := ln1a.X + t * r.X; - Result.Y := ln1a.Y + t * r.Y; -// pqd.X := -pqd.X; pqd.Y := -pqd.Y; -// u := CrossProduct(pqd, r) / rs; -// if (u < -0.05) or (u > 1.05) then Exit; -end; -//------------------------------------------------------------------------------ - -function SegmentsIntersect(const ln1a, ln1b, ln2a, ln2b: TPointD; - out ip: TPointD): Boolean; -begin - ip := SegmentIntersectPt(ln1a, ln1b, ln2a, ln2b); - Result := IsValid(ip); -end; -//------------------------------------------------------------------------------ - -function ReverseNormals(const norms: TPathD): TPathD; -var - i, highI: integer; -begin - highI := high(norms); - setLength(result, highI +1); - for i := 1 to highI do - begin - result[i -1].X := -norms[highI -i].X; - result[i -1].Y := -norms[highI -i].Y; - end; - result[highI].X := -norms[highI].X; - result[highI].Y := -norms[highI].Y; -end; -//------------------------------------------------------------------------------ - -function GrowOpenLine(const line: TPathD; width: double; - joinStyle: TJoinStyle; endStyle: TEndStyle; - miterLimOrRndScale: double): TPathD; -var - len, x,y: integer; - halfWidth: double; - normals, lineL, lineR, arc: TPathD; - invNorm: TPointD; - growRec: TGrowRec; -begin - Result := nil; - len := length(line); - if len = 0 then Exit; - if width < MinStrokeWidth then - width := MinStrokeWidth; - halfWidth := width * 0.5; - if len = 1 then - begin - x := Round(line[0].X); - y := Round(line[0].Y); - SetLength(result, 1); - result := Ellipse(RectD(x -halfWidth, y -halfWidth, - x +halfWidth, y +halfWidth)); - Exit; - end; - - //with very narrow lines, don't get fancy with joins and line ends - if (width <= 2) then - begin - joinStyle := jsSquare; - if endStyle = esRound then endStyle := esSquare; - end - else if joinStyle = jsAuto then - begin - if (endStyle = esRound) and - (width >= AutoWidthThreshold) then - joinStyle := jsRound - else - joinStyle := jsSquare; - end; - - normals := GetNormals(line); - if endStyle = esRound then - begin - //get the rounding parameters - growRec.StepsPerRad := - CalcRoundingSteps(halfWidth * miterLimOrRndScale)/(Pi*2); - GetSinCos(1/growRec.StepsPerRad, growRec.StepSin, growRec.StepCos); - growRec.Radius := halfWidth; - growRec.aSin := invNorm.X * normals[0].Y - invNorm.Y * normals[0].X; - growRec.aCos := invNorm.X * normals[0].X + invNorm.Y * normals[0].Y; - - //grow the line's left side of the line => line1 - lineL := Grow(line, normals, - halfWidth, joinStyle, miterLimOrRndScale, true); - //build the rounding at the start => result - invNorm.X := -normals[0].X; - invNorm.Y := -normals[0].Y; - growRec.aSin := invNorm.X * normals[0].Y - invNorm.Y * normals[0].X; - growRec.aCos := invNorm.X * normals[0].X + invNorm.Y * normals[0].Y; - Result := DoRound(line[0], invNorm, normals[0], growRec); - //join line1 into result - AppendPath(Result, lineL); - //reverse the normals and build the end arc => arc - normals := ReverseNormals(normals); - invNorm.X := -normals[0].X; invNorm.Y := -normals[0].Y; - growRec.aSin := invNorm.X * normals[0].Y - invNorm.Y * normals[0].X; - growRec.aCos := invNorm.X * normals[0].X + invNorm.Y * normals[0].Y; - arc := DoRound(line[High(line)], invNorm, normals[0], growRec); - //grow the line's right side of the line - lineR := Grow(ReversePath(line), normals, - halfWidth, joinStyle, miterLimOrRndScale, true); - //join arc and line2 into result - AppendPath(Result, arc); - AppendPath(Result, lineR); - end else - begin - - //esSquare => extends both line ends by 1/2 lineWidth - if endStyle = esSquare then - begin - lineL := Copy(line, 0, len); - AdjustPoint(lineL[0], lineL[1], width * 0.5); - AdjustPoint(lineL[len-1], lineL[len-2], width * 0.5); - end else - lineL := line; - - //first grow the left side of the line => Result - Result := Grow(lineL, normals, - halfWidth, joinStyle, miterLimOrRndScale, true); - //reverse normals and path and grow the right side => lineR - normals := ReverseNormals(normals); - lineR := Grow(ReversePath(lineL), normals, - halfWidth, joinStyle, miterLimOrRndScale, true); - //join both sides - AppendPath(Result, lineR); - end; -end; -//------------------------------------------------------------------------------ - -function GrowClosedLine(const line: TPathD; width: double; - joinStyle: TJoinStyle; miterLimOrRndScale: double): TPathsD; -var - line2, norms: TPathD; - rec: TRectD; - skipHole: Boolean; -begin - rec := GetBoundsD(line); - skipHole := (rec.Width <= width) or (rec.Height <= width); - if skipHole then - begin - SetLength(Result, 1); - norms := GetNormals(line); - Result[0] := Grow(line, norms, width/2, joinStyle, miterLimOrRndScale); - end else - begin - SetLength(Result, 2); - norms := GetNormals(line); - Result[0] := Grow(line, norms, width/2, joinStyle, miterLimOrRndScale); - line2 := ReversePath(line); - norms := ReverseNormals(norms); - Result[1] := Grow(line2, norms, width/2, joinStyle, miterLimOrRndScale); - end; -end; -//------------------------------------------------------------------------------ - -function Outline(const line: TPathD; lineWidth: double; - joinStyle: TJoinStyle; endStyle: TEndStyle; - miterLimOrRndScale: double): TPathsD; -begin - if not assigned(line) then - Result := nil - else if endStyle = esClosed then - result := GrowClosedLine(line, - lineWidth, joinStyle, miterLimOrRndScale) - else - begin - SetLength(Result,1); - result[0] := GrowOpenLine(line, lineWidth, - joinStyle, endStyle, miterLimOrRndScale); - end; -end; -//------------------------------------------------------------------------------ - -function Outline(const lines: TPathsD; lineWidth: double; - joinStyle: TJoinStyle; endStyle: TEndStyle; - miterLimOrRndScale: double): TPathsD; -var - i: integer; -begin - result := nil; - if not assigned(lines) then exit; - if joinStyle = jsAuto then - begin - if endStyle in [esPolygon, esRound] then - joinStyle := jsRound else - joinStyle := jsSquare; - end; - if endStyle = esPolygon then - for i := 0 to high(lines) do - AppendPath(Result, GrowClosedLine(lines[i], - lineWidth, joinStyle, miterLimOrRndScale)) - else - for i := 0 to high(lines) do - AppendPath(Result, GrowOpenLine(lines[i], lineWidth, - joinStyle, endStyle, miterLimOrRndScale)); -end; -//------------------------------------------------------------------------------ - -function Rectangle(const rec: TRect): TPathD; -begin - setLength(Result, 4); - with rec do - begin - result[0] := PointD(left, top); - result[1] := PointD(right, top); - result[2] := PointD(right, bottom); - result[3] := PointD(left, bottom); - end; -end; -//------------------------------------------------------------------------------ - -function Rectangle(const rec: TRectD): TPathD; -begin - setLength(Result, 4); - with rec do - begin - result[0] := PointD(left, top); - result[1] := PointD(right, top); - result[2] := PointD(right, bottom); - result[3] := PointD(left, bottom); - end; -end; -//------------------------------------------------------------------------------ - -function Rectangle(l, t, r, b: double): TPathD; -begin - setLength(Result, 4); - result[0] := PointD(l, t); - result[1] := PointD(r, t); - result[2] := PointD(r, b); - result[3] := PointD(l, b); -end; -//------------------------------------------------------------------------------ - -procedure InflateRect(var rec: TRect; dx, dy: integer); -begin - rec.Left := rec.Left - dx; - rec.Top := rec.Top - dy; - rec.Right := rec.Right + dx; - rec.Bottom := rec.Bottom + dy; -end; -//------------------------------------------------------------------------------ - -procedure InflateRect(var rec: TRectD; dx, dy: double); -begin - rec.Left := rec.Left - dx; - rec.Top := rec.Top - dy; - rec.Right := rec.Right + dx; - rec.Bottom := rec.Bottom + dy; -end; -//------------------------------------------------------------------------------ - -function NormalizeRect(var rect: TRect): Boolean; -var - i: integer; -begin - Result := False; - with rect do - begin - if Left > Right then - begin - i := Left; - Left := Right; - Right := i; - Result := True; - end; - if Top > Bottom then - begin - i := Top; - Top := Bottom; - Bottom := i; - Result := True; - end; - end; -end; -//------------------------------------------------------------------------------ - -function RoundRect(const rec: TRect; radius: integer): TPathD; -begin - Result := RoundRect(RectD(rec), PointD(radius, radius)); -end; -//------------------------------------------------------------------------------ - -function RoundRect(const rec: TRect; radius: TPoint): TPathD; -begin - Result := RoundRect(RectD(rec), PointD(radius)); -end; -//------------------------------------------------------------------------------ - -function RoundRect(const rec: TRectD; radius: double): TPathD; -begin - Result := RoundRect(rec, PointD(radius, radius)); -end; -//------------------------------------------------------------------------------ - -function RoundRect(const rec: TRectD; radius: TPointD): TPathD; -var - i,j : integer; - corners : TPathD; - bezPts : TPathD; - magic : TPointD; -const - magicC: double = 0.55228475; // =4/3 * (sqrt(2)-1) -begin - Result := nil; - if rec.IsEmpty then Exit; - radius.X := Min(radius.X, rec.Width/2); - radius.Y := Min(radius.Y, rec.Height/2); - if (radius.X < 1) and (radius.Y < 1) then - begin - Result := Rectangle(rec); - Exit; - end; - magic.X := radius.X * magicC; - magic.Y := radius.Y * magicC; - SetLength(Corners, 4); - with rec do - begin - corners[0] := PointD(Right, Top); - corners[1] := BottomRight; - corners[2] := PointD(Left, Bottom); - corners[3] := TopLeft; - end; - SetLength(Result, 1); - Result[0].X := corners[3].X + radius.X; - Result[0].Y := corners[3].Y; - SetLength(bezPts, 4); - for i := 0 to High(corners) do - begin - for j := 0 to 3 do bezPts[j] := corners[i]; - case i of - 3: - begin - bezPts[0].Y := bezPts[0].Y + radius.Y; - bezPts[1].Y := bezPts[0].Y - magic.Y; - bezPts[3].X := bezPts[3].X + radius.X; - bezPts[2].X := bezPts[3].X - magic.X; - end; - 0: - begin - bezPts[0].X := bezPts[0].X - radius.X; - bezPts[1].X := bezPts[0].X + magic.X; - bezPts[3].Y := bezPts[3].Y + radius.Y; - bezPts[2].Y := bezPts[3].Y - magic.Y; - end; - 1: - begin - bezPts[0].Y := bezPts[0].Y - radius.Y; - bezPts[1].Y := bezPts[0].Y + magic.Y; - bezPts[3].X := bezPts[3].X - radius.X; - bezPts[2].X := bezPts[3].X + magic.X; - end; - 2: - begin - bezPts[0].X := bezPts[0].X + radius.X; - bezPts[1].X := bezPts[0].X - magic.X; - bezPts[3].Y := bezPts[3].Y - radius.Y; - bezPts[2].Y := bezPts[3].Y + magic.Y; - end; - end; - AppendPath(Result, FlattenCBezier(bezPts)); - end; -end; -//------------------------------------------------------------------------------ - -function Circle(const pt: TPoint; radius: double): TPathD; -var - rec: TRectD; -begin - rec.Left := pt.X - radius; - rec.Right := pt.X + radius; - rec.Top := pt.Y - radius; - rec.Bottom := pt.Y + radius; - Result := Ellipse(rec); -end; -//------------------------------------------------------------------------------ - -function Circle(const pt: TPointD; radius: double): TPathD; -var - rec: TRectD; -begin - rec.Left := pt.X - radius; - rec.Right := pt.X + radius; - rec.Top := pt.Y - radius; - rec.Bottom := pt.Y + radius; - Result := Ellipse(rec); -end; -//------------------------------------------------------------------------------ - -function Circle(const pt: TPointD; radius: double; pendingScale: double): TPathD; -var - rec: TRectD; -begin - rec.Left := pt.X - radius; - rec.Right := pt.X + radius; - rec.Top := pt.Y - radius; - rec.Bottom := pt.Y + radius; - Result := Ellipse(rec, pendingScale); -end; -//------------------------------------------------------------------------------ - -function Ellipse(const rec: TRectD; pendingScale: double): TPathD; -var - steps: integer; -begin - if pendingScale <= 0 then pendingScale := 1; - steps := Round(CalcRoundingSteps((rec.width + rec.Height) * pendingScale)); - Result := Ellipse(rec, steps); -end; -//------------------------------------------------------------------------------ - - -function Ellipse(const rec: TRect; steps: integer): TPathD; -begin - Result := Ellipse(RectD(rec), steps); -end; -//------------------------------------------------------------------------------ - -function Ellipse(const rec: TRectD; steps: integer): TPathD; -var - i: Integer; - sinA, cosA: double; - centre, radius, delta: TPointD; -begin - result := nil; - if rec.IsEmpty then Exit; - with rec do - begin - centre := rec.MidPoint; - radius := PointD(Width * 0.5, Height * 0.5); - end; - if steps < 4 then - steps := Round(CalcRoundingSteps(rec.width + rec.height)); - GetSinCos(2 * Pi / Steps, sinA, cosA); - delta.x := cosA; delta.y := sinA; - SetLength(Result, Steps); - Result[0] := PointD(centre.X + radius.X, centre.Y); - for i := 1 to steps -1 do - begin - Result[i] := PointD(centre.X + radius.X * delta.x, - centre.Y + radius.y * delta.y); - delta := PointD(delta.X * cosA - delta.Y * sinA, - delta.Y * cosA + delta.X * sinA); - end; //rotates clockwise -end; -//------------------------------------------------------------------------------ - -function RotatedEllipse(const rec: TRectD; angle: double; steps: integer = 0): TPathD; -begin - Result := Ellipse(rec, steps); - if angle = 0 then Exit; - Result := RotatePath(Result, rec.MidPoint, angle); -end; -//------------------------------------------------------------------------------ - -function RotatedEllipse(const rec: TRectD; angle: double; pendingScale: double): TPathD; -begin - Result := Ellipse(rec, pendingScale); - if angle = 0 then Exit; - Result := RotatePath(Result, rec.MidPoint, angle); -end; -//------------------------------------------------------------------------------ - -function AngleToEllipticalAngle(const ellRec: TRectD; angle: double): double; -begin - Result := arctan2(ellRec.Height/ellRec.Width * sin(angle), cos(angle)); -end; -//------------------------------------------------------------------------------ - -function EllipticalAngleToAngle(const ellRec: TRectD; angle: double): double; -begin - Result := ArcTan2(sin(angle) *ellRec.Width, cos(angle) * ellRec.Height); -end; -//------------------------------------------------------------------------------ - -function Star(const rec: TRectD; points: integer; indentFrac: double): TPathD; -var - i: integer; - innerOff: double; - p, p2: TPathD; - rec2: TRectD; -begin - Result := nil; - if points < 5 then points := 5 - else if points > 15 then points := 15; - if indentFrac < 0.2 then indentFrac := 0.2 - else if indentFrac > 0.8 then indentFrac := 0.8; - innerOff := Min(rec.Width, rec.Height) * indentFrac * 0.5; - if not Odd(points) then inc(points); - p := Ellipse(rec, points); - if not Assigned(p) then Exit; - rec2 := rec; - Img32.Vector.InflateRect(rec2, -innerOff, -innerOff); - if rec2.IsEmpty then - p2 := Ellipse(rec, points*2) else - p2 := Ellipse(rec2, points*2); - SetLength(Result, points*2); - for i := 0 to points -1 do - begin - Result[i*2] := p[i]; - Result[i*2+1] := p2[i*2+1]; - end; -end; -//------------------------------------------------------------------------------ - -function Star(const focalPt: TPointD; - innerRadius, outerRadius: double; points: integer): TPathD; -var - i: Integer; - sinA, cosA: double; - delta: TPointD; -begin - result := nil; - if (innerRadius <= 0) or (outerRadius <= 0) then Exit; - if points <= 5 then points := 10 - else points := points * 2; - GetSinCos(2 * Pi / points, sinA, cosA); - delta.x := cosA; delta.y := sinA; - SetLength(Result, points); - Result[0] := PointD(focalPt.X + innerRadius, focalPt.Y); - for i := 1 to points -1 do - begin - if Odd(i) then - Result[i] := PointD(focalPt.X + outerRadius * delta.x, - focalPt.Y + outerRadius * delta.y) - else - Result[i] := PointD(focalPt.X + innerRadius * delta.x, - focalPt.Y + innerRadius * delta.y); - delta := PointD(delta.X * cosA - delta.Y * sinA, - delta.Y * cosA + delta.X * sinA); - end; -end; -//------------------------------------------------------------------------------ - -function Arc(const rec: TRectD; - startAngle, endAngle: double; scale: double): TPathD; -var - i, steps: Integer; - angle: double; - sinA, cosA: double; - centre, radius: TPointD; - deltaX, deltaX2, deltaY: double; -const - qtrDeg = PI/1440; -begin - Result := nil; - if (endAngle = startAngle) or IsEmptyRect(rec) then Exit; - if scale <= 0 then scale := 4.0; - if not ClockwiseRotationIsAnglePositive then - begin - startAngle := -startAngle; - endAngle := -endAngle; - end; - NormalizeAngle(startAngle, qtrDeg); - NormalizeAngle(endAngle, qtrDeg); - with rec do - begin - centre := MidPoint; - radius := PointD(Width * 0.5, Height * 0.5); - end; - if endAngle < startAngle then - angle := endAngle - startAngle + angle360 else - angle := endAngle - startAngle; - //steps = (No. steps for a whole ellipse) * angle/(2*Pi) - steps := Round(CalcRoundingSteps((rec.width + rec.height) * scale)); - steps := steps div 2; ///////////////////////////////// - if steps < 2 then steps := 2; - SetLength(Result, Steps +1); - //angle of the first step ... - GetSinCos(startAngle, deltaY, deltaX); - Result[0].X := centre.X + radius.X * deltaX; - Result[0].Y := centre.Y + radius.y * deltaY; - //angle of each subsequent step ... - GetSinCos(angle / Steps, sinA, cosA); - for i := 1 to steps do - begin - deltaX2 := deltaX * cosA - deltaY * sinA; - deltaY := deltaY * cosA + deltaX * sinA; - deltaX := deltaX2; - Result[i].X := centre.X + radius.X * deltaX; - Result[i].Y := centre.Y + radius.y * deltaY; - end; //progresses clockwise from start to end -end; -//------------------------------------------------------------------------------ - -function Pie(const rec: TRectD; - StartAngle, EndAngle: double; scale: double): TPathD; -var - len: integer; -begin - result := Arc(rec, StartAngle, EndAngle, scale); - len := length(result); - setLength(result, len +1); - result[len] := PointD((rec.Left + rec.Right)/2, (rec.Top + rec.Bottom)/2); -end; -//------------------------------------------------------------------------------ - -function ArrowHead(const arrowTip, ctrlPt: TPointD; size: double; - arrowStyle: TArrowStyle): TPathD; -var - unitVec, basePt: TPointD; - sDiv40, sDiv50, sDiv60, sDiv120: double; -begin - result := nil; - sDiv40 := size * 0.40; - sDiv50 := size * 0.50; - sDiv60 := size * 0.60; - sDiv120 := sDiv60 * 2; - unitVec := GetUnitVector(ctrlPt, arrowTip); - case arrowStyle of - asNone: - Exit; - asSimple: - begin - setLength(result, 3); - basePt := OffsetPoint(arrowTip, -unitVec.X * size, -unitVec.Y * size); - result[0] := arrowTip; - result[1] := OffsetPoint(basePt, -unitVec.Y * sDiv50, unitVec.X * sDiv50); - result[2] := OffsetPoint(basePt, unitVec.Y * sDiv50, -unitVec.X * sDiv50); - end; - asFancy: - begin - setLength(result, 4); - basePt := OffsetPoint(arrowTip, - -unitVec.X * sDiv120, -unitVec.Y * sDiv120); - result[0] := OffsetPoint(basePt, -unitVec.Y *sDiv50, unitVec.X *sDiv50); - result[1] := OffsetPoint(arrowTip, -unitVec.X *size, -unitVec.Y *size); - result[2] := OffsetPoint(basePt, unitVec.Y *sDiv50, -unitVec.X *sDiv50); - result[3] := arrowTip; - end; - asDiamond: - begin - setLength(result, 4); - basePt := OffsetPoint(arrowTip, -unitVec.X * sDiv60, -unitVec.Y * sDiv60); - result[0] := arrowTip; - result[1] := OffsetPoint(basePt, -unitVec.Y * sDiv50, unitVec.X * sDiv50); - result[2] := OffsetPoint(arrowTip, -unitVec.X * sDiv120, -unitVec.Y * sDiv120); - result[3] := OffsetPoint(basePt, unitVec.Y * sDiv50, -unitVec.X * sDiv50); - end; - asCircle: - begin - basePt := OffsetPoint(arrowTip, -unitVec.X * sDiv50, -unitVec.Y * sDiv50); - with Point(basePt) do - result := Ellipse(RectD(x - sDiv50, y - sDiv50, x + sDiv50, y + sDiv50)); - end; - asTail: - begin - setLength(result, 6); - basePt := OffsetPoint(arrowTip, -unitVec.X * sDiv60, -unitVec.Y * sDiv60); - result[0] := OffsetPoint(arrowTip, -unitVec.X * sDiv50, -unitVec.Y * sDiv50); - result[1] := OffsetPoint(arrowTip, -unitVec.Y * sDiv40, unitVec.X * sDiv40); - result[2] := OffsetPoint(basePt, -unitVec.Y * sDiv40, unitVec.X * sDiv40); - result[3] := OffsetPoint(arrowTip, -unitVec.X * sDiv120, -unitVec.Y * sDiv120); - result[4] := OffsetPoint(basePt, unitVec.Y * sDiv40, -unitVec.X * sDiv40); - result[5] := OffsetPoint(arrowTip, unitVec.Y * sDiv40, -unitVec.X * sDiv40); - end; - end; -end; -//------------------------------------------------------------------------------ - -function GetDefaultArrowHeadSize(lineWidth: double): double; -begin - Result := lineWidth *3 + 7; -end; -//------------------------------------------------------------------------------ - -procedure AdjustPoint(var pt: TPointD; const referencePt: TPointD; delta: double); -var - vec: TPointD; -begin - //Positive delta moves pt away from referencePt, and - //negative delta moves pt toward referencePt. - vec := GetUnitVector(referencePt, pt); - pt.X := pt.X + (vec.X * delta); - pt.Y := pt.Y + (vec.Y * delta); -end; -//------------------------------------------------------------------------------ - -function ShortenPath(const path: TPathD; - pathEnd: TPathEnd; amount: double): TPathD; -var - len, amount2: double; - vec: TPointD; - i, highPath: integer; -begin - result := path; - highPath := high(path); - if highPath < 1 then Exit; - amount2 := amount; - if pathEnd <> peEnd then - begin - //shorten start - i := 0; - while (i < highPath) do - begin - len := Distance(result[i], result[i+1]); - if (len >= amount) then Break; - amount := amount - len; - inc(i); - end; - if i > 0 then - begin - Move(path[i], Result[0], (highPath - i +1) * SizeOf(TPointD)); - dec(highPath, i); - SetLength(Result, highPath +1); - end; - if amount > 0 then - begin - vec := GetUnitVector(result[0], result[1]); - result[0].X := result[0].X + vec.X * amount; - result[0].Y := result[0].Y + vec.Y * amount; - end; - end; - if pathEnd <> peStart then - begin - //shorten end - while (highPath > 1) do - begin - len := Distance(result[highPath], result[highPath -1]); - if (len >= amount2) then Break; - amount2 := amount2 - len; - dec(highPath); - end; - SetLength(Result, highPath +1); - if amount2 > 0 then - begin - vec := GetUnitVector(result[highPath], result[highPath -1]); - result[highPath].X := result[highPath].X + vec.X * amount2; - result[highPath].Y := result[highPath].Y + vec.Y * amount2; - end; - end; -end; -//------------------------------------------------------------------------------ - -function GetDashedPath(const path: TPathD; - closed: Boolean; const pattern: TArrayOfInteger; - patternOffset: PDouble): TPathsD; -var - i, highI, paIdx: integer; - vecs, path2, dash: TPathD; - patCnt, patLen: integer; - dashCapacity, dashCnt, ptsCapacity, ptsCnt: integer; - segLen, residualPat, patOff: double; - filling: Boolean; - pt, pt2: TPointD; - - procedure NewDash; - begin - if ptsCnt = 1 then ptsCnt := 0; - if ptsCnt = 0 then Exit; - if dashCnt = dashCapacity then - begin - inc(dashCapacity, BuffSize); - setLength(result, dashCapacity); - end; - result[dashCnt] := Copy(dash, 0, ptsCnt); - inc(dashCnt); - ptsCapacity := BuffSize; - setLength(dash, ptsCapacity); - ptsCnt := 0; - end; - - procedure ExtendDash(const pt: TPointD); - begin - if ptsCnt = ptsCapacity then - begin - inc(ptsCapacity, BuffSize); - setLength(dash, ptsCapacity); - end; - dash[ptsCnt] := pt; - inc(ptsCnt); - end; - -begin - Result := nil; - paIdx := 0; - patCnt := length(pattern); - path2 := path; - highI := high(path2); - if (highI < 1) or (patCnt = 0) then Exit; - if closed and - ((path2[highI].X <> path2[0].X) or (path2[highI].Y <> path2[0].Y)) then - begin - inc(highI); - setLength(path2, highI +2); - path2[highI] := path2[0]; - end; - vecs := GetVectors(path2); - if (vecs[0].X = 0) and (vecs[0].Y = 0) then Exit; //not a line - if not assigned(patternOffset) then - patOff := 0 else - patOff := patternOffset^; - patLen := 0; - for i := 0 to patCnt -1 do - inc(patLen, pattern[i]); - if patOff < 0 then - begin - patOff := patLen + patOff; - while patOff < 0 do - patOff := patOff + patLen; - end - else while patOff > patLen do - patOff := patOff - patLen; - //nb: each dash is made up of 2 or more pts - dashCnt := 0; - dashCapacity := 0; - ptsCnt := 0; - ptsCapacity := 0; - filling := true; - while patOff >= pattern[paIdx] do - begin - filling := not filling; - patOff := patOff - pattern[paIdx]; - paIdx := (paIdx + 1) mod patCnt; - end; - residualPat := pattern[paIdx] - patOff; - pt := path2[0]; - ExtendDash(pt); - i := 0; - while (i < highI) do - begin - segLen := Distance(pt, path2[i+1]); - if residualPat > segLen then - begin - if filling then ExtendDash(path2[i+1]); - residualPat := residualPat - segLen; - pt := path2[i+1]; - inc(i); - end else - begin - pt2.X := pt.X + vecs[i].X * residualPat; - pt2.Y := pt.Y + vecs[i].Y * residualPat; - if filling then ExtendDash(pt2); - filling := not filling; - NewDash; - paIdx := (paIdx + 1) mod patCnt; - residualPat := pattern[paIdx]; - pt := pt2; - ExtendDash(pt); - end; - end; - NewDash; - SetLength(Result, dashCnt); - if not assigned(patternOffset) then Exit; - patOff := 0; - for i := 0 to paIdx -1 do - patOff := patOff + pattern[i]; - patternOffset^ := patOff + (pattern[paIdx] - residualPat); -end; -//------------------------------------------------------------------------------ - -function GetDashedOutLine(const path: TPathD; - closed: Boolean; const pattern: TArrayOfInteger; - patternOffset: PDouble; lineWidth: double; - joinStyle: TJoinStyle; endStyle: TEndStyle): TPathsD; -var - i: integer; - tmp: TPathsD; -begin - Result := nil; - for i := 0 to High(pattern) do - if pattern[i] <= 0 then pattern[i] := 1; - tmp := GetDashedPath(path, closed, pattern, patternOffset); - for i := 0 to high(tmp) do - AppendPath(Result, GrowOpenLine(tmp[i], - lineWidth, joinStyle, endStyle, 2)); -end; -//------------------------------------------------------------------------------ - -function GetBoundsD(const paths: TPathsD): TRectD; -var - i,j: integer; - l,t,r,b: double; - p: PPointD; -begin - l := MaxInt; t := MaxInt; - r := -MaxInt; b := -MaxInt; - for i := 0 to high(paths) do - begin - p := PPointD(paths[i]); - if not assigned(p) then Continue; - for j := 0 to high(paths[i]) do - begin - if p.x < l then l := p.x; - if p.x > r then r := p.x; - if p.y < t then t := p.y; - if p.y > b then b := p.y; - inc(p); - end; - end; - if r < l then - result := NullRectD else - result := RectD(l, t, r, b); -end; -//------------------------------------------------------------------------------ - -function GetBoundsD(const path: TPathD): TRectD; -var - i,highI: integer; - l,t,r,b: double; - p: PPointD; -begin - highI := High(path); - if highI < 0 then - begin - Result := NullRectD; - Exit; - end; - l := path[0].X; r := l; - t := path[0].Y; b := t; - p := PPointD(path); - for i := 1 to highI do - begin - inc(p); - if p.x < l then l := p.x; - if p.x > r then r := p.x; - if p.y < t then t := p.y; - if p.y > b then b := p.y; - end; - result := RectD(l, t, r, b); -end; -//------------------------------------------------------------------------------ - -function GetBounds(const path: TPathD): TRect; -var - recD: TRectD; -begin - recD := GetBoundsD(path); - Result := Rect(recD); -end; -//------------------------------------------------------------------------------ - -function GetBounds(const paths: TPathsD): TRect; -var - recD: TRectD; -begin - recD := GetBoundsD(paths); - Result := Rect(recD); -end; -//------------------------------------------------------------------------------ - -function PrePendPoint(const pt: TPointD; const p: TPathD): TPathD; -var - len: integer; -begin - len := Length(p); - SetLength(Result, len +1); - Result[0] := pt; - if len > 0 then Move(p[0], Result[1], len * SizeOf(TPointD)); -end; -//------------------------------------------------------------------------------ - -function PrePendPoints(const pt1, pt2: TPointD; const p: TPathD): TPathD; -var - len: integer; -begin - len := Length(p); - SetLength(Result, len +2); - Result[0] := pt1; - Result[1] := pt2; - if len > 0 then Move(p[0], Result[2], len * SizeOf(TPointD)); -end; -//------------------------------------------------------------------------------ - -function GetPointInQuadBezier(const a,b,c: TPointD; t: double): TPointD; -var - omt: double; -begin - if t > 1 then t := 1 - else if t < 0 then t := 0; - omt := 1 - t; - Result.X := a.X*omt*omt + b.X*2*omt*t + c.X*t*t; - Result.Y := a.Y*omt*omt + b.Y*2*omt*t + c.Y*t*t; -end; -//------------------------------------------------------------------------------ - -function FlattenQBezier(const firstPt: TPointD; const pts: TPathD; - tolerance: double = 0.0): TPathD; overload; -begin - if tolerance <= 0.0 then tolerance := BezierTolerance; - Result := FlattenQBezier(PrePendPoint(firstPt, pts), tolerance); -end; -//------------------------------------------------------------------------------ - -function FlattenQBezier(const pts: TPathD; tolerance: double = 0.0): TPathD; -var - i, highI: integer; - p: TPathD; -begin - Result := nil; - highI := high(pts); - if highI < 0 then Exit; - if (highI < 2) or Odd(highI) then - raise Exception.Create(rsInvalidQBezier); - if tolerance <= 0.0 then tolerance := BezierTolerance; - setLength(Result, 1); - Result[0] := pts[0]; - for i := 0 to (highI div 2) -1 do - begin - if PointsEqual(pts[i*2], pts[i*2+1]) and - PointsEqual(pts[i*2+1], pts[i*2+2]) then - begin - AppendPoint(Result, pts[i*2]); - AppendPoint(Result, pts[i*2 +2]); - end else - begin - p := FlattenQBezier(pts[i*2], pts[i*2+1], pts[i*2+2], tolerance); - AppendPath(Result, Copy(p, 1, Length(p) -1)); - end; - end; -end; -//------------------------------------------------------------------------------ - -function FlattenQBezier(const pt1, pt2, pt3: TPointD; - tolerance: double = 0.0): TPathD; -var - resultCnt, resultLen: integer; - - procedure AddPoint(const pt: TPointD); - begin - if resultCnt = resultLen then - begin - inc(resultLen, BuffSize); - setLength(result, resultLen); - end; - result[resultCnt] := pt; - inc(resultCnt); - end; - - procedure DoCurve(const p1, p2, p3: TPointD); - var - p12, p23, p123: TPointD; - begin - if (abs(p1.x + p3.x - 2 * p2.x) + - abs(p1.y + p3.y - 2 * p2.y) < tolerance) then - begin - AddPoint(p3); - end else - begin - P12.X := (P1.X + P2.X) * 0.5; - P12.Y := (P1.Y + P2.Y) * 0.5; - P23.X := (P2.X + P3.X) * 0.5; - P23.Y := (P2.Y + P3.Y) * 0.5; - P123.X := (P12.X + P23.X) * 0.5; - P123.Y := (P12.Y + P23.Y) * 0.5; - DoCurve(p1, p12, p123); - DoCurve(p123, p23, p3); - end; - end; - -begin - resultLen := 0; resultCnt := 0; - if tolerance <= 0.0 then tolerance := BezierTolerance; - AddPoint(pt1); - if ((pt1.X = pt2.X) and (pt1.Y = pt2.Y)) or - ((pt2.X = pt3.X) and (pt2.Y = pt3.Y)) then - begin - AddPoint(pt3) - end else - DoCurve(pt1, pt2, pt3); - SetLength(result, resultCnt); -end; -//------------------------------------------------------------------------------ - -function GetPointInCubicBezier(const a,b,c,d: TPointD; t: double): TPointD; -var - omt: double; -begin - if t > 1 then t := 1 - else if t < 0 then t := 0; - omt := 1 - t; - Result.X := a.X*omt*omt*omt +b.X*3*omt*omt*t +c.X*3*omt*t*t +d.X*t*t*t; - Result.Y := a.Y*omt*omt*omt +b.Y*3*omt*omt*t +c.Y*3*omt*t*t +d.Y*t*t*t; -end; -//------------------------------------------------------------------------------ - -function FlattenCBezier(const firstPt: TPointD; const pts: TPathD; - tolerance: double = 0.0): TPathD; overload; -begin - Result := FlattenCBezier(PrePendPoint(firstPt, pts), tolerance); -end; -//------------------------------------------------------------------------------ - -function FlattenCBezier(const pts: TPathD; tolerance: double = 0.0): TPathD; -var - i, len: integer; - p: TPathD; -begin - Result := nil; - len := Length(pts) -1; - if len < 0 then Exit; - if (len < 3) or (len mod 3 <> 0) then - raise Exception.Create(rsInvalidCBezier); - if tolerance <= 0.0 then tolerance := BezierTolerance; - setLength(Result, 1); - Result[0] := pts[0]; - for i := 0 to (len div 3) -1 do - begin - if PointsEqual(pts[i*3], pts[i*3+1]) and - PointsEqual(pts[i*3+2], pts[i*3+3]) then - begin - AppendPoint(Result, pts[i*3]); - AppendPoint(Result, pts[i*3 +3]); - end else - begin - p := FlattenCBezier(pts[i*3], pts[i*3+1], - pts[i*3+2], pts[i*3+3], tolerance); - AppendPath(Result, Copy(p, 1, Length(p) -1)); - end; - end; -end; -//------------------------------------------------------------------------------ - -function FlattenCBezier(const pt1, pt2, pt3, pt4: TPointD; - tolerance: double = 0.0): TPathD; -var - resultCnt, resultLen: integer; - - procedure AddPoint(const pt: TPointD); - begin - if resultCnt = resultLen then - begin - inc(resultLen, BuffSize); - setLength(result, resultLen); - end; - result[resultCnt] := pt; - inc(resultCnt); - end; - - procedure DoCurve(const p1, p2, p3, p4: TPointD); - var - p12, p23, p34, p123, p234, p1234: TPointD; - begin - if ((abs(p1.x +p3.x - 2*p2.x) < tolerance) and - (abs(p2.x +p4.x - 2*p3.x) < tolerance)) and - ((abs(p1.y +p3.y - 2*p2.y) < tolerance) and - (abs(p2.y +p4.y - 2*p3.y) < tolerance)) then - begin - AddPoint(p4); - end else - begin - p12.X := (p1.X + p2.X) / 2; - p12.Y := (p1.Y + p2.Y) / 2; - p23.X := (p2.X + p3.X) / 2; - p23.Y := (p2.Y + p3.Y) / 2; - p34.X := (p3.X + p4.X) / 2; - p34.Y := (p3.Y + p4.Y) / 2; - p123.X := (p12.X + p23.X) / 2; - p123.Y := (p12.Y + p23.Y) / 2; - p234.X := (p23.X + p34.X) / 2; - p234.Y := (p23.Y + p34.Y) / 2; - p1234.X := (p123.X + p234.X) / 2; - p1234.Y := (p123.Y + p234.Y) / 2; - DoCurve(p1, p12, p123, p1234); - DoCurve(p1234, p234, p34, p4); - end; - end; - -begin - result := nil; - resultLen := 0; resultCnt := 0; - if tolerance <= 0.0 then tolerance := BezierTolerance; - AddPoint(pt1); - if ValueAlmostZero(pt1.X - pt2.X) and ValueAlmostZero(pt1.Y - pt2.Y) and - ValueAlmostZero(pt3.X - pt4.X) and ValueAlmostZero(pt3.Y - pt4.Y) then - begin - AddPoint(pt4) - end else - DoCurve(pt1, pt2, pt3, pt4); - SetLength(result,resultCnt); -end; -//------------------------------------------------------------------------------ - -function ReflectPoint(const pt, pivot: TPointD): TPointD; -begin - Result.X := pivot.X + (pivot.X - pt.X); - Result.Y := pivot.Y + (pivot.Y - pt.Y); -end; -//------------------------------------------------------------------------------ - -function FlattenCSpline(const priorCtrlPt, startPt: TPointD; - const pts: TPathD; tolerance: double = 0.0): TPathD; -var - p: TPathD; - len: integer; -begin - len := Length(pts); - SetLength(p, len + 2); - p[0] := startPt; - p[1] := ReflectPoint(priorCtrlPt, startPt); - if len > 0 then - Move(pts[0], p[2], len * SizeOf(TPointD)); - Result := FlattenCSpline(p, tolerance); -end; -//------------------------------------------------------------------------------ - -function FlattenCSpline(const pts: TPathD; tolerance: double = 0.0): TPathD; -var - resultCnt, resultLen: integer; - - procedure AddPoint(const pt: TPointD); - begin - if resultCnt = resultLen then - begin - inc(resultLen, BuffSize); - setLength(result, resultLen); - end; - result[resultCnt] := pt; - inc(resultCnt); - end; - - procedure DoCurve(const p1, p2, p3, p4: TPointD); - var - p12, p23, p34, p123, p234, p1234: TPointD; - begin - if (abs(p1.x + p3.x - 2*p2.x) + abs(p2.x + p4.x - 2*p3.x) + - abs(p1.y + p3.y - 2*p2.y) + abs(p2.y + p4.y - 2*p3.y)) < tolerance then - begin - if resultCnt = length(result) then - setLength(result, length(result) +BuffSize); - result[resultCnt] := p4; - inc(resultCnt); - end else - begin - p12.X := (p1.X + p2.X) / 2; - p12.Y := (p1.Y + p2.Y) / 2; - p23.X := (p2.X + p3.X) / 2; - p23.Y := (p2.Y + p3.Y) / 2; - p34.X := (p3.X + p4.X) / 2; - p34.Y := (p3.Y + p4.Y) / 2; - p123.X := (p12.X + p23.X) / 2; - p123.Y := (p12.Y + p23.Y) / 2; - p234.X := (p23.X + p34.X) / 2; - p234.Y := (p23.Y + p34.Y) / 2; - p1234.X := (p123.X + p234.X) / 2; - p1234.Y := (p123.Y + p234.Y) / 2; - DoCurve(p1, p12, p123, p1234); - DoCurve(p1234, p234, p34, p4); - end; - end; - -var - i, len: integer; - p: PPointD; - pt1,pt2,pt3,pt4: TPointD; -begin - result := nil; - len := Length(pts); resultLen := 0; resultCnt := 0; - if (len < 4) then Exit; - if tolerance <= 0.0 then tolerance := BezierTolerance; - //ignore incomplete trailing control points - if Odd(len) then dec(len); - p := @pts[0]; - AddPoint(p^); - pt1 := p^; inc(p); - pt2 := p^; inc(p); - for i := 0 to (len shr 1) - 2 do - begin - pt3 := p^; inc(p); - pt4 := p^; inc(p); - DoCurve(pt1, pt2, pt3, pt4); - pt1 := pt4; - pt2 := ReflectPoint(pt3, pt1); - end; - SetLength(result,resultCnt); -end; -//------------------------------------------------------------------------------ - -function FlattenQSpline(const priorCtrlPt, startPt: TPointD; - const pts: TPathD; tolerance: double = 0.0): TPathD; -var - p: TPathD; - len: integer; -begin - len := Length(pts); - SetLength(p, len + 2); - p[0] := startPt; - p[1] := ReflectPoint(priorCtrlPt, startPt); - if len > 0 then - Move(pts[0], p[2], len * SizeOf(TPointD)); - Result := FlattenQSpline(p, tolerance); -end; -//------------------------------------------------------------------------------ - -function FlattenQSpline(const pts: TPathD; tolerance: double = 0.0): TPathD; -var - resultCnt, resultLen: integer; - - procedure AddPoint(const pt: TPointD); - begin - if resultCnt = resultLen then - begin - inc(resultLen, BuffSize); - setLength(result, resultLen); - end; - result[resultCnt] := pt; - inc(resultCnt); - end; - - procedure DoCurve(const p1, p2, p3: TPointD); - var - p12, p23, p123: TPointD; - begin - if (abs(p1.x + p3.x - 2 * p2.x) + - abs(p1.y + p3.y - 2 * p2.y) < tolerance) then - begin - AddPoint(p3); - end else - begin - P12.X := (P1.X + P2.X) * 0.5; - P12.Y := (P1.Y + P2.Y) * 0.5; - P23.X := (P2.X + P3.X) * 0.5; - P23.Y := (P2.Y + P3.Y) * 0.5; - P123.X := (P12.X + P23.X) * 0.5; - P123.Y := (P12.Y + P23.Y) * 0.5; - DoCurve(p1, p12, p123); - DoCurve(p123, p23, p3); - end; - end; - -var - i, len: integer; - p: PPointD; - pt1, pt2, pt3: TPointD; -begin - result := nil; - len := Length(pts); - if (len < 3) then Exit; - resultLen := 0; - resultCnt := 0; - if tolerance <= 0.0 then tolerance := BezierTolerance; - p := @pts[0]; - AddPoint(p^); - pt1 := p^; inc(p); - pt2 := p^; inc(p); - for i := 0 to len - 3 do - begin - pt3 := p^; inc(p); - DoCurve(pt1, pt2, pt3); - pt1 := pt3; - pt2 := ReflectPoint(pt2, pt1); - end; - SetLength(result,resultCnt); -end; -//------------------------------------------------------------------------------ - -function MakePath(const pts: array of integer): TPathD; -var - i,j, x,y, len: Integer; -begin - Result := nil; - len := length(pts) div 2; - if len < 1 then Exit; - setlength(Result, len); - Result[0].X := pts[0]; - Result[0].Y := pts[1]; - j := 0; - for i := 1 to len -1 do - begin - x := pts[i*2]; - y := pts[i*2 +1]; - inc(j); - Result[j].X := x; - Result[j].Y := y; - end; - setlength(Result, j+1); -end; -//------------------------------------------------------------------------------ - -function MakePath(const pts: array of double): TPathD; -var - i, j, len: Integer; - x,y: double; -begin - Result := nil; - len := length(pts) div 2; - if len = 0 then Exit; - setlength(Result, len); - Result[0].X := pts[0]; - Result[0].Y := pts[1]; - j := 0; - for i := 1 to len -1 do - begin - x := pts[i*2]; - y := pts[i*2 +1]; - inc(j); - Result[j].X := x; - Result[j].Y := y; - end; - setlength(Result, j+1); -end; -//------------------------------------------------------------------------------ - -end. +unit Img32.Vector; + +(******************************************************************************* +* Author : Angus Johnson * +* Version : 4.2 * +* Date : 28 July 2022 * +* Website : http://www.angusj.com * +* Copyright : Angus Johnson 2019-2022 * +* * +* Purpose : Vector drawing for TImage32 * +* * +* License : Use, modification & distribution is subject to * +* Boost Software License Ver 1 * +* http://www.boost.org/LICENSE_1_0.txt * +*******************************************************************************) + +interface + +{$I Img32.inc} + +uses + SysUtils, Classes, Math, Types, Img32; + +type + TArrowStyle = (asNone, asSimple, asFancy, asDiamond, asCircle, asTail); + TJoinStyle = (jsAuto, jsSquare, jsMiter, jsRound); + TEndStyle = (esPolygon = 0, esClosed = 0, esButt, esSquare, esRound); + TPathEnd = (peStart, peEnd, peBothEnds); + TSplineType = (stQuadratic, stCubic); + TFillRule = (frEvenOdd, frNonZero, frPositive, frNegative); + TImg32FillRule = TFillRule; //useful whenever there's ambiguity with Clipper + + TSizeD = {$IFDEF RECORD_METHODS} record {$ELSE} object {$ENDIF} + cx : double; + cy : double; + function average: double; + property Width: Double read cx write cx; + property Height: Double read cy write cy; + end; + + TRectWH = {$IFDEF RECORD_METHODS} record {$ELSE} object {$ENDIF} + public + Left, Top, Width, Height: double; + function IsEmpty: Boolean; + function IsValid: Boolean; + function Right: double; + function Bottom: double; + function Contains(const Pt: TPoint): Boolean; overload; + function Contains(const Pt: TPointD): Boolean; overload; + function MidPoint: TPointD; + function RectD: TRectD; + function Rect: TRect; + end; + + function RectWH(left, top, width, height: integer): TRectWH; overload; + function RectWH(left, top, width, height: double ): TRectWH; overload; + function RectWH(const rec: TRectD): TRectWH; overload; + + //InflateRect: missing in Delphi 7 + procedure InflateRect(var rec: TRect; dx, dy: integer); overload; + procedure InflateRect(var rec: TRectD; dx, dy: double); overload; + + function NormalizeRect(var rect: TRect): Boolean; + + function PrePendPoint(const pt: TPointD; const p: TPathD): TPathD; + function PrePendPoints(const pt1, pt2: TPointD; const p: TPathD): TPathD; + + function Rectangle(const rec: TRect): TPathD; overload; + function Rectangle(const rec: TRectD): TPathD; overload; + function Rectangle(l, t, r, b: double): TPathD; overload; + + function RoundRect(const rec: TRect; radius: integer): TPathD; overload; + function RoundRect(const rec: TRectD; radius: double): TPathD; overload; + function RoundRect(const rec: TRect; radius: TPoint): TPathD; overload; + function RoundRect(const rec: TRectD; radius: TPointD): TPathD; overload; + + function Ellipse(const rec: TRect; steps: integer = 0): TPathD; overload; + function Ellipse(const rec: TRectD; steps: integer = 0): TPathD; overload; + function Ellipse(const rec: TRectD; pendingScale: double): TPathD; overload; + + function RotatedEllipse(const rec: TRectD; angle: double; steps: integer = 0): TPathD; overload; + function RotatedEllipse(const rec: TRectD; angle: double; pendingScale: double): TPathD; overload; + + function AngleToEllipticalAngle(const ellRec: TRectD; angle: double): double; + + function EllipticalAngleToAngle(const ellRec: TRectD; angle: double): double; + + function Circle(const pt: TPoint; radius: double): TPathD; overload; + function Circle(const pt: TPointD; radius: double): TPathD; overload; + function Circle(const pt: TPointD; radius: double; pendingScale: double): TPathD; overload; + + function Star(const rec: TRectD; points: integer; indentFrac: double = 0.4): TPathD; overload; + function Star(const focalPt: TPointD; + innerRadius, outerRadius: double; points: integer): TPathD; overload; + + function Arc(const rec: TRectD; + startAngle, endAngle: double; scale: double = 0): TPathD; + + function Pie(const rec: TRectD; + StartAngle, EndAngle: double; scale: double = 0): TPathD; + + function FlattenQBezier(const pt1, pt2, pt3: TPointD; + tolerance: double = 0.0): TPathD; overload; + function FlattenQBezier(const pts: TPathD; + tolerance: double = 0.0): TPathD; overload; + function FlattenQBezier(const firstPt: TPointD; const pts: TPathD; + tolerance: double = 0.0): TPathD; overload; + + function GetPointInQuadBezier(const a,b,c: TPointD; t: double): TPointD; + + function FlattenCBezier(const pt1, pt2, pt3, pt4: TPointD; + tolerance: double = 0.0): TPathD; overload; + function FlattenCBezier(const pts: TPathD; + tolerance: double = 0.0): TPathD; overload; + function FlattenCBezier(const firstPt: TPointD; const pts: TPathD; + tolerance: double = 0.0): TPathD; overload; + + function GetPointInCubicBezier(const a,b,c,d: TPointD; t: double): TPointD; + + //FlattenCSpline: Approximates the 'S' command inside the 'd' property of an + //SVG path. (See https://www.w3.org/TR/SVG/paths.html#DProperty) + function FlattenCSpline(const pts: TPathD; + tolerance: double = 0.0): TPathD; overload; + function FlattenCSpline(const priorCtrlPt, startPt: TPointD; + const pts: TPathD; tolerance: double = 0.0): TPathD; overload; + + //FlattenQSpline: Approximates the 'T' command inside the 'd' property of an + //SVG path. (See https://www.w3.org/TR/SVG/paths.html#DProperty) + function FlattenQSpline(const pts: TPathD; + tolerance: double = 0.0): TPathD; overload; + function FlattenQSpline(const priorCtrlPt, startPt: TPointD; + const pts: TPathD; tolerance: double = 0.0): TPathD; overload; + + //ArrowHead: The ctrlPt's only function is to control the angle of the arrow. + function ArrowHead(const arrowTip, ctrlPt: TPointD; size: double; + arrowStyle: TArrowStyle): TPathD; + + function GetDefaultArrowHeadSize(lineWidth: double): double; + + procedure AdjustPoint(var pt: TPointD; + const referencePt: TPointD; delta: double); + + function ShortenPath(const path: TPathD; + pathEnd: TPathEnd; amount: double): TPathD; + + //GetDashPath: Returns a polyline (not polygons) + function GetDashedPath(const path: TPathD; + closed: Boolean; const pattern: TArrayOfInteger; + patternOffset: PDouble): TPathsD; + + function GetDashedOutLine(const path: TPathD; + closed: Boolean; const pattern: TArrayOfInteger; + patternOffset: PDouble; lineWidth: double; + joinStyle: TJoinStyle; endStyle: TEndStyle): TPathsD; + + function OffsetPoint(const pt: TPoint; dx, dy: integer): TPoint; overload; + function OffsetPoint(const pt: TPointD; dx, dy: double): TPointD; overload; + + function OffsetPath(const path: TPathD; + dx, dy: double): TPathD; overload; + function OffsetPath(const paths: TPathsD; + dx, dy: double): TPathsD; overload; + function OffsetPath(const ppp: TArrayOfPathsD; + dx, dy: double): TArrayOfPathsD; overload; + + function Paths(const path: TPathD): TPathsD; + {$IFDEF INLINING} inline; {$ENDIF} + + //CopyPath: note that only dynamic string arrays are copy-on-write + function CopyPath(const path: TPathD): TPathD; + {$IFDEF INLINING} inline; {$ENDIF} + function CopyPaths(const paths: TPathsD): TPathsD; + + function ScalePoint(const pt: TPointD; scale: double): TPointD; overload; + {$IFDEF INLINING} inline; {$ENDIF} + function ScalePoint(const pt: TPointD; sx, sy: double): TPointD; overload; + {$IFDEF INLINING} inline; {$ENDIF} + function ScalePath(const path: TPathD; + sx, sy: double): TPathD; overload; + + function ScalePath(const path: TPathD; + scale: double): TPathD; overload; + function ScalePath(const paths: TPathsD; + sx, sy: double): TPathsD; overload; + function ScalePath(const paths: TPathsD; + scale: double): TPathsD; overload; + + function ScaleRect(const rec: TRect; scale: double): TRect; overload; + function ScaleRect(const rec: TRectD; scale: double): TRectD; overload; + function ScaleRect(const rec: TRect; sx, sy: double): TRect; overload; + function ScaleRect(const rec: TRectD; sx, sy: double): TRectD; overload; + + function ReversePath(const path: TPathD): TPathD; overload; + function ReversePath(const paths: TPathsD): TPathsD; overload; + + function OpenPathToFlatPolygon(const path: TPathD): TPathD; + + procedure AppendPoint(var path: TPathD; const extra: TPointD); + + procedure AppendPath(var path: TPathD; const pt: TPointD); overload; + procedure AppendPath(var path1: TPathD; const path2: TPathD); overload; + procedure AppendPath(var paths: TPathsD; const extra: TPathD); overload; + procedure AppendPath(var paths: TPathsD; const extra: TPathsD); overload; + procedure AppendPath(var ppp: TArrayOfPathsD; const extra: TPathsD); overload; + + function GetAngle(const origin, pt: TPoint): double; overload; + function GetAngle(const origin, pt: TPointD): double; overload; + function GetAngle(const a, b, c: TPoint): double; overload; + function GetAngle(const a, b, c: TPointD): double; overload; + + procedure GetSinCos(angle: double; out sinA, cosA: double); + + function GetPointAtAngleAndDist(const origin: TPointD; + angle, distance: double): TPointD; + + function IntersectPoint(const ln1a, ln1b, ln2a, ln2b: TPointD): TPointD; overload; + function IntersectPoint(const ln1a, ln1b, ln2a, ln2b: TPointD; out ip: TPointD): Boolean; overload; + + function SegmentIntersectPt(const ln1a, ln1b, ln2a, ln2b: TPointD): TPointD; + function SegmentsIntersect(const ln1a, ln1b, ln2a, ln2b: TPointD; + out ip: TPointD): Boolean; + + procedure RotatePoint(var pt: TPointD; + const focalPoint: TPointD; sinA, cosA: double); overload; + procedure RotatePoint(var pt: TPointD; + const focalPoint: TPointD; angleRad: double); overload; + + function RotatePath(const path: TPathD; + const focalPoint: TPointD; angleRads: double): TPathD; overload; + function RotatePath(const paths: TPathsD; + const focalPoint: TPointD; angleRads: double): TPathsD; overload; + + //function MakePath(const pts: array of integer): TPathD; overload; + function MakePath(const pts: array of double): TPathD; overload; + + function GetBounds(const path: TPathD): TRect; overload; + function GetBounds(const paths: TPathsD): TRect; overload; + + function GetBoundsD(const path: TPathD): TRectD; overload; + function GetBoundsD(const paths: TPathsD): TRectD; overload; + + function GetRotatedRectBounds(const rec: TRect; angle: double): TRect; overload; + function GetRotatedRectBounds(const rec: TRectD; angle: double): TRectD; overload; + + function Rect(const recD: TRectD): TRect; overload; + function Rect(const left,top,right,bottom: integer): TRect; overload; + + function PtInRect(const rec: TRectD; const pt: TPointD): Boolean; overload; + + function Size(cx, cy: integer): TSize; + function SizeD(cx, cy: double): TSizeD; + + function IsClockwise(const path: TPathD): Boolean; + + function Area(const path: TPathD): Double; overload; + + function RectsEqual(const rec1, rec2: TRect): Boolean; + + procedure OffsetRect(var rec: TRectD; dx, dy: double); overload; + + function MakeSquare(rec: TRect): TRect; + + function IsValid(value: integer): Boolean; overload; + function IsValid(value: double): Boolean; overload; + function IsValid(const pt: TPoint): Boolean; overload; + function IsValid(const pt: TPointD): Boolean; overload; + function IsValid(const rec: TRect): Boolean; overload; + + function Point(X,Y: Integer): TPoint; overload; + function Point(const pt: TPointD): TPoint; overload; + + function PointsEqual(const pt1, pt2: TPointD): Boolean; overload; + {$IFDEF INLINING} inline; {$ENDIF} + + function PointsNearEqual(const pt1, pt2: TPoint; + dist: integer): Boolean; overload; + function PointsNearEqual(const pt1, pt2: TPointD; + distSqrd: double): Boolean; overload; + {$IFDEF INLINING} inline; {$ENDIF} + + function StripNearDuplicates(const path: TPathD; + minDist: double; isClosedPath: Boolean): TPathD; overload; + function StripNearDuplicates(const paths: TPathsD; + minLength: double; isClosedPaths: Boolean): TPathsD; overload; + + function MidPoint(const rec: TRect): TPoint; overload; + function MidPoint(const rec: TRectD): TPointD; overload; + function MidPoint(const pt1, pt2: TPoint): TPoint; overload; + function MidPoint(const pt1, pt2: TPointD): TPointD; overload; + + function Average(val1, val2: integer): integer; overload; + function Average(val1, val2: double): double; overload; + + function ReflectPoint(const pt, pivot: TPointD): TPointD; + {$IFDEF INLINING} inline; {$ENDIF} + + function RectsOverlap(const rec1, rec2: TRect): Boolean; + + function IsSameRect(const rec1, rec2: TRect): Boolean; + + function RectsIntersect(const rec1, rec2: TRect): Boolean; overload; + function RectsIntersect(const rec1, rec2: TRectD): Boolean; overload; + function IntersectRect(const rec1, rec2: TRectD): TRectD; overload; + + //UnionRect: this behaves differently to types.UnionRect + //in that if either parameter is empty the other parameter is returned + function UnionRect(const rec1, rec2: TRect): TRect; overload; + function UnionRect(const rec1, rec2: TRectD): TRectD; overload; + + //these 2 functions are only needed to support older versions of Delphi + function MakeArrayOfInteger(const ints: array of integer): TArrayOfInteger; + function MakeArrayOfDouble(const doubles: array of double): TArrayOfDouble; + + function CrossProduct(const vector1, vector2: TPointD): double; overload; + {$IFDEF INLINING} inline; {$ENDIF} + function CrossProduct(const pt1, pt2, pt3: TPointD): double; overload; + {$IFDEF INLINING} inline; {$ENDIF} + function CrossProduct(const pt1, pt2, pt3, pt4: TPointD): double; overload; + {$IFDEF INLINING} inline; {$ENDIF} + + function DotProduct(const vector1, vector2: TPointD): double; overload; + {$IFDEF INLINING} inline; {$ENDIF} + function DotProduct(const pt1, pt2, pt3: TPointD): double; overload; + {$IFDEF INLINING} inline; {$ENDIF} + + function TurnsLeft(const pt1, pt2, pt3: TPointD): boolean; + {$IFDEF INLINING} inline; {$ENDIF} + function TurnsRight(const pt1, pt2, pt3: TPointD): boolean; + {$IFDEF INLINING} inline; {$ENDIF} + + function IsPathConvex(const path: TPathD): Boolean; + + function NormalizeVector(const vec: TPointD): TPointD; + {$IFDEF INLINING} inline; {$ENDIF} + + //GetUnitVector: Used internally + function GetUnitVector(const pt1, pt2: TPointD): TPointD; + + //GetUnitNormal: Used internally + function GetUnitNormal(const pt1, pt2: TPointD): TPointD; + function GetAvgUnitVector(const vec1, vec2: TPointD): TPointD; + {$IFDEF INLINING} inline; {$ENDIF} + + //GetVectors: Used internally + function GetVectors(const path: TPathD): TPathD; + //GetNormals: Used internally + + function GetNormals(const path: TPathD): TPathD; + + //DistanceSqrd: Used internally + function DistanceSqrd(const pt1, pt2: TPoint): double; overload; + {$IFDEF INLINE} inline; {$ENDIF} + //DistanceSqrd: Used internally + function DistanceSqrd(const pt1, pt2: TPointD): double; overload; + {$IFDEF INLINE} inline; {$ENDIF} + + function Distance(const pt1, pt2: TPoint): double; overload; + {$IFDEF INLINE} inline; {$ENDIF} + function Distance(const pt1, pt2: TPointD): double; overload; + {$IFDEF INLINE} inline; {$ENDIF} + function Distance(const path: TPathD; stopAt: integer = 0): double; overload; + + function GetDistances(const path: TPathD): TArrayOfDouble; + + function GetCumulativeDistances(const path: TPathD): TArrayOfDouble; + + function PerpendicularDistSqrd(const pt, line1, line2: TPointD): double; + + function PointInPolygon(const pt: TPointD; + const polygon: TPathD; fillRule: TFillRule): Boolean; + + function PointInPolygons(const pt: TPointD; + const polygons: TPathsD; fillRule: TFillRule): Boolean; + + function PerpendicularDist(const pt, line1, line2: TPointD): double; + + function ClosestPointOnLine(const pt, linePt1, linePt2: TPointD): TPointD; + + function ClosestPointOnSegment(const pt, segPt1, segPt2: TPointD): TPointD; + + function IsPointInEllipse(const ellipseRec: TRect; const pt: TPoint): Boolean; + + //GetIntersectsEllipseAndLine: Gets the intersection of an ellipse and + //a line. The function result = true when the line either touches + //tangentially or passes through the ellipse. If the line touches + //tangentially, the coordintates returned in pt1 and pt2 will match. + function GetLineEllipseIntersects(const ellipseRec: TRect; + var linePt1, linePt2: TPointD): Boolean; + + function GetPtOnEllipseFromAngle(const ellipseRect: TRectD; angle: double): TPointD; + + function GetPtOnRotatedEllipseFromAngle(const ellipseRect: TRectD; + ellipseRotAngle, angle: double): TPointD; + + function GetEllipticalAngleFromPoint(const ellipseRect: TRectD; + const pt: TPointD): double; + + function GetRotatedEllipticalAngleFromPoint(const ellipseRect: TRectD; + ellipseRotAngle: double; pt: TPointD): double; + + function GetClosestPtOnRotatedEllipse(const ellipseRect: TRectD; + ellipseRotation: double; const pt: TPointD): TPointD; + + function Outline(const line: TPathD; lineWidth: double; + joinStyle: TJoinStyle; endStyle: TEndStyle; + miterLimOrRndScale: double = 0): TPathsD; overload; + function Outline(const lines: TPathsD; lineWidth: double; + joinStyle: TJoinStyle; endStyle: TEndStyle; + miterLimOrRndScale: double = 0): TPathsD; overload; + + //Grow: Offsets path by 'delta' (positive is away from the left of the path). + //With a positive delta, clockwise paths will expand and counter-clockwise + //ones will contract. The reverse happens with negative deltas. + function Grow(const path, normals: TPathD; delta: double; joinStyle: TJoinStyle; + miterLimOrRndScale: double; isOpen: Boolean = false): TPathD; + + function ValueAlmostZero(val: double; epsilon: double = 0.001): Boolean; + function ValueAlmostOne(val: double; epsilon: double = 0.001): Boolean; +const + Invalid = -MaxInt; + InvalidD = -Infinity; + NullPoint : TPoint = (X: 0; Y: 0); + NullPointD : TPointD = (X: 0; Y: 0); + InvalidPoint : TPoint = (X: -MaxInt; Y: -MaxInt); + InvalidPointD : TPointD = (X: -Infinity; Y: -Infinity); + NullRect : TRect = (left: 0; top: 0; right: 0; Bottom: 0); + NullRectD : TRectD = (left: 0; top: 0; right: 0; Bottom: 0); + InvalidRect : TRect = (left: MaxInt; top: MaxInt; right: 0; Bottom: 0); + BezierTolerance: double = 0.25; +var + //AutoWidthThreshold: When JoinStyle = jsAuto, this is the threshold at + //which line joins will be rounded instead of squared. With wider strokes, + //rounded joins generally look better, but as rounding is more complex it + //also requries more processing and hence is slower to execute. + AutoWidthThreshold: double = 5.0; + //When lines are too narrow, they become too faint to sensibly draw + MinStrokeWidth: double = 0.5; + //Miter limit avoids excessive spikes when line offsetting + DefaultMiterLimit: double = 4.0; + +resourcestring + rsInvalidMatrix = 'Invalid matrix.'; //nb: always start with IdentityMatrix + +implementation + +resourcestring + rsInvalidQBezier = 'Invalid number of control points for a QBezier'; + rsInvalidCBezier = 'Invalid number of control points for a CBezier'; + +const + BuffSize = 64; + +//------------------------------------------------------------------------------ +// TSizeD +//------------------------------------------------------------------------------ + +function TSizeD.average: double; +begin + Result := (cx + cy) * 0.5; +end; + +//------------------------------------------------------------------------------ +// TRectWH record/object. +//------------------------------------------------------------------------------ + +function TRectWH.IsEmpty: Boolean; +begin + Result := (Width <= 0) or (Height <= 0); +end; +//------------------------------------------------------------------------------ + +function TRectWH.IsValid: Boolean; +begin + Result := (Left <> InvalidD) and (Top <> InvalidD) + and (Width >= 0) and (Height >= 0); +end; +//------------------------------------------------------------------------------ + +function TRectWH.Right: double; +begin + Result := Left + Width; +end; +//------------------------------------------------------------------------------ + +function TRectWH.Bottom: double; +begin + Result := Top + Height; +end; +//------------------------------------------------------------------------------ + +function TRectWH.Contains(const Pt: TPoint): Boolean; +begin + Result := (pt.X >= Left) and (pt.X <= Left + Width) and + (pt.Y >= Top) and (pt.Y <= Top + Height) +end; +//------------------------------------------------------------------------------ + +function TRectWH.Contains(const Pt: TPointD): Boolean; +begin + Result := (pt.X >= Left) and (pt.X <= Left + Width) and + (pt.Y >= Top) and (pt.Y <= Top + Height) +end; +//------------------------------------------------------------------------------ + +function TRectWH.MidPoint: TPointD; +begin + Result := PointD(left + Width * 0.5, top + Height * 0.5); +end; +//------------------------------------------------------------------------------ + +function TRectWH.RectD: TRectD; +begin + Result := Img32.RectD(left, top, left + Width, top + Height); +end; +//------------------------------------------------------------------------------ + +function TRectWH.Rect: TRect; +begin + Result := Img32.Vector.Rect(RectD); +end; +//------------------------------------------------------------------------------ + +function RectWH(left, top, width, height: integer): TRectWH; +begin + Result.Left := left; + Result.Top := top; + Result.Width := width; + Result.Height := height; +end; +//------------------------------------------------------------------------------ + +function RectWH(left, top, width, height: double): TRectWH; +begin + Result.Left := left; + Result.Top := top; + Result.Width := width; + Result.Height := height; +end; +//------------------------------------------------------------------------------ + +function RectWH(const rec: TRectD): TRectWH; +begin + Result.Left := rec.left; + Result.Top := rec.top; + Result.Width := rec.width; + Result.Height := rec.height; +end; +//------------------------------------------------------------------------------ + +function RectsEqual(const rec1, rec2: TRect): Boolean; +begin + result := (rec1.Left = rec2.Left) and (rec1.Top = rec2.Top) and + (rec1.Right = rec2.Right) and (rec1.Bottom = rec2.Bottom); +end; +//------------------------------------------------------------------------------ + +function Rect(const left, top, right, bottom: integer): TRect; +begin + Result.Left := left; + Result.Top := top; + Result.Right := right; + Result.Bottom := bottom; +end; +//------------------------------------------------------------------------------ + +function IsValid(value: integer): Boolean; +begin + Result := value <> -MaxInt; +end; +//------------------------------------------------------------------------------ + +function IsValid(value: double): Boolean; +begin + Result := value <> InvalidD; +end; +//------------------------------------------------------------------------------ + +function IsValid(const pt: TPoint): Boolean; +begin + result := (pt.X <> Invalid) and (pt.Y <> Invalid); +end; +//------------------------------------------------------------------------------ + +function IsValid(const pt: TPointD): Boolean; +begin + result := (pt.X <> -Infinity) and (pt.Y <> -Infinity); +end; +//------------------------------------------------------------------------------ + +function IsValid(const rec: TRect): Boolean; +begin + result := (rec.Left <> MaxInt) and (rec.Top <> MaxInt); +end; +//------------------------------------------------------------------------------ + +function Point(X,Y: Integer): TPoint; +begin + result.X := X; + result.Y := Y; +end; +//------------------------------------------------------------------------------ + +function Point(const pt: TPointD): TPoint; +begin + result.X := Round(pt.x); + result.Y := Round(pt.y); +end; +//------------------------------------------------------------------------------ + +function PointsEqual(const pt1, pt2: TPointD): Boolean; +begin + result := (pt1.X = pt2.X) and (pt1.Y = pt2.Y); +end; +//------------------------------------------------------------------------------ + +function PointsNearEqual(const pt1, pt2: TPoint; dist: integer): Boolean; +begin + Result := (Abs(pt1.X - pt2.X) <= dist) and (Abs(pt1.Y - pt2.Y) < dist); +end; +//------------------------------------------------------------------------------ + +function PointsNearEqual(const pt1, pt2: TPointD; distSqrd: double): Boolean; +begin + Result := Sqr(pt1.X - pt2.X) + Sqr(pt1.Y - pt2.Y) < distSqrd; +end; +//------------------------------------------------------------------------------ + +function StripNearDuplicates(const path: TPathD; + minDist: double; isClosedPath: Boolean): TPathD; +var + i,j, len: integer; +begin + len := length(path); + SetLength(Result, len); + if len = 0 then Exit; + Result[0] := path[0]; + j := 0; + minDist := minDist * minDist; + for i := 1 to len -1 do + if not PointsNearEqual(Result[j], path[i], minDist) then + begin + inc(j); + Result[j] := path[i]; + end; + if isClosedPath and + PointsNearEqual(Result[j], Result[0], minDist) then dec(j); + SetLength(Result, j +1); +end; +//------------------------------------------------------------------------------ + +function StripNearDuplicates(const paths: TPathsD; + minLength: double; isClosedPaths: Boolean): TPathsD; +var + i, len: integer; +begin + len := Length(paths); + SetLength(Result, len); + for i := 0 to len -1 do + Result[i] := StripNearDuplicates(paths[i], minLength, isClosedPaths); +end; +//------------------------------------------------------------------------------ + +function ValueAlmostZero(val: double; epsilon: double = 0.001): Boolean; + {$IFDEF INLINE} inline; {$ENDIF} +begin + Result := Abs(val) < epsilon; +end; +//------------------------------------------------------------------------------ + +function ValueAlmostOne(val: double; epsilon: double = 0.001): Boolean; + {$IFDEF INLINE} inline; {$ENDIF} +begin + Result := Abs(val-1) < epsilon; +end; +//------------------------------------------------------------------------------ + +procedure GetSinCos(angle: double; out sinA, cosA: double); +{$IFDEF INLINE} inline; {$ENDIF} +{$IFNDEF FPC} +var s, c: extended; +{$ENDIF} +begin +{$IFDEF FPC} + Math.SinCos(angle, sinA, cosA); +{$ELSE} + Math.SinCos(angle, s, c); + sinA := s; cosA := c; +{$ENDIF} +end; +//------------------------------------------------------------------------------ + +function GetRotatedRectBounds(const rec: TRect; angle: double): TRect; +var + sinA, cosA: double; + w,h, recW, recH: integer; + mp: TPoint; +begin + NormalizeAngle(angle); + if angle <> 0 then + begin + GetSinCos(angle, sinA, cosA); //the sign of the angle isn't important + sinA := Abs(sinA); cosA := Abs(cosA); + RectWidthHeight(rec, recW, recH); + w := Ceil((recW *cosA + recH *sinA) /2); + h := Ceil((recW *sinA + recH *cosA) /2); + mp := MidPoint(rec); + Result := Rect(mp.X - w, mp.Y - h, mp.X + w, mp.Y +h); + end + else + Result := rec; +end; +//------------------------------------------------------------------------------ + +function GetRotatedRectBounds(const rec: TRectD; angle: double): TRectD; +var + sinA, cosA: double; + w,h: double; + mp: TPointD; +begin + NormalizeAngle(angle); + if angle <> 0 then + begin + GetSinCos(angle, sinA, cosA); //the sign of the angle isn't important + sinA := Abs(sinA); cosA := Abs(cosA); + w := (rec.Width *cosA + rec.Height *sinA) /2; + h := (rec.Width *sinA + rec.Height *cosA) /2; + mp := rec.MidPoint; + Result := RectD(mp.X - w, mp.Y - h, mp.X + w, mp.Y +h); + end + else + Result := rec; +end; +//------------------------------------------------------------------------------ + + +function Rect(const recD: TRectD): TRect; +begin + Result.Left := Floor(recD.Left); + Result.Top := Floor(recD.Top); + Result.Right := Ceil(recD.Right); + Result.Bottom := Ceil(recD.Bottom); +end; +//------------------------------------------------------------------------------ + +function PtInRect(const rec: TRectD; const pt: TPointD): Boolean; +begin + Result := (pt.X >= rec.Left) and (pt.X < rec.Right) and + (pt.Y >= rec.Top) and (pt.Y < rec.Bottom); +end; +//------------------------------------------------------------------------------ + +function Size(cx, cy: integer): TSize; +begin + Result.cx := cx; + Result.cy := cy; +end; +//------------------------------------------------------------------------------ + +function SizeD(cx, cy: double): TSizeD; +begin + Result.cx := cx; + Result.cy := cy; +end; +//------------------------------------------------------------------------------ + +function IsClockwise(const path: TPathD): Boolean; +begin + Result := Area(path) > 0; +end; +//------------------------------------------------------------------------------ + +function Area(const path: TPathD): Double; +var + i, j, highI: Integer; + d: Double; +begin + Result := 0.0; + highI := High(path); + if (highI < 2) then Exit; + j := highI; + for i := 0 to highI do + begin + d := (path[j].X + path[i].X); + Result := Result + d * (path[j].Y - path[i].Y); + j := i; + end; + Result := -Result * 0.5; +end; +//------------------------------------------------------------------------------ + +procedure OffsetRect(var rec: TRectD; dx, dy: double); +begin + rec.Left := rec.Left + dx; + rec.Top := rec.Top + dy; + rec.Right := rec.Right + dx; + rec.Bottom := rec.Bottom + dy; +end; +//------------------------------------------------------------------------------ + +function MakeSquare(rec: TRect): TRect; +var + i: integer; +begin + Result := rec; + i := ((rec.Right - rec.Left) + (rec.Bottom - rec.Top)) div 2; + Result.Right := Result.Left + i; + Result.Bottom := Result.Top + i; +end; +//------------------------------------------------------------------------------ + +function MidPoint(const rec: TRect): TPoint; +begin + Result.X := (rec.Left + rec.Right) div 2; + Result.Y := (rec.Top + rec.Bottom) div 2; +end; +//------------------------------------------------------------------------------ + +function MidPoint(const rec: TRectD): TPointD; +begin + Result.X := (rec.Left + rec.Right) * 0.5; + Result.Y := (rec.Top + rec.Bottom) * 0.5; +end; +//------------------------------------------------------------------------------ + +function MidPoint(const pt1, pt2: TPoint): TPoint; +begin + Result.X := (pt1.X + pt2.X) div 2; + Result.Y := (pt1.Y + pt2.Y) div 2; +end; +//------------------------------------------------------------------------------ + +function MidPoint(const pt1, pt2: TPointD): TPointD; +begin + Result.X := (pt1.X + pt2.X) * 0.5; + Result.Y := (pt1.Y + pt2.Y) * 0.5; +end; +//------------------------------------------------------------------------------ + +function Average(val1, val2: integer): integer; +begin + Result := (val1 + val2) div 2; +end; +//------------------------------------------------------------------------------ + +function Average(val1, val2: double): double; +begin + Result := (val1 + val2) * 0.5; +end; +//------------------------------------------------------------------------------ + +function RectsOverlap(const rec1, rec2: TRect): Boolean; +begin + Result := (rec1.Left < rec2.Right) and (rec1.Right > rec2.Left) and + (rec1.Top < rec2.Bottom) and (rec1.Bottom > rec2.Top); +end; +//------------------------------------------------------------------------------ + +function IsSameRect(const rec1, rec2: TRect): Boolean; +begin + Result := (rec1.Left = rec2.Left) and (rec1.Top = rec2.Top) and + (rec1.Right = rec2.Right) and (rec1.Bottom = rec2.Bottom); +end; +//------------------------------------------------------------------------------ + +function RectsIntersect(const rec1, rec2: TRect): Boolean; +var + dummy: TRect; +begin + Result := Types.IntersectRect(dummy, rec1, rec2); +end; +//------------------------------------------------------------------------------ + +function RectsIntersect(const rec1, rec2: TRectD): Boolean; +begin + Result := not IntersectRect(rec1, rec2).IsEmpty; +end; +//------------------------------------------------------------------------------ + +function IntersectRect(const rec1, rec2: TRectD): TRectD; +begin + result.Left := Max(rec1.Left, rec2.Left); + result.Top := Max(rec1.Top, rec2.Top); + result.Right := Min(rec1.Right, rec2.Right); + result.Bottom := Min(rec1.Bottom, rec2.Bottom); +end; +//------------------------------------------------------------------------------ + +function UnionRect(const rec1, rec2: TRect): TRect; +begin + if IsEmptyRect(rec1) then + Result := rec2 + else if IsEmptyRect(rec2) then + Result := rec1 + else + begin + result.Left := Min(rec1.Left, rec2.Left); + result.Top := Min(rec1.Top, rec2.Top); + result.Right := Max(rec1.Right, rec2.Right); + result.Bottom := Max(rec1.Bottom, rec2.Bottom); + end; +end; +//------------------------------------------------------------------------------ + +function UnionRect(const rec1, rec2: TRectD): TRectD; +begin + if IsEmptyRect(rec1) then + Result := rec2 + else if IsEmptyRect(rec2) then + Result := rec1 + else + begin + result.Left := Min(rec1.Left, rec2.Left); + result.Top := Min(rec1.Top, rec2.Top); + result.Right := Max(rec1.Right, rec2.Right); + result.Bottom := Max(rec1.Bottom, rec2.Bottom); + end; +end; +//------------------------------------------------------------------------------ + +function MakeArrayOfInteger(const ints: array of integer): TArrayOfInteger; +var + i, len: integer; +begin + len := Length(ints); + SetLength(Result, len); + for i := 0 to len -1 do Result[i] := ints[i]; +end; +//------------------------------------------------------------------------------ + +function MakeArrayOfDouble(const doubles: array of double): TArrayOfDouble; +var + i, len: integer; +begin + len := Length(doubles); + SetLength(Result, len); + for i := 0 to len -1 do Result[i] := doubles[i]; +end; +//------------------------------------------------------------------------------ + +function CrossProduct(const vector1, vector2: TPointD): double; +begin + result := vector1.X * vector2.Y - vector2.X * vector1.Y; +end; +//------------------------------------------------------------------------------ + +function CrossProduct(const pt1, pt2, pt3: TPointD): double; +var + x1,x2,y1,y2: double; +begin + x1 := pt2.X - pt1.X; + y1 := pt2.Y - pt1.Y; + x2 := pt3.X - pt2.X; + y2 := pt3.Y - pt2.Y; + result := (x1 * y2 - y1 * x2); +end; +//--------------------------------------------------------------------------- + +function CrossProduct(const pt1, pt2, pt3, pt4: TPointD): double; +var + x1,x2,y1,y2: double; +begin + x1 := pt2.X - pt1.X; + y1 := pt2.Y - pt1.Y; + x2 := pt4.X - pt3.X; + y2 := pt4.Y - pt3.Y; + result := (x1 * y2 - y1 * x2); +end; +//--------------------------------------------------------------------------- + +function DotProduct(const vector1, vector2: TPointD): double; +begin + result := vector1.X * vector2.X + vector1.Y * vector2.Y; +end; +//------------------------------------------------------------------------------ + +function DotProduct(const pt1, pt2, pt3: TPointD): double; +var + x1,x2,y1,y2: double; +begin + x1 := pt2.X - pt1.X; + y1 := pt2.Y - pt1.Y; + x2 := pt2.X - pt3.X; + y2 := pt2.Y - pt3.Y; + result := (x1 * x2 + y1 * y2); +end; +//------------------------------------------------------------------------------ + +function TurnsLeft(const pt1, pt2, pt3: TPointD): boolean; +begin + result := CrossProduct(pt1, pt2, pt3) < 0; +end; +//------------------------------------------------------------------------------ + +function TurnsRight(const pt1, pt2, pt3: TPointD): boolean; +begin + result := CrossProduct(pt1, pt2, pt3) > 0; +end; +//------------------------------------------------------------------------------ + +function IsPathConvex(const path: TPathD): Boolean; +var + i, pathLen: integer; + dir: boolean; +begin + result := false; + pathLen := length(path); + if pathLen < 3 then Exit; + //get the winding direction of the first angle + dir := TurnsRight(path[0], path[1], path[2]); + //check that each other angle has the same winding direction + for i := 1 to pathLen -1 do + if TurnsRight(path[i], path[(i+1) mod pathLen], + path[(i+2) mod pathLen]) <> dir then Exit; + result := true; +end; +//------------------------------------------------------------------------------ + +function GetUnitVector(const pt1, pt2: TPointD): TPointD; +var + dx, dy, inverseHypot: Double; +begin + if (pt1.x = pt2.x) and (pt1.y = pt2.y) then + begin + Result.X := 0; + Result.Y := 0; + Exit; + end; + dx := (pt2.X - pt1.X); + dy := (pt2.Y - pt1.Y); + inverseHypot := 1 / Hypot(dx, dy); + dx := dx * inverseHypot; + dy := dy * inverseHypot; + Result.X := dx; + Result.Y := dy; +end; +//------------------------------------------------------------------------------ + +function GetUnitNormal(const pt1, pt2: TPointD): TPointD; +var + dx, dy, inverseHypot: Double; +begin + if PointsNearEqual(pt1, pt2, 0.001) then + begin + Result := NullPointD; + Exit; + end; + dx := (pt2.X - pt1.X); + dy := (pt2.Y - pt1.Y); + inverseHypot := 1 / Hypot(dx, dy); + dx := dx * inverseHypot; + dy := dy * inverseHypot; + Result.X := dy; + Result.Y := -dx +end; +//------------------------------------------------------------------------------ + +function NormalizeVector(const vec: TPointD): TPointD; +var + h, inverseHypot: Double; +begin + h := Hypot(vec.X, vec.Y); + if ValueAlmostZero(h, 0.001) then + begin + Result := NullPointD; + Exit; + end; + inverseHypot := 1 / h; + Result.X := vec.X * inverseHypot; + Result.Y := vec.Y * inverseHypot; +end; +//------------------------------------------------------------------------------ + +function GetAvgUnitVector(const vec1, vec2: TPointD): TPointD; +begin + Result := NormalizeVector(PointD(vec1.X + vec2.X, vec1.Y + vec2.Y)); +end; +//------------------------------------------------------------------------------ + +function Paths(const path: TPathD): TPathsD; +begin + SetLength(Result, 1); + result[0] := Copy(path, 0, length(path)); +end; +//------------------------------------------------------------------------------ + +function CopyPath(const path: TPathD): TPathD; +begin + Result := Copy(path, 0, Length(path)); +end; +//------------------------------------------------------------------------------ + +function CopyPaths(const paths: TPathsD): TPathsD; +var + i, len1: integer; +begin + len1 := length(paths); + setLength(result, len1); + for i := 0 to len1 -1 do + result[i] := Copy(paths[i], 0, length(paths[i])); +end; +//------------------------------------------------------------------------------ + +function OffsetPoint(const pt: TPoint; dx, dy: integer): TPoint; +begin + result.x := pt.x + dx; + result.y := pt.y + dy; +end; +//------------------------------------------------------------------------------ + +function OffsetPoint(const pt: TPointD; dx, dy: double): TPointD; +begin + result.x := pt.x + dx; + result.y := pt.y + dy; +end; +//------------------------------------------------------------------------------ + +function OffsetPath(const path: TPathD; dx, dy: double): TPathD; +var + i, len: integer; +begin + len := length(path); + setLength(result, len); + for i := 0 to len -1 do + begin + result[i].x := path[i].x + dx; + result[i].y := path[i].y + dy; + end; +end; +//------------------------------------------------------------------------------ + +function OffsetPath(const paths: TPathsD; + dx, dy: double): TPathsD; +var + i,len: integer; +begin + len := length(paths); + setLength(result, len); + for i := 0 to len -1 do + result[i] := OffsetPath(paths[i], dx, dy); +end; +//------------------------------------------------------------------------------ + +function OffsetPath(const ppp: TArrayOfPathsD; dx, dy: double): TArrayOfPathsD; +var + i,len: integer; +begin + len := length(ppp); + setLength(result, len); + for i := 0 to len -1 do + result[i] := OffsetPath(ppp[i], dx, dy); +end; +//------------------------------------------------------------------------------ + +function ScalePoint(const pt: TPointD; scale: double): TPointD; +begin + Result.X := pt.X * scale; + Result.Y := pt.Y * scale; +end; +//------------------------------------------------------------------------------ + +function ScalePoint(const pt: TPointD; sx, sy: double): TPointD; +begin + Result.X := pt.X * sx; + Result.Y := pt.Y * sy; +end; +//------------------------------------------------------------------------------ + +function ScalePath(const path: TPathD; sx, sy: double): TPathD; +var + i, len: integer; +begin + if (sx = 0) or (sy = 0) then + Result := nil + else if ((sx = 1) and (sy = 1)) then + begin + Result := Copy(path, 0, Length(path)); + end else + begin + len := length(path); + setLength(result, len); + for i := 0 to len -1 do + begin + result[i].x := path[i].x * sx; + result[i].y := path[i].y * sy; + end; + end; +end; +//------------------------------------------------------------------------------ + +function ScalePath(const path: TPathD; + scale: double): TPathD; +begin + result := ScalePath(path, scale, scale); +end; +//------------------------------------------------------------------------------ + +function ScalePath(const paths: TPathsD; + sx, sy: double): TPathsD; +var + i,len: integer; +begin + len := length(paths); + setLength(result, len); + for i := 0 to len -1 do + result[i] := ScalePath(paths[i], sx, sy); +end; +//------------------------------------------------------------------------------ + +function ScalePath(const paths: TPathsD; + scale: double): TPathsD; +begin + result := ScalePath(paths, scale, scale); +end; +//------------------------------------------------------------------------------ + +function ScaleRect(const rec: TRect; scale: double): TRect; +begin + result := rec; + Result.Left := Round(Result.Left * scale); + Result.Top := Round(Result.Top * scale); + Result.Right := Round(Result.Right * scale); + Result.Bottom := Round(Result.Bottom * scale); +end; +//------------------------------------------------------------------------------ + +function ScaleRect(const rec: TRect; sx, sy: double): TRect; +begin + result := rec; + Result.Left := Round(Result.Left * sx); + Result.Top := Round(Result.Top * sy); + Result.Right := Round(Result.Right * sx); + Result.Bottom := Round(Result.Bottom * sy); +end; +//------------------------------------------------------------------------------ + +function ScaleRect(const rec: TRectD; scale: double): TRectD; +begin + result := rec; + Result.Left := Result.Left * scale; + Result.Top := Result.Top * scale; + Result.Right := Result.Right * scale; + Result.Bottom := Result.Bottom * scale; +end; +//------------------------------------------------------------------------------ + +function ScaleRect(const rec: TRectD; sx, sy: double): TRectD; +begin + result := rec; + Result.Left := Result.Left * sx; + Result.Top := Result.Top * sy; + Result.Right := Result.Right * sx; + Result.Bottom := Result.Bottom * sy; +end; +//------------------------------------------------------------------------------ + +function ReversePath(const path: TPathD): TPathD; +var + i, highI: integer; +begin + highI := High(path); + SetLength(result, highI +1); + for i := 0 to highI do + result[i] := path[highI -i]; +end; +//------------------------------------------------------------------------------ + +function ReversePath(const paths: TPathsD): TPathsD; +var + i, len: integer; +begin + len := Length(paths); + SetLength(result, len); + for i := 0 to len -1 do + result[i] := ReversePath(paths[i]); +end; +//------------------------------------------------------------------------------ + +function OpenPathToFlatPolygon(const path: TPathD): TPathD; +var + i, len, len2: integer; +begin + len := Length(path); + len2 := Max(0, len - 2); + setLength(Result, len + len2); + if len = 0 then Exit; + Move(path[0], Result[0], len * SizeOf(TPointD)); + if len2 = 0 then Exit; + for i := 0 to len - 3 do + result[len + i] := path[len - 2 -i]; +end; +//------------------------------------------------------------------------------ + +function GetVectors(const path: TPathD): TPathD; +var + i,j, len: cardinal; + pt: TPointD; +begin + len := length(path); + setLength(result, len); + if len = 0 then Exit; + pt := path[0]; + //skip duplicates + i := len -1; + while (i > 0) and + (path[i].X = pt.X) and (path[i].Y = pt.Y) do dec(i); + if (i = 0) then + begin + //all points are equal! + for i := 0 to len -1 do result[i] := PointD(0,0); + Exit; + end; + result[i] := GetUnitVector(path[i], pt); + //fix up any duplicates at the end of the path + for j := i +1 to len -1 do + result[j] := result[j-1]; + //with at least one valid vector, we can now + //safely get the remaining vectors + pt := path[i]; + for i := i -1 downto 0 do + begin + if (path[i].X <> pt.X) or (path[i].Y <> pt.Y) then + begin + result[i] := GetUnitVector(path[i], pt); + pt := path[i]; + end else + result[i] := result[i+1] + end; +end; +//------------------------------------------------------------------------------ + +function GetNormals(const path: TPathD): TPathD; +var + i,highI,j, len: cardinal; + pt: TPointD; +begin + len := length(path); + setLength(result, len); + if len = 0 then Exit; + pt := path[0]; + //watch out for, and fix up duplicates at end of line + highI := len -1; + while (highI > 0) and PointsNearEqual(path[highI], pt, 0.001) do dec(highI); + if (highI = 0) then + begin + //all points are equal! + for i := 0 to len -1 do result[i] := PointD(0,0); + Exit; + end; + result[highI] := GetUnitNormal(path[highI], pt); + //now fix up any duplicates at the end of the path + for j := highI +1 to len -1 do result[j] := result[j-1]; + //with at least one valid vector, we can now + //safely get the remaining vectors + pt := path[highI]; + for i := highI -1 downto 0 do + begin + if (path[i].X <> pt.X) or (path[i].Y <> pt.Y) then + begin + result[i] := GetUnitNormal(path[i], pt); + if (Result[i].X = 0) and (Result[i].Y = 0) then + Result[i] := Result[i+1]; + pt := path[i]; + end else + result[i] := result[i+1] + end; +end; +//------------------------------------------------------------------------------ + +function DistanceSqrd(const pt1, pt2: TPoint): double; +begin + result := Sqr(pt1.X - pt2.X) + Sqr(pt1.Y - pt2.Y); +end; +//------------------------------------------------------------------------------ + +function DistanceSqrd(const pt1, pt2: TPointD): double; +begin + result := Sqr(pt1.X - pt2.X) + Sqr(pt1.Y - pt2.Y); +end; +//------------------------------------------------------------------------------ + +function Distance(const pt1, pt2: TPoint): double; +begin + Result := Sqrt(DistanceSqrd(pt1, pt2)); +end; +//------------------------------------------------------------------------------ + +function Distance(const pt1, pt2: TPointD): double; +begin + Result := Sqrt(DistanceSqrd(pt1, pt2)); +end; +//------------------------------------------------------------------------------ + +function Distance(const path: TPathD; stopAt: integer): double; +var + i, highI: integer; +begin + Result := 0; + highI := High(path); + if (stopAt > 0) and (stopAt < HighI) then highI := stopAt; + for i := 1 to highI do + Result := Result + Distance(path[i-1],path[i]); +end; +//------------------------------------------------------------------------------ + +function GetDistances(const path: TPathD): TArrayOfDouble; +var + i, len: integer; +begin + len := Length(path); + SetLength(Result, len); + if len = 0 then Exit; + Result[0] := 0; + for i := 1 to len -1 do + Result[i] := Distance(path[i-1], path[i]); +end; +//------------------------------------------------------------------------------ + +function GetCumulativeDistances(const path: TPathD): TArrayOfDouble; +var + i, len: integer; +begin + len := Length(path); + SetLength(Result, len); + if len = 0 then Exit; + Result[0] := 0; + for i := 1 to len -1 do + Result[i] := Result[i-1] + Distance(path[i-1], path[i]); +end; +//------------------------------------------------------------------------------ + +function PerpendicularDistSqrd(const pt, line1, line2: TPointD): double; +var + a,b,c,d: double; +begin + if PointsEqual(line1, line2) then + begin + Result := DistanceSqrd(pt, line1); + end else + begin + a := pt.X - line1.X; + b := pt.Y - line1.Y; + c := line2.X - line1.X; + d := line2.Y - line1.Y; + if (c = 0) and (d = 0) then + result := 0 else + result := Sqr(a * d - c * b) / (c * c + d * d); + end; +end; +//------------------------------------------------------------------------------ + +function PointInPolyWindingCount(const pt: TPointD; + const path: TPathD; out PointOnEdgeDir: integer): integer; +var + i, len: integer; + prevPt: TPointD; + isAbove: Boolean; + crossProd: double; +begin + //nb: PointOnEdgeDir == 0 unless 'pt' is on 'path' + Result := 0; + PointOnEdgeDir := 0; + i := 0; + len := Length(path); + if len = 0 then Exit; + prevPt := path[len-1]; + while (i < len) and (path[i].Y = prevPt.Y) do inc(i); + if i = len then Exit; + isAbove := (prevPt.Y < pt.Y); + while (i < len) do + begin + if isAbove then + begin + while (i < len) and (path[i].Y < pt.Y) do inc(i); + if i = len then break + else if i > 0 then prevPt := path[i -1]; + crossProd := CrossProduct(prevPt, path[i], pt); + if crossProd = 0 then + begin + PointOnEdgeDir := -1; + //nb: could safely exit here with frNonZero or frEvenOdd fill rules + end + else if crossProd < 0 then dec(Result); + end else + begin + while (i < len) and (path[i].Y > pt.Y) do inc(i); + if i = len then break + else if i > 0 then prevPt := path[i -1]; + crossProd := CrossProduct(prevPt, path[i], pt); + if crossProd = 0 then + begin + PointOnEdgeDir := 1; + //nb: could safely exit here with frNonZero or frEvenOdd fill rules + end + else if crossProd > 0 then inc(Result); + end; + inc(i); + isAbove := not isAbove; + end; +end; +//------------------------------------------------------------------------------ + +function PointInPolygon(const pt: TPointD; + const polygon: TPathD; fillRule: TFillRule): Boolean; +var + wc: integer; + PointOnEdgeDir: integer; +begin + wc := PointInPolyWindingCount(pt, polygon, PointOnEdgeDir); + case fillRule of + frEvenOdd: result := (PointOnEdgeDir <> 0) or Odd(wc); + frNonZero: result := (PointOnEdgeDir <> 0) or (wc <> 0); + frPositive: result := (PointOnEdgeDir + wc > 0); + else {frNegative} result := (PointOnEdgeDir + wc < 0); + end; +end; +//------------------------------------------------------------------------------ + +function PointInPolysWindingCount(const pt: TPointD; + const paths: TPathsD; out PointOnEdgeDir: integer): integer; +var + i,j, len: integer; + p: TPathD; + prevPt: TPointD; + isAbove: Boolean; + crossProd: double; +begin + //nb: PointOnEdgeDir == 0 unless 'pt' is on 'path' + Result := 0; + PointOnEdgeDir := 0; + for i := 0 to High(paths) do + begin + j := 0; + p := paths[i]; + len := Length(p); + if len < 3 then Continue; + prevPt := p[len-1]; + while (j < len) and (p[j].Y = prevPt.Y) do inc(j); + if j = len then continue; + isAbove := (prevPt.Y < pt.Y); + while (j < len) do + begin + if isAbove then + begin + while (j < len) and (p[j].Y < pt.Y) do inc(j); + if j = len then break + else if j > 0 then prevPt := p[j -1]; + crossProd := CrossProduct(prevPt, p[j], pt); + if crossProd = 0 then PointOnEdgeDir := -1 + else if crossProd < 0 then dec(Result); + end else + begin + while (j < len) and (p[j].Y > pt.Y) do inc(j); + if j = len then break + else if j > 0 then prevPt := p[j -1]; + crossProd := CrossProduct(prevPt, p[j], pt); + if crossProd = 0 then PointOnEdgeDir := 1 + else if crossProd > 0 then inc(Result); + end; + inc(j); + isAbove := not isAbove; + end; + end; +end; +//------------------------------------------------------------------------------ + +function PointInPolygons(const pt: TPointD; + const polygons: TPathsD; fillRule: TFillRule): Boolean; +var + wc: integer; + PointOnEdgeDir: integer; +begin + wc := PointInPolysWindingCount(pt, polygons, PointOnEdgeDir); + case fillRule of + frEvenOdd: result := (PointOnEdgeDir <> 0) or Odd(wc); + frNonZero: result := (PointOnEdgeDir <> 0) or (wc <> 0); + frPositive: result := (PointOnEdgeDir + wc > 0); + else {frNegative} result := (PointOnEdgeDir + wc < 0); + end; +end; +//------------------------------------------------------------------------------ + +function PerpendicularDist(const pt, line1, line2: TPointD): double; +var + a,b,c,d: double; +begin + //given: cross product of 2 vectors = area of parallelogram + //and given: area of parallelogram = length base * height + //height (ie perpendic. dist.) = cross product of 2 vectors / length base + a := pt.X - line1.X; + b := pt.Y - line1.Y; + c := line2.X - line1.X; + d := line2.Y - line1.Y; + result := abs(a * d - c * b) / Sqrt(c * c + d * d); +end; +//------------------------------------------------------------------------------ + +function ClosestPoint(const pt, linePt1, linePt2: TPointD; + constrainToSegment: Boolean): TPointD; +var + q: double; +begin + if (linePt1.X = linePt2.X) and (linePt1.Y = linePt2.Y) then + begin + Result := linePt1; + end else + begin + q := ((pt.X-linePt1.X)*(linePt2.X-linePt1.X) + + (pt.Y-linePt1.Y)*(linePt2.Y-linePt1.Y)) / + (sqr(linePt2.X-linePt1.X) + sqr(linePt2.Y-linePt1.Y)); + if constrainToSegment then + begin + if q < 0 then q := 0 else if q > 1 then q := 1; + end; + Result.X := (1-q)*linePt1.X + q*linePt2.X; + Result.Y := (1-q)*linePt1.Y + q*linePt2.Y; + end; +end; +//------------------------------------------------------------------------------ + +function ClosestPointOnLine(const pt, linePt1, linePt2: TPointD): TPointD; +begin + result := ClosestPoint(pt, linePt1, linePt2, false); +end; +//------------------------------------------------------------------------------ + +function ClosestPointOnSegment(const pt, segPt1, segPt2: TPointD): TPointD; +begin + result := ClosestPoint(pt, segPt1, segPt2, true); +end; +//------------------------------------------------------------------------------ + +function GetPtOnEllipseFromAngle(const ellipseRect: TRectD; + angle: double): TPointD; +var + sn, co: double; +begin + NormalizeAngle(angle); + GetSinCos(angle, sn, co); + Result.X := ellipseRect.MidPoint.X + ellipseRect.Width/2 * co; + Result.Y := ellipseRect.MidPoint.Y + ellipseRect.Height/2 * sn; +end; +//------------------------------------------------------------------------------ + +function GetEllipticalAngleFromPoint(const ellipseRect: TRectD; + const pt: TPointD): double; +begin + with ellipseRect do + Result := ArcTan2(Width/Height * (pt.Y - MidPoint.Y), (pt.X - MidPoint.X)); +end; +//------------------------------------------------------------------------------ + +function GetRotatedEllipticalAngleFromPoint(const ellipseRect: TRectD; + ellipseRotAngle: double; pt: TPointD): double; +begin + Result := 0; + if ellipseRect.IsEmpty then Exit; + RotatePoint(pt, ellipseRect.MidPoint, -ellipseRotAngle); + Result := GetEllipticalAngleFromPoint(ellipseRect, pt); +end; +//------------------------------------------------------------------------------ + +function GetPtOnRotatedEllipseFromAngle(const ellipseRect: TRectD; + ellipseRotAngle, angle: double): TPointD; +begin + Result := GetPtOnEllipseFromAngle(ellipseRect, angle); + if ellipseRotAngle <> 0 then + img32.Vector.RotatePoint(Result, ellipseRect.MidPoint, ellipseRotAngle); +end; +//------------------------------------------------------------------------------ + +function GetClosestPtOnRotatedEllipse(const ellipseRect: TRectD; + ellipseRotation: double; const pt: TPointD): TPointD; +var + pt2: TPointD; + angle: double; +begin + pt2 := pt; + Img32.Vector.RotatePoint(pt2, ellipseRect.MidPoint, -ellipseRotation); + angle := GetEllipticalAngleFromPoint(ellipseRect, pt2); + Result := GetPtOnEllipseFromAngle(ellipseRect, angle); + Img32.Vector.RotatePoint(Result, ellipseRect.MidPoint, ellipseRotation); +end; +//------------------------------------------------------------------------------ + +function IsPointInEllipse(const ellipseRec: TRect; const pt: TPoint): Boolean; +var + rec: TRectD; + w,h: integer; + x,y, y2, a,b, dx,dy: double; +begin + RectWidthHeight(ellipseRec, w, h); + a := w * 0.5; + b := h * 0.5; + dx := ellipseRec.Left + a; + dy := ellipseRec.Top + b; + rec := RectD(ellipseRec); + OffsetRect(rec, -dx, -dy); + x := pt.X -dx; y := pt.Y -dy; + //first make sure pt is inside rect + Result := (abs(x) <= a) and (abs(y) <= b); + if not result then Exit; + //given (x*x)/(a*a) + (y*y)/(b*b) = 1 + //then y*y = b*b(1 - (x*x)/(a*a)) + //nb: contents of Sqrt below will always be positive + //since the substituted x must be within ellipseRec bounds + y2 := Sqrt((b*b*(1 - (x*x)/(a*a)))); + Result := (y >= -y2) and (y <= y2); +end; +//------------------------------------------------------------------------------ + +function GetLineEllipseIntersects(const ellipseRec: TRect; + var linePt1, linePt2: TPointD): Boolean; +var + dx, dy, m,a,b,c,q: double; + qa,qb,qc,qs: double; + rec: TRectD; + pt1, pt2: TPointD; +begin + rec := RectD(ellipseRec); + a := rec.Width *0.5; + b := rec.Height *0.5; + //offset ellipseRect so it's centered over the coordinate origin + dx := ellipseRec.Left + a; dy := ellipseRec.Top + b; + offsetRect(rec, -dx, -dy); + pt1 := OffsetPoint(linePt1, -dx, -dy); + pt2 := OffsetPoint(linePt2, -dx, -dy); + //equation of ellipse = (x*x)/(a*a) + (y*y)/(b*b) = 1 + //equation of line = y = mx + c; + if (pt1.X = pt2.X) then //vertical line (ie infinite slope) + begin + //given x = K, then y*y = b*b(1 - (x*x)/(a*a)) + q := (b*b)*(1 - Sqr(pt1.X)/(a*a)); + result := q >= 0; + if not result then Exit; + q := Sqrt(q); + pt1.Y := q; + pt2.Y := -q; + end else + begin + //using simultaneous equations and substitution + //given y = mx + c + m := (pt1.Y - pt2.Y)/(pt1.X - pt2.X); + c := pt1.Y - m * pt1.X; + //given (x*x)/(a*a) + (y*y)/(b*b) = 1 + //(x*x)/(a*a)*(b*b) + (y*y) = (b*b) + //(b*b)/(a*a) *(x*x) + Sqr(m*x +c) = (b*b) + //(b*b)/(a*a) *(x*x) + (m*m)*(x*x) + 2*m*x*c +c*c = b*b + //((b*b)/(a*a) +(m*m)) *(x*x) + 2*m*c*(x) + (c*c) - (b*b) = 0 + //solving quadratic equation + qa := ((b*b)/(a*a) +(m*m)); + qb := 2*m*c; + qc := (c*c) - (b*b); + qs := (qb*qb) - 4*qa*qc; + Result := qs >= 0; + if not result then Exit; + qs := Sqrt(qs); + pt1.X := (-qb +qs)/(2 * qa); + pt1.Y := m * pt1.X + c; + pt2.X := (-qb -qs)/(2 * qa); + pt2.Y := m * pt2.X + c; + end; + //finally reverse initial offset + linePt1 := OffsetPoint(pt1, dx, dy); + linePt2 := OffsetPoint(pt2, dx, dy); +end; +//------------------------------------------------------------------------------ + +function Sign(const value: Double): integer; {$IFDEF INLINE} inline; {$ENDIF} +begin + if value < 0 then Result := -1 + else if value > 0 then Result := 1 + else Result := 0; +end; +//------------------------------------------------------------------------------ + +function GetNormal(const pt, norm: TPointD; delta: double): TPointD; +begin + result := PointD(pt.X + norm.X * delta, pt.Y + norm.Y * delta); +end; +//------------------------------------------------------------------------------ + +function GetVector(const pt, norm: TPointD; delta: double): TPointD; +begin + result := PointD(pt.X - norm.Y * delta, pt.Y + norm.X * delta); +end; +//------------------------------------------------------------------------------ + +function GetParallelOffests(const path, norms: TPathD; + delta: double): TPathD; +var + i, highI, len: integer; +begin + len := Length(path); + highI := len -1; + SetLength(Result, len *2); + Result[0] := GetNormal(path[0], norms[0], delta); + for i := 1 to highI do + begin + Result[i*2-1] := GetNormal(path[i], norms[i-1], delta); + Result[i*2] := GetNormal(path[i], norms[i], delta); + end; + Result[highI*2+1] := GetNormal(path[0], norms[highI], delta); +end; +//------------------------------------------------------------------------------ + +type + TGrowRec = record + StepsPerRad : double; + StepSin : double; + StepCos : double; + Radius : double; + aSin : double; + aCos : double; + end; + +function DoRound(const pt, norm1: TPointD; + const growRec: TGrowRec): TPathD; +var + i, steps: Integer; + a: Double; + pt2: TPointD; +begin + a := ArcTan2(growRec.aSin, growRec.aCos); + steps := Round(growRec.StepsPerRad * Abs(a)); + SetLength(Result, steps +1); + + pt2 := PointD(norm1.x * growRec.Radius, norm1.y * growRec.Radius); + Result[0] := PointD(pt.x + pt2.x, pt.y + pt2.y); + with growRec do + for i := 1 to steps do + begin + pt2 := PointD(pt2.X * StepCos - StepSin * pt2.Y, + pt2.X * StepSin + pt2.Y * StepCos); + Result[i] := PointD(pt.X + pt2.X, pt.Y + pt2.Y); + end; +end; +//------------------------------------------------------------------------------ + +function CalcRoundingSteps(radius: double): double; +begin + //the results of this function have been derived empirically + //and may need further adjustment + if radius < 0.55 then result := 4 + else result := Pi * Sqrt(radius); +end; +//------------------------------------------------------------------------------ + +function Grow(const path, normals: TPathD; delta: double; + joinStyle: TJoinStyle; miterLimOrRndScale: double; isOpen: Boolean): TPathD; +var + resCnt, resCap: integer; + + procedure AddPoint(const pt: TPointD); + begin + if resCnt >= resCap then + begin + inc(resCap, 64); + setLength(result, resCap); + end; + result[resCnt] := pt; + inc(resCnt); + end; + + procedure AppendPath(const path: TPathD); + var + len: integer; + begin + len := Length(path); + if resCnt + len > resCap then + begin + inc(resCap, len); + setLength(result, resCap); + end; + Move(path[0], result[resCnt], len * SizeOf(TPointD)); + inc(resCnt, len); + end; + +var + i : cardinal; + prevI : cardinal; + len : cardinal; + highI : cardinal; + iLo,iHi : cardinal; + norms : TPathD; + vec : TPointD; + pt, ptQ : TPointD; + p : TPathD; + a : double; + growRec : TGrowRec; + absDelta : double; + pt1, pt2, pt3, pt4: TPointD; +begin + Result := nil; + if not Assigned(path) then exit; + len := Length(path); + if not isOpen then + while (len > 2) and + PointsNearEqual(path[len -1], path[0], 0.001) do + dec(len); + if len < 2 then Exit; + + absDelta := Abs(delta); + if absDelta < MinStrokeWidth/2 then + begin + if delta < 0 then + delta := -MinStrokeWidth/2 else + delta := MinStrokeWidth/2; + end; + if absDelta < 1 then + joinStyle := jsSquare + else if joinStyle = jsAuto then + begin + if delta < AutoWidthThreshold / 2 then + joinStyle := jsSquare else + joinStyle := jsRound; + end; + + if assigned(normals) then + norms := normals else + norms := GetNormals(path); + + highI := len -1; + p := GetParallelOffests(path, norms, delta); + + if joinStyle = jsRound then + begin + if miterLimOrRndScale <= 0 then miterLimOrRndScale := 1; + growRec.Radius := delta; + growRec.StepsPerRad := CalcRoundingSteps(growRec.Radius)/(Pi *2); + if delta < 0 then + GetSinCos(-1/growRec.StepsPerRad, growRec.StepSin, growRec.StepCos) else + GetSinCos(1/growRec.StepsPerRad, growRec.StepSin, growRec.StepCos); + end else + begin + if miterLimOrRndScale <= 0 then miterLimOrRndScale := DefaultMiterLimit + else if miterLimOrRndScale < 2 then miterLimOrRndScale := 2; + miterLimOrRndScale := 2 /(sqr(miterLimOrRndScale)); + growRec.StepsPerRad := 0; //stop compiler warning. + end; + + resCnt := 0; resCap := 0; + + if isOpen then + begin + iLo := 1; iHi := highI -1; + prevI := 0; + AddPoint(p[0]); + end else + begin + iLo := 0; iHi := highI; + prevI := highI; + end; + + for i := iLo to iHi do + begin + pt1 := p[prevI*2]; + pt2 := p[prevI*2+1]; + pt3 := p[i*2]; + pt4 := p[i*2+1]; + growRec.aSin := CrossProduct(norms[prevI], norms[i]); + growRec.aCos := DotProduct(norms[prevI], norms[i]); + + if ValueAlmostZero(growRec.aSin) or ((growRec.aSin < 0) = (delta > 0)) then + begin //is concave + if SegmentsIntersect(pt1, pt2, pt3, pt4, pt) then + AddPoint(pt) else + begin + AddPoint(pt2); + AddPoint(pt3); + end; + end + else if (joinStyle = jsRound) and + (Abs(growRec.aSin) > 0.08) then //only round if angle > ~5 deg + begin + AppendPath(DoRound(path[i], norms[prevI], growRec)); + end + else if (joinStyle = jsMiter) and + (1 + growRec.aCos > miterLimOrRndScale) then + begin + //within miter range + a := delta / (1 + growRec.aCos); + AddPoint(PointD(path[i].X + (norms[i].X + norms[prevI].X) * a, + path[i].Y + (norms[i].Y + norms[prevI].Y) * a)); + end + else if (growRec.aCos < -0.001) and (growRec.aCos > -0.999) then + begin + // squaring off at delta distance from original vertex + + // while a negative cos indicates an angle > 90, the angle here + // is the **angle of deviation**, so convexity will be > 270. + // And only convex angles > 270 degrees will need squaring since + // less obtuse angles can be safely mitered. + + // using the reciprocal of unit normals (as unit vectors) + // get the average unit vector ... + vec := GetAvgUnitVector( + PointD(-norms[prevI].Y, norms[prevI].X), + PointD(norms[i].Y, -norms[i].X)); + // now offset the original vertex delta units along unit vector + ptQ := OffsetPoint(path[i], delta * vec.X, delta * vec.Y); + + // get perpendicular vertices + pt1 := OffsetPoint(ptQ, delta * vec.Y, delta * -vec.X); + pt2 := OffsetPoint(ptQ, delta * -vec.Y, delta * vec.X); + // get 2 vertices along one edge offset + pt3 := p[prevI*2]; + pt4 := p[prevI*2 +1]; + IntersectPoint(pt1,pt2,pt3,pt4, pt); + AddPoint(pt); + //get the second intersect point through reflecion + pt := ReflectPoint(pt, ptQ); + AddPoint(pt); + end else + begin + a := delta / (1 + growRec.aCos); + AddPoint(PointD(path[i].X + (norms[i].X + norms[prevI].X) * a, + path[i].Y + (norms[i].Y + norms[prevI].Y) * a)); +// AddPoint(pt2); +// AddPoint(pt3); + end; + prevI := i; + end; + if isOpen then AddPoint(p[highI*2-1]); + SetLength(Result, resCnt); +end; +//------------------------------------------------------------------------------ + +procedure AppendPath(var path: TPathD; const pt: TPointD); +var + len: integer; +begin + len := length(path); + if (len > 0) and PointsEqual(pt, path[len -1]) then Exit; + setLength(path, len + 1); + path[len] := pt; +end; +//------------------------------------------------------------------------------ + +procedure AppendPath(var path1: TPathD; const path2: TPathD); +var + len1, len2: integer; +begin + len1 := length(path1); + len2 := length(path2); + if len2 = 0 then Exit; + if (len1 > 0) and PointsEqual(path2[0], path1[len1 -1]) then dec(len1); + setLength(path1, len1 + len2); + Move(path2[0], path1[len1], len2 * SizeOf(TPointD)); +end; +//------------------------------------------------------------------------------ + +procedure AppendPoint(var path: TPathD; const extra: TPointD); +var + len: integer; +begin + len := length(path); + SetLength(path, len +1); + path[len] := extra; +end; +//------------------------------------------------------------------------------ + +procedure AppendPath(var paths: TPathsD; + const extra: TPathD); +var + len1, len2: integer; +begin + len2 := length(extra); + if len2 = 0 then Exit; + len1 := length(paths); + setLength(paths, len1 + 1); + paths[len1] := Copy(extra, 0, len2); +end; +//------------------------------------------------------------------------------ + +procedure AppendPath(var paths: TPathsD; + const extra: TPathsD); +var + i, len1, len2: integer; +begin + len2 := length(extra); + if len2 = 0 then Exit; + len1 := length(paths); + setLength(paths, len1 + len2); + for i := 0 to len2 -1 do + paths[len1+i] := Copy(extra[i], 0, length(extra[i])); +end; +//------------------------------------------------------------------------------ + +procedure AppendPath(var ppp: TArrayOfPathsD; const extra: TPathsD); +var + len: integer; +begin + len := length(ppp); + setLength(ppp, len + 1); + if Assigned(extra) then + AppendPath(ppp[len], extra) else + ppp[len] := nil; +end; +//------------------------------------------------------------------------------ + +procedure RotatePoint(var pt: TPointD; + const focalPoint: TPointD; sinA, cosA: double); +var + tmpX, tmpY: double; +begin + tmpX := pt.X-focalPoint.X; + tmpY := pt.Y-focalPoint.Y; + pt.X := tmpX * cosA - tmpY * sinA + focalPoint.X; + pt.Y := tmpX * sinA + tmpY * cosA + focalPoint.Y; +end; +//------------------------------------------------------------------------------ + +procedure RotatePoint(var pt: TPointD; + const focalPoint: TPointD; angleRad: double); +var + sinA, cosA: double; +begin + if angleRad = 0 then Exit; + if not ClockwiseRotationIsAnglePositive then angleRad := -angleRad; + GetSinCos(angleRad, sinA, cosA); + RotatePoint(pt, focalPoint, sinA, cosA); +end; +//------------------------------------------------------------------------------ + +function RotatePathInternal(const path: TPathD; + const focalPoint: TPointD; sinA, cosA: double): TPathD; +var + i: integer; + x,y: double; +begin + SetLength(Result, length(path)); + for i := 0 to high(path) do + begin + x := path[i].X - focalPoint.X; + y := path[i].Y - focalPoint.Y; + Result[i].X := x * cosA - y * sinA + focalPoint.X; + Result[i].Y := x * sinA + y * cosA + focalPoint.Y; + end; +end; +//------------------------------------------------------------------------------ + +function RotatePath(const path: TPathD; + const focalPoint: TPointD; angleRads: double): TPathD; +var + sinA, cosA: double; +begin + if angleRads = 0 then + begin + Result := path; + Exit; + end; + if not ClockwiseRotationIsAnglePositive then angleRads := -angleRads; + GetSinCos(angleRads, sinA, cosA); + Result := RotatePathInternal(path, focalPoint, sinA, cosA); +end; +//------------------------------------------------------------------------------ + +function RotatePath(const paths: TPathsD; + const focalPoint: TPointD; angleRads: double): TPathsD; +var + i: integer; + sinA, cosA: double; + fp: TPointD; +begin + Result := paths; + if not IsValid(angleRads) then Exit; + NormalizeAngle(angleRads); + if angleRads = 0 then Exit; + if not ClockwiseRotationIsAnglePositive then + angleRads := -angleRads; + GetSinCos(angleRads, sinA, cosA); + SetLength(Result, length(paths)); + if IsValid(focalPoint) then + fp := focalPoint else + fp := GetBoundsD(paths).MidPoint; + for i := 0 to high(paths) do + Result[i] := RotatePathInternal(paths[i], fp, sinA, cosA); +end; +//------------------------------------------------------------------------------ + +function GetAngle(const origin, pt: TPoint): double; +var + x,y: double; +begin + x := pt.X - origin.X; + y := pt.Y - origin.Y; + if x = 0 then + begin + if y > 0 then result := angle90 + else result := -angle90; + end + else if y = 0 then + begin + if x > 0 then result := 0 + else result := angle180; + end else + result := arctan2(y, x); //range between -Pi and Pi + if not ClockwiseRotationIsAnglePositive then Result := -Result; +end; +//------------------------------------------------------------------------------ + +function GetAngle(const origin, pt: TPointD): double; +var + x,y: double; +begin + x := pt.X - origin.X; + y := pt.Y - origin.Y; + if x = 0 then + begin + if y > 0 then result := angle90 + else result := -angle90; + end + else if y = 0 then + begin + if x > 0 then result := 0 + else result := angle180; + end else + result := arctan2(y, x); //range between -Pi and Pi + if not ClockwiseRotationIsAnglePositive then Result := -Result; +end; +//------------------------------------------------------------------------------ + +function GetAngle(const a, b, c: TPoint): double; +var + ab, bc: TPointD; + dp, cp: double; +begin + //https://stackoverflow.com/a/3487062/359538 + ab := PointD(b.x - a.x, b.y - a.y); + bc := PointD(b.x - c.x, b.y - c.y); + dp := (ab.x * bc.x + ab.y * bc.y); + cp := (ab.x * bc.y - ab.y * bc.x); + Result := arctan2(cp, dp); //range between -Pi and Pi + if not ClockwiseRotationIsAnglePositive then Result := -Result; +end; +//------------------------------------------------------------------------------ + +function GetAngle(const a, b, c: TPointD): double; +var + ab, bc: TPointD; + dp, cp: double; +begin + //https://stackoverflow.com/a/3487062/359538 + ab := PointD(b.x - a.x, b.y - a.y); + bc := PointD(b.x - c.x, b.y - c.y); + dp := (ab.x * bc.x + ab.y * bc.y); + cp := (ab.x * bc.y - ab.y * bc.x); + Result := arctan2(cp, dp); //range between -Pi and Pi + if not ClockwiseRotationIsAnglePositive then Result := -Result; +end; +//------------------------------------------------------------------------------ + +function GetPointAtAngleAndDist(const origin: TPointD; + angle, distance: double): TPointD; +begin + Result := origin; + Result.X := Result.X + distance; + RotatePoint(Result, origin, angle); +end; +//------------------------------------------------------------------------------ + +function IntersectPoint(const ln1a, ln1b, ln2a, ln2b: TPointD): TPointD; +var + m1,b1,m2,b2: double; +begin + result := InvalidPointD; + //see http://astronomy.swin.edu.au/~pbourke/geometry/lineline2d/ + if (ln1B.X = ln1A.X) then + begin + if (ln2B.X = ln2A.X) then exit; //parallel lines + m2 := (ln2B.Y - ln2A.Y)/(ln2B.X - ln2A.X); + b2 := ln2A.Y - m2 * ln2A.X; + Result.X := ln1A.X; + Result.Y := m2*ln1A.X + b2; + end + else if (ln2B.X = ln2A.X) then + begin + m1 := (ln1B.Y - ln1A.Y)/(ln1B.X - ln1A.X); + b1 := ln1A.Y - m1 * ln1A.X; + Result.X := ln2A.X; + Result.Y := m1*ln2A.X + b1; + end else + begin + m1 := (ln1B.Y - ln1A.Y)/(ln1B.X - ln1A.X); + b1 := ln1A.Y - m1 * ln1A.X; + m2 := (ln2B.Y - ln2A.Y)/(ln2B.X - ln2A.X); + b2 := ln2A.Y - m2 * ln2A.X; + if m1 = m2 then exit; //parallel lines + Result.X := (b2 - b1)/(m1 - m2); + Result.Y := m1 * Result.X + b1; + end; +end; +//------------------------------------------------------------------------------ + +function IntersectPoint(const ln1a, ln1b, ln2a, ln2b: TPointD; + out ip: TPointD): Boolean; +begin + ip := IntersectPoint(ln1a, ln1b, ln2a, ln2b); + Result := IsValid(ip); +end; +//------------------------------------------------------------------------------ + +function SegmentIntersectPt(const ln1a, ln1b, ln2a, ln2b: TPointD): TPointD; +var + pqd,r,s : TPointD; //scalar vectors; + rs, t : double; +begin + //https://stackoverflow.com/a/565282/359538 + Result := InvalidPointD; + r := PointD(ln1b.X - ln1a.X, ln1b.Y - ln1a.Y); + s := PointD(ln2b.X - ln2a.X, ln2b.Y - ln2a.Y); + rs := CrossProduct(r,s); + if Abs(rs) < 1 then Exit; + pqd.X := ln2a.X - ln1a.X; + pqd.y := ln2a.Y - ln1a.Y; + t := CrossProduct(pqd, s) / rs; + if (t < -0.025) or (t > 1.025) then Exit; + Result.X := ln1a.X + t * r.X; + Result.Y := ln1a.Y + t * r.Y; +// pqd.X := -pqd.X; pqd.Y := -pqd.Y; +// u := CrossProduct(pqd, r) / rs; +// if (u < -0.05) or (u > 1.05) then Exit; +end; +//------------------------------------------------------------------------------ + +function SegmentsIntersect(const ln1a, ln1b, ln2a, ln2b: TPointD; + out ip: TPointD): Boolean; +begin + ip := SegmentIntersectPt(ln1a, ln1b, ln2a, ln2b); + Result := IsValid(ip); +end; +//------------------------------------------------------------------------------ + +function ReverseNormals(const norms: TPathD): TPathD; +var + i, highI: integer; +begin + highI := high(norms); + setLength(result, highI +1); + for i := 1 to highI do + begin + result[i -1].X := -norms[highI -i].X; + result[i -1].Y := -norms[highI -i].Y; + end; + result[highI].X := -norms[highI].X; + result[highI].Y := -norms[highI].Y; +end; +//------------------------------------------------------------------------------ + +function GrowOpenLine(const line: TPathD; width: double; + joinStyle: TJoinStyle; endStyle: TEndStyle; + miterLimOrRndScale: double): TPathD; +var + len, x,y: integer; + halfWidth: double; + normals, lineL, lineR, arc: TPathD; + invNorm: TPointD; + growRec: TGrowRec; +begin + Result := nil; + len := length(line); + if len = 0 then Exit; + if width < MinStrokeWidth then + width := MinStrokeWidth; + halfWidth := width * 0.5; + if len = 1 then + begin + x := Round(line[0].X); + y := Round(line[0].Y); + SetLength(result, 1); + result := Ellipse(RectD(x -halfWidth, y -halfWidth, + x +halfWidth, y +halfWidth)); + Exit; + end; + + //with very narrow lines, don't get fancy with joins and line ends + if (width <= 2) then + begin + joinStyle := jsSquare; + if endStyle = esRound then endStyle := esSquare; + end + else if joinStyle = jsAuto then + begin + if (endStyle = esRound) and + (width >= AutoWidthThreshold) then + joinStyle := jsRound + else + joinStyle := jsSquare; + end; + + normals := GetNormals(line); + if endStyle = esRound then + begin + //get the rounding parameters + growRec.StepsPerRad := + CalcRoundingSteps(halfWidth * miterLimOrRndScale)/(Pi*2); + GetSinCos(1/growRec.StepsPerRad, growRec.StepSin, growRec.StepCos); + growRec.Radius := halfWidth; + + //grow the line's left side of the line => line1 + lineL := Grow(line, normals, + halfWidth, joinStyle, miterLimOrRndScale, true); + //build the rounding at the start => result + invNorm.X := -normals[0].X; + invNorm.Y := -normals[0].Y; + growRec.aSin := invNorm.X * normals[0].Y - invNorm.Y * normals[0].X; + growRec.aCos := invNorm.X * normals[0].X + invNorm.Y * normals[0].Y; + Result := DoRound(line[0], invNorm, growRec); + //join line1 into result + AppendPath(Result, lineL); + //reverse the normals and build the end arc => arc + normals := ReverseNormals(normals); + invNorm.X := -normals[0].X; invNorm.Y := -normals[0].Y; + growRec.aSin := invNorm.X * normals[0].Y - invNorm.Y * normals[0].X; + growRec.aCos := invNorm.X * normals[0].X + invNorm.Y * normals[0].Y; + arc := DoRound(line[High(line)], invNorm, growRec); + //grow the line's right side of the line + lineR := Grow(ReversePath(line), normals, + halfWidth, joinStyle, miterLimOrRndScale, true); + //join arc and line2 into result + AppendPath(Result, arc); + AppendPath(Result, lineR); + end else + begin + //esSquare => extends both line ends by 1/2 lineWidth + if endStyle = esSquare then + begin + lineL := Copy(line, 0, len); + AdjustPoint(lineL[0], lineL[1], width * 0.5); + AdjustPoint(lineL[len-1], lineL[len-2], width * 0.5); + end else + lineL := line; + + //first grow the left side of the line => Result + Result := Grow(lineL, normals, + halfWidth, joinStyle, miterLimOrRndScale, true); + //reverse normals and path and grow the right side => lineR + normals := ReverseNormals(normals); + lineR := Grow(ReversePath(lineL), normals, + halfWidth, joinStyle, miterLimOrRndScale, true); + //join both sides + AppendPath(Result, lineR); + end; +end; +//------------------------------------------------------------------------------ + +function GrowClosedLine(const line: TPathD; width: double; + joinStyle: TJoinStyle; miterLimOrRndScale: double): TPathsD; +var + line2, norms: TPathD; + rec: TRectD; + skipHole: Boolean; +begin + rec := GetBoundsD(line); + skipHole := (rec.Width <= width) or (rec.Height <= width); + if skipHole then + begin + SetLength(Result, 1); + norms := GetNormals(line); + Result[0] := Grow(line, norms, width/2, joinStyle, miterLimOrRndScale); + end else + begin + SetLength(Result, 2); + norms := GetNormals(line); + Result[0] := Grow(line, norms, width/2, joinStyle, miterLimOrRndScale); + line2 := ReversePath(line); + norms := ReverseNormals(norms); + Result[1] := Grow(line2, norms, width/2, joinStyle, miterLimOrRndScale); + end; +end; +//------------------------------------------------------------------------------ + +function Outline(const line: TPathD; lineWidth: double; + joinStyle: TJoinStyle; endStyle: TEndStyle; + miterLimOrRndScale: double): TPathsD; +begin + if not assigned(line) then + Result := nil + else if endStyle = esClosed then + result := GrowClosedLine(line, + lineWidth, joinStyle, miterLimOrRndScale) + else + begin + SetLength(Result,1); + result[0] := GrowOpenLine(line, lineWidth, + joinStyle, endStyle, miterLimOrRndScale); + end; +end; +//------------------------------------------------------------------------------ + +function Outline(const lines: TPathsD; lineWidth: double; + joinStyle: TJoinStyle; endStyle: TEndStyle; + miterLimOrRndScale: double): TPathsD; +var + i: integer; +begin + result := nil; + if not assigned(lines) then exit; + if joinStyle = jsAuto then + begin + if endStyle in [esPolygon, esRound] then + joinStyle := jsRound else + joinStyle := jsSquare; + end; + if endStyle = esPolygon then + for i := 0 to high(lines) do + AppendPath(Result, GrowClosedLine(lines[i], + lineWidth, joinStyle, miterLimOrRndScale)) + else + for i := 0 to high(lines) do + AppendPath(Result, GrowOpenLine(lines[i], lineWidth, + joinStyle, endStyle, miterLimOrRndScale)); +end; +//------------------------------------------------------------------------------ + +function Rectangle(const rec: TRect): TPathD; +begin + setLength(Result, 4); + with rec do + begin + result[0] := PointD(left, top); + result[1] := PointD(right, top); + result[2] := PointD(right, bottom); + result[3] := PointD(left, bottom); + end; +end; +//------------------------------------------------------------------------------ + +function Rectangle(const rec: TRectD): TPathD; +begin + setLength(Result, 4); + with rec do + begin + result[0] := PointD(left, top); + result[1] := PointD(right, top); + result[2] := PointD(right, bottom); + result[3] := PointD(left, bottom); + end; +end; +//------------------------------------------------------------------------------ + +function Rectangle(l, t, r, b: double): TPathD; +begin + setLength(Result, 4); + result[0] := PointD(l, t); + result[1] := PointD(r, t); + result[2] := PointD(r, b); + result[3] := PointD(l, b); +end; +//------------------------------------------------------------------------------ + +procedure InflateRect(var rec: TRect; dx, dy: integer); +begin + rec.Left := rec.Left - dx; + rec.Top := rec.Top - dy; + rec.Right := rec.Right + dx; + rec.Bottom := rec.Bottom + dy; +end; +//------------------------------------------------------------------------------ + +procedure InflateRect(var rec: TRectD; dx, dy: double); +begin + rec.Left := rec.Left - dx; + rec.Top := rec.Top - dy; + rec.Right := rec.Right + dx; + rec.Bottom := rec.Bottom + dy; +end; +//------------------------------------------------------------------------------ + +function NormalizeRect(var rect: TRect): Boolean; +var + i: integer; +begin + Result := False; + with rect do + begin + if Left > Right then + begin + i := Left; + Left := Right; + Right := i; + Result := True; + end; + if Top > Bottom then + begin + i := Top; + Top := Bottom; + Bottom := i; + Result := True; + end; + end; +end; +//------------------------------------------------------------------------------ + +function RoundRect(const rec: TRect; radius: integer): TPathD; +begin + Result := RoundRect(RectD(rec), PointD(radius, radius)); +end; +//------------------------------------------------------------------------------ + +function RoundRect(const rec: TRect; radius: TPoint): TPathD; +begin + Result := RoundRect(RectD(rec), PointD(radius)); +end; +//------------------------------------------------------------------------------ + +function RoundRect(const rec: TRectD; radius: double): TPathD; +begin + Result := RoundRect(rec, PointD(radius, radius)); +end; +//------------------------------------------------------------------------------ + +function RoundRect(const rec: TRectD; radius: TPointD): TPathD; +var + i,j : integer; + corners : TPathD; + bezPts : TPathD; + magic : TPointD; +const + magicC: double = 0.55228475; // =4/3 * (sqrt(2)-1) +begin + Result := nil; + if rec.IsEmpty then Exit; + radius.X := Min(radius.X, rec.Width/2); + radius.Y := Min(radius.Y, rec.Height/2); + if (radius.X < 1) and (radius.Y < 1) then + begin + Result := Rectangle(rec); + Exit; + end; + magic.X := radius.X * magicC; + magic.Y := radius.Y * magicC; + SetLength(Corners, 4); + with rec do + begin + corners[0] := PointD(Right, Top); + corners[1] := BottomRight; + corners[2] := PointD(Left, Bottom); + corners[3] := TopLeft; + end; + SetLength(Result, 1); + Result[0].X := corners[3].X + radius.X; + Result[0].Y := corners[3].Y; + SetLength(bezPts, 4); + for i := 0 to High(corners) do + begin + for j := 0 to 3 do bezPts[j] := corners[i]; + case i of + 3: + begin + bezPts[0].Y := bezPts[0].Y + radius.Y; + bezPts[1].Y := bezPts[0].Y - magic.Y; + bezPts[3].X := bezPts[3].X + radius.X; + bezPts[2].X := bezPts[3].X - magic.X; + end; + 0: + begin + bezPts[0].X := bezPts[0].X - radius.X; + bezPts[1].X := bezPts[0].X + magic.X; + bezPts[3].Y := bezPts[3].Y + radius.Y; + bezPts[2].Y := bezPts[3].Y - magic.Y; + end; + 1: + begin + bezPts[0].Y := bezPts[0].Y - radius.Y; + bezPts[1].Y := bezPts[0].Y + magic.Y; + bezPts[3].X := bezPts[3].X - radius.X; + bezPts[2].X := bezPts[3].X + magic.X; + end; + 2: + begin + bezPts[0].X := bezPts[0].X + radius.X; + bezPts[1].X := bezPts[0].X - magic.X; + bezPts[3].Y := bezPts[3].Y - radius.Y; + bezPts[2].Y := bezPts[3].Y + magic.Y; + end; + end; + AppendPath(Result, FlattenCBezier(bezPts)); + end; +end; +//------------------------------------------------------------------------------ + +function Circle(const pt: TPoint; radius: double): TPathD; +var + rec: TRectD; +begin + rec.Left := pt.X - radius; + rec.Right := pt.X + radius; + rec.Top := pt.Y - radius; + rec.Bottom := pt.Y + radius; + Result := Ellipse(rec); +end; +//------------------------------------------------------------------------------ + +function Circle(const pt: TPointD; radius: double): TPathD; +var + rec: TRectD; +begin + rec.Left := pt.X - radius; + rec.Right := pt.X + radius; + rec.Top := pt.Y - radius; + rec.Bottom := pt.Y + radius; + Result := Ellipse(rec); +end; +//------------------------------------------------------------------------------ + +function Circle(const pt: TPointD; radius: double; pendingScale: double): TPathD; +var + rec: TRectD; +begin + rec.Left := pt.X - radius; + rec.Right := pt.X + radius; + rec.Top := pt.Y - radius; + rec.Bottom := pt.Y + radius; + Result := Ellipse(rec, pendingScale); +end; +//------------------------------------------------------------------------------ + +function Ellipse(const rec: TRectD; pendingScale: double): TPathD; +var + steps: integer; +begin + if pendingScale <= 0 then pendingScale := 1; + steps := Round(CalcRoundingSteps((rec.width + rec.Height) * pendingScale)); + Result := Ellipse(rec, steps); +end; +//------------------------------------------------------------------------------ + + +function Ellipse(const rec: TRect; steps: integer): TPathD; +begin + Result := Ellipse(RectD(rec), steps); +end; +//------------------------------------------------------------------------------ + +function Ellipse(const rec: TRectD; steps: integer): TPathD; +var + i: Integer; + sinA, cosA: double; + centre, radius, delta: TPointD; +begin + result := nil; + if rec.IsEmpty then Exit; + with rec do + begin + centre := rec.MidPoint; + radius := PointD(Width * 0.5, Height * 0.5); + end; + if steps < 4 then + steps := Round(CalcRoundingSteps(rec.width + rec.height)); + GetSinCos(2 * Pi / Steps, sinA, cosA); + delta.x := cosA; delta.y := sinA; + SetLength(Result, Steps); + Result[0] := PointD(centre.X + radius.X, centre.Y); + for i := 1 to steps -1 do + begin + Result[i] := PointD(centre.X + radius.X * delta.x, + centre.Y + radius.y * delta.y); + delta := PointD(delta.X * cosA - delta.Y * sinA, + delta.Y * cosA + delta.X * sinA); + end; //rotates clockwise +end; +//------------------------------------------------------------------------------ + +function RotatedEllipse(const rec: TRectD; angle: double; steps: integer = 0): TPathD; +begin + Result := Ellipse(rec, steps); + if angle = 0 then Exit; + Result := RotatePath(Result, rec.MidPoint, angle); +end; +//------------------------------------------------------------------------------ + +function RotatedEllipse(const rec: TRectD; angle: double; pendingScale: double): TPathD; +begin + Result := Ellipse(rec, pendingScale); + if angle = 0 then Exit; + Result := RotatePath(Result, rec.MidPoint, angle); +end; +//------------------------------------------------------------------------------ + +function AngleToEllipticalAngle(const ellRec: TRectD; angle: double): double; +begin + Result := arctan2(ellRec.Height/ellRec.Width * sin(angle), cos(angle)); +end; +//------------------------------------------------------------------------------ + +function EllipticalAngleToAngle(const ellRec: TRectD; angle: double): double; +begin + Result := ArcTan2(sin(angle) *ellRec.Width, cos(angle) * ellRec.Height); +end; +//------------------------------------------------------------------------------ + +function Star(const rec: TRectD; points: integer; indentFrac: double): TPathD; +var + i: integer; + innerOff: double; + p, p2: TPathD; + rec2: TRectD; +begin + Result := nil; + if points < 5 then points := 5 + else if points > 15 then points := 15; + if indentFrac < 0.2 then indentFrac := 0.2 + else if indentFrac > 0.8 then indentFrac := 0.8; + innerOff := Min(rec.Width, rec.Height) * indentFrac * 0.5; + if not Odd(points) then inc(points); + p := Ellipse(rec, points); + if not Assigned(p) then Exit; + rec2 := rec; + Img32.Vector.InflateRect(rec2, -innerOff, -innerOff); + if rec2.IsEmpty then + p2 := Ellipse(rec, points*2) else + p2 := Ellipse(rec2, points*2); + SetLength(Result, points*2); + for i := 0 to points -1 do + begin + Result[i*2] := p[i]; + Result[i*2+1] := p2[i*2+1]; + end; +end; +//------------------------------------------------------------------------------ + +function Star(const focalPt: TPointD; + innerRadius, outerRadius: double; points: integer): TPathD; +var + i: Integer; + sinA, cosA: double; + delta: TPointD; +begin + result := nil; + if (innerRadius <= 0) or (outerRadius <= 0) then Exit; + if points <= 5 then points := 10 + else points := points * 2; + GetSinCos(2 * Pi / points, sinA, cosA); + delta.x := cosA; delta.y := sinA; + SetLength(Result, points); + Result[0] := PointD(focalPt.X + innerRadius, focalPt.Y); + for i := 1 to points -1 do + begin + if Odd(i) then + Result[i] := PointD(focalPt.X + outerRadius * delta.x, + focalPt.Y + outerRadius * delta.y) + else + Result[i] := PointD(focalPt.X + innerRadius * delta.x, + focalPt.Y + innerRadius * delta.y); + delta := PointD(delta.X * cosA - delta.Y * sinA, + delta.Y * cosA + delta.X * sinA); + end; +end; +//------------------------------------------------------------------------------ + +function Arc(const rec: TRectD; + startAngle, endAngle: double; scale: double): TPathD; +var + i, steps: Integer; + angle: double; + sinA, cosA: double; + centre, radius: TPointD; + deltaX, deltaX2, deltaY: double; +const + qtrDeg = PI/1440; +begin + Result := nil; + if (endAngle = startAngle) or IsEmptyRect(rec) then Exit; + if scale <= 0 then scale := 4.0; + if not ClockwiseRotationIsAnglePositive then + begin + startAngle := -startAngle; + endAngle := -endAngle; + end; + NormalizeAngle(startAngle, qtrDeg); + NormalizeAngle(endAngle, qtrDeg); + with rec do + begin + centre := MidPoint; + radius := PointD(Width * 0.5, Height * 0.5); + end; + if endAngle < startAngle then + angle := endAngle - startAngle + angle360 else + angle := endAngle - startAngle; + //steps = (No. steps for a whole ellipse) * angle/(2*Pi) + steps := Round(CalcRoundingSteps((rec.width + rec.height) * scale)); + steps := steps div 2; ///////////////////////////////// + if steps < 2 then steps := 2; + SetLength(Result, Steps +1); + //angle of the first step ... + GetSinCos(startAngle, deltaY, deltaX); + Result[0].X := centre.X + radius.X * deltaX; + Result[0].Y := centre.Y + radius.y * deltaY; + //angle of each subsequent step ... + GetSinCos(angle / Steps, sinA, cosA); + for i := 1 to steps do + begin + deltaX2 := deltaX * cosA - deltaY * sinA; + deltaY := deltaY * cosA + deltaX * sinA; + deltaX := deltaX2; + Result[i].X := centre.X + radius.X * deltaX; + Result[i].Y := centre.Y + radius.y * deltaY; + end; //progresses clockwise from start to end +end; +//------------------------------------------------------------------------------ + +function Pie(const rec: TRectD; + StartAngle, EndAngle: double; scale: double): TPathD; +var + len: integer; +begin + result := Arc(rec, StartAngle, EndAngle, scale); + len := length(result); + setLength(result, len +1); + result[len] := PointD((rec.Left + rec.Right)/2, (rec.Top + rec.Bottom)/2); +end; +//------------------------------------------------------------------------------ + +function ArrowHead(const arrowTip, ctrlPt: TPointD; size: double; + arrowStyle: TArrowStyle): TPathD; +var + unitVec, basePt: TPointD; + sDiv40, sDiv50, sDiv60, sDiv120: double; +begin + result := nil; + sDiv40 := size * 0.40; + sDiv50 := size * 0.50; + sDiv60 := size * 0.60; + sDiv120 := sDiv60 * 2; + unitVec := GetUnitVector(ctrlPt, arrowTip); + case arrowStyle of + asNone: + Exit; + asSimple: + begin + setLength(result, 3); + basePt := OffsetPoint(arrowTip, -unitVec.X * size, -unitVec.Y * size); + result[0] := arrowTip; + result[1] := OffsetPoint(basePt, -unitVec.Y * sDiv50, unitVec.X * sDiv50); + result[2] := OffsetPoint(basePt, unitVec.Y * sDiv50, -unitVec.X * sDiv50); + end; + asFancy: + begin + setLength(result, 4); + basePt := OffsetPoint(arrowTip, + -unitVec.X * sDiv120, -unitVec.Y * sDiv120); + result[0] := OffsetPoint(basePt, -unitVec.Y *sDiv50, unitVec.X *sDiv50); + result[1] := OffsetPoint(arrowTip, -unitVec.X *size, -unitVec.Y *size); + result[2] := OffsetPoint(basePt, unitVec.Y *sDiv50, -unitVec.X *sDiv50); + result[3] := arrowTip; + end; + asDiamond: + begin + setLength(result, 4); + basePt := OffsetPoint(arrowTip, -unitVec.X * sDiv60, -unitVec.Y * sDiv60); + result[0] := arrowTip; + result[1] := OffsetPoint(basePt, -unitVec.Y * sDiv50, unitVec.X * sDiv50); + result[2] := OffsetPoint(arrowTip, -unitVec.X * sDiv120, -unitVec.Y * sDiv120); + result[3] := OffsetPoint(basePt, unitVec.Y * sDiv50, -unitVec.X * sDiv50); + end; + asCircle: + begin + basePt := OffsetPoint(arrowTip, -unitVec.X * sDiv50, -unitVec.Y * sDiv50); + with Point(basePt) do + result := Ellipse(RectD(x - sDiv50, y - sDiv50, x + sDiv50, y + sDiv50)); + end; + asTail: + begin + setLength(result, 6); + basePt := OffsetPoint(arrowTip, -unitVec.X * sDiv60, -unitVec.Y * sDiv60); + result[0] := OffsetPoint(arrowTip, -unitVec.X * sDiv50, -unitVec.Y * sDiv50); + result[1] := OffsetPoint(arrowTip, -unitVec.Y * sDiv40, unitVec.X * sDiv40); + result[2] := OffsetPoint(basePt, -unitVec.Y * sDiv40, unitVec.X * sDiv40); + result[3] := OffsetPoint(arrowTip, -unitVec.X * sDiv120, -unitVec.Y * sDiv120); + result[4] := OffsetPoint(basePt, unitVec.Y * sDiv40, -unitVec.X * sDiv40); + result[5] := OffsetPoint(arrowTip, unitVec.Y * sDiv40, -unitVec.X * sDiv40); + end; + end; +end; +//------------------------------------------------------------------------------ + +function GetDefaultArrowHeadSize(lineWidth: double): double; +begin + Result := lineWidth *3 + 7; +end; +//------------------------------------------------------------------------------ + +procedure AdjustPoint(var pt: TPointD; const referencePt: TPointD; delta: double); +var + vec: TPointD; +begin + //Positive delta moves pt away from referencePt, and + //negative delta moves pt toward referencePt. + vec := GetUnitVector(referencePt, pt); + pt.X := pt.X + (vec.X * delta); + pt.Y := pt.Y + (vec.Y * delta); +end; +//------------------------------------------------------------------------------ + +function ShortenPath(const path: TPathD; + pathEnd: TPathEnd; amount: double): TPathD; +var + len, amount2: double; + vec: TPointD; + i, highPath: integer; +begin + result := path; + highPath := high(path); + if highPath < 1 then Exit; + amount2 := amount; + if pathEnd <> peEnd then + begin + //shorten start + i := 0; + while (i < highPath) do + begin + len := Distance(result[i], result[i+1]); + if (len >= amount) then Break; + amount := amount - len; + inc(i); + end; + if i > 0 then + begin + Move(path[i], Result[0], (highPath - i +1) * SizeOf(TPointD)); + dec(highPath, i); + SetLength(Result, highPath +1); + end; + if amount > 0 then + begin + vec := GetUnitVector(result[0], result[1]); + result[0].X := result[0].X + vec.X * amount; + result[0].Y := result[0].Y + vec.Y * amount; + end; + end; + if pathEnd <> peStart then + begin + //shorten end + while (highPath > 1) do + begin + len := Distance(result[highPath], result[highPath -1]); + if (len >= amount2) then Break; + amount2 := amount2 - len; + dec(highPath); + end; + SetLength(Result, highPath +1); + if amount2 > 0 then + begin + vec := GetUnitVector(result[highPath], result[highPath -1]); + result[highPath].X := result[highPath].X + vec.X * amount2; + result[highPath].Y := result[highPath].Y + vec.Y * amount2; + end; + end; +end; +//------------------------------------------------------------------------------ + +function GetDashedPath(const path: TPathD; + closed: Boolean; const pattern: TArrayOfInteger; + patternOffset: PDouble): TPathsD; +var + i, highI, paIdx: integer; + vecs, path2, dash: TPathD; + patCnt, patLen: integer; + dashCapacity, dashCnt, ptsCapacity, ptsCnt: integer; + segLen, residualPat, patOff: double; + filling: Boolean; + pt, pt2: TPointD; + + procedure NewDash; + begin + if ptsCnt = 1 then ptsCnt := 0; + if ptsCnt = 0 then Exit; + if dashCnt = dashCapacity then + begin + inc(dashCapacity, BuffSize); + setLength(result, dashCapacity); + end; + result[dashCnt] := Copy(dash, 0, ptsCnt); + inc(dashCnt); + ptsCapacity := BuffSize; + setLength(dash, ptsCapacity); + ptsCnt := 0; + end; + + procedure ExtendDash(const pt: TPointD); + begin + if ptsCnt = ptsCapacity then + begin + inc(ptsCapacity, BuffSize); + setLength(dash, ptsCapacity); + end; + dash[ptsCnt] := pt; + inc(ptsCnt); + end; + +begin + Result := nil; + paIdx := 0; + patCnt := length(pattern); + path2 := path; + highI := high(path2); + if (highI < 1) or (patCnt = 0) then Exit; + if closed and + ((path2[highI].X <> path2[0].X) or (path2[highI].Y <> path2[0].Y)) then + begin + inc(highI); + setLength(path2, highI +2); + path2[highI] := path2[0]; + end; + vecs := GetVectors(path2); + if (vecs[0].X = 0) and (vecs[0].Y = 0) then Exit; //not a line + if not assigned(patternOffset) then + patOff := 0 else + patOff := patternOffset^; + patLen := 0; + for i := 0 to patCnt -1 do + inc(patLen, pattern[i]); + if patOff < 0 then + begin + patOff := patLen + patOff; + while patOff < 0 do + patOff := patOff + patLen; + end + else while patOff > patLen do + patOff := patOff - patLen; + //nb: each dash is made up of 2 or more pts + dashCnt := 0; + dashCapacity := 0; + ptsCnt := 0; + ptsCapacity := 0; + filling := true; + while patOff >= pattern[paIdx] do + begin + filling := not filling; + patOff := patOff - pattern[paIdx]; + paIdx := (paIdx + 1) mod patCnt; + end; + residualPat := pattern[paIdx] - patOff; + pt := path2[0]; + ExtendDash(pt); + i := 0; + while (i < highI) do + begin + segLen := Distance(pt, path2[i+1]); + if residualPat > segLen then + begin + if filling then ExtendDash(path2[i+1]); + residualPat := residualPat - segLen; + pt := path2[i+1]; + inc(i); + end else + begin + pt2.X := pt.X + vecs[i].X * residualPat; + pt2.Y := pt.Y + vecs[i].Y * residualPat; + if filling then ExtendDash(pt2); + filling := not filling; + NewDash; + paIdx := (paIdx + 1) mod patCnt; + residualPat := pattern[paIdx]; + pt := pt2; + ExtendDash(pt); + end; + end; + NewDash; + SetLength(Result, dashCnt); + if not assigned(patternOffset) then Exit; + patOff := 0; + for i := 0 to paIdx -1 do + patOff := patOff + pattern[i]; + patternOffset^ := patOff + (pattern[paIdx] - residualPat); +end; +//------------------------------------------------------------------------------ + +function GetDashedOutLine(const path: TPathD; + closed: Boolean; const pattern: TArrayOfInteger; + patternOffset: PDouble; lineWidth: double; + joinStyle: TJoinStyle; endStyle: TEndStyle): TPathsD; +var + i: integer; + tmp: TPathsD; +begin + Result := nil; + for i := 0 to High(pattern) do + if pattern[i] <= 0 then pattern[i] := 1; + tmp := GetDashedPath(path, closed, pattern, patternOffset); + for i := 0 to high(tmp) do + AppendPath(Result, GrowOpenLine(tmp[i], + lineWidth, joinStyle, endStyle, 2)); +end; +//------------------------------------------------------------------------------ + +function GetBoundsD(const paths: TPathsD): TRectD; +var + i,j: integer; + l,t,r,b: double; + p: PPointD; +begin + l := MaxInt; t := MaxInt; + r := -MaxInt; b := -MaxInt; + for i := 0 to high(paths) do + begin + p := PPointD(paths[i]); + if not assigned(p) then Continue; + for j := 0 to high(paths[i]) do + begin + if p.x < l then l := p.x; + if p.x > r then r := p.x; + if p.y < t then t := p.y; + if p.y > b then b := p.y; + inc(p); + end; + end; + if r < l then + result := NullRectD else + result := RectD(l, t, r, b); +end; +//------------------------------------------------------------------------------ + +function GetBoundsD(const path: TPathD): TRectD; +var + i,highI: integer; + l,t,r,b: double; + p: PPointD; +begin + highI := High(path); + if highI < 0 then + begin + Result := NullRectD; + Exit; + end; + l := path[0].X; r := l; + t := path[0].Y; b := t; + p := PPointD(path); + for i := 1 to highI do + begin + inc(p); + if p.x < l then l := p.x; + if p.x > r then r := p.x; + if p.y < t then t := p.y; + if p.y > b then b := p.y; + end; + result := RectD(l, t, r, b); +end; +//------------------------------------------------------------------------------ + +function GetBounds(const path: TPathD): TRect; +var + recD: TRectD; +begin + recD := GetBoundsD(path); + Result := Rect(recD); +end; +//------------------------------------------------------------------------------ + +function GetBounds(const paths: TPathsD): TRect; +var + recD: TRectD; +begin + recD := GetBoundsD(paths); + Result := Rect(recD); +end; +//------------------------------------------------------------------------------ + +function PrePendPoint(const pt: TPointD; const p: TPathD): TPathD; +var + len: integer; +begin + len := Length(p); + SetLength(Result, len +1); + Result[0] := pt; + if len > 0 then Move(p[0], Result[1], len * SizeOf(TPointD)); +end; +//------------------------------------------------------------------------------ + +function PrePendPoints(const pt1, pt2: TPointD; const p: TPathD): TPathD; +var + len: integer; +begin + len := Length(p); + SetLength(Result, len +2); + Result[0] := pt1; + Result[1] := pt2; + if len > 0 then Move(p[0], Result[2], len * SizeOf(TPointD)); +end; +//------------------------------------------------------------------------------ + +function GetPointInQuadBezier(const a,b,c: TPointD; t: double): TPointD; +var + omt: double; +begin + if t > 1 then t := 1 + else if t < 0 then t := 0; + omt := 1 - t; + Result.X := a.X*omt*omt + b.X*2*omt*t + c.X*t*t; + Result.Y := a.Y*omt*omt + b.Y*2*omt*t + c.Y*t*t; +end; +//------------------------------------------------------------------------------ + +function FlattenQBezier(const firstPt: TPointD; const pts: TPathD; + tolerance: double = 0.0): TPathD; overload; +begin + if tolerance <= 0.0 then tolerance := BezierTolerance; + Result := FlattenQBezier(PrePendPoint(firstPt, pts), tolerance); +end; +//------------------------------------------------------------------------------ + +function FlattenQBezier(const pts: TPathD; tolerance: double = 0.0): TPathD; +var + i, highI: integer; + p: TPathD; +begin + Result := nil; + highI := high(pts); + if highI < 0 then Exit; + if (highI < 2) or Odd(highI) then + raise Exception.Create(rsInvalidQBezier); + if tolerance <= 0.0 then tolerance := BezierTolerance; + setLength(Result, 1); + Result[0] := pts[0]; + for i := 0 to (highI div 2) -1 do + begin + if PointsEqual(pts[i*2], pts[i*2+1]) and + PointsEqual(pts[i*2+1], pts[i*2+2]) then + begin + AppendPoint(Result, pts[i*2]); + AppendPoint(Result, pts[i*2 +2]); + end else + begin + p := FlattenQBezier(pts[i*2], pts[i*2+1], pts[i*2+2], tolerance); + AppendPath(Result, Copy(p, 1, Length(p) -1)); + end; + end; +end; +//------------------------------------------------------------------------------ + +function FlattenQBezier(const pt1, pt2, pt3: TPointD; + tolerance: double = 0.0): TPathD; +var + resultCnt, resultLen: integer; + + procedure AddPoint(const pt: TPointD); + begin + if resultCnt = resultLen then + begin + inc(resultLen, BuffSize); + setLength(result, resultLen); + end; + result[resultCnt] := pt; + inc(resultCnt); + end; + + procedure DoCurve(const p1, p2, p3: TPointD); + var + p12, p23, p123: TPointD; + begin + if (abs(p1.x + p3.x - 2 * p2.x) + + abs(p1.y + p3.y - 2 * p2.y) < tolerance) then + begin + AddPoint(p3); + end else + begin + P12.X := (P1.X + P2.X) * 0.5; + P12.Y := (P1.Y + P2.Y) * 0.5; + P23.X := (P2.X + P3.X) * 0.5; + P23.Y := (P2.Y + P3.Y) * 0.5; + P123.X := (P12.X + P23.X) * 0.5; + P123.Y := (P12.Y + P23.Y) * 0.5; + DoCurve(p1, p12, p123); + DoCurve(p123, p23, p3); + end; + end; + +begin + resultLen := 0; resultCnt := 0; + if tolerance <= 0.0 then tolerance := BezierTolerance; + AddPoint(pt1); + if ((pt1.X = pt2.X) and (pt1.Y = pt2.Y)) or + ((pt2.X = pt3.X) and (pt2.Y = pt3.Y)) then + begin + AddPoint(pt3) + end else + DoCurve(pt1, pt2, pt3); + SetLength(result, resultCnt); +end; +//------------------------------------------------------------------------------ + +function GetPointInCubicBezier(const a,b,c,d: TPointD; t: double): TPointD; +var + omt: double; +begin + if t > 1 then t := 1 + else if t < 0 then t := 0; + omt := 1 - t; + Result.X := a.X*omt*omt*omt +b.X*3*omt*omt*t +c.X*3*omt*t*t +d.X*t*t*t; + Result.Y := a.Y*omt*omt*omt +b.Y*3*omt*omt*t +c.Y*3*omt*t*t +d.Y*t*t*t; +end; +//------------------------------------------------------------------------------ + +function FlattenCBezier(const firstPt: TPointD; const pts: TPathD; + tolerance: double = 0.0): TPathD; overload; +begin + Result := FlattenCBezier(PrePendPoint(firstPt, pts), tolerance); +end; +//------------------------------------------------------------------------------ + +function FlattenCBezier(const pts: TPathD; tolerance: double = 0.0): TPathD; +var + i, len: integer; + p: TPathD; +begin + Result := nil; + len := Length(pts) -1; + if len < 0 then Exit; + if (len < 3) or (len mod 3 <> 0) then + raise Exception.Create(rsInvalidCBezier); + if tolerance <= 0.0 then tolerance := BezierTolerance; + setLength(Result, 1); + Result[0] := pts[0]; + for i := 0 to (len div 3) -1 do + begin + if PointsEqual(pts[i*3], pts[i*3+1]) and + PointsEqual(pts[i*3+2], pts[i*3+3]) then + begin + AppendPoint(Result, pts[i*3]); + AppendPoint(Result, pts[i*3 +3]); + end else + begin + p := FlattenCBezier(pts[i*3], pts[i*3+1], + pts[i*3+2], pts[i*3+3], tolerance); + AppendPath(Result, Copy(p, 1, Length(p) -1)); + end; + end; +end; +//------------------------------------------------------------------------------ + +function FlattenCBezier(const pt1, pt2, pt3, pt4: TPointD; + tolerance: double = 0.0): TPathD; +var + resultCnt, resultLen: integer; + + procedure AddPoint(const pt: TPointD); + begin + if resultCnt = resultLen then + begin + inc(resultLen, BuffSize); + setLength(result, resultLen); + end; + result[resultCnt] := pt; + inc(resultCnt); + end; + + procedure DoCurve(const p1, p2, p3, p4: TPointD); + var + p12, p23, p34, p123, p234, p1234: TPointD; + begin + if ((abs(p1.x +p3.x - 2*p2.x) < tolerance) and + (abs(p2.x +p4.x - 2*p3.x) < tolerance)) and + ((abs(p1.y +p3.y - 2*p2.y) < tolerance) and + (abs(p2.y +p4.y - 2*p3.y) < tolerance)) then + begin + AddPoint(p4); + end else + begin + p12.X := (p1.X + p2.X) / 2; + p12.Y := (p1.Y + p2.Y) / 2; + p23.X := (p2.X + p3.X) / 2; + p23.Y := (p2.Y + p3.Y) / 2; + p34.X := (p3.X + p4.X) / 2; + p34.Y := (p3.Y + p4.Y) / 2; + p123.X := (p12.X + p23.X) / 2; + p123.Y := (p12.Y + p23.Y) / 2; + p234.X := (p23.X + p34.X) / 2; + p234.Y := (p23.Y + p34.Y) / 2; + p1234.X := (p123.X + p234.X) / 2; + p1234.Y := (p123.Y + p234.Y) / 2; + DoCurve(p1, p12, p123, p1234); + DoCurve(p1234, p234, p34, p4); + end; + end; + +begin + result := nil; + resultLen := 0; resultCnt := 0; + if tolerance <= 0.0 then tolerance := BezierTolerance; + AddPoint(pt1); + if ValueAlmostZero(pt1.X - pt2.X) and ValueAlmostZero(pt1.Y - pt2.Y) and + ValueAlmostZero(pt3.X - pt4.X) and ValueAlmostZero(pt3.Y - pt4.Y) then + begin + AddPoint(pt4) + end else + DoCurve(pt1, pt2, pt3, pt4); + SetLength(result,resultCnt); +end; +//------------------------------------------------------------------------------ + +function ReflectPoint(const pt, pivot: TPointD): TPointD; +begin + Result.X := pivot.X + (pivot.X - pt.X); + Result.Y := pivot.Y + (pivot.Y - pt.Y); +end; +//------------------------------------------------------------------------------ + +function FlattenCSpline(const priorCtrlPt, startPt: TPointD; + const pts: TPathD; tolerance: double = 0.0): TPathD; +var + p: TPathD; + len: integer; +begin + len := Length(pts); + SetLength(p, len + 2); + p[0] := startPt; + p[1] := ReflectPoint(priorCtrlPt, startPt); + if len > 0 then + Move(pts[0], p[2], len * SizeOf(TPointD)); + Result := FlattenCSpline(p, tolerance); +end; +//------------------------------------------------------------------------------ + +function FlattenCSpline(const pts: TPathD; tolerance: double = 0.0): TPathD; +var + resultCnt, resultLen: integer; + + procedure AddPoint(const pt: TPointD); + begin + if resultCnt = resultLen then + begin + inc(resultLen, BuffSize); + setLength(result, resultLen); + end; + result[resultCnt] := pt; + inc(resultCnt); + end; + + procedure DoCurve(const p1, p2, p3, p4: TPointD); + var + p12, p23, p34, p123, p234, p1234: TPointD; + begin + if (abs(p1.x + p3.x - 2*p2.x) + abs(p2.x + p4.x - 2*p3.x) + + abs(p1.y + p3.y - 2*p2.y) + abs(p2.y + p4.y - 2*p3.y)) < tolerance then + begin + if resultCnt = length(result) then + setLength(result, length(result) +BuffSize); + result[resultCnt] := p4; + inc(resultCnt); + end else + begin + p12.X := (p1.X + p2.X) / 2; + p12.Y := (p1.Y + p2.Y) / 2; + p23.X := (p2.X + p3.X) / 2; + p23.Y := (p2.Y + p3.Y) / 2; + p34.X := (p3.X + p4.X) / 2; + p34.Y := (p3.Y + p4.Y) / 2; + p123.X := (p12.X + p23.X) / 2; + p123.Y := (p12.Y + p23.Y) / 2; + p234.X := (p23.X + p34.X) / 2; + p234.Y := (p23.Y + p34.Y) / 2; + p1234.X := (p123.X + p234.X) / 2; + p1234.Y := (p123.Y + p234.Y) / 2; + DoCurve(p1, p12, p123, p1234); + DoCurve(p1234, p234, p34, p4); + end; + end; + +var + i, len: integer; + p: PPointD; + pt1,pt2,pt3,pt4: TPointD; +begin + result := nil; + len := Length(pts); resultLen := 0; resultCnt := 0; + if (len < 4) then Exit; + if tolerance <= 0.0 then tolerance := BezierTolerance; + //ignore incomplete trailing control points + if Odd(len) then dec(len); + p := @pts[0]; + AddPoint(p^); + pt1 := p^; inc(p); + pt2 := p^; inc(p); + for i := 0 to (len shr 1) - 2 do + begin + pt3 := p^; inc(p); + pt4 := p^; inc(p); + DoCurve(pt1, pt2, pt3, pt4); + pt1 := pt4; + pt2 := ReflectPoint(pt3, pt1); + end; + SetLength(result,resultCnt); +end; +//------------------------------------------------------------------------------ + +function FlattenQSpline(const priorCtrlPt, startPt: TPointD; + const pts: TPathD; tolerance: double = 0.0): TPathD; +var + p: TPathD; + len: integer; +begin + len := Length(pts); + SetLength(p, len + 2); + p[0] := startPt; + p[1] := ReflectPoint(priorCtrlPt, startPt); + if len > 0 then + Move(pts[0], p[2], len * SizeOf(TPointD)); + Result := FlattenQSpline(p, tolerance); +end; +//------------------------------------------------------------------------------ + +function FlattenQSpline(const pts: TPathD; tolerance: double = 0.0): TPathD; +var + resultCnt, resultLen: integer; + + procedure AddPoint(const pt: TPointD); + begin + if resultCnt = resultLen then + begin + inc(resultLen, BuffSize); + setLength(result, resultLen); + end; + result[resultCnt] := pt; + inc(resultCnt); + end; + + procedure DoCurve(const p1, p2, p3: TPointD); + var + p12, p23, p123: TPointD; + begin + if (abs(p1.x + p3.x - 2 * p2.x) + + abs(p1.y + p3.y - 2 * p2.y) < tolerance) then + begin + AddPoint(p3); + end else + begin + P12.X := (P1.X + P2.X) * 0.5; + P12.Y := (P1.Y + P2.Y) * 0.5; + P23.X := (P2.X + P3.X) * 0.5; + P23.Y := (P2.Y + P3.Y) * 0.5; + P123.X := (P12.X + P23.X) * 0.5; + P123.Y := (P12.Y + P23.Y) * 0.5; + DoCurve(p1, p12, p123); + DoCurve(p123, p23, p3); + end; + end; + +var + i, len: integer; + p: PPointD; + pt1, pt2, pt3: TPointD; +begin + result := nil; + len := Length(pts); + if (len < 3) then Exit; + resultLen := 0; + resultCnt := 0; + if tolerance <= 0.0 then tolerance := BezierTolerance; + p := @pts[0]; + AddPoint(p^); + pt1 := p^; inc(p); + pt2 := p^; inc(p); + for i := 0 to len - 3 do + begin + pt3 := p^; inc(p); + DoCurve(pt1, pt2, pt3); + pt1 := pt3; + pt2 := ReflectPoint(pt2, pt1); + end; + SetLength(result,resultCnt); +end; +//------------------------------------------------------------------------------ + +function MakePath(const pts: array of double): TPathD; +var + i, j, len: Integer; + x,y: double; +begin + Result := nil; + len := length(pts) div 2; + if len = 0 then Exit; + setlength(Result, len); + Result[0].X := pts[0]; + Result[0].Y := pts[1]; + j := 0; + for i := 1 to len -1 do + begin + x := pts[i*2]; + y := pts[i*2 +1]; + inc(j); + Result[j].X := x; + Result[j].Y := y; + end; + setlength(Result, j+1); +end; +//------------------------------------------------------------------------------ + +end. diff --git a/Ext/SVGIconImageList/Image32/source/Img32.inc b/Ext/SVGIconImageList/Image32/source/Img32.inc index 63ce553..3db5f1a 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.inc +++ b/Ext/SVGIconImageList/Image32/source/Img32.inc @@ -1,3 +1,13 @@ +//NO_STORAGE is experimental +//Allows file system storage of layered objects etc +//Must be disabled to compile the experimental 'CtrlDemo' in Examples +{$DEFINE NO_STORAGE} + +//USING_VCL_LCL - using either Delphi or Lazarus Component Libraries +//Adds a few extra library features (eg copying to and from TBitmap objects) +//Enabled is recommended unless you're compiling console applications. +{.$DEFINE USING_VCL_LCL} + {$IFDEF FPC} {$MODE DELPHI} {$DEFINE ABSTRACT_CLASSES} @@ -9,48 +19,52 @@ {$DEFINE INLINE} {$ENDIF} {$DEFINE DELPHI_PNG} + {$IFDEF WINDOWS} + {$DEFINE MSWINDOWS} + {$ENDIF} {$ELSE} {$IF COMPILERVERSION < 15} Your version of Delphi is not supported (Image32 requires Delphi version 7 or above) {$IFEND} {$IFDEF CPUX86} - {$DEFINE ASM_X86} //nb: do not define in FPC + {$DEFINE ASM_X86} //caution: do not define in FPC {$ENDIF} - {$IF COMPILERVERSION >= 17} + {$IF COMPILERVERSION >= 17} //Delphi 2005 {$IFNDEF DEBUG} - {$DEFINE INLINE} //Delphi 2005 - added inlining + {$DEFINE INLINE} //added inlining {$ENDIF} - {$DEFINE NESTED_TYPES} //Delphi 2005 - added nested types & nested constants - {$IF COMPILERVERSION >= 18} - {$DEFINE ABSTRACT_CLASSES} //Delphi 2006 - added abstract classes - {$DEFINE REPORTMEMORYLEAKS} //Delphi 2006 - added ReportMemoryLeaksOnShutdown + {$DEFINE NESTED_TYPES} //added nested types & nested constants + {$IF COMPILERVERSION >= 18} //Delphi 2006 + {$DEFINE ABSTRACT_CLASSES} //added abstract classes + {$DEFINE REPORTMEMORYLEAKS} //added ReportMemoryLeaksOnShutdown {$WARN SYMBOL_PLATFORM OFF} - {$DEFINE SETSIZE} //Delphi 2006 - added TBitmap.SetSize - {$IF COMPILERVERSION >= 18.5} - {$DEFINE RECORD_METHODS} //Delphi 2007 - added records with methods - {$DEFINE DELPHI_PNG} //Delphi 2007 - added PNG support - {$DEFINE DELPHI_GIF} //Delphi 2007 - added GIF support - {$DEFINE MAINFORMONTASKBAR} //Delphi 2007 - added TApplication.MainFormOnTaskbar - {$if CompilerVersion >= 20} - {$DEFINE PBYTE} //Delphi 2009 - added PByte - {$DEFINE CHARINSET} //Delphi 2009 - added CharInSet function - {$DEFINE EXIT_PARAM} //Delphi 2009 - added Exit(value) - {$DEFINE ALPHAFORMAT} //Delphi 2009 - added TBitmap.AlphaFormat property - {$IF COMPILERVERSION >= 21} - {$DEFINE GESTURES} //Delphi 2010 - added screen gesture support - {$IF COMPILERVERSION >= 23} - {$IF declared(FireMonkeyVersion)} //defined in FMX.Types + {$DEFINE SETSIZE} //added TBitmap.SetSize + {$IF COMPILERVERSION >= 18.5} //Delphi 2007 + {$DEFINE RECORD_METHODS} //added records with methods + {$DEFINE DELPHI_PNG} //added PNG support + {$DEFINE DELPHI_GIF} //added GIF support + {$DEFINE MAINFORMONTASKBAR} //added TApplication.MainFormOnTaskbar + {$if CompilerVersion >= 20} //Delphi 2009 + {$DEFINE PBYTE} //added PByte + {$DEFINE CHARINSET} //added CharInSet function + {$DEFINE EXIT_PARAM} //added Exit(value) + {$DEFINE ALPHAFORMAT} //added TBitmap.AlphaFormat property + {$IF COMPILERVERSION >= 21} //Delphi 2010 + {$DEFINE GESTURES} //added screen gesture support + {$IF COMPILERVERSION >= 23} //DelphiXE2 + {$IF declared(FireMonkeyVersion)} //defined in FMX.Types {$DEFINE FMX} {$IFEND} {$DEFINE FORMATSETTINGS} {$DEFINE TROUNDINGMODE} - {$DEFINE UITYPES} //DelphiXE2 - added UITypes unit - {$DEFINE XPLAT_GENERICS} //DelphiXE2 - reasonable cross-platform & generics support - {$DEFINE STYLESERVICES} //DelphiXE2 - added StyleServices unit - {$IF COMPILERVERSION >= 24} - {$DEFINE ZEROBASEDSTR} //DelphiXE3 - {$IF COMPILERVERSION >= 25} - {$LEGACYIFEND ON} //DelphiXE4 - avoids compiler warning + {$DEFINE UITYPES} //added UITypes unit + {$DEFINE XPLAT_GENERICS} //reasonable cross-platform & generics support + {$DEFINE STYLESERVICES} //added StyleServices unit + {$IF COMPILERVERSION >= 24} //DelphiXE3 + {$LEGACYIFEND ON} + {$DEFINE ZEROBASEDSTR} + {$IF COMPILERVERSION >= 25} //DelphiXE4 + {$LEGACYIFEND ON} //avoids compiler warning {$IFEND} {$IFEND} {$IFEND} diff --git a/Ext/SVGIconImageList/Image32/source/Img32.pas b/Ext/SVGIconImageList/Image32/source/Img32.pas index edec94a..191844b 100644 --- a/Ext/SVGIconImageList/Image32/source/Img32.pas +++ b/Ext/SVGIconImageList/Image32/source/Img32.pas @@ -3,7 +3,7 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.2 * -* Date : 11 March 2022 * +* Date : 30 July 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * * @@ -17,13 +17,11 @@ interface {$I Img32.inc} -{.$DEFINE USING_VCL} uses Types, SysUtils, Classes, - {$IFDEF MSWINDOWS} Windows, {$IFDEF USING_VCL} Graphics,{$ENDIF}{$ENDIF} + {$IFDEF MSWINDOWS} Windows,{$ENDIF} {$IFDEF USING_VCL_LCL} Graphics, Forms,{$ENDIF} {$IFDEF XPLAT_GENERICS} Generics.Collections, Generics.Defaults, Character,{$ENDIF} - {$IFDEF USING_FMX} FMX.Types, FMX.Graphics,{$ENDIF} {$IFDEF UITYPES} UITypes,{$ENDIF} Math; type @@ -111,17 +109,18 @@ TPointD = record TInterfacedObj = class(TObject, IInterface) public - function _AddRef: Integer; stdcall; - function _Release: Integer; stdcall; {$IFDEF FPC} + function _AddRef: Integer; + {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; + function _Release: Integer; + {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; function QueryInterface( - {$IFDEF FPC_HAS_CONSTREF}constref - {$ELSE}const - {$ENDIF} iid : tguid;out obj) : longint; - {$IFNDEF WINDOWS}cdecl - {$ELSE}stdcall - {$ENDIF}; + {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid; + out obj) : longint; + {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; {$ELSE} + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; {$ENDIF} end; @@ -239,10 +238,10 @@ TImage32 = class(TObject) x: Integer = 0; y: Integer = 0; transparent: Boolean = true); overload; procedure CopyToDc(const srcRect, dstRect: TRect; dstDc: HDC; transparent: Boolean = true); overload; - {$IFDEF USING_VCL} +{$ENDIF} +{$IFDEF USING_VCL_LCL} procedure CopyFromBitmap(bmp: TBitmap); procedure CopyToBitmap(bmp: TBitmap); - {$ENDIF} {$ENDIF} function CopyToClipBoard: Boolean; class function CanPasteFromClipBoard: Boolean; @@ -369,7 +368,7 @@ TImageList32 = class PHsl = ^THsl; TArrayofHSL = array of THsl; - TTriState = (tsUnknown, tsYes, tsChecked = 1, tsNo, tsUnchecked = 2); + TTriState = (tsUnknown = 0, tsYes = 1, tsChecked = 1, tsNo = 2, tsUnchecked = 2); PPointD = ^TPointD; TPathD = array of TPointD; //nb: watch for ambiguity with Clipper.pas @@ -474,8 +473,6 @@ TImageList32 = class procedure NormalizeAngle(var angle: double; tolerance: double = Pi/360); function GrayScale(color: TColor32): TColor32; - {$IFDEF MSWINDOWS} - //DPIAware: Useful for DPIAware sizing of images and their container controls. //It scales values relative to the display's resolution (PixelsPerInch). //See https://docs.microsoft.com/en-us/windows/desktop/hidpi/high-DPIAware-desktop-application-development-on-windows @@ -486,13 +483,13 @@ TImageList32 = class function DPIAware(const rec: TRect): TRect; overload; function DPIAware(const rec: TRectD): TRectD; overload; +{$IFDEF MSWINDOWS} {$IFDEF FPC} function AlphaBlend(DC: HDC; p2, p3, p4, p5: Integer; DC6: HDC; p7, p8, p9, p10: Integer; p11: Windows.TBlendFunction): BOOL; stdcall; external 'msimg32.dll' name 'AlphaBlend'; {$ENDIF} - - {$ENDIF} +{$ENDIF} //CreateResourceStream: handles both numeric and string names and types function CreateResourceStream(const resName: string; @@ -1052,10 +1049,11 @@ function Get32bitBitmapInfoHeader(width, height: Integer): TBitmapInfoHeader; Result.biCompression := BI_RGB; end; //------------------------------------------------------------------------------ +{$ENDIF} function DPIAware(val: Integer): Integer; begin - result := Round( val * DpiAwareOne); + result := Round(val * DpiAwareOne); end; //------------------------------------------------------------------------------ @@ -1096,7 +1094,6 @@ function DPIAware(const rec: TRectD): TRectD; result.Bottom := rec.Bottom * DpiAwareOne; end; //------------------------------------------------------------------------------ -{$ENDIF} function GrayScale(color: TColor32): TColor32; var @@ -1225,9 +1222,9 @@ function RgbToHsl(color: TColor32): THsl; begin //https://en.wikipedia.org/wiki/HSL_and_HSV and //http://en.wikipedia.org/wiki/HSL_color_space -{$IFDEF ANDROID} +{$IF DEFINED(ANDROID)} color := SwapRedBlue(color); -{$ENDIF} +{$IFEND} r := rgba.R; g := rgba.G; b := rgba.B; maxRGB := Max(r, Max(g, b)); @@ -1273,11 +1270,12 @@ function HslToRgb(hslColor: THsl): TColor32; var rgba: TARGB absolute result; hsl: THsl absolute hslColor; - c, x, m: Integer; + c, x, m, a: Integer; begin //formula from https://www.rapidtables.com/convert/color/hsl-to-rgb.html c := (255 - abs(2 * hsl.lum - 255)) * hsl.sat div 255; - x := c * (255 - abs((hsl.hue mod 85) * 6 - 255)) div 255; + a := (hsl.hue mod 85) * 6 - 255; + x := c * (255 - abs(a)) div 255; m := hsl.lum - c div 2; rgba.A := hsl.alpha; case (hsl.hue * 6) shr 8 of @@ -1288,9 +1286,9 @@ function HslToRgb(hslColor: THsl): TColor32; 4: begin rgba.R := x + m; rgba.G := 0 + m; rgba.B := c + m; end; 5: begin rgba.R := c + m; rgba.G := 0 + m; rgba.B := x + m; end; end; -{$IFDEF ANDROID} +{$IF DEFINED(ANDROID)} Result := SwapRedBlue(Result); -{$ENDIF} +{$IFEND} end; //------------------------------------------------------------------------------ @@ -2325,15 +2323,21 @@ function TImage32.GetPixelRow(row: Integer): PColor32; procedure TImage32.CopyInternal(src: TImage32; const srcRec, dstRec: TRect; blendFunc: TBlendFunction); var - i, j, srcRecWidth: Integer; + i, j, srcRecWidth, srcRecHeight: Integer; s, d: PColor32; begin - srcRecWidth := srcRec.Right - srcRec.Left; + // occasionally, due to rounding, srcRec and dstRec + // don't have exactly the same widths and heights, so ... + srcRecWidth := + Min(srcRec.Right - srcRec.Left, dstRec.Right - dstRec.Left); + srcRecHeight := + Min(srcRec.Bottom - srcRec.Top, dstRec.Bottom - dstRec.Top); + s := @src.Pixels[srcRec.Top * src.Width + srcRec.Left]; d := @Pixels[dstRec.top * Width + dstRec.Left]; if assigned(blendFunc) then - for i := srcRec.Top to srcRec.Bottom -1 do + for i := srcRec.Top to srcRec.Top + srcRecHeight -1 do begin for j := 1 to srcRecWidth do begin @@ -2345,7 +2349,7 @@ procedure TImage32.CopyInternal(src: TImage32; end else //simply overwrite src with dst (ie without blending) - for i := srcRec.Top to srcRec.Bottom -1 do + for i := srcRec.Top to srcRec.Top + srcRecHeight -1 do begin move(s^, d^, srcRecWidth * SizeOf(TColor32)); inc(s, src.Width); @@ -2376,8 +2380,14 @@ function TImage32.CopyBlend(src: TImage32; srcRec, dstRec: TRect; //dstRec might be adjusted due to clipping ... RectWidthHeight(dstRec, dstW, dstH); RectWidthHeight(srcRec, srcW, srcH); - scaleX := dstW / srcW; - scaleY := dstH / srcH; + + //watching out for insignificant scaling + if Abs(dstW - srcW) < 2 then + scaleX := 1 else + scaleX := dstW / srcW; + if Abs(dstH - srcH) < 2 then + scaleY := 1 else + scaleY := dstH / srcH; //check if the source rec has been clipped ... if not RectsEqual(srcRecClipped, srcRec) then @@ -2590,32 +2600,7 @@ procedure TImage32.CopyToDc(const srcRect, dstRect: TRect; end; end; //------------------------------------------------------------------------------ - -{$IFDEF USING_VCL} -procedure TImage32.CopyFromBitmap(bmp: TBitmap); -var - savedPF: TPixelFormat; -begin - if not Assigned(bmp) then Exit; - savedPF := bmp.PixelFormat; - bmp.PixelFormat := pf32bit; - SetSize(bmp.Width, bmp.Height); - GetBitmapBits(bmp.Handle, Width * Height * 4, PixelBase); - bmp.PixelFormat := savedPF; -end; -//------------------------------------------------------------------------------ - -procedure TImage32.CopyToBitmap(bmp: TBitmap); -begin - if not Assigned(bmp) then Exit; - bmp.PixelFormat := pf32bit; - bmp.SetSize(Width, Height); - bmp.AlphaFormat := afDefined; - SetBitmapBits(bmp.Handle, Width * Height * 4, PixelBase); -end; {$ENDIF} -{$ENDIF} -//------------------------------------------------------------------------------ function TImage32.CopyToClipBoard: Boolean; var @@ -2685,6 +2670,60 @@ function TImage32.PasteFromClipBoard: Boolean; end; //------------------------------------------------------------------------------ +{$IFDEF USING_VCL_LCL} +procedure TImage32.CopyFromBitmap(bmp: TBitmap); +var + savedPF: TPixelFormat; +{$IFNDEF MSWINDOWS} + i: integer; + pxDst, pxSrc: PColor32; +{$ENDIF} +begin + if not Assigned(bmp) then Exit; + savedPF := bmp.PixelFormat; + bmp.PixelFormat := pf32bit; + SetSize(bmp.Width, bmp.Height); +{$IFDEF MSWINDOWS} + GetBitmapBits(bmp.Handle, Width * Height * 4, PixelBase); +{$ELSE} + for i := 0 to bmp.Height -1 do + begin + pxSrc := bmp.ScanLine[i]; + pxDst := PixelRow[i]; + Move(pxSrc^, pxDst^, bmp.Width * SizeOf(TColor32)); + end; +{$ENDIF} + bmp.PixelFormat := savedPF; +end; +//------------------------------------------------------------------------------ + +procedure TImage32.CopyToBitmap(bmp: TBitmap); +{$IFNDEF MSWINDOWS} +var + i: integer; + pxDst, pxSrc: PColor32; +{$ENDIF} +begin + if not Assigned(bmp) then Exit; + bmp.PixelFormat := pf32bit; + bmp.SetSize(Width, Height); +{$IFDEF MSWINDOWS} + {$IFNDEF FPC} + bmp.AlphaFormat := afDefined; + {$ENDIF} + SetBitmapBits(bmp.Handle, Width * Height * 4, PixelBase); +{$ELSE} + for i := 0 to bmp.Height -1 do + begin + pxDst := bmp.ScanLine[i]; + pxSrc := PixelRow[i]; + Move(pxSrc^, pxDst^, bmp.Width * SizeOf(TColor32)); + end; +{$ENDIF} +end; +//------------------------------------------------------------------------------ +{$ENDIF} + procedure TImage32.ConvertToBoolMask(reference: TColor32; tolerance: integer; colorFunc: TCompareFunction; maskBg: TColor32; maskFg: TColor32); var @@ -2699,11 +2738,11 @@ procedure TImage32.ConvertToBoolMask(reference: TColor32; tolerance: integer; b := @mask[0]; for i := 0 to Width * Height -1 do begin - {$IFDEF PBYTE} + {$IFDEF PBYTE} if b^ = 0 then c^ := maskBg else c^ := maskFg; - {$ELSE} + {$ELSE} if b^ = #0 then c^ := maskBg else c^ := maskFg; - {$ENDIF} + {$ENDIF} inc(c); inc(b); end; Changed; @@ -2724,11 +2763,11 @@ procedure TImage32.ConvertToAlphaMask(reference: TColor32; b := @mask[0]; for i := 0 to Width * Height -1 do begin - {$IFDEF PBYTE} + {$IFDEF PBYTE} c^ := b^ shl 24; - {$ELSE} + {$ELSE} c^ := Ord(b^) shl 24; - {$ENDIF} + {$ENDIF} inc(c); inc(b); end; Changed; @@ -3299,6 +3338,31 @@ class function TImageFormat.CanCopyToClipboard: Boolean; // TInterfacedObj //------------------------------------------------------------------------------ +{$IFDEF FPC} +function TInterfacedObj._AddRef: Integer; + {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; +begin + Result := -1; +end; +//------------------------------------------------------------------------------ + +function TInterfacedObj._Release: Integer; + {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF}; +begin + Result := -1; +end; +//------------------------------------------------------------------------------ + +function TInterfacedObj.QueryInterface( + {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid; + out obj) : longint; +begin + if GetInterface(IID, Obj) then Result := 0 + else Result := E_NOINTERFACE; +end; + +{$ELSE} + function TInterfacedObj._AddRef: Integer; stdcall; begin Result := -1; @@ -3311,15 +3375,13 @@ function TInterfacedObj._Release: Integer; stdcall; end; //------------------------------------------------------------------------------ -{$IFDEF FPC} -function TInterfacedObj.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint; -{$ELSE} -function TInterfacedObj.QueryInterface(const IID: TGUID; out Obj): HResult; -{$ENDIF} +function TInterfacedObj.QueryInterface(const IID: TGUID; + out Obj): HResult; begin if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE; end; +{$ENDIF} //------------------------------------------------------------------------------ // Initialization and Finalization functions @@ -3362,6 +3424,15 @@ procedure GetScreenScale; {$ENDIF} //------------------------------------------------------------------------------ +{$IFDEF USING_VCL_LCL} +procedure GetScreenScale2; +begin + DpiAwareOne := Screen.PixelsPerInch / 96; + dpiAware1 := Round(DpiAwareOne); +end; +{$ENDIF} +//------------------------------------------------------------------------------ + procedure CleanUpImageFormatClassList; var i: integer; @@ -3444,8 +3515,13 @@ procedure CleanUpResamplerClassList; initialization CreateImageFormatList; MakeBlendTables; + {$IFDEF MSWINDOWS} GetScreenScale; +{$ELSE} + {$IFDEF USING_VCL_LCL} + GetScreenScale2; + {$ENDIF} {$ENDIF} finalization diff --git a/Ext/SVGIconImageList/Source/FMX.Image32SVG.pas b/Ext/SVGIconImageList/Source/FMX.Image32SVG.pas index d3c3dc4..3d6fd99 100644 --- a/Ext/SVGIconImageList/Source/FMX.Image32SVG.pas +++ b/Ext/SVGIconImageList/Source/FMX.Image32SVG.pas @@ -78,9 +78,6 @@ function AlphaToColor32(AlphaColor: TAlphaColor): TColor32; res.G := TAlphaColorRec(AlphaColor).G; res.B := TAlphaColorRec(AlphaColor).B; Result := res.Color; -{$IF Defined(ANDROID) or Defined(MACOS) or Defined(MACOSX)} - Result := SwapRedBlue(Result); -{$IFEND} end; { TFmxImage32SVG } diff --git a/Ext/SVGIconImageList/Source/FMX.SVGIconImageList.pas b/Ext/SVGIconImageList/Source/FMX.SVGIconImageList.pas index d001b2b..c0a6252 100644 --- a/Ext/SVGIconImageList/Source/FMX.SVGIconImageList.pas +++ b/Ext/SVGIconImageList/Source/FMX.SVGIconImageList.pas @@ -47,7 +47,7 @@ interface ; const - SVGIconImageListVersion = '3.8.2'; + SVGIconImageListVersion = '3.9.3'; DEFAULT_SIZE = 32; ZOOM_DEFAULT = 100; SVG_INHERIT_COLOR = TAlphaColors.Null; @@ -124,7 +124,7 @@ TSVGIconSourceItem = class(TCustomSourceItem) FFixedColor: TAlphaColor; FApplyFixedColorToRootOnly: Boolean; FGrayScale: Boolean; - procedure UpdateAllItems; + procedure RefreshAllIcons; function GetSVGText: string; procedure SetFixedColor(const Value: TAlphaColor); procedure SetGrayScale(const Value: Boolean); @@ -179,7 +179,6 @@ TSVGIconImageList = class(TCustomImageList) function StoreOpacity: Boolean; procedure SetAutoSizeBitmaps(const Value: Boolean); procedure SetFixedColor(const Value: TAlphaColor); - procedure UpdateSourceItems; procedure UpdateDestination(ASize: TSize; const Index: Integer); procedure SetGrayScale(const Value: Boolean); procedure SetOpacity(const Value: single); @@ -210,6 +209,7 @@ TSVGIconImageList = class(TCustomImageList) function LoadFromFiles(const AFileNames: TStrings; const AAppend: Boolean = True): Integer; procedure ClearIcons; virtual; + procedure RefreshAllIcons; procedure UpdateIconAttributes(const ASize: Integer; const AOpacity: Single); overload; published //Publishing properties of standard ImageList @@ -485,7 +485,7 @@ constructor TSVGIconSourceItem.Create(Collection: TCollection); FOpacity := -1; FixedColor := SVG_INHERIT_COLOR; FGrayScale := False; - UpdateAllItems; + RefreshAllIcons; end; function TSVGIconSourceItem.CreateMultiResBitmap: TMultiResBitmap; @@ -558,7 +558,7 @@ procedure TSVGIconSourceItem.SetApplyFixedColorToRootOnly(const Value: Boolean); if FApplyFixedColorToRootOnly <> Value then begin FApplyFixedColorToRootOnly := Value; - UpdateAllItems; + RefreshAllIcons; end; end; @@ -567,7 +567,7 @@ procedure TSVGIconSourceItem.SetFixedColor(const Value: TAlphaColor); if FFixedColor <> Value then begin FFixedColor := Value; - UpdateAllItems; + RefreshAllIcons; end; end; @@ -576,7 +576,7 @@ procedure TSVGIconSourceItem.SetGrayScale(const Value: Boolean); if FGrayScale <> Value then begin FGrayScale := Value; - UpdateAllItems; + RefreshAllIcons; end; end; @@ -601,7 +601,7 @@ procedure TSVGIconSourceItem.SetOpacity(const AValue: single); end else FOpacity := AValue; - UpdateAllItems; + RefreshAllIcons; end; procedure TSVGIconSourceItem.SetSVG(const Value: TFmxImageSVG); @@ -609,14 +609,14 @@ procedure TSVGIconSourceItem.SetSVG(const Value: TFmxImageSVG); if not SameText(FSVG.Source, Value.Source) then begin FSVG.LoadFromText(Value.Source); - UpdateAllItems; + RefreshAllIcons; end; end; procedure TSVGIconSourceItem.SetSVGText(const Value: string); begin FSVG.LoadFromText(Value); - UpdateAllItems; + RefreshAllIcons; end; function TSVGIconSourceItem.StoreOpacity: Boolean; @@ -634,12 +634,13 @@ procedure TSVGIconSourceItem.UpdateIconAttributes( FApplyFixedColorToRootOnly := ApplyToRootOnly; end; -procedure TSVGIconSourceItem.UpdateAllItems; +procedure TSVGIconSourceItem.RefreshAllIcons; var I: Integer; LItem: TSVGIconBitmapItem; LSize: TSize; begin + //Update all Source and Destination Items/Icons for I := 0 to MultiResBitmap.Count -1 do begin LItem := MultiResBitmap.Items[I] as TSVGIconBitmapItem; @@ -667,12 +668,11 @@ function TSVGIconImageList.InsertIcon(const AIndex: Integer; LItem.MultiResBitmap.Add; LItem.SVGText := ASVGText; LDest := Self.Destination.Insert(AIndex); - try - if AIconName <> '' then - LItem.Name := AIconName; - finally + if AIconName <> '' then + begin + LItem.Name := AIconName; with LDest.Layers.Add do - Name := LItem.Name; + Name := AIconName; end; end; @@ -691,10 +691,7 @@ function TSVGIconImageList.CloneIcon(const AIndex: Integer; const AInsertIndex: Result.FixedColor := LItem.FixedColor; Result.GrayScale := LItem.GrayScale; Result.SVG.LoadFromText(LItem.SVG.Source); - - // Result.Assign(Self.Destination.Items[AIndex]); - - UpdateSourceItems; + RefreshAllIcons; end; function TSVGIconImageList.LoadFromFiles(const AFileNames: TStrings; @@ -786,6 +783,12 @@ procedure TSVGIconImageList.UpdateDestination(ASize: TSize; while Index > Destination.Count-1 do Destination.Add; LDestItem := Destination.Items[Index] as TDestinationItem; + if LDestItem.Layers.Count = 0 then + begin + LSourceItem := Source.Items[Index] as TSVGIconSourceItem; + with LDestItem.Layers.Add do + Name := LSourceItem.IconName; + end; if LDestItem.Layers.Count > 0 then begin LIndex := Source.indexOf(LDestItem.Layers[0].Name); @@ -896,21 +899,25 @@ function TSVGIconImageList.GetHeight: Integer; procedure TSVGIconImageList.Loaded; begin inherited; - UpdateSourceItems; + RefreshAllIcons; end; procedure TSVGIconImageList.SetAutoSizeBitmaps(const Value: Boolean); begin FAutoSizeBitmaps := Value; if (Count > 0) then - UpdateSourceItems; + RefreshAllIcons; end; -procedure TSVGIconImageList.UpdateSourceItems; +procedure TSVGIconImageList.RefreshAllIcons; var I: Integer; LSourceItem: TSVGIconSourceItem; begin + //Delete destination items more than source items + while Destination.Count > Source.Count do + Destination.Delete(Destination.Count-1); + //Update all Source and Destination Items/Icons for I := 0 to Source.Count -1 do begin LSourceItem := Source[I] as TSVGIconSourceItem; @@ -920,7 +927,7 @@ procedure TSVGIconImageList.UpdateSourceItems; LSourceItem.GrayScale := FGrayScale; if LSourceItem.FixedColor = SVG_INHERIT_COLOR then LSourceItem.FixedColor := FFixedColor; - LSourceItem.UpdateAllItems; + LSourceItem.RefreshAllIcons; end; end; @@ -929,7 +936,7 @@ procedure TSVGIconImageList.SetFixedColor(const Value: TAlphaColor); if FFixedColor <> Value then begin FFixedColor := Value; - UpdateSourceItems; + RefreshAllIcons; end; end; @@ -938,7 +945,7 @@ procedure TSVGIconImageList.SetApplyFixedColorToRootOnly(const Value: Boolean); if FApplyFixedColorToRootOnly <> Value then begin FApplyFixedColorToRootOnly := Value; - UpdateSourceItems; + RefreshAllIcons; end; end; @@ -947,7 +954,7 @@ procedure TSVGIconImageList.SetGrayScale(const Value: Boolean); if FGrayScale <> Value then begin FGrayScale := Value; - UpdateSourceItems; + RefreshAllIcons; end; end; @@ -956,7 +963,7 @@ procedure TSVGIconImageList.SetHeight(const AValue: Integer); if FHeight <> AValue then begin FHeight := AValue; - UpdateSourceItems; + RefreshAllIcons; end; end; @@ -967,7 +974,7 @@ procedure TSVGIconImageList.SetIconSize(const AWidth, AHeight: Integer); begin FWidth := AWidth; FHeight := AHeight; - UpdateSourceItems; + RefreshAllIcons; end; end; @@ -976,7 +983,7 @@ procedure TSVGIconImageList.SetOpacity(const Value: single); if FOpacity <> Value then begin FOpacity := Value; - UpdateSourceItems; + RefreshAllIcons; end; end; @@ -996,7 +1003,7 @@ procedure TSVGIconImageList.SetWidth(const AValue: Integer); if FWidth <> AValue then begin FWidth := AValue; - UpdateSourceItems; + RefreshAllIcons; end; end; @@ -1005,7 +1012,7 @@ procedure TSVGIconImageList.SetZoom(const AValue: Integer); if (FZoom <> AValue) and (AValue <= 100) and (AValue >= 10) then begin FZoom := AValue; - UpdateSourceItems; + RefreshAllIcons; end; end; diff --git a/Ext/SVGIconImageList/Source/SVGIconImage.pas b/Ext/SVGIconImageList/Source/SVGIconImage.pas index a96082c..996309d 100644 --- a/Ext/SVGIconImageList/Source/SVGIconImage.pas +++ b/Ext/SVGIconImageList/Source/SVGIconImage.pas @@ -509,7 +509,10 @@ procedure TSVGIconImage.SetStretch(const Value: Boolean); procedure TSVGIconImage.SetSVGText(const AValue: string); begin FSVG.Source := AValue; - Repaint; + if AValue = '' then + Clear + else + Repaint; end; procedure TSVGIconImage.SetOpacity(Value: Byte); @@ -600,7 +603,9 @@ procedure TSVGGraphic.Assign(Source: TPersistent); begin FSVG := TSVGGraphic(Source).FSVG; Changed(Self); - end; + end + else + inherited; end; procedure TSVGGraphic.AssignSVG(SVG: ISVG); @@ -612,7 +617,9 @@ procedure TSVGGraphic.AssignSVG(SVG: ISVG); procedure TSVGGraphic.AssignTo(Dest: TPersistent); begin if Dest is TSVGGraphic then - TSVGGraphic(Dest).Assign(Self); + TSVGGraphic(Dest).Assign(Self) + else + inherited; end; procedure TSVGGraphic.SetOpacity(Value: Byte); diff --git a/Ext/SVGIconImageList/Source/SVGIconImageListBase.pas b/Ext/SVGIconImageList/Source/SVGIconImageListBase.pas index 80a73a2..200e299 100644 --- a/Ext/SVGIconImageList/Source/SVGIconImageListBase.pas +++ b/Ext/SVGIconImageList/Source/SVGIconImageListBase.pas @@ -48,7 +48,7 @@ interface SvgInterfaces; const - SVGIconImageListVersion = '3.8.2'; + SVGIconImageListVersion = '3.9.3'; DEFAULT_SIZE = 16; type diff --git a/Ext/SVGIconImageList/Source/SVGIconUtils.pas b/Ext/SVGIconImageList/Source/SVGIconUtils.pas index e118947..1ecdb32 100644 --- a/Ext/SVGIconImageList/Source/SVGIconUtils.pas +++ b/Ext/SVGIconImageList/Source/SVGIconUtils.pas @@ -47,6 +47,16 @@ interface , Vcl.Imaging.pngimage , ComCtrls; +Type + TPngExportSize = (es16, es32, es48, es64, es96, es128, es192, es256, esCustom); + TPngExportSizes = Set of TPngExportSize; + + TExportToPngEvent = procedure (const ASizes: TPngExportSizes; const SVGText: string; + const AFolder, AFormat: string; ACustomSize: Integer) of Object; + +const + AllPngExportSizes = [es16, es32, es48, es64, es96, es128, es192, es256, esCustom]; + function UpdateSVGIconListView(const AListView: TListView; const ACategory: string = ''; const AIncludeIndex: Boolean = True): Integer; diff --git a/Ext/SVGIconImageList/Source/Winapi.D2DMissing.pas b/Ext/SVGIconImageList/Source/Winapi.D2DMissing.pas index df59043..c3b21aa 100644 --- a/Ext/SVGIconImageList/Source/Winapi.D2DMissing.pas +++ b/Ext/SVGIconImageList/Source/Winapi.D2DMissing.pas @@ -75,7 +75,7 @@ D2D_MATRIX_4X4_F = record D2D1_MATRIX_4X4_F = D2D_MATRIX_4X4_F; {$EXTERNALSYM D2D1_MATRIX_4X4_F} - {$IF CompilerVersion < 30} + {$IF CompilerVersion < 31} DXGI_COLOR_SPACE_TYPE = WORD; {$IFEND} diff --git a/Ext/SVGIconImageList/Source/dlgExportPNG.dfm b/Ext/SVGIconImageList/Source/dlgExportPNG.dfm index b506158..a83e976 100644 --- a/Ext/SVGIconImageList/Source/dlgExportPNG.dfm +++ b/Ext/SVGIconImageList/Source/dlgExportPNG.dfm @@ -3,8 +3,8 @@ object ExportToPNGDialog: TExportToPNGDialog Top = 168 BorderStyle = bsDialog Caption = 'Export SVG to PNG files' - ClientHeight = 280 - ClientWidth = 458 + ClientHeight = 279 + ClientWidth = 454 Color = clBtnFace Font.Charset = ANSI_CHARSET Font.Color = clWindowText @@ -38,6 +38,13 @@ object ExportToPNGDialog: TExportToPNGDialog Height = 13 Caption = 'Filename' end + object SVGIconImage: TSVGIconImage + Left = 24 + Top = 8 + Width = 200 + Height = 200 + AutoSize = False + end object FSearchOptions: TGroupBox Left = 247 Top = 8 @@ -176,13 +183,6 @@ object ExportToPNGDialog: TExportToPNGDialog TabOrder = 2 OnClick = btnCancelClick end - object SVGIconImage: TSVGIconImage - Left = 24 - Top = 8 - Width = 200 - Height = 200 - AutoSize = False - end object FormatEdit: TEdit Left = 247 Top = 174 @@ -198,7 +198,7 @@ object ExportToPNGDialog: TExportToPNGDialog Width = 169 Height = 23 Caption = 'Change output filename...' - TabOrder = 5 + TabOrder = 3 OnClick = OutputButtonClick end object SavePNGDialog: TSaveDialog diff --git a/Ext/SVGIconImageList/Source/dlgExportPNG.pas b/Ext/SVGIconImageList/Source/dlgExportPNG.pas index f25b9cc..d74362e 100644 --- a/Ext/SVGIconImageList/Source/dlgExportPNG.pas +++ b/Ext/SVGIconImageList/Source/dlgExportPNG.pas @@ -4,7 +4,7 @@ interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, ExtCtrls, SVGIconImage; + StdCtrls, ExtCtrls, SVGIconImage, SVGIconUtils; resourcestring SVG_IMAGE_EXPORTED = 'PNG Images created into Folder'; @@ -41,6 +41,7 @@ TExportToPNGDialog = class(TForm) private FFileName: TFileName; FIconName: string; + FOnExportToPng: TExportToPngEvent; procedure UpdateExampleLabel; procedure ExportToPNG; procedure SetFileName(const Value: TFileName); @@ -54,24 +55,29 @@ TExportToPNGDialog = class(TForm) function ExportToPNG(const AParentRect: TRect; const AFileName: TFileName; - ASVGContent: string; + const ASVGContent: string; const AShowModal: Boolean; - const ACustomSize: Integer = 0): boolean; + const ACustomSize: Integer = 0; + const AExportFormat: string = ''; + const ASizes: TPngExportSizes = []; + const OnExportToPng: TExportToPngEvent = nil): Boolean; implementation {$R *.dfm} uses - SVGIconUtils - , System.UITypes + System.UITypes , System.Math; function ExportToPNG(const AParentRect: TRect; const AFileName: TFileName; - ASVGContent: string; + const ASVGContent: string; const AShowModal: Boolean; - const ACustomSize: Integer = 0): Boolean; + const ACustomSize: Integer = 0; + const AExportFormat: string = ''; + const ASizes: TPngExportSizes = []; + const OnExportToPng: TExportToPngEvent = nil): Boolean; var LExportToPNGDialog: TExportToPNGDialog; I: Integer; @@ -99,7 +105,25 @@ function ExportToPNG(const AParentRect: TRect; if not Assigned(LExportToPNGDialog) then LExportToPNGDialog := TExportToPNGDialog.Create(nil); + + LExportToPNGDialog.FOnExportToPng := OnExportToPng; + + if ASizes <> [] then + begin + LExportToPNGDialog.Export16x16.Checked := es16 in ASizes; + LExportToPNGDialog.Export32x32.Checked := es32 in ASizes; + LExportToPNGDialog.Export48x48.Checked := es48 in ASizes; + LExportToPNGDialog.Export64x64.Checked := es64 in ASizes; + LExportToPNGDialog.Export96x96.Checked := es96 in ASizes; + LExportToPNGDialog.Export128x128.Checked := es128 in ASizes; + LExportToPNGDialog.Export192x192.Checked := es192 in ASizes; + LExportToPNGDialog.Export256x256.Checked := es256 in ASizes; + LExportToPNGDialog.ExportCustom.Checked := LCustomSize <> 0; + end; + LExportToPNGDialog.FileName := AFileName; + if AExportFormat <> '' then + LExportToPNGDialog.FormatEdit.Text := AExportFormat; LExportToPNGDialog.SVGIconImage.SVGText := ASVGContent; if LCustomSize <> 0 then LExportToPNGDialog.CustomSizeValue := LCustomSize @@ -144,36 +168,45 @@ procedure TExportToPNGDialog.ExportToPNG; LOutFolder: string; LIconName: string; LFileExported: TStringList; + LExportSizes: TPngExportSizes; - function ExportToPNG(ASize: Integer): string; + function ExportToPNG(ASize: Integer; AExportSize: TPngExportSize): string; begin Result := GetOutFileName(ASize); SVGExportToPng(ASize, ASize, SVGIconImage.SVG, LOutFolder, Result); + LExportSizes := LExportSizes + [AExportSize]; end; begin + LExportSizes := []; LFileExported := TStringList.Create; try LOutFolder := ExtractFilePath(FileName); ForceDirectories(LOutFolder); LIconName := ChangeFileExt(ExtractFileName(FileName),''); if Export16x16.Checked then - LFileExported.Add(ExportToPNG(16)); + LFileExported.Add(ExportToPNG(16, es16)); if Export32x32.Checked then - LFileExported.Add(ExportToPNG(32)); + LFileExported.Add(ExportToPNG(32, es32)); if Export48x48.Checked then - LFileExported.Add(ExportToPNG(48)); + LFileExported.Add(ExportToPNG(48, es48)); + if Export64x64.Checked then + LFileExported.Add(ExportToPNG(64, es64)); if Export96x96.Checked then - LFileExported.Add(ExportToPNG(96)); + LFileExported.Add(ExportToPNG(96, es96)); if Export128x128.Checked then - LFileExported.Add(ExportToPNG(128)); + LFileExported.Add(ExportToPNG(128, es128)); if Export192x192.Checked then - LFileExported.Add(ExportToPNG(192)); + LFileExported.Add(ExportToPNG(192, es192)); if Export256x256.Checked then - LFileExported.Add(ExportToPNG(256)); + LFileExported.Add(ExportToPNG(256, es256)); if ExportCustom.Checked and (CustomSizeValue > 0) then - LFileExported.Add(ExportToPNG(CustomSizeValue)); + LFileExported.Add(ExportToPNG(CustomSizeValue, esCustom)); + + if Assigned(FOnExportToPng) then + FOnExportToPng(LExportSizes, SVGIconImage.SVG.Source, + ExtractFilePath(FileName), FormatEdit.Text, CustomSizeValue*Ord(ExportCustom.Checked)); MessageDlg(SVG_IMAGE_EXPORTED+sLineBreak+LOutFolder+sLineBreak+ LFileExported.Text, diff --git a/Ext/SVGIconImageList/Svg/SVGColor.pas b/Ext/SVGIconImageList/Svg/SVGColor.pas index 93587e4..52842fb 100644 --- a/Ext/SVGIconImageList/Svg/SVGColor.pas +++ b/Ext/SVGIconImageList/Svg/SVGColor.pas @@ -291,7 +291,7 @@ procedure CreateSVGColorList; M: TMethod; begin SVGColorList := TStringList.Create; -{$IF CompilerVersion > 29} +{$IF CompilerVersion > 30} SVGColorList.Options := SVGColorList.Options - [soUseLocale]; {$IFEND} SVGColorList.CaseSensitive := False; diff --git a/README.md b/README.md index 2b9926b..e07e059 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # SVG Shell Extensions [![License](https://img.shields.io/badge/License-Apache%202.0-yellowgreen.svg)](https://opensource.org/licenses/Apache-2.0) -**Latest Version 2.7.0 - 10 Apr 2022** +**Latest Version 2.9.0 - 18 Sep 2022** **A collection of extensions tools for SVG files, integrated into Microsoft Windows Explorer (Vista, 7, 8, 10 and 11):** @@ -8,9 +8,10 @@ - A [Thumbnail handler][2] which allows you to see the SVG image into Windows Explorer. -- An [SVG-XML Text Editor][10] to manually edit and preview the text of SVG files. +- An [SVG-XML Text Editor][12] to manually edit and preview the text of SVG files. ### Features + - Supports Windows Vista, 7, 8, 10 and 11 (for 32 bits and 64 bits). - Themes (Dark and Light) according to user preferences of Windows Theme @@ -21,8 +22,6 @@ Click to download the [SVGShellExtensionsSetup.exe][3] located also in the Release area. The Installer works both for 32 and 64 bit system. -INFO: currently the installer is signed with a public certificate! - ![SVG Setup_Program](./Images/Setup.png) ***For a clean Setup close all the windows explorer instances which have the preview handler active or the preview handler was used (remember the dll remains in memory until the windows explorer was closed).*** @@ -75,6 +74,14 @@ To manually install the SVGShellExtensions.dll follow these steps: ## Release Notes ## +18 Set 2022: ver. 2.9.0 +- Fixed Preview size in multi-monitor +- Fixed flickering of Preview + +13 Set 2022: ver. 2.8.0 +- Fixed load file with blanks in content menu +- Built with Delphi 11.2 + 10 Apr 2022 - Version 2.7.0 - Updated Image32 Library - Built with Delphi 11.1 @@ -173,23 +180,33 @@ Third Party libraries and tools used: - [SynEdit][5] -- [TSVG Library][10] -![Delphi 11 Sydney Support](/Setup/SupportingDelphi.jpg) +![Delphi 11 Alexandria Support](/Setup/SupportingDelphi.jpg) -Related links: [embarcadero.com][11] - [learndelphi.org][12] +Related links: [embarcadero.com][10] - [learndelphi.org][11] [1]: https://docs.microsoft.com/en-us/windows/win32/shell/preview-handlers + [2]: https://docs.microsoft.com/en-us/windows/win32/shell/thumbnail-providers + [3]: https://github.com/EtheaDev/SVGShellExtensions/releases/latest/download/SVGShellExtensionsSetup.exe + [4]: https://github.com/EtheaDev/SVGIconImageList + [5]: https://github.com/SynEdit/SynEdit + [6]: https://github.com/RRUZ/vcl-styles-utils + [7]: https://theroadtodelphi.com/ + [8]: https://github.com/RRUZ/delphi-preview-handler + [9]: https://opensource.org/licenses/Apache-2.0 -[10]: https://github.com/EtheaDev/SVGShellExtensions/wiki/Using-The-SVG-Text-Editor -[10]: http://www.mwcs.de -[11]: https://www.embarcadero.com/ -[12]: https://learndelphi.org/ + +[10]: https://www.embarcadero.com/ + +[11]: https://learndelphi.org/ + +[12]: https://github.com/EtheaDev/SVGShellExtensions/wiki/Using-The-SVG-Text-Editor + diff --git a/Setup/Output/SVGShellExtensionsSetup.exe b/Setup/Output/SVGShellExtensionsSetup.exe index 2c596ad..cb508ee 100644 Binary files a/Setup/Output/SVGShellExtensionsSetup.exe and b/Setup/Output/SVGShellExtensionsSetup.exe differ diff --git a/Setup/SVGShellExtensions.iss b/Setup/SVGShellExtensions.iss index 70e5571..073047e 100644 --- a/Setup/SVGShellExtensions.iss +++ b/Setup/SVGShellExtensions.iss @@ -1,7 +1,7 @@ ; Script generated by the Inno Setup Script Wizard. ; SEE THE DOCUMENTATION FOR DETAILS ON CREATING INNO SETUP SCRIPT FILES! #define MyAppName 'SVG Shell Extensions and SVG Text Editor' -#define MyAppVersion '2.7.0' +#define MyAppVersion '2.9.0' [Setup] AppName={#MyAppName} @@ -10,7 +10,7 @@ AppVerName={#MyAppName} {#MyAppVersion} VersionInfoVersion={#MyAppVersion} AppPublisherURL=https://www.ethea.it/ AppSupportURL=https://github.com/EtheaDev/SVGShellExtensions/issues -DefaultDirName={pf}\Ethea\SVGShellExtensions +DefaultDirName={commonpf}\Ethea\SVGShellExtensions OutputBaseFileName=SVGShellExtensionsSetup DisableDirPage=false DefaultGroupName=SVG Shell Extensions @@ -126,7 +126,7 @@ begin begin if (IsUpgrade()) then begin - MsgBox(ExpandConstant('An old version of SVG Shell Extensions was detected. The uninstaller will be executed...'), mbInformation, MB_OK); + MsgBox(ExpandConstant('An old version of "SVG Shell Extensions" was detected. The uninstaller will be executed...'), mbInformation, MB_OK); UnInstallOldVersion(); end; end; diff --git a/Source/DResources.pas b/Source/DResources.pas index 450a39e..0daf778 100644 --- a/Source/DResources.pas +++ b/Source/DResources.pas @@ -28,8 +28,8 @@ interface uses - SysUtils - , Classes + System.SysUtils + , System.Classes , SynHighlighterXML , Vcl.Graphics , Vcl.ImgList diff --git a/Source/EditorMainForm.dfm b/Source/EditorMainForm.dfm index eb7153c..ef74651 100644 --- a/Source/EditorMainForm.dfm +++ b/Source/EditorMainForm.dfm @@ -2,8 +2,8 @@ object frmMain: TfrmMain Left = 250 Top = 217 Caption = 'SVG Text Editor' - ClientHeight = 590 - ClientWidth = 907 + ClientHeight = 589 + ClientWidth = 903 Color = clWindow Ctl3D = False Font.Charset = DEFAULT_CHARSET @@ -11,7 +11,6 @@ object frmMain: TfrmMain Font.Height = -12 Font.Name = 'Segoe UI' Font.Style = [] - OldCreateOrder = False Position = poScreenCenter ShowHint = True OnAfterMonitorDpiChanged = FormAfterMonitorDpiChanged @@ -24,15 +23,14 @@ object frmMain: TfrmMain OnResize = FormResize OnShow = FormShow DesignSize = ( - 907 - 590) - PixelsPerInch = 96 + 903 + 589) TextHeight = 15 object RightSplitter: TSplitter - Left = 651 + Left = 647 Top = 36 Width = 6 - Height = 535 + Height = 534 Align = alRight AutoSnap = False MinSize = 240 @@ -42,8 +40,8 @@ object frmMain: TfrmMain end object StatusBar: TStatusBar Left = 0 - Top = 571 - Width = 907 + Top = 570 + Width = 903 Height = 19 Panels = < item @@ -67,31 +65,37 @@ object frmMain: TfrmMain item Width = 80 end> + ExplicitTop = 569 + ExplicitWidth = 899 end object PageControl: TPageControl Left = 44 Top = 36 - Width = 607 - Height = 535 + Width = 603 + Height = 534 Align = alClient Images = VirtualImageList TabOrder = 1 OnChange = PageControlChange + ExplicitWidth = 599 + ExplicitHeight = 533 end object ImagePanel: TPanel - Left = 657 + Left = 653 Top = 36 Width = 250 - Height = 535 + Height = 534 Align = alRight BevelOuter = bvNone Color = clWhite ParentBackground = False TabOrder = 2 StyleElements = [] + ExplicitLeft = 649 + ExplicitHeight = 533 object StatusSplitter: TSplitter Left = 0 - Top = 497 + Top = 496 Width = 250 Height = 4 Cursor = crVSplit @@ -105,7 +109,7 @@ object frmMain: TfrmMain Left = 0 Top = 172 Width = 250 - Height = 325 + Height = 324 AutoSize = False Align = alClient OnMouseMove = SVGIconImageMouseMove @@ -204,12 +208,13 @@ object frmMain: TfrmMain end object StatusPanel: TPanel Left = 0 - Top = 501 + Top = 500 Width = 250 Height = 34 Align = alBottom ParentBackground = False TabOrder = 2 + ExplicitTop = 499 object StatusImage: TSVGIconImage Left = 1 Top = 1 @@ -224,8 +229,8 @@ object frmMain: TfrmMain AlignWithMargins = True Left = 36 Top = 4 - Width = 4 - Height = 4 + Width = 210 + Height = 26 Align = alClient Alignment = taCenter TabOrder = 0 @@ -236,7 +241,7 @@ object frmMain: TfrmMain Left = 0 Top = 36 Width = 160 - Height = 535 + Height = 534 CloseStyle = svcCompact Color = clHighlight CompactWidth = 44 @@ -249,11 +254,12 @@ object frmMain: TfrmMain OnClosing = SVClosing OnOpened = SVOpened OnOpening = SVOpening + ExplicitHeight = 533 object catMenuItems: TCategoryButtons Left = 0 Top = 0 Width = 160 - Height = 535 + Height = 534 Align = alClient BackgroundGradientDirection = gdVertical BorderStyle = bsNone @@ -354,30 +360,33 @@ object frmMain: TfrmMain OnGetHint = catMenuItemsGetHint OnMouseLeave = catMenuItemsMouseLeave OnMouseMove = catMenuItemsMouseMove + ExplicitHeight = 533 end end object panlTop: TPanel Left = 0 Top = 0 - Width = 907 + Width = 903 Height = 36 Align = alTop BevelOuter = bvNone ParentBackground = False TabOrder = 4 + ExplicitWidth = 899 object lblTitle: TLabel AlignWithMargins = True Left = 40 Top = 3 Width = 79 - Height = 15 + Height = 30 Align = alLeft Caption = 'SVG Text Editor' Layout = tlCenter + ExplicitHeight = 15 end object SettingsToolBar: TToolBar AlignWithMargins = True - Left = 704 + Left = 700 Top = 3 Width = 200 Height = 30 @@ -393,6 +402,7 @@ object frmMain: TfrmMain ParentColor = False TabOrder = 0 Transparent = True + ExplicitLeft = 696 object ColorSettingsToolButton: TToolButton Left = 0 Top = 0 @@ -840,259 +850,215 @@ object frmMain: TfrmMain Top = 192 end object VirtualImageList: TVirtualImageList - DisabledGrayscale = False - DisabledSuffix = '_Disabled' Images = < item CollectionIndex = 0 CollectionName = 'Style' - Disabled = False Name = 'Style' end item CollectionIndex = 1 CollectionName = 'Open' - Disabled = False Name = 'Open' end item CollectionIndex = 2 CollectionName = 'New' - Disabled = False Name = 'New' end item CollectionIndex = 3 CollectionName = 'Close' - Disabled = False Name = 'Close' end item CollectionIndex = 4 CollectionName = 'Close-all' - Disabled = False Name = 'Close-all' end item CollectionIndex = 5 CollectionName = 'Close-all-folder' - Disabled = False Name = 'Close-all-folder' end item CollectionIndex = 6 CollectionName = 'Search' - Disabled = False Name = 'Search' end item CollectionIndex = 7 CollectionName = 'Search-repeat' - Disabled = False Name = 'Search-repeat' end item CollectionIndex = 8 CollectionName = 'Copy' - Disabled = False Name = 'Copy' end item CollectionIndex = 9 CollectionName = 'Paste' - Disabled = False Name = 'Paste' end item CollectionIndex = 10 CollectionName = 'Cut' - Disabled = False Name = 'Cut' end item CollectionIndex = 11 CollectionName = 'Undo' - Disabled = False Name = 'Undo' end item CollectionIndex = 12 CollectionName = 'Save' - Disabled = False Name = 'Save' end item CollectionIndex = 13 CollectionName = 'Save-all' - Disabled = False Name = 'Save-all' end item CollectionIndex = 14 CollectionName = 'Save-as' - Disabled = False Name = 'Save-as' end item CollectionIndex = 15 CollectionName = 'Print' - Disabled = False Name = 'Print' end item CollectionIndex = 16 CollectionName = 'Print-preview' - Disabled = False Name = 'Print-preview' end item CollectionIndex = 17 CollectionName = 'Print-settings' - Disabled = False Name = 'Print-settings' end item CollectionIndex = 18 CollectionName = 'Select-all' - Disabled = False Name = 'Select-all' end item CollectionIndex = 19 CollectionName = 'Reformat' - Disabled = False Name = 'Reformat' end item CollectionIndex = 20 CollectionName = 'Replace' - Disabled = False Name = 'Replace' end item CollectionIndex = 21 CollectionName = 'Settings' - Disabled = False Name = 'Settings' end item CollectionIndex = 22 CollectionName = 'Exit' - Disabled = False Name = 'Exit' end item CollectionIndex = 23 CollectionName = 'about' - Disabled = False Name = 'about' end item CollectionIndex = 24 CollectionName = 'menu' - Disabled = False Name = 'menu' end item CollectionIndex = 25 CollectionName = 'Minus' - Disabled = False Name = 'Minus' end item CollectionIndex = 26 CollectionName = 'plus' - Disabled = False Name = 'plus' end item CollectionIndex = 27 CollectionName = 'back' - Disabled = False Name = 'back' end item CollectionIndex = 28 CollectionName = 'preferences-desktop' - Disabled = False Name = 'preferences-desktop' end item CollectionIndex = 29 CollectionName = 'preferences-desktop-color' - Disabled = False Name = 'preferences-desktop-color' end item CollectionIndex = 30 CollectionName = 'view_details' - Disabled = False Name = 'view_details' end item CollectionIndex = 31 CollectionName = 'left' - Disabled = False Name = 'left' end item CollectionIndex = 32 CollectionName = 'right' - Disabled = False Name = 'right' end item CollectionIndex = 33 CollectionName = 'binoculars' - Disabled = False Name = 'binoculars' end item CollectionIndex = 34 CollectionName = 'whole-page' - Disabled = False Name = 'whole-page' end item CollectionIndex = 35 CollectionName = 'page-width' - Disabled = False Name = 'page-width' end item CollectionIndex = 36 CollectionName = 'svg-logo' - Disabled = False Name = 'svg-logo' end item CollectionIndex = 37 CollectionName = 'svg-logo-gray' - Disabled = False Name = 'svg-logo-gray' end item CollectionIndex = 38 CollectionName = 'export' - Disabled = False Name = 'export' end item CollectionIndex = 46 CollectionName = 'error' - Disabled = False Name = 'error' end item CollectionIndex = 47 CollectionName = 'info' - Disabled = False Name = 'info' end item CollectionIndex = 41 CollectionName = 'Support' - Disabled = False Name = 'Support' end> ImageCollection = dmResources.SVGIconImageCollection diff --git a/Source/EditorMainForm.pas b/Source/EditorMainForm.pas index aab8b18..522b6df 100644 --- a/Source/EditorMainForm.pas +++ b/Source/EditorMainForm.pas @@ -36,7 +36,7 @@ interface ActnMenus, SynCompletionProposal, SynEditTypes, SynEditMiscClasses, SynEditSearch, XPStyleActnCtrls, System.Actions, SVGIconImage, Vcl.Buttons, Vcl.CategoryButtons, Vcl.WinXCtrls, System.ImageList, Vcl.VirtualImageList, - uSVGSettings + uSettings , Vcl.PlatformVclStylesActnCtrls , Vcl.Styles.Fixes , Vcl.Styles.FormStyleHooks @@ -53,6 +53,8 @@ interface , Vcl.Styles.Utils.StdCtrls , Vcl.Styles.Ext , uDragDropUtils + , dlgExportPNG + , SVGIconUtils ; const @@ -277,6 +279,8 @@ TfrmMain = class(TForm, IDragDrop) FEditorOptions: TSynEditorOptionsContainer; FFontSize: Integer; FDropTarget: TDropTarget; + procedure OnExportToPng(const ASizes: TPngExportSizes; const SVGText: string; + const AFolder, AFormat: string; ACustomSize: Integer); // implement IDragDrop function DropAllowed(const FileNames: array of string): Boolean; procedure Drop(const FileNames: array of string); @@ -335,8 +339,7 @@ implementation , FSynHighlightProp , Math , Winapi.SHFolder - , dlgExportPNG - , SVGSettings + , SettingsForm ; {$R *.dfm} @@ -452,6 +455,12 @@ function TfrmMain.AcceptedExtensions: string; Result := '.svg;.xml'; end; +procedure TfrmMain.OnExportToPng(const ASizes: TPngExportSizes; const SVGText: string; + const AFolder, AFormat: string; ACustomSize: Integer); +begin + FEditorSettings.UpdateExportToPngSettings(ASizes, AFolder, AFormat, ACustomSize); +end; + function TfrmMain.OpenFile(const FileName : string; const ARaiseError: Boolean = True): Boolean; var @@ -734,7 +743,14 @@ procedure TfrmMain.ExportToPNGActionExecute(Sender: TObject); LFileName: string; begin LFileName := ChangeFileExt(CurrentEditFile.FileName, '.png'); - ExportToPNG(DialogPosRect, LFileName, SVGIconImage.SVGText, True); + dlgExportPNG.ExportToPNG(DialogPosRect, + LFileName, + SVGIconImage.SVGText, + True, + FEditorSettings.PngExportCustomSize, + FEditorSettings.PngExportFormat, + FEditorSettings.PngExportSizes, + OnExportToPng); end; procedure TfrmMain.acSearchExecute(Sender: TObject); @@ -951,52 +967,52 @@ procedure TfrmMain.SynEditEnter(Sender: TObject); function TfrmMain.AddEditingFile(EditingFile: TEditingFile): Integer; var - ts : TTabSheet; - Editor : TSynEdit; + LTabSheet : TTabSheet; + LEditor : TSynEdit; begin //Add file to opened-list Result := EditFileList.Add(EditingFile); //Create the Tabsheet page associated to the file - ts := nil; - Editor := nil; + LTabSheet := nil; + LEditor := nil; Try - ts := TTabSheet.Create(self); - ts.PageControl := PageControl; + LTabSheet := TTabSheet.Create(self); + LTabSheet.PageControl := PageControl; //Use TAG of tabsheet to store the object pointer - ts.Tag := Integer(EditingFile); - ts.Caption := EditingFile.Name; - ts.Imagename := 'svg-logo-gray'; - ts.Parent := PageControl; - ts.TabVisible := True; - EditingFile.TabSheet := ts; + LTabSheet.Tag := NativeInt(EditingFile); + LTabSheet.Caption := EditingFile.Name; + LTabSheet.Imagename := 'svg-logo-gray'; + LTabSheet.Parent := PageControl; + LTabSheet.TabVisible := True; + EditingFile.TabSheet := LTabSheet; //Create the SynEdit object editor into the TabSheet that is the owner - Editor := TSynEdit.Create(ts); - Editor.OnChange := SynEditChange; - Editor.OnEnter := SynEditEnter; - Editor.MaxUndo := 5000; - Editor.Align := alClient; - Editor.Parent := ts; - Editor.SearchEngine := SynEditSearch; - Editor.PopupMenu := popEditor; + LEditor := TSynEdit.Create(LTabSheet); + LEditor.OnChange := SynEditChange; + LEditor.OnEnter := SynEditEnter; + LEditor.MaxUndo := 5000; + LEditor.Align := alClient; + LEditor.Parent := LTabSheet; + LEditor.SearchEngine := SynEditSearch; + LEditor.PopupMenu := popEditor; //Assign user preferences to the editor - FEditorOptions.AssignTo(Editor); - Editor.MaxScrollWidth := 3000; - EditingFile.SynEditor := Editor; - UpdateFromSettings(Editor); - UpdateHighlighter(Editor); - Editor.Visible := True; + FEditorOptions.AssignTo(LEditor); + LEditor.MaxScrollWidth := 3000; + EditingFile.SynEditor := LEditor; + UpdateFromSettings(LEditor); + UpdateHighlighter(LEditor); + LEditor.Visible := True; //Show the tabsheet - ts.Visible := True; + LTabSheet.Visible := True; Except - ts.Free; - Editor.Free; + LTabSheet.Free; + LEditor.Free; raise; End; //Make the Tabsheet the current page - PageControl.ActivePage := ts; + PageControl.ActivePage := LTabSheet; //and call "change" of pagecontrol PageControl.OnChange(PageControl); @@ -1147,6 +1163,7 @@ procedure TfrmMain.acCloseAllExecute(Sender: TObject); finally FProcessingFiles := False; AssignSVGToImage; + UpdateStatusBarPanels; end; end; @@ -1263,10 +1280,11 @@ procedure TfrmMain.SetEditorFontSize(const Value: Integer); if (CurrentEditor <> nil) and (Value >= MinfontSize) and (Value <= MaxfontSize) then begin if FFontSize <> 0 then - LScaleFactor := CurrentEditor.Font.Size / FFontSize + LScaleFactor := CurrentEditor.Font.Height / FFontSize else LScaleFactor := 1; - CurrentEditor.Font.Size := Round(Value * LScaleFactor); + CurrentEditor.Font.PixelsPerInch := Self.PixelsPerInch; + CurrentEditor.Font.Height := Round(Value * LScaleFactor * Self.ScaleFactor); FEditorSettings.FontSize := Value; end; FFontSize := Value; @@ -1417,14 +1435,17 @@ procedure TfrmMain.RecentPopupMenuPopup(Sender: TObject); for I := 0 to FEditorSettings.HistoryFileList.Count -1 do begin LFileName := FEditorSettings.HistoryFileList.Strings[I]; - LMenuItem := TMenuItem.Create(nil); - if Length(LFileName) > 100 then - LMenuItem.Caption := Copy(LFileName,1,20)+'...'+RightStr(LFileName, 80) - else - LMenuItem.Caption := LFileName; - LMenuItem.Hint := LFileName; - LMenuItem.OnClick := HistoryListClick; - RecentPopupMenu.Items.Add(LMenuItem); + if FileExists(LFileName) then + begin + LMenuItem := TMenuItem.Create(nil); + if Length(LFileName) > 100 then + LMenuItem.Caption := Copy(LFileName,1,20)+'...'+RightStr(LFileName, 80) + else + LMenuItem.Caption := LFileName; + LMenuItem.Hint := LFileName; + LMenuItem.OnClick := HistoryListClick; + RecentPopupMenu.Items.Add(LMenuItem); + end; end; end; @@ -1459,6 +1480,7 @@ procedure TfrmMain.UpdateStatusBarPanels; StatusBar.Panels[STATUSBAR_PANEL_CARET].Text := ''; StatusBar.Panels[STATUSBAR_PANEL_MODIFIED].Text := ''; StatusBar.Panels[STATUSBAR_PANEL_STATE].Text := ''; + StatusBar.Panels[STATUSBAR_MESSAGE].Text := ''; end; end; diff --git a/Source/FSplash.dfm b/Source/FSplash.dfm index 82d3569..5ffae38 100644 Binary files a/Source/FSplash.dfm and b/Source/FSplash.dfm differ diff --git a/Source/SVGPreviewForm.dfm b/Source/PreviewForm.dfm similarity index 81% rename from Source/SVGPreviewForm.dfm rename to Source/PreviewForm.dfm index 9e77539..a6eaae2 100644 --- a/Source/SVGPreviewForm.dfm +++ b/Source/PreviewForm.dfm @@ -1,26 +1,19 @@ -object FrmPreview: TFrmPreview +inherited FrmPreview: TFrmPreview Left = 522 Top = 286 - ClientHeight = 543 - ClientWidth = 531 - Color = clBtnFace + ClientHeight = 617 + ClientWidth = 617 DoubleBuffered = True - Font.Charset = DEFAULT_CHARSET - Font.Color = clWindowText - Font.Height = -11 Font.Name = 'Segoe UI' - Font.Style = [] - OldCreateOrder = False OnAfterMonitorDpiChanged = FormAfterMonitorDpiChanged - OnCreate = FormCreate - OnDestroy = FormDestroy OnResize = FormResize - PixelsPerInch = 96 + ExplicitWidth = 629 + ExplicitHeight = 655 TextHeight = 13 object Splitter: TSplitter Left = 0 Top = 329 - Width = 531 + Width = 617 Height = 6 Cursor = crVSplit Align = alTop @@ -32,26 +25,27 @@ object FrmPreview: TFrmPreview object PanelTop: TPanel Left = 0 Top = 0 - Width = 531 + Width = 617 Height = 35 Align = alTop BevelOuter = bvNone TabOrder = 0 + ExplicitWidth = 613 object ToolBar: TToolBar Left = 0 Top = 0 - Width = 531 + Width = 617 Height = 35 Align = alClient AutoSize = True ButtonHeight = 30 - ButtonWidth = 87 + ButtonWidth = 35 EdgeInner = esNone EdgeOuter = esNone Images = SVGIconImageList List = True - ShowCaptions = True TabOrder = 0 + ExplicitWidth = 613 object ToolButtonShowText: TToolButton Left = 0 Top = 0 @@ -66,7 +60,7 @@ object FrmPreview: TFrmPreview OnMouseLeave = ToolButtonMouseLeave end object ToolButtonSettings: TToolButton - Left = 85 + Left = 35 Top = 0 Cursor = crHandPoint Hint = 'Preview settings...' @@ -80,7 +74,7 @@ object FrmPreview: TFrmPreview OnMouseLeave = ToolButtonMouseLeave end object ToolButtonAbout: TToolButton - Left = 175 + Left = 70 Top = 0 Cursor = crHandPoint Hint = 'Show about...' @@ -93,17 +87,10 @@ object FrmPreview: TFrmPreview OnMouseEnter = ToolButtonMouseEnter OnMouseLeave = ToolButtonMouseLeave end - object SeparatorEditor: TToolButton - Left = 255 - Top = 0 - Width = 8 - Caption = 'SeparatorEditor' - ImageName = 'settings' - Style = tbsSeparator - end object ToolButtonReformat: TToolButton - Left = 263 + Left = 105 Top = 0 + Cursor = crHandPoint Hint = 'Reformat XML text' AutoSize = True Caption = 'Format' @@ -113,8 +100,16 @@ object FrmPreview: TFrmPreview OnMouseEnter = ToolButtonMouseEnter OnMouseLeave = ToolButtonMouseLeave end + object SeparatorEditor: TToolButton + Left = 140 + Top = 0 + Width = 8 + Caption = 'SeparatorEditor' + ImageName = 'settings' + Style = tbsSeparator + end object ToolButtonZoomIn: TToolButton - Left = 338 + Left = 148 Top = 0 Cursor = crHandPoint Hint = 'Zoom in (increase font size)' @@ -128,7 +123,7 @@ object FrmPreview: TFrmPreview OnMouseLeave = ToolButtonMouseLeave end object ToolButtonZommOut: TToolButton - Left = 419 + Left = 183 Top = 0 Cursor = crHandPoint Hint = 'Zoom out (decrease font size)' @@ -146,16 +141,16 @@ object FrmPreview: TFrmPreview object PanelEditor: TPanel Left = 0 Top = 35 - Width = 531 + Width = 617 Height = 294 Align = alTop BevelOuter = bvNone - Caption = 'PanelEditor' TabOrder = 1 + ExplicitWidth = 613 object SynEdit: TSynEdit Left = 0 Top = 0 - Width = 531 + Width = 617 Height = 294 Align = alClient Font.Charset = DEFAULT_CHARSET @@ -182,50 +177,56 @@ object FrmPreview: TFrmPreview Gutter.ShowLineNumbers = True ReadOnly = True FontSmoothing = fsmNone + ExplicitTop = 6 + ExplicitWidth = 218 + ExplicitHeight = 185 end end object StatusBar: TStatusBar Left = 0 - Top = 524 - Width = 531 + Top = 598 + Width = 617 Height = 19 Panels = <> ParentFont = True SimplePanel = True SimpleText = - ' SVG Preview - Copyright '#169' 2021 - Ethea S.r.l. - Author: Carlo B' + - 'arazzetta' - SizeGrip = False + ' SVG Preview - Ver.%s (%dbit)- Copyright '#169' 2021-2022 Ethea S.r.l' + + '. - Author: Carlo Barazzetta' UseSystemFont = False + ExplicitTop = 597 + ExplicitWidth = 613 end object ImagePanel: TPanel Left = 0 Top = 335 - Width = 531 - Height = 189 + Width = 617 + Height = 263 Align = alClient BevelOuter = bvNone ParentBackground = False TabOrder = 3 StyleElements = [] + ExplicitWidth = 613 + ExplicitHeight = 262 object SVGIconImage: TSVGIconImage Left = 0 Top = 40 - Width = 531 - Height = 149 + Width = 617 + Height = 223 AutoSize = False - Proportional = True Align = alClient end object panelPreview: TPanel Left = 0 Top = 0 - Width = 531 + Width = 617 Height = 40 Align = alTop ParentBackground = False ShowCaption = False - TabOrder = 1 + TabOrder = 0 + ExplicitWidth = 613 object BackgroundGrayScaleLabel: TLabel Left = 10 Top = 6 @@ -239,7 +240,7 @@ object FrmPreview: TFrmPreview AlignWithMargins = True Left = 81 Top = 4 - Width = 446 + Width = 532 Height = 32 Margins.Left = 80 Align = alClient @@ -249,83 +250,70 @@ object FrmPreview: TFrmPreview TabOrder = 0 TabStop = False OnChange = BackgroundTrackBarChange + ExplicitWidth = 528 end end end object SVGIconImageList: TVirtualImageList - DisabledGrayscale = False - DisabledSuffix = '_Disabled' Images = < item CollectionIndex = 42 CollectionName = 'Show-Text' - Disabled = False Name = 'Show-Text' end item CollectionIndex = 43 CollectionName = 'Hide-Text' - Disabled = False Name = 'Hide-Text' end item CollectionIndex = 23 CollectionName = 'about' - Disabled = False Name = 'about' end item CollectionIndex = 41 CollectionName = 'Support' - Disabled = False Name = 'Support' end item CollectionIndex = 0 CollectionName = 'Style' - Disabled = False Name = 'Style' end item CollectionIndex = 45 CollectionName = 'Services' - Disabled = False Name = 'Services' end item CollectionIndex = 26 CollectionName = 'plus' - Disabled = False Name = 'plus' end item CollectionIndex = 25 CollectionName = 'Minus' - Disabled = False Name = 'Minus' end item CollectionIndex = 6 CollectionName = 'Search' - Disabled = False Name = 'Search' end item CollectionIndex = 38 CollectionName = 'export' - Disabled = False Name = 'export' end item CollectionIndex = 19 CollectionName = 'Reformat' - Disabled = False Name = 'Reformat' end item CollectionIndex = 28 CollectionName = 'preferences-desktop' - Disabled = False Name = 'preferences-desktop' end> ImageCollection = dmResources.SVGIconImageCollection diff --git a/Source/SVGPreviewForm.pas b/Source/PreviewForm.pas similarity index 91% rename from Source/SVGPreviewForm.pas rename to Source/PreviewForm.pas index d45cd3c..dde6fa8 100644 --- a/Source/SVGPreviewForm.pas +++ b/Source/PreviewForm.pas @@ -30,7 +30,7 @@ { All Rights Reserved. } {******************************************************************************} -unit SVGPreviewForm; +unit PreviewForm; interface @@ -42,11 +42,12 @@ interface ComCtrls, ToolWin, ImgList, SynHighlighterXML, Vcl.Menus, SynEditExport, SynExportHTML, SynExportRTF, SynEditMiscClasses, - uSVGSettings, System.ImageList, SynEditCodeFolding, - SVGIconImageList, SVGIconImageListBase, SVGIconImage, Vcl.VirtualImageList; + uSettings, System.ImageList, SynEditCodeFolding, + SVGIconImageList, SVGIconImageListBase, SVGIconImage, Vcl.VirtualImageList, + UPreviewContainer; type - TFrmPreview = class(TForm) + TFrmPreview = class(TPreviewContainer) SynEdit: TSynEdit; PanelTop: TPanel; PanelEditor: TPanel; @@ -130,12 +131,13 @@ implementation , GraphUtil , uAbout , Xml.XMLDoc - , SVGSettings + , SettingsForm , DResources ; {$R *.dfm} - { TFrmEditor } + + { TFrmPreview } procedure TFrmPreview.AppException(Sender: TObject; E: Exception); begin @@ -172,10 +174,7 @@ destructor TFrmPreview.Destroy; function TFrmPreview.DialogPosRect: TRect; begin - if Self.Parent <> nil then - GetWindowRect(Self.Parent.ParentWindow, Result) - else - Result := TRect.Create(0,0,0,0); + Result := ClientToScreen(ActualRect); end; procedure TFrmPreview.UpdateGUI; @@ -229,15 +228,20 @@ procedure TFrmPreview.UpdateHighlighter; procedure TFrmPreview.FormAfterMonitorDpiChanged(Sender: TObject; OldDPI, NewDPI: Integer); begin - TLogPreview.Add('TFrmEditor.FormAfterMonitorDpiChanged: '+ + TLogPreview.Add('TFrmPreview.FormAfterMonitorDpiChanged: '+ '- Old: '+OldDPI.ToString+' - New: '+NewDPI.ToString); end; procedure TFrmPreview.FormCreate(Sender: TObject); +var + FileVersionStr: string; begin - TLogPreview.Add('TFrmEditor.FormCreate'); + TLogPreview.Add('TFrmPreview.FormCreate'); + FileVersionStr := uMisc.GetFileVersion(GetModuleLocation()); + FSimpleText := Format(StatusBar.SimpleText, + [FileVersionStr, {$IFDEF WIN32}32{$ELSE}64{$ENDIF}]); + StatusBar.SimpleText := FSimpleText; Application.OnException := AppException; - FSimpleText := StatusBar.SimpleText; UpdateFromSettings; end; @@ -245,7 +249,7 @@ procedure TFrmPreview.FormDestroy(Sender: TObject); begin HideAboutForm; SaveSettings; - TLogPreview.Add('TFrmEditor.FormDestroy'); + TLogPreview.Add('TFrmPreview.FormDestroy'); inherited; end; @@ -262,7 +266,7 @@ procedure TFrmPreview.FormResize(Sender: TObject); procedure TFrmPreview.LoadFromFile(const AFileName: string); begin - TLogPreview.Add('TFrmEditor.LoadFromFile Init'); + TLogPreview.Add('TFrmPreview.LoadFromFile Init'); FFileName := AFileName; SynEdit.Lines.LoadFromFile(FFileName); SVGIconImage.SVGText := SynEdit.Lines.Text; @@ -273,7 +277,7 @@ procedure TFrmPreview.LoadFromStream(const AStream: TStream); var LStringStream: TStringStream; begin - TLogPreview.Add('TFrmEditor.LoadFromStream Init'); + TLogPreview.Add('TFrmPreview.LoadFromStream Init'); AStream.Position := 0; LStringStream := TStringStream.Create('',TEncoding.UTF8); try @@ -340,6 +344,8 @@ procedure TFrmPreview.SplitterMoved(Sender: TObject); procedure TFrmPreview.ToolButtonShowTextClick(Sender: TObject); begin PanelEditor.Visible := not PanelEditor.Visible; + SynEdit.Visible := PanelEditor.Visible; + ToolBar.Invalidate; UpdateGUI; SaveSettings; end; diff --git a/Source/SVGShellExtensions.dpr b/Source/SVGShellExtensions.dpr index b30d229..5e4c42b 100644 --- a/Source/SVGShellExtensions.dpr +++ b/Source/SVGShellExtensions.dpr @@ -45,9 +45,9 @@ uses uSVGThumbnailHandler in 'uSVGThumbnailHandler.pas', uThumbnailHandlerRegister in 'uThumbnailHandlerRegister.pas', uSVGContextMenuHandler in 'uSVGContextMenuHandler.pas', - SVGPreviewForm in 'SVGPreviewForm.pas' {FrmPreview}, - SVGSettings in 'SVGSettings.pas' {SVGSettingsForm}, - uSVGSettings in 'uSVGSettings.pas', + PreviewForm in 'PreviewForm.pas' {FrmPreview}, + SettingsForm in 'SettingsForm.pas' {UserSettingsForm}, + uSettings in 'uSettings.pas', DResources in 'DResources.pas' {dmResources: TDataModule}, dlgSearchText in 'dlgSearchText.pas' {TextSearchDialog}, uAbout in 'uAbout.pas' {FrmAbout}; diff --git a/Source/SVGShellExtensions.dproj b/Source/SVGShellExtensions.dproj index b3ea51a..fbb5d6f 100644 --- a/Source/SVGShellExtensions.dproj +++ b/Source/SVGShellExtensions.dproj @@ -3,7 +3,7 @@ {8F3F28E2-735C-49BE-8B07-1DB5F21482E8} Release DCC32 - 19.4 + 19.5 VCL True Win64 @@ -58,7 +58,7 @@ ..\Icons\logo.ico $(BDS)\bin\default_app.manifest 1033 - CompanyName=Ethea S.r.l.;FileDescription=SVG Shell Extensions 64bit;FileVersion=2.7.0.0;InternalName=;LegalCopyright=Copyright © 2021-2022 Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SVG Shell Extensions 64bit;ProductVersion=2.7;Comments= + CompanyName=Ethea S.r.l.;FileDescription=SVG Shell Extensions 64bit;FileVersion=2.9.0.0;InternalName=;LegalCopyright=Copyright © 2021-2022 Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SVG Shell Extensions 64bit;ProductVersion=2.9;Comments= Glow|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Glow.vsf;Sky|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Sky.vsf;Windows10|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10.vsf;"Windows10 Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Dark.vsf";"Windows10 SlateGray|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10SlateGray.vsf";"Windows11 Modern Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Dark.vsf";"Windows11 Modern Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Light.vsf";"Flat UI Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\FlatUILight.vsf";"Windows10 BlackPearl|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlackPearl.vsf";"Windows10 Blue Whale|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhale.vsf";"Windows10 Blue Whale LE|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhaleLE.vsf";"Windows10 Clear Day|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10ClearDay.vsf";"Windows10 Malibu|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Malibu.vsf" rtl;vcl;vclx;vclactnband;xmlrtl;VclSmp;vclimg;svnui;svn;bdertl;TeeUI;TeeDB;Tee;vcldb;dbrtl;vcldbx;vcltouch;dsnap;dsnapcon;vclib;ibxpress;adortl;IndyCore;IndySystem;IndyProtocols;inet;intrawebdb_110_150;Intraweb_110_150;vclie;websnap;webdsnap;inetdb;inetdbbde;inetdbxpress;soaprtl;vclribbon;dbexpress;DbxCommonDriver;DataSnapIndy10ServerTransport;DataSnapProviderClient;DbxClientDriver;DataSnapClient;dbxcds;DataSnapServer;AzureCloud;DBXInterBaseDriver;DBXMySQLDriver;DBXFirebirdDriver;DBXSybaseASEDriver;DBXSybaseASADriver;DBXOracleDriver;DBXMSSQLDriver;DBXInformixDriver;DBXDb2Driver;Hydra_Core_D15;SynEdit_RXE;mbColorLibDXE;JclDeveloperTools;Jcl;JclVcl;JclContainers;JvCore;JvSystem;JvStdCtrls;JvAppFrm;JvBands;JvDB;JvDlgs;JvBDE;JvControls;JvCmp;JvCrypt;JvCustom;JvDocking;JvDotNetCtrls;JvGlobus;JvHMI;JvJans;JvManagedThreads;JvMM;JvNet;JvPageComps;JvPascalInterpreter;JvPluginSystem;JvPrintPreview;JvRuntimeDesign;JvTimeFramework;JvWizards;JvXPCtrls;WinSkinDXE;bsfd2011;IceTabSet;$(DCC_UsePackage) .\$(Config)\$(Platform) @@ -68,7 +68,7 @@ ..\Bin64 true 2 - 7 + 9 D:\ETHEA\SVGShellExtensions\Debug\Preview Handlers\OpenDialog\OpenDialogTest.exe @@ -128,13 +128,13 @@ - +
FrmPreview
 - -
SVGSettingsForm
+ +
UserSettingsForm
 - +
dmResources
TDataModule @@ -199,6 +199,10 @@ c:\temp + Ethea InstantSolutions 7 Rtl Library + Ethea InstantSolutions 7 Vcl Library + Ethea InstantSolutions 7 LibreOffice/OpenOffice Components + Ethea InstantSolutions 7 Framework Library Microsoft Office 2000 Sample Automation Server Wrapper Components Microsoft Office XP Sample Automation Server Wrapper Components @@ -207,25 +211,9 @@ False True - - - - SVGShellExtensions.dll - true - - - - - SVGShellExtensions.dll - true - - - - - SVGShellExtensions.dll - true - - + + + 1 @@ -244,16 +232,6 @@ 64 - - - classes - 1 - - - classes - 1 - - res\xml @@ -577,7 +555,7 @@ 1 .dylib - + 1 .dylib @@ -611,7 +589,7 @@ 0 - + 0 @@ -632,13 +610,17 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -648,71 +630,27 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - - - 1 - - - 1 - - - 1 - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -722,7 +660,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -732,7 +670,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -742,7 +680,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -752,7 +690,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -762,7 +700,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -772,60 +710,27 @@ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - - - 1 - - - 1 - - - 1 - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -835,7 +740,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -845,7 +750,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -855,7 +760,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -865,7 +770,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -875,7 +780,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -885,7 +790,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -895,7 +800,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -917,9 +822,11 @@ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 1 + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + - - @@ -930,11 +837,10 @@ 1 - + 1 - @@ -967,7 +873,7 @@ 1 - + 1 @@ -1024,6 +930,7 @@ + diff --git a/Source/SVGShellExtensions.res b/Source/SVGShellExtensions.res index f4b1aa9..0bfd6b5 100644 Binary files a/Source/SVGShellExtensions.res and b/Source/SVGShellExtensions.res differ diff --git a/Source/SVGShellExtensions32.dpr b/Source/SVGShellExtensions32.dpr index 00235bc..6aeaf34 100644 --- a/Source/SVGShellExtensions32.dpr +++ b/Source/SVGShellExtensions32.dpr @@ -45,12 +45,11 @@ uses uSVGThumbnailHandler in 'uSVGThumbnailHandler.pas', uThumbnailHandlerRegister in 'uThumbnailHandlerRegister.pas', uSVGContextMenuHandler in 'uSVGContextMenuHandler.pas', - SVGPreviewForm in 'SVGPreviewForm.pas' {FrmPreview}, - SVGSettings in 'SVGSettings.pas' {SVGSettingsForm}, - uSVGSettings in 'uSVGSettings.pas', + PreviewForm in 'PreviewForm.pas' {FrmPreview}, + SettingsForm in 'SettingsForm.pas' {UserSettingsForm}, + uSettings in 'uSettings.pas', DResources in 'DResources.pas' {dmResources: TDataModule}, dlgSearchText in 'dlgSearchText.pas' {TextSearchDialog}, - //SVGPreviewPanel in 'SVGPreviewPanel.pas' {FrmPreview}, uAbout in 'uAbout.pas' {FrmAbout}; exports diff --git a/Source/SVGShellExtensions32.dproj b/Source/SVGShellExtensions32.dproj index d43f3e6..684ff00 100644 --- a/Source/SVGShellExtensions32.dproj +++ b/Source/SVGShellExtensions32.dproj @@ -3,7 +3,7 @@ {94AA5932-5147-49A9-8E4A-F04C36007B1C} Debug DCC32 - 19.4 + 19.5 VCL True Win32 @@ -58,7 +58,7 @@ ..\Icons\logo.ico $(BDS)\bin\default_app.manifest 1033 - CompanyName=Ethea S.r.l.;FileDescription=SVG Shell Extensions 32bit;FileVersion=2.7.0.0;InternalName=;LegalCopyright=Copyright © 2021-2022 Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SVG Shell Extensions 32bit;ProductVersion=2.7;Comments= + CompanyName=Ethea S.r.l.;FileDescription=SVG Shell Extensions 32bit;FileVersion=2.9.0.0;InternalName=;LegalCopyright=Copyright © 2021-2022 Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SVG Shell Extensions 32bit;ProductVersion=2.9;Comments= Glow|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Glow.vsf;Sky|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Sky.vsf;Windows10|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10.vsf;"Windows10 Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Dark.vsf";"Windows10 SlateGray|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10SlateGray.vsf";"Windows11 Modern Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Dark.vsf";"Windows11 Modern Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Light.vsf";"Flat UI Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\FlatUILight.vsf";"Windows10 BlackPearl|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlackPearl.vsf";"Windows10 Blue Whale|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhale.vsf";"Windows10 Blue Whale LE|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhaleLE.vsf";"Windows10 Clear Day|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10ClearDay.vsf";"Windows10 Malibu|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Malibu.vsf" rtl;vcl;vclx;vclactnband;xmlrtl;VclSmp;vclimg;svnui;svn;bdertl;TeeUI;TeeDB;Tee;vcldb;dbrtl;vcldbx;vcltouch;dsnap;dsnapcon;vclib;ibxpress;adortl;IndyCore;IndySystem;IndyProtocols;inet;intrawebdb_110_150;Intraweb_110_150;vclie;websnap;webdsnap;inetdb;inetdbbde;inetdbxpress;soaprtl;vclribbon;dbexpress;DbxCommonDriver;DataSnapIndy10ServerTransport;DataSnapProviderClient;DbxClientDriver;DataSnapClient;dbxcds;DataSnapServer;AzureCloud;DBXInterBaseDriver;DBXMySQLDriver;DBXFirebirdDriver;DBXSybaseASEDriver;DBXSybaseASADriver;DBXOracleDriver;DBXMSSQLDriver;DBXInformixDriver;DBXDb2Driver;Hydra_Core_D15;SynEdit_RXE;mbColorLibDXE;JclDeveloperTools;Jcl;JclVcl;JclContainers;JvCore;JvSystem;JvStdCtrls;JvAppFrm;JvBands;JvDB;JvDlgs;JvBDE;JvControls;JvCmp;JvCrypt;JvCustom;JvDocking;JvDotNetCtrls;JvGlobus;JvHMI;JvJans;JvManagedThreads;JvMM;JvNet;JvPageComps;JvPascalInterpreter;JvPluginSystem;JvPrintPreview;JvRuntimeDesign;JvTimeFramework;JvWizards;JvXPCtrls;WinSkinDXE;bsfd2011;IceTabSet;$(DCC_UsePackage) .\$(Config)\$(Platform) @@ -68,7 +68,7 @@ ..\Bin32 true 2 - 7 + 9 D:\ETHEA\SVGShellExtensions\Debug\Preview Handlers\OpenDialog\OpenDialogTest.exe @@ -94,8 +94,8 @@ c:\Windows\SysWoW64 false - D:\ETHEA\SVGShellExtensions\SVGShellExtensions.dll D:\ETHEA\SVGShellExtensions\Debug\Preview Handlers\PreviewHandler Host\Bin\PreviewHost.exe + false true @@ -129,13 +129,13 @@ - +
FrmPreview
 - -
SVGSettingsForm
+ +
UserSettingsForm
 - +
dmResources
TDataModule @@ -200,6 +200,10 @@ c:\temp + Ethea InstantSolutions 7 Rtl Library + Ethea InstantSolutions 7 Vcl Library + Ethea InstantSolutions 7 LibreOffice/OpenOffice Components + Ethea InstantSolutions 7 Framework Library Microsoft Office 2000 Sample Automation Server Wrapper Components Microsoft Office XP Sample Automation Server Wrapper Components @@ -208,31 +212,10 @@ True False - - - - SVGShellExtensions32.dll - true - - - - - SVGShellExtensions32.dll - true - - - - - SVGShellExtensions32.dll - true - - - - - SVGShellExtensions32.dll - true - - + + + + 1 @@ -251,16 +234,6 @@ 64 - - - classes - 1 - - - classes - 1 - - res\xml @@ -584,7 +557,7 @@ 1 .dylib - + 1 .dylib @@ -618,7 +591,7 @@ 0 - + 0 @@ -639,13 +612,17 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -655,71 +632,27 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - - - 1 - - - 1 - - - 1 - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -729,7 +662,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -739,7 +672,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -749,7 +682,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -759,7 +692,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -769,7 +702,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -779,60 +712,27 @@ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - - - 1 - - - 1 - - - 1 - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - - - 1 - - - 1 - - - 1 - - - - - 1 - - - 1 - - - 1 - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -842,7 +742,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -852,7 +752,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -862,7 +762,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -872,7 +772,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -882,7 +782,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -892,7 +792,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -902,7 +802,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -924,9 +824,11 @@ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 1 + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + - - @@ -937,11 +839,10 @@ 1 - + 1 - @@ -974,7 +875,7 @@ 1 - + 1 @@ -1031,6 +932,7 @@ + diff --git a/Source/SVGShellExtensions32.res b/Source/SVGShellExtensions32.res index 24515f7..fb91ca2 100644 Binary files a/Source/SVGShellExtensions32.res and b/Source/SVGShellExtensions32.res differ diff --git a/Source/SVGShellExtensionsGroup.groupproj b/Source/SVGShellExtensionsGroup.groupproj new file mode 100644 index 0000000..c5f0b45 --- /dev/null +++ b/Source/SVGShellExtensionsGroup.groupproj @@ -0,0 +1,60 @@ + + + {68E0D2A4-9F7D-409B-9373-BA6AC49A07FE} + + + + + + + + + + + + + + Default.Personality.12 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Source/SVGTextEditor.dpr b/Source/SVGTextEditor.dpr index f8d53b8..f9c7cac 100644 --- a/Source/SVGTextEditor.dpr +++ b/Source/SVGTextEditor.dpr @@ -47,8 +47,8 @@ uses Vcl.Themes, Vcl.Styles, SynEditOptionsDialog in 'SynEditOptionsDialog.pas' {fmEditorOptionsDialog}, - uSVGSettings in 'uSVGSettings.pas', - SVGSettings in 'SVGSettings.pas' {SVGSettingsForm}, + uSettings in 'uSettings.pas', + SettingsForm in 'SettingsForm.pas' {UserSettingsForm}, uRegistry in 'uRegistry.pas'; {$R *.res} diff --git a/Source/SVGTextEditor.dproj b/Source/SVGTextEditor.dproj index 94942fc..e3a18b9 100644 --- a/Source/SVGTextEditor.dproj +++ b/Source/SVGTextEditor.dproj @@ -5,7 +5,7 @@ Release DCC32 ..\..\exe\InstantXMLEditor.exe - 19.4 + 19.5 Debug VCL True @@ -67,7 +67,7 @@ ..\Icons\logo.ico $(BDS)\bin\default_app.manifest 1033 - CompanyName=Ethea S.r.l.;FileDescription=SVG Text Editor;FileVersion=2.7.0.0;InternalName=;LegalCopyright=Copyright © 2021-2022 - Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SVG Text Editor;ProductVersion=2.7;Comments= + CompanyName=Ethea S.r.l.;FileDescription=SVG Text Editor;FileVersion=2.9.0.0;InternalName=;LegalCopyright=Copyright © 2021-2022 - Ethea S.r.l.;LegalTrademarks=;OriginalFilename=;ProductName=SVG Text Editor;ProductVersion=2.9;Comments= Glow|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Glow.vsf;Sky|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Sky.vsf;Windows10|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10.vsf;"Windows10 Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Dark.vsf";"Windows10 SlateGray|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10SlateGray.vsf";"Windows11 Modern Dark|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Dark.vsf";"Windows11 Modern Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows11_Modern_Light.vsf";"Flat UI Light|VCLSTYLE|$(BDSCOMMONDIR)\Styles\FlatUILight.vsf";"Windows10 BlackPearl|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlackPearl.vsf";"Windows10 Blue Whale|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhale.vsf";"Windows10 Blue Whale LE|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10BlueWhaleLE.vsf";"Windows10 Clear Day|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10ClearDay.vsf";"Windows10 Malibu|VCLSTYLE|$(BDSCOMMONDIR)\Styles\Windows10Malibu.vsf" 0 false @@ -77,7 +77,7 @@ ..\..\exe\InstantXMLEditor.exe VCLSTYLEUTILS;$(DCC_Define) 2 - 7 + 9 System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Bde;$(DCC_Namespace) @@ -130,7 +130,6 @@ Debug - true PerMonitorV2 3 2 @@ -172,6 +171,10 @@ SVGTextEditor.dpr + Ethea InstantSolutions 7 Rtl Library + Ethea InstantSolutions 7 Vcl Library + Ethea InstantSolutions 7 LibreOffice/OpenOffice Components + Ethea InstantSolutions 7 Framework Library Microsoft Office 2000 Sample Automation Server Wrapper Components Microsoft Office XP Sample Automation Server Wrapper Components @@ -180,19 +183,8 @@ True True - - - - SVGTextEditor.exe - true - - - - - SVGTextEditor.exe - true - - + + 1 @@ -211,16 +203,6 @@ 64 - - - classes - 1 - - - classes - 1 - - res\xml @@ -544,7 +526,7 @@ 1 .dylib - + 1 .dylib @@ -578,7 +560,7 @@ 0 - + 0 @@ -599,13 +581,17 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 + + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset + 1 + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -615,7 +601,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -625,7 +611,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -635,7 +621,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -645,7 +631,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -655,7 +641,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -665,7 +651,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -675,7 +661,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -685,7 +671,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -695,7 +681,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -705,7 +691,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -715,7 +701,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -725,7 +711,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset 1 @@ -735,7 +721,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -745,7 +731,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -755,7 +741,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -765,7 +751,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -775,7 +761,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -785,7 +771,7 @@ ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 - + ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset 1 @@ -807,6 +793,10 @@ ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF 1 + + ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF + 1 + @@ -818,7 +808,7 @@ 1 - + 1 @@ -854,7 +844,7 @@ 1 - + 1 @@ -911,6 +901,7 @@ + @@ -958,9 +949,9 @@
fmEditorOptionsDialog
 - - -
SVGSettingsForm
+ + +
UserSettingsForm
 diff --git a/Source/SVGTextEditor.res b/Source/SVGTextEditor.res index a4ac03d..2eb3f55 100644 Binary files a/Source/SVGTextEditor.res and b/Source/SVGTextEditor.res differ diff --git a/Source/SVGSettings.dfm b/Source/SettingsForm.dfm similarity index 86% rename from Source/SVGSettings.dfm rename to Source/SettingsForm.dfm index 2bb1d24..ab81941 100644 --- a/Source/SVGSettings.dfm +++ b/Source/SettingsForm.dfm @@ -1,4 +1,4 @@ -object SVGSettingsForm: TSVGSettingsForm +object UserSettingsForm: TUserSettingsForm Left = 259 Top = 148 BorderIcons = [biSystemMenu] @@ -18,7 +18,6 @@ object SVGSettingsForm: TSVGSettingsForm ShowHint = True OnCreate = FormCreate OnDestroy = FormDestroy - PixelsPerInch = 96 TextHeight = 15 object TLabel Left = 4 @@ -29,30 +28,27 @@ object SVGSettingsForm: TSVGSettingsForm object pc: TPageControl Left = 153 Top = 41 - Width = 662 + Width = 666 Height = 451 - ActivePage = stGeneral + ActivePage = tsColors Align = alClient Images = SettingsImageList TabOrder = 0 object tsColors: TTabSheet Caption = 'Text color' ImageName = 'palette' - TabVisible = False object VertSplitter: TSplitter - Left = 193 + Left = 143 Top = 0 Width = 4 - Height = 441 + Height = 366 MinSize = 100 - ExplicitLeft = 143 - ExplicitHeight = 366 end object paLeft: TPanel Left = 0 - Top = 0 + Top = 25 Width = 193 - Height = 441 + Height = 377 Align = alLeft BevelOuter = bvNone TabOrder = 0 @@ -60,7 +56,7 @@ object SVGSettingsForm: TSVGSettingsForm Left = 0 Top = 0 Width = 193 - Height = 283 + Height = 219 Align = alClient BevelOuter = bvLowered TabOrder = 0 @@ -68,7 +64,7 @@ object SVGSettingsForm: TSVGSettingsForm Left = 1 Top = 17 Width = 191 - Height = 265 + Height = 201 Align = alClient BevelOuter = bvNone ItemHeight = 15 @@ -88,7 +84,7 @@ object SVGSettingsForm: TSVGSettingsForm end object ElementColorGroupBox: TGroupBox Left = 0 - Top = 283 + Top = 219 Width = 193 Height = 116 Align = alBottom @@ -138,7 +134,7 @@ object SVGSettingsForm: TSVGSettingsForm end object ResetPanel: TPanel Left = 0 - Top = 399 + Top = 335 Width = 193 Height = 42 Align = alBottom @@ -160,9 +156,9 @@ object SVGSettingsForm: TSVGSettingsForm end object paAttributesContainer: TPanel Left = 197 - Top = 0 + Top = 25 Width = 457 - Height = 441 + Height = 377 Align = alClient BevelOuter = bvNone TabOrder = 1 @@ -255,7 +251,7 @@ object SVGSettingsForm: TSVGSettingsForm Left = 0 Top = 65 Width = 457 - Height = 376 + Height = 312 Align = alClient Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText @@ -281,29 +277,37 @@ object SVGSettingsForm: TSVGSettingsForm FontSmoothing = fsmNone end end + object PanelTopEditor: TPanel + Left = 0 + Top = 0 + Width = 654 + Height = 25 + Align = alTop + Caption = 'EDITOR COLOR SETTINGS' + TabOrder = 2 + end end object tsFont: TTabSheet Caption = 'Font' ImageIndex = 1 ImageName = 'alphabetical-variant' - TabVisible = False object FontLabel: TLabel Left = 8 - Top = 8 + Top = 33 Width = 57 Height = 15 Caption = 'Font name' end object SizeLabel: TLabel Left = 8 - Top = 54 + Top = 79 Width = 20 Height = 15 Caption = 'Size' end object CbFont: TComboBox Left = 8 - Top = 25 + Top = 50 Width = 225 Height = 22 Style = csOwnerDrawFixed @@ -313,7 +317,7 @@ object SVGSettingsForm: TSVGSettingsForm end object EditFontSize: TEdit Left = 8 - Top = 71 + Top = 96 Width = 34 Height = 23 Alignment = taRightJustify @@ -323,7 +327,7 @@ object SVGSettingsForm: TSVGSettingsForm end object FontSizeUpDown: TUpDown Left = 42 - Top = 71 + Top = 96 Width = 16 Height = 23 Associate = EditFontSize @@ -332,17 +336,25 @@ object SVGSettingsForm: TSVGSettingsForm Position = 12 TabOrder = 2 end + object PanelTopFont: TPanel + Left = 0 + Top = 0 + Width = 654 + Height = 25 + Align = alTop + Caption = 'FONT SELECTION AND SIZE' + TabOrder = 3 + end end object stTheme: TTabSheet Caption = 'Theme' ImageIndex = 2 ImageName = 'theme-light-dark' - TabVisible = False object ThemeLeftPanel: TPanel Left = 0 - Top = 0 + Top = 25 Width = 185 - Height = 441 + Height = 377 Align = alLeft BevelOuter = bvNone TabOrder = 0 @@ -365,7 +377,7 @@ object SVGSettingsForm: TSVGSettingsForm Left = 0 Top = 118 Width = 185 - Height = 323 + Height = 259 Align = alClient Caption = 'Selected Theme' TabOrder = 1 @@ -374,46 +386,55 @@ object SVGSettingsForm: TSVGSettingsForm end object ThemeClientPanel: TPanel Left = 185 - Top = 0 + Top = 25 Width = 469 - Height = 441 + Height = 377 Align = alClient BevelOuter = bvNone TabOrder = 1 StyleElements = [] end + object PanelTopTheme: TPanel + Left = 0 + Top = 0 + Width = 654 + Height = 25 + Align = alTop + Caption = 'THEME SELECTION' + TabOrder = 2 + end end object stGeneral: TTabSheet Caption = 'Preview settings' ImageIndex = 3 ImageName = 'arrow-left' - TabVisible = False - object RenderingGroupBox: TGroupBox - Left = 3 - Top = 3 - Width = 310 - Height = 158 - Caption = 'Rendering options' + object PanelTopPreviewSettings: TPanel + Left = 0 + Top = 0 + Width = 650 + Height = 25 + Align = alTop + Caption = 'RENDERING OPTIONS' TabOrder = 0 - object PreferD2DCheckBox: TCheckBox - Left = 13 - Top = 127 - Width = 284 - Height = 18 - Caption = 'Prefer Direct 2D Engine (if available in Windows)' - TabOrder = 0 - end - object EngineRadioGroup: TRadioGroup - Left = 13 - Top = 19 - Width = 284 - Height = 102 - Caption = 'Engine' - Items.Strings = ( - 'Delphi Image32' - 'Delphi TSVG') - TabOrder = 1 - end + end + object EngineRadioGroup: TRadioGroup + Left = 13 + Top = 37 + Width = 284 + Height = 102 + Caption = 'Engine' + Items.Strings = ( + 'Delphi Image32' + 'Delphi TSVG') + TabOrder = 1 + end + object PreferD2DCheckBox: TCheckBox + Left = 13 + Top = 145 + Width = 284 + Height = 18 + Caption = 'Prefer Direct 2D Engine (if available in Windows)' + TabOrder = 2 end end end diff --git a/Source/SVGSettings.pas b/Source/SettingsForm.pas similarity index 83% rename from Source/SVGSettings.pas rename to Source/SettingsForm.pas index a9781e1..c2cacff 100644 --- a/Source/SVGSettings.pas +++ b/Source/SettingsForm.pas @@ -29,7 +29,7 @@ { Portions created by Rodrigo Ruz V. are Copyright 2011-2021 Rodrigo Ruz V. } { All Rights Reserved. } {******************************************************************************} -unit SVGSettings; +unit SettingsForm; interface @@ -37,11 +37,11 @@ interface Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, ExtCtrls, ColorGrd, StdCtrls, CheckLst, SynEdit, ActnList, SynEditHighlighter, SynUnicode, System.ImageList, Vcl.ImgList, - SVGIconImageListBase, SVGIconImageList, uSVGSettings, Vcl.ButtonGroup, + SVGIconImageListBase, SVGIconImageList, uSettings, Vcl.ButtonGroup, Vcl.ToolWin, DResources, Vcl.VirtualImageList, uAbout, Vcl.WinXCtrls; type - TSVGSettingsForm = class(TForm) + TUserSettingsForm = class(TForm) pc: TPageControl; tsColors: TTabSheet; paLeft: TPanel; @@ -84,9 +84,12 @@ TSVGSettingsForm = class(TForm) ResetPanel: TPanel; ResetButton: TButton; stGeneral: TTabSheet; - RenderingGroupBox: TGroupBox; - PreferD2DCheckBox: TCheckBox; + PanelTopTheme: TPanel; + PanelTopFont: TPanel; + PanelTopEditor: TPanel; + PanelTopPreviewSettings: TPanel; EngineRadioGroup: TRadioGroup; + PreferD2DCheckBox: TCheckBox; procedure BoxElementsClick(Sender: TObject); procedure cbForegroundClick(Sender: TObject); procedure cbBackgroundClick(Sender: TObject); @@ -150,6 +153,7 @@ function ShowSettings(const AParentRect: TRect; implementation uses + System.UITypes, {$IFNDEF DISABLE_STYLES} Vcl.Themes, {$ENDIF} @@ -166,18 +170,18 @@ function ShowSettings(const AParentRect: TRect; TSynCustomHighlighterClass = class of TSynCustomHighlighter; var HighLightSettingsClass: TSynCustomHighlighterClass; - LSettingsForm: TSVGSettingsForm; + LSettingsForm: TUserSettingsForm; I: integer; begin Result := False; for I := 0 to Screen.FormCount - 1 do - if Screen.Forms[I].ClassType = TSVGSettingsForm then + if Screen.Forms[I].ClassType = TUserSettingsForm then begin Screen.Forms[I].BringToFront; exit; end; - LSettingsForm := TSVGSettingsForm.Create(nil); + LSettingsForm := TUserSettingsForm.Create(nil); with LSettingsForm do Try Title := ATitle; @@ -214,9 +218,9 @@ TSynCustomHighlighterClass = class of TSynCustomHighlighter; End; end; -{ TSVGSettingsForm } +{ TUserSettingsForm } -procedure TSVGSettingsForm.AddElements; +procedure TUserSettingsForm.AddElements; var i : integer; begin @@ -232,12 +236,12 @@ procedure TSVGSettingsForm.AddElements; RefreshMap; end; -procedure TSVGSettingsForm.BoxElementsClick(Sender: TObject); +procedure TUserSettingsForm.BoxElementsClick(Sender: TObject); begin RefreshMap; end; -procedure TSVGSettingsForm.RefreshColorBoxes; +procedure TUserSettingsForm.RefreshColorBoxes; begin if (CurrentElement.ForeGround <> ForeGroundColor) or CurrentIsWhiteSpace then @@ -263,7 +267,7 @@ procedure TSVGSettingsForm.RefreshColorBoxes; end; end; -procedure TSVGSettingsForm.RefreshDefaultCheckBox; +procedure TUserSettingsForm.RefreshDefaultCheckBox; begin cbForeground.OnClick := nil; cbBackground.OnClick := nil; @@ -276,7 +280,7 @@ procedure TSVGSettingsForm.RefreshDefaultCheckBox; End; end; -procedure TSVGSettingsForm.RefreshTextAttributes; +procedure TUserSettingsForm.RefreshTextAttributes; begin with CurrentElement do begin @@ -288,7 +292,7 @@ procedure TSVGSettingsForm.RefreshTextAttributes; end; end; -procedure TSVGSettingsForm.ResetButtonClick(Sender: TObject); +procedure TUserSettingsForm.ResetButtonClick(Sender: TObject); var LBackGroundColor: TColor; begin @@ -301,7 +305,7 @@ procedure TSVGSettingsForm.ResetButtonClick(Sender: TObject); SelectedStyleIsDark, LBackGroundColor)); end; -procedure TSVGSettingsForm.RefreshMap; +procedure TUserSettingsForm.RefreshMap; begin //imposta la mappa sulla base delle impostazioni della lista with CurrentElement do @@ -313,17 +317,17 @@ procedure TSVGSettingsForm.RefreshMap; end; end; -function TSVGSettingsForm.GetCurrentElement: TSynHighlighterAttributes; +function TUserSettingsForm.GetCurrentElement: TSynHighlighterAttributes; begin Result := TSynHighlighterAttributes(BoxElements.Items.Objects[BoxElements.ItemIndex]); end; -function TSVGSettingsForm.GetCurrentIsWhiteSpace: Boolean; +function TUserSettingsForm.GetCurrentIsWhiteSpace: Boolean; begin Result := CurrentElement.Name = 'Whitespace'; end; -procedure TSVGSettingsForm.cbForegroundClick(Sender: TObject); +procedure TUserSettingsForm.cbForegroundClick(Sender: TObject); begin if cbForeground.Checked then CurrentElement.Foreground := ForeGroundColor @@ -333,7 +337,7 @@ procedure TSVGSettingsForm.cbForegroundClick(Sender: TObject); RefreshDefaultCheckBox; end; -procedure TSVGSettingsForm.ChangeAllDefaultColors(const OldForeground, +procedure TUserSettingsForm.ChangeAllDefaultColors(const OldForeground, NewForeground, OldBackGround, NewBackGround: TColor); var I: Integer; @@ -352,7 +356,7 @@ procedure TSVGSettingsForm.ChangeAllDefaultColors(const OldForeground, end; end; -procedure TSVGSettingsForm.cbBackgroundClick(Sender: TObject); +procedure TUserSettingsForm.cbBackgroundClick(Sender: TObject); begin if cbBackground.Checked then CurrentElement.Background := BackGroundColor @@ -362,7 +366,7 @@ procedure TSVGSettingsForm.cbBackgroundClick(Sender: TObject); RefreshDefaultCheckBox; end; -procedure TSVGSettingsForm.CbFontDrawItem(Control: TWinControl; Index: Integer; +procedure TUserSettingsForm.CbFontDrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState); begin with CbFont do @@ -373,7 +377,7 @@ procedure TSVGSettingsForm.CbFontDrawItem(Control: TWinControl; Index: Integer; end; end; -procedure TSVGSettingsForm.ColorBoxChanged; +procedure TUserSettingsForm.ColorBoxChanged; begin cbForeground.OnClick := nil; cbBackground.OnClick := nil; @@ -404,7 +408,7 @@ procedure TSVGSettingsForm.ColorBoxChanged; end; end; -procedure TSVGSettingsForm.cbFontStyleClick(Sender: TObject); +procedure TUserSettingsForm.cbFontStyleClick(Sender: TObject); var FontStyle : TFontStyle; begin @@ -429,7 +433,7 @@ procedure TSVGSettingsForm.cbFontStyleClick(Sender: TObject); RefreshMap; end; -procedure TSVGSettingsForm.GetActiveAttribute; +procedure TUserSettingsForm.GetActiveAttribute; var Token : UnicodeString; Attr : TSynHighlighterAttributes; @@ -446,73 +450,81 @@ procedure TSVGSettingsForm.GetActiveAttribute; BoxElements.ItemIndex := 0; //goto WiteSpace Element end; -procedure TSVGSettingsForm.SelectThemeRadioGroupClick(Sender: TObject); +procedure TUserSettingsForm.SelectThemeRadioGroupClick(Sender: TObject); begin ThemeClientPanel.StyleName := SelectedStyleName; CreateAboutForm; end; -procedure TSVGSettingsForm.SetTitle(const Value: string); +procedure TUserSettingsForm.SetTitle(const Value: string); begin FTitle := Value; TitlePanel.Caption := ' '+FTitle+' - '+TitlePanel.Caption; Caption := TitlePanel.Caption; end; -procedure TSVGSettingsForm.SynEditClick(Sender: TObject); +procedure TUserSettingsForm.SynEditClick(Sender: TObject); begin GetActiveAttribute; end; -procedure TSVGSettingsForm.SynEditKeyUp(Sender: TObject; var Key: Word; +procedure TUserSettingsForm.SynEditKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin GetActiveAttribute; end; -procedure TSVGSettingsForm.ThemesRadioGroupClick(Sender: TObject); +procedure TUserSettingsForm.ThemesRadioGroupClick(Sender: TObject); begin PopulateAvailThemes; end; -procedure TSVGSettingsForm.ColorGridClick(Sender: TObject); +procedure TUserSettingsForm.ColorGridClick(Sender: TObject); begin ColorBoxChanged; end; -procedure TSVGSettingsForm.FormCreate(Sender: TObject); +procedure TUserSettingsForm.FormCreate(Sender: TObject); begin + tsColors.TabVisible := False; + tsFont.TabVisible := False; + stTheme.TabVisible := False; + stGeneral.TabVisible := False; CbFont.Items.Assign(Screen.Fonts); TitlePanel.Font.Height := Round(TitlePanel.Font.Height * 1.5); MenuButtonGroup.Font.Height := Round(MenuButtonGroup.Font.Height * 1.2); + PanelTopPreviewSettings.Font.Style := PanelTopPreviewSettings.Font.Style + [fsBold]; + PanelTopTheme.Font.Style := PanelTopTheme.Font.Style + [fsBold]; + PanelTopFont.Font.Style := PanelTopFont.Font.Style + [fsBold]; + PanelTopEditor.Font.Style := PanelTopEditor.Font.Style + [fsBold]; end; -procedure TSVGSettingsForm.FormDestroy(Sender: TObject); +procedure TUserSettingsForm.FormDestroy(Sender: TObject); begin FAboutForm.Free; end; -procedure TSVGSettingsForm.ColorBoxSelect(Sender: TObject); +procedure TUserSettingsForm.ColorBoxSelect(Sender: TObject); begin ColorBoxChanged; end; -function TSVGSettingsForm.GetBackGroundColor: TColor; +function TUserSettingsForm.GetBackGroundColor: TColor; begin Result := FHighlighter.WhitespaceAttribute.Background; end; -function TSVGSettingsForm.GetForeGroundColor: TColor; +function TUserSettingsForm.GetForeGroundColor: TColor; begin Result := FHighlighter.WhitespaceAttribute.Foreground; end; -procedure TSVGSettingsForm.ChangePage(AIndex: Integer); +procedure TUserSettingsForm.ChangePage(AIndex: Integer); begin pc.ActivePageIndex := AIndex; end; -procedure TSVGSettingsForm.AssignSettings(ASettings: TSettings); +procedure TUserSettingsForm.AssignSettings(ASettings: TSettings); begin ChangePage(ASettings.ActivePageIndex); MenuButtonGroup.ItemIndex := pc.ActivePageIndex +1; @@ -532,7 +544,7 @@ procedure TSVGSettingsForm.AssignSettings(ASettings: TSettings); PopulateAvailThemes; end; -function TSVGSettingsForm.SelectedStyleIsDark: Boolean; +function TUserSettingsForm.SelectedStyleIsDark: Boolean; var LThemeAttributes: TThemeAttribute; begin @@ -543,7 +555,7 @@ function TSVGSettingsForm.SelectedStyleIsDark: Boolean; Result := LThemeAttributes.ThemeType = ttDark; end; -function TSVGSettingsForm.SelectedStyleName: string; +function TUserSettingsForm.SelectedStyleName: string; begin if SelectThemeRadioGroup.ItemIndex <> -1 then Result := SelectThemeRadioGroup.Items[SelectThemeRadioGroup.ItemIndex] @@ -551,7 +563,7 @@ function TSVGSettingsForm.SelectedStyleName: string; Result := DefaultStyleName; end; -procedure TSVGSettingsForm.UpdateSettings(ASettings: TSettings); +procedure TUserSettingsForm.UpdateSettings(ASettings: TSettings); begin ASettings.ActivePageIndex := pc.ActivePageIndex; ASettings.ThemeSelection := TThemeSelection(ThemesRadioGroup.ItemIndex); @@ -562,7 +574,7 @@ procedure TSVGSettingsForm.UpdateSettings(ASettings: TSettings); ASettings.SVGEngine := TSVGEngine(EngineRadioGroup.ItemIndex); end; -procedure TSVGSettingsForm.MenuButtonGroupButtonClicked(Sender: TObject; +procedure TUserSettingsForm.MenuButtonGroupButtonClicked(Sender: TObject; Index: Integer); begin if Sender is TButtonGroup then @@ -576,7 +588,7 @@ procedure TSVGSettingsForm.MenuButtonGroupButtonClicked(Sender: TObject; end; end; -procedure TSVGSettingsForm.CreateAboutForm; +procedure TUserSettingsForm.CreateAboutForm; begin FAboutForm.Free; FAboutForm := TFrmAbout.Create(Self); @@ -589,7 +601,7 @@ procedure TSVGSettingsForm.CreateAboutForm; FAboutForm.Visible := True; end; -procedure TSVGSettingsForm.PopulateAvailThemes; +procedure TUserSettingsForm.PopulateAvailThemes; var I: Integer; IsLight: Boolean; @@ -634,14 +646,14 @@ procedure TSVGSettingsForm.PopulateAvailThemes; end; end; -procedure TSVGSettingsForm.ExitFromSettings(Sender: TObject); +procedure TUserSettingsForm.ExitFromSettings(Sender: TObject); begin //Salva i parametri su file CloneSynEdit(SynEdit, FSourceSynEdit); ModalResult := mrOk; end; -procedure TSVGSettingsForm.CloneSynEdit(Source, Dest: TSynEdit); +procedure TUserSettingsForm.CloneSynEdit(Source, Dest: TSynEdit); begin Dest.Highlighter.Assign(Source.Highlighter); Dest.Font.Assign(Source.Font); diff --git a/Source/uCommonPreviewHandler.pas b/Source/uCommonPreviewHandler.pas index 19c3cea..73bfe68 100644 --- a/Source/uCommonPreviewHandler.pas +++ b/Source/uCommonPreviewHandler.pas @@ -29,7 +29,7 @@ interface Controls, StdCtrls, SysUtils, - SVGPreviewForm, + PreviewForm, {$IFDEF USE_TStreamPreviewHandler} uStreamAdapter, uStreamPreviewHandler, @@ -44,126 +44,8 @@ TBasePreviewHandler = class(TStreamPreviewHandler) {$ELSE} TBasePreviewHandler = class(TFilePreviewHandler) {$ENDIF} - private - FEditor: TFrmPreview; - public - constructor Create(AParent: TWinControl); override; - procedure Unload; override; -{$IFDEF USE_TStreamPreviewHandler} - procedure DoPreview(Stream: TIStreamAdapter); override; -{$ELSE} - procedure DoPreview(const FilePath: string); override; -{$ENDIF} - property Editor: TFrmPreview read FEditor write FEditor; end; implementation -Uses - uLogExcept, - SynEdit, - Windows, - Forms, - uMisc, uPreviewContainer; - -constructor TBasePreviewHandler.Create(AParent: TWinControl); -begin - inherited; - FEditor := nil; -end; - -{$IFDEF USE_TStreamPreviewHandler} - -procedure TBasePreviewHandler.DoPreview(Stream: TIStreamAdapter); -begin - try - TLogPreview.Add('DoPreview ' + Self.ClassName); - //if (Editor <> nil) and IsWindow(Editor.Handle) then - begin - Initialize_GDI; - TLogPreview.Add('TGlobalPreviewHandler TFrmPreview.Create'); - Editor := TFrmPreview.Create(nil); - Editor.Parent := TPreviewContainer(TFrmPreview.AParent); - Editor.Align := alClient; - Editor.BorderStyle := bsNone; - - TLogPreview.Add('DoPreview Visible'); - Editor.Visible := True; - TLogPreview.Add('DoPreview LoadFromStream'); - Editor.LoadFromStream(Stream); - end; - except - on E: Exception do - TLogPreview.Add(Format('Error in TBasePreviewHandler.DoPreview(Stream) - Message: %s: Trace %s', [E.Message, E.StackTrace])); - end; -end; -{$ELSE} - -procedure TBasePreviewHandler.DoPreview(const FilePath: string); -begin - try - TLogPreview.Add('DoPreview ' + Self.ClassName); - //if (Editor <> nil) and IsWindow(Editor.Handle) then - begin - Initialize_GDI; - TLogPreview.Add('TGlobalPreviewHandler TFrmPreview.Create'); - Editor := TFrmPreview.Create(nil); - Editor.Align := alClient; - Editor.Parent := TPreviewContainer(TFrmPreview.AParent); - Editor.BorderStyle := bsNone; - - TLogPreview.Add('DoPreview Visible'); - Editor.Visible := True; - TLogPreview.Add('DoPreview LoadFile'); - Editor.LoadFromFile(FilePath); - end; - except - on E: Exception do - TLogPreview.Add(Format('Error in TBasePreviewHandler.DoPreview(FilePath) - Message: %s: Trace %s', [E.Message, E.StackTrace])); - end; -end; -{$ENDIF} -{ - http://msdn.microsoft.com/en-us/library/bb776865%28v=vs.85%29.aspx - IPreviewHandler::Unload - When this method is called, stop any rendering, release any resources allocated by reading data from the stream, and release the IStream itself. - Once this method is called, the handler must be reinitialized before any attempt to call IPreviewHandler::DoPreview again. -} - -type - TWinControlClass = class(TWinControl); - -procedure TBasePreviewHandler.Unload; -begin - try - TLogPreview.Add('Unload Init ' + Self.ClassName); - // if IsWindow(TWinControlClass(Editor).WindowHandle) then - // begin - // Editor.Visible:=False; - // Editor.SynEdit1.Lines.Clear; - // end; - - if Editor<>nil then - begin - Editor.Free; - Editor:=nil; - end; - - if (TFrmPreview.AParent<>nil) then - begin - if TPreviewContainer(TFrmPreview.AParent).PreviewHandler <> nil then - TComPreviewHandler(TPreviewContainer(TFrmPreview.AParent).PreviewHandler).Container := nil; - - TFrmPreview.AParent.Free; - TFrmPreview.AParent:=nil; - end; - inherited; - Finalize_GDI; - TLogPreview.Add('Unload Done ' + Self.ClassName); - except - on E: Exception do - TLogPreview.Add(Format('Error in TBasePreviewHandler.Unload - Message: %s: Trace %s', [E.Message, E.StackTrace])); - end; -end; - end. diff --git a/Source/uFilePreviewHandler.pas b/Source/uFilePreviewHandler.pas index e8a2a34..85bb378 100644 --- a/Source/uFilePreviewHandler.pas +++ b/Source/uFilePreviewHandler.pas @@ -13,9 +13,9 @@ // // The Original Code is uFilePreviewHandler.pas. // -// The Initial Developer of the Original Code is Rodrigo Ruz V. -// Portions created by Rodrigo Ruz V. are Copyright (C) 2011-2021 Rodrigo Ruz V. -// All Rights Reserved. +// The Initial Developer of the Original Code is Rodrigo Ruz V. +// Portions created by Rodrigo Ruz V. are Copyright (C) 2011-2021 Rodrigo Ruz V. +// All Rights Reserved. // // ************************************************************************************************* @@ -30,7 +30,6 @@ interface type TFilePreviewHandler = class abstract(TPreviewHandler) public - procedure DoPreview(const FilePath: String); virtual; abstract; class function GetComClass: TComClass; override; final; end; @@ -39,7 +38,8 @@ implementation uses Windows, PropSys, - SysUtils; + SysUtils, + uLogExcept; type TComFilePreviewHandler = class(TComPreviewHandler, IInitializeWithFile) @@ -72,7 +72,9 @@ function TComFilePreviewHandler.IInitializeWithFile_Initialize(pszFilePath: LPCW procedure TComFilePreviewHandler.InternalDoPreview; begin - PreviewHandler.DoPreview(FFilePath); + TLogPreview.Add('TComFilePreviewHandler.InternalDoPreview'); + CheckContainer; + Container.LoadFromFile(FFilePath); end; procedure TComFilePreviewHandler.InternalUnload; diff --git a/Source/uLogExcept.pas b/Source/uLogExcept.pas index c1f345d..7e7b976 100644 --- a/Source/uLogExcept.pas +++ b/Source/uLogExcept.pas @@ -31,6 +31,8 @@ interface TLogPreview = class private FLogStream: TStream; + class var FLogFile: string; + class procedure InitLogFile; static; public property LogStream: TStream read FLogStream write FLogStream; class procedure Add(const AMessage: string); overload; @@ -43,10 +45,9 @@ implementation uMisc, IOUtils; -var - sLogFile: string; - +{$IFDEF DEBUG} {$DEFINE ENABLELOG} +{$ENDIF} procedure AppendAllText(const FileName, Contents: string); {$IFDEF ENABLELOG} @@ -72,12 +73,20 @@ procedure AppendAllText(const FileName, Contents: string); end; { TLogException } + +class procedure TLogPreview.InitLogFile; +begin + if FLogFile = '' then + FLogFile := IncludeTrailingPathDelimiter(GetTempDirectory) + 'SvgShellExtensions.log'; +end; + class procedure TLogPreview.Add(const AMessage: string); begin -{$IFDEF DEBUG} +{$IFDEF ENABLELOG} try - if (Copy(AMessage,1,15) = 'TSVGContextMenu') then - AppendAllText(sLogFile, FormatDateTime('hh:nn:ss.zzz', Now) + ' ' + AMessage + sLineBreak); + InitLogFile; + if (Copy(AMessage,1,4) = 'GDI+') then + AppendAllText(FLogFile, FormatDateTime('hh:nn:ss.zzz', Now) + ' ' + AMessage + sLineBreak); except on e: EFOpenError do; end; @@ -87,7 +96,8 @@ class procedure TLogPreview.Add(const AMessage: string); class procedure TLogPreview.Add(const AException: Exception); begin try - AppendAllText(sLogFile, Format('%s %s StackTrace %s %s', [FormatDateTime('hh:nn:ss.zzz', Now), AException.Message, + InitLogFile; + AppendAllText(FLogFile, Format('%s %s StackTrace %s %s', [FormatDateTime('hh:nn:ss.zzz', Now), AException.Message, AException.StackTrace, sLineBreak])); except on e: EFOpenError do; @@ -96,6 +106,4 @@ class procedure TLogPreview.Add(const AException: Exception); initialization -sLogFile := IncludeTrailingPathDelimiter(GetTempDirectory) + 'SVGshellExtensions.log'; - end. diff --git a/Source/uMisc.pas b/Source/uMisc.pas index 58d9aba..4cbb574 100644 --- a/Source/uMisc.pas +++ b/Source/uMisc.pas @@ -64,7 +64,7 @@ implementation procedure Initialize_GDI; stdcall; begin //Initialize GDI+ - TLogPreview.Add('Initialize GDI+'); + TLogPreview.Add('GDI+: Initialize'); StartupInput.DebugEventCallback := nil; StartupInput.SuppressBackgroundThread := False; StartupInput.SuppressExternalCodecs := False; @@ -74,6 +74,7 @@ procedure Initialize_GDI; stdcall; procedure Finalize_GDI; stdcall; begin + TLogPreview.Add('GDI+: Finalize'); GdiplusShutdown(gdiplusToken); end; diff --git a/Source/uPreviewContainer.dfm b/Source/uPreviewContainer.dfm index 4cb5d4a..5b276af 100644 --- a/Source/uPreviewContainer.dfm +++ b/Source/uPreviewContainer.dfm @@ -1,17 +1,15 @@ object PreviewContainer: TPreviewContainer Left = 753 Top = 443 - ClientHeight = 447 - ClientWidth = 684 + ClientHeight = 274 + ClientWidth = 300 Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'Tahoma' Font.Style = [] - OldCreateOrder = False OnCreate = FormCreate OnDestroy = FormDestroy - PixelsPerInch = 96 TextHeight = 13 end diff --git a/Source/uPreviewContainer.pas b/Source/uPreviewContainer.pas index 2ef49d9..fa0a618 100644 --- a/Source/uPreviewContainer.pas +++ b/Source/uPreviewContainer.pas @@ -35,7 +35,7 @@ interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs; + Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls, Vcl.ComCtrls; type TPreviewContainer = class(TForm) @@ -43,17 +43,20 @@ TPreviewContainer = class(TForm) procedure FormDestroy(Sender: TObject); private FPreviewHandler: TObject; + FActualRect: TRect; public procedure SetFocusTabFirst; procedure SetFocusTabLast; procedure SetBackgroundColor(color: TColorRef); - procedure SetBoundsRectAndPPI(const ARect: TRect; - const AOldPPI, ANewPPI: Integer); virtual; + procedure SetBoundsRectAndPPI(const ARect: TRect; AOldPPI, ANewPPI: Integer); virtual; procedure SetTextColor(color: TColorRef); procedure SetTextFont(const plf: TLogFont); - property PreviewHandler: TObject read FPreviewHandler write FPreviewHandler; + property PreviewHandler: TObject read FPreviewHandler write FPreviewHandler; + property ActualRect: TRect read FActualRect; end; +function GetRect(const ARect: TRect; const ATxt: string): string; + implementation uses @@ -65,10 +68,16 @@ implementation Vcl.Themes, {$ENDIF} uLogExcept, - uSVGSettings; + uSettings; {$R *.dfm} +function GetRect(const ARect: TRect; const ATxt: string): string; +begin + Result := Format('%s: L:%d - T:%d - W:%d - H:%d', + [ATxt, ARect.Left, ARect.Top, ARect.Width, ARect.Height]); +end; + procedure TPreviewContainer.SetFocusTabFirst; begin SelectNext(nil, True, True); @@ -111,38 +120,47 @@ procedure TPreviewContainer.SetBackgroundColor(color: TColorRef); end; procedure TPreviewContainer.SetBoundsRectAndPPI(const ARect: TRect; - const AOldPPI, ANewPPI: Integer); + AOldPPI, ANewPPI: Integer); +var + Lmsg: string; + LActualMonitor, LMainMonitor: TMonitor; + LScaleFactor: Double; + I: Integer; begin - if (ARect.Width <> 0) and (ARect.Height <> 0) then + LActualMonitor := Screen.MonitorFromWindow(Self.Handle); + LMainMonitor := LActualMonitor; + for I := 0 to Screen.MonitorCount do begin - TLogPreview.Add('TPreviewContainer.SetBoundsRect:'+ - ' Visible: '+Self.Visible.Tostring+ - ' CurrentPPI:'+Self.CurrentPPI.ToString+ - ' AOldPPI:'+AOldPPI.ToString+ - ' ANewPPI:'+ANewPPI.ToString+ - ' Scaled:'+Self.Scaled.ToString+ - ' ARect.Width: '+ARect.Width.ToString+ - ' ARect.Height: '+ARect.Height.ToString); - - if ANewPPI <> AOldPPI then - begin - SetBounds( - ARect.Left, - ARect.Top, - MulDiv(ARect.Width, ANewPPI, AOldPPI), - MulDiv(ARect.Height, ANewPPI, AOldPPI)); - end - else - begin - SetBounds( - ARect.Left, - ARect.Top, - ARect.Width, - ARect.Height); - end; - - FCurrentPPI := ANewPPI; + LMainMonitor := Screen.Monitors[I]; + if LMainMonitor.Primary then + Break; end; + + if LMainMonitor <> LActualMonitor then + begin + LScaleFactor := LActualMonitor.PixelsPerInch / LMainMonitor.PixelsPerInch; + ARect.Width := Round(ARect.Width * LScaleFactor); + ARect.Height := Round(ARect.Height * LScaleFactor); + end; + + Lmsg := 'TPreviewContainer.SetBoundsRect:'+ + ' Visible: '+Self.Visible.Tostring+slineBreak+ + ' ANewPPI = AOldPPI'+slineBreak+ + ' Form.CurrentPPI:'+Self.CurrentPPI.ToString+slineBreak+ + ' Form.Scaled:'+Self.Scaled.ToString+slineBreak+ + ' AOldPPI:'+AOldPPI.ToString+slineBreak+ + ' ANewPPI:'+ANewPPI.ToString+slineBreak+ + ' Scaled:'+Self.Scaled.ToString+slineBreak+ + ' ARect.Width: '+ARect.Width.ToString+slineBreak+ + ' ARect.Height: '+ARect.Height.ToString+slineBreak; + + SetWindowPos(WindowHandle, 0, ARect.Left, ARect.Top, ARect.Width, ARect.Height, SWP_NOZORDER + SWP_NOACTIVATE); + //if LMainMonitor <> LActualMonitor then + // ChangeScale(LMainMonitor.PixelsPerInch, LActualMonitor.PixelsPerInch); + FActualRect := ARect; + FCurrentPPI := ANewPPI; + + TLogPreview.Add(Lmsg); end; procedure TPreviewContainer.SetTextColor(color: TColorRef); diff --git a/Source/uPreviewHandler.pas b/Source/uPreviewHandler.pas index 0e1b5e2..7cda3c2 100644 --- a/Source/uPreviewHandler.pas +++ b/Source/uPreviewHandler.pas @@ -34,7 +34,8 @@ interface Windows, uPreviewContainer, System.Generics.Collections, - ActiveX; + ActiveX, + PreviewForm; type @@ -70,7 +71,7 @@ TComPreviewHandler = class(TComObject, IOleWindow, IObjectWithSite, IPreviewHa FCurrentPPI: Integer; FBackgroundColor: TColorRef; FBounds: TRect; - FContainer: TPreviewContainer; + FContainer: TFrmPreview; FLogFont: TLogFont; FParentWindow: HWND; FPreviewHandler: TPreviewHandler; @@ -81,7 +82,7 @@ TComPreviewHandler = class(TComObject, IOleWindow, IObjectWithSite, IPreviewHa procedure SetBounds(const Value: TRect); procedure UpdateContainerBoundsRect; protected - procedure CheckContainer; + function CheckContainer: Boolean; procedure CheckPreviewHandler; procedure InternalUnload; virtual; abstract; procedure InternalDoPreview; virtual; abstract; @@ -95,7 +96,7 @@ TComPreviewHandler = class(TComObject, IOleWindow, IObjectWithSite, IPreviewHa property Site: IInterface read FSite; public destructor Destroy; override; - property Container: TPreviewContainer read FContainer write FContainer; + property Container: TFrmPreview read FContainer write FContainer; property PreviewHandlerClass: TPreviewHandlerClass read FPreviewHandlerClass write FPreviewHandlerClass; end; @@ -110,7 +111,6 @@ implementation ExtCtrls, uMisc, uLogExcept, - SVGPreviewForm, uPreviewHandlerRegister; @@ -138,16 +138,22 @@ procedure TComPreviewHandler.UpdateContainerBoundsRect; end; end; -procedure TComPreviewHandler.CheckContainer; +function TComPreviewHandler.CheckContainer: Boolean; +var + LRect: TRect; begin TLogPreview.Add('CheckContainer Init'); - TLogPreview.Add('CheckContainer FContainer = nil '+BoolToStr(FContainer = nil, True)+ - 'Fbounds.Width: '+FBounds.width.ToString); if (FContainer = nil) and IsWindow(FParentWindow) then begin - TLogPreview.Add('ParentWindow '+IntToHex(ParentWindow, 8)); + TLogPreview.Add('ParentWindow '+IntToHex(FParentWindow, 8)); + + GetWindowRect(FParentWindow, LRect); + TLogPreview.Add('CheckContainer'+GetRect(LRect,' - GetWindowRect')); + + //FContainer := TPreviewContainer.Create(nil); + FContainer := TFrmPreview.Create(nil); - FContainer := TPreviewContainer.Create(nil); + TLogPreview.Add('FContainer created:'+GetRect(FBounds,' FBounds')); FContainer.ParentWindow := FParentWindow; FContainer.BorderStyle := bsNone; FContainer.Visible := True; @@ -156,17 +162,17 @@ procedure TComPreviewHandler.CheckContainer; TFrmPreview.AParent := FContainer; end; TLogPreview.Add('CheckContainer Done'); + Result := Assigned(FContainer); end; procedure TComPreviewHandler.CheckPreviewHandler; begin TLogPreview.Add('CheckPreviewHandler Init'); - if FContainer = nil then - CheckContainer; - - if FPreviewHandler = nil then - FPreviewHandler := PreviewHandlerClass.Create(Container); - + if CheckContainer then + begin + if FPreviewHandler = nil then + FPreviewHandler := PreviewHandlerClass.Create(Container); + end; TLogPreview.Add('CheckPreviewHandler Done'); end; @@ -190,6 +196,8 @@ function TComPreviewHandler.GetSite(const riid: TGUID; out site: IInterface): HR end; function TComPreviewHandler.GetWindow(out wnd: HWND): HRESULT; +var + LRect: TRect; begin TLogPreview.Add('GetWindow Init'); if (Container = nil) or (Container.Handle = 0) then @@ -200,6 +208,9 @@ function TComPreviewHandler.GetWindow(out wnd: HWND): HRESULT; else begin wnd := Container.Handle; + GetWindowRect(wnd, LRect); + TLogPreview.Add('GetWindow'+GetRect(LRect,' - GetWindowRect')); + result := S_OK; end; TLogPreview.Add('GetWindow Done'); @@ -248,7 +259,9 @@ procedure TComPreviewHandler.SetBounds(const Value: TRect); if (Value.Width <> 0) and (Value.Height <> 0) then begin FBounds := Value; - CheckPreviewHandler; + FBounds.Left := 0; + FBounds.Top := 0; + //CheckPreviewHandler; UpdateContainerBoundsRect; end; end; @@ -280,6 +293,7 @@ function TComPreviewHandler.SetFont(const plf: TLogFont): HRESULT; function TComPreviewHandler.SetRect(var prc: TRect): HRESULT; var LNewPPI: Integer; + LRect: TRect; begin LNewPPI := GetDpiForWindow(FParentWindow); @@ -287,16 +301,13 @@ function TComPreviewHandler.SetRect(var prc: TRect): HRESULT; ' prc.Width: '+prc.Width.ToString+ ' prc.Height: '+prc.Height.ToString+ ' GetDpiForWindow: '+LNewPPI.ToString); -(* - if (LNewPPI <> FCurrentPPI) then - begin - FreeAndNil(FPreviewHandler); - FreeAndNil(FContainer); - CheckPreviewHandler; - InternalDoPreview; - end; -*) - Bounds := prc; + + GetWindowRect(FParentWindow, LRect); + TLogPreview.Add('SetRect'+GetRect(LRect,' - GetWindowRect')); + + //Bounds is calculated on Windows Rect + TLogPreview.Add('SetRect: Imposto Bounds dalla Window'+GetRect(LRect, ' LRect')); + Bounds := TRect.Create(0,0,LRect.Width,LRect.Height); FCurrentPPI := LNewPPI; TLogPreview.Add('FCurrentPPI := LNewPPI: '+LNewPPI.ToString); Result := S_OK; @@ -308,13 +319,14 @@ function TComPreviewHandler.SetSite(const pUnkSite: IInterface): HRESULT; TLogPreview.Add('SetSite Init'); FSite := PUnkSite; FPreviewHandlerFrame := FSite as IPreviewHandlerFrame; + FBounds := TRect.Create(0,0,0,0); result := S_OK; TLogPreview.Add('SetSite Done'); end; function TComPreviewHandler.SetTextColor(color: Cardinal): HRESULT; begin - TLogPreview.Add('SetTextColor Init'); + TLogPreview.Add('SetTextColor Init - Color:'+Color.ToString); FTextColor := color; if Container <> nil then Container.SetTextColor(FTextColor); @@ -327,11 +339,14 @@ function TComPreviewHandler.SetWindow(hwnd: HWND; var prc: TRect): HRESULT; LMonitor: TMonitor; LRect: TRect; begin - TLogPreview.Add('SetWindow Init'); + TLogPreview.Add('SetWindow Init'+GetRect(prc, '-prc:')); FParentWindow := hwnd; // FCurrentPPI := 96; FCurrentPPI := GetDpiForWindow(hwnd); + GetWindowRect(FParentWindow, LRect); + TLogPreview.Add('SetWindow'+GetRect(LRect,' - GetWindowRect')); + TLogPreview.Add('SetWindow: Window DPI: '+FCurrentPPI.ToString); LMonitor := Screen.MonitorFromWindow(hwnd); @@ -341,6 +356,11 @@ function TComPreviewHandler.SetWindow(hwnd: HWND; var prc: TRect): HRESULT; ' Height: '+LMonitor.Height.ToString+ ' PPI: '+LMonitor.PixelsPerInch.ToString); + TLogPreview.Add('SetWindow: Imposto Bounds'+GetRect(LRect, ' LRect')); + Bounds := TRect.Create(0,0,LRect.Width,LRect.Height); + + Result := S_OK; +(* if (prc.Width <> 0) and (prc.Height <> 0) then begin Bounds := prc; @@ -354,6 +374,7 @@ function TComPreviewHandler.SetWindow(hwnd: HWND; var prc: TRect): HRESULT; Bounds := LRect; Result := S_OK; end; +*) TLogPreview.Add('SetWindow Done'); end; diff --git a/Source/uPreviewHandlerRegister.pas b/Source/uPreviewHandlerRegister.pas index cb93c84..47d84e8 100644 --- a/Source/uPreviewHandlerRegister.pas +++ b/Source/uPreviewHandlerRegister.pas @@ -43,7 +43,7 @@ interface TPreviewHandlerRegister = class(TComObjectFactory) private FPreviewHandlerClass: TPreviewHandlerClass; - class procedure DeleteRegValue(const Key, ValueName: string; RootKey: DWord); + class procedure DeleteRegValue(const Key, ValueName: string; RootKey: HKEY); protected public constructor Create(APreviewHandlerClass: TPreviewHandlerClass; @@ -78,7 +78,7 @@ function TPreviewHandlerRegister.CreateComObject(const Controller: IUnknown): TC TComPreviewHandler(result).PreviewHandlerClass := PreviewHandlerClass; end; -class procedure TPreviewHandlerRegister.DeleteRegValue(const Key, ValueName: string; RootKey: DWord); +class procedure TPreviewHandlerRegister.DeleteRegValue(const Key, ValueName: string; RootKey: HKEY); var RegKey: HKEY; begin diff --git a/Source/uSVGContextMenuHandler.pas b/Source/uSVGContextMenuHandler.pas index 5a129ce..f631bbb 100644 --- a/Source/uSVGContextMenuHandler.pas +++ b/Source/uSVGContextMenuHandler.pas @@ -37,7 +37,9 @@ interface , ComObj , ShlObj , ShellApi - , SVGInterfaces; + , uSettings + , SVGInterfaces + , SVGIconUtils; const MENU_ITEM_OPEN_WITH_EDITOR = 0; @@ -50,8 +52,9 @@ TSVGContextMenu = class(TComObject, IUnknown, //IContextMenu2, IContextMenu3, IShellExtInit) private - fFileName: string; + FFileName: string; FOwnerDrawId: UINT; + FSettings: TPreviewSettings; protected {Declare IContextMenu methods here} function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast, @@ -70,6 +73,8 @@ TSVGContextMenu = class(TComObject, IUnknown, function HandleMenuMsg2(uMsg: UINT; wParam: WPARAM; lParam: LPARAM; var lpResult: LRESULT): HResult; stdcall; function MenuMessageHandler(uMsg: UINT; wParam: WPARAM; lParam: LPARAM; var lpResult: LRESULT): HResult; stdcall; *) + public + destructor Destroy; override; end; TSVGContextMenuFactory = class (TComObjectFactory) @@ -92,13 +97,11 @@ implementation , Registry , uLogExcept , System.Classes - , uSVGSettings {$IFNDEF DISABLE_STYLES} , Vcl.Themes {$ENDIF} , dlgExportPNG - , DResources - , SVGIconUtils; + , DResources; // IShellExtInit method function TSVGContextMenu.InitShellExt(pidlFolder: PItemIDList; @@ -106,11 +109,16 @@ function TSVGContextMenu.InitShellExt(pidlFolder: PItemIDList; var medium: TStgMedium; fe: TFormatEtc; + LFileExt: string; + LCountFile: Integer; begin + TLogPreview.Add('TSVGContextMenu.InitShellExt'); + Result := E_FAIL; // check if the lpdobj pointer is nil - if Assigned (lpdobj) then + if Assigned(lpdobj) then begin + TLogPreview.Add('Assigned(lpdobj)'); with fe do begin cfFormat := CF_HDROP; @@ -121,17 +129,22 @@ function TSVGContextMenu.InitShellExt(pidlFolder: PItemIDList; end; // transform the lpdobj data to a storage medium structure Result := lpdobj.GetData(fe, medium); - if not Failed (Result) then + if not Failed(Result) then begin + LCountFile := DragQueryFile(medium.hGlobal, $FFFFFFFF, nil, 0); + TLogPreview.Add('LCountFile: '+IntToStr(LCountFile)); // check if only one file is selected - if DragQueryFile(medium.hGlobal, $FFFFFFFF, nil, 0) = 1 then + if LCountFile = 1 then begin - SetLength(fFileName, 1000); - DragQueryFile(medium.hGlobal, 0, PChar (fFileName), 1000); + SetLength(FFileName, 1000); + DragQueryFile(medium.hGlobal, 0, PChar (FFileName), 1000); // realign string - fFileName := PChar(fFileName); + FFileName := PChar(FFileName); + FSettings := TPreviewSettings.CreateSettings(nil); + TLogPreview.Add('FFileName: '+FFileName); + LFileExt := ExtractFileExt(FFileName); // only for .svg files - if SameText(ExtractFileExt(fFileName),'.svg') then + if SameText(LFileExt,'.svg') then Result := NOERROR else Result := E_FAIL; @@ -154,7 +167,7 @@ function TSVGContextMenu.QueryContextMenu(Menu: HMENU; // add a new item to context menu LMenuIndex := indexMenu; InsertMenu(Menu, LMenuIndex, MF_STRING or MF_BYPOSITION, idCmdFirst+MENU_ITEM_OPEN_WITH_EDITOR, - 'Open with SVG Text Editor...'); + 'Open with "SVG Text Editor"...'); Inc(LMenuIndex); InsertMenu(Menu, LMenuIndex, MF_STRING or MF_BYPOSITION, idCmdFirst+MENU_ITEM_EXPORT_TO_PNG, 'Export to PNG files...'); @@ -166,20 +179,26 @@ function TSVGContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult var LStringStream: TStringStream; LFileName: string; - LSettings: TPreviewSettings; LSVGText: string; Reg: TRegistry; LCommand: string; procedure EditorNotInstalled; begin - MessageBox(0, 'Editor not installed', 'SVG Shell Extensions', MB_OK); + MessageBox(0, '"SVG Text Editor" not installed', + 'Error opening file', MB_OK); + end; + + procedure EditorNotFound; + begin + MessageBox(0, '"SVG Text Editor" not found!', + 'Error opening file', MB_OK); end; begin Result := NOERROR; // Make sure we are not being called by an application - if HiWord(Integer(lpici.lpVerb)) <> 0 then + if HiWord(NativeInt(lpici.lpVerb)) <> 0 then begin Result := E_FAIL; Exit; @@ -193,7 +212,8 @@ function TSVGContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult // execute the command specified by lpici.lpVerb. if LoWord(lpici.lpVerb) = MENU_ITEM_OPEN_WITH_EDITOR then begin - //TLogPreview.Add('TSVGContextMenu: Menu clicked'); + TLogPreview.Add('TSVGContextMenu: Menu clicked'); + Reg := TRegistry.Create(KEY_READ); try Reg.RootKey := HKEY_CLASSES_ROOT; @@ -202,15 +222,20 @@ function TSVGContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult begin LCommand := Reg.ReadString(''); LCommand := StringReplace(LCommand,' "%1"','', []); - LCommand := StringReplace(LCommand,'"','', [rfReplaceAll]); - TLogPreview.Add(Format('TSVGContextMenuHandler: Open Editor: %s', [LCommand])); - if (LCommand <> '') and FileExists(LCommand) then - ShellExecute(0, 'Open', PChar(LCommand), PChar(FFileName), nil, SW_SHOWNORMAL) + LFileName := format('"%s"',[FFileName]); + TLogPreview.Add(Format('TMDContextMenuHandler: Command: %s FileName %s', + [LCommand, LFileName])); + if (FFileName <> '') and FileExists(FFileName) then + begin + TLogPreview.Add(Format('TSVGContextMenuHandler: ShellExecute: %s for file %s', + [LCommand, LFileName])); + ShellExecute(0, 'Open', PChar(LCommand), PChar(LFileName), nil, SW_SHOWNORMAL); + end else EditorNotInstalled; end else - EditorNotInstalled; + EditorNotFound; finally Reg.Free; end; @@ -221,24 +246,30 @@ function TSVGContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult LStringStream.LoadFromFile(fFileName); try LFileName := ChangeFileExt(fFileName,'.png'); - LSettings := TPreviewSettings.CreateSettings(nil); - try {$IFNDEF DISABLE_STYLES} - if (Trim(LSettings.StyleName) <> '') and not SameText('Windows', LSettings.StyleName) then - TStyleManager.TrySetStyle(LSettings.StyleName, False); + if (Trim(FSettings.StyleName) <> '') and not SameText('Windows', FSettings.StyleName) then + TStyleManager.TrySetStyle(FSettings.StyleName, False); {$ENDIF} - finally - LSettings.Free; - end; + ExportToPNG(TRect.Create(0,0,0,0), + LFileName, + LSVGText, + False, + FSettings.PngExportCustomSize, + FSettings.PngExportFormat, + FSettings.PngExportSizes); LSVGText := LStringStream.DataString; finally LStringStream.Free; end; - ExportToPNG(TRect.Create(0,0,0,0), LFileName, - LSVGText, False); end; end; +destructor TSVGContextMenu.Destroy; +begin + FreeAndNil(FSettings); + inherited; +end; + function TSVGContextMenu.GetCommandString(idCmd: UINT_PTR; uFlags: UINT; pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult; stdcall; begin diff --git a/Source/uSVGThumbnailHandler.pas b/Source/uSVGThumbnailHandler.pas index a91eea4..81e5490 100644 --- a/Source/uSVGThumbnailHandler.pas +++ b/Source/uSVGThumbnailHandler.pas @@ -57,9 +57,9 @@ TThumbnailHandlerClass = class of TSVGThumbnailProvider; end; const - {$EXTERNALSYM IID_IThumbnailProvider} - ThumbnailProviderGUID = '{E357FCCD-A995-4576-B01F-234630154E96}'; - IID_IThumbnailProvider: TGUID = ThumbnailProviderGUID; + {$EXTERNALSYM IID_IThumbnailProvider} + ThumbnailProviderGUID = '{E357FCCD-A995-4576-B01F-234630154E96}'; + IID_IThumbnailProvider: TGUID = ThumbnailProviderGUID; MySVG_ThumbNailProviderGUID: TGUID = '{00580C37-8ED4-41CF-B4DB-B3D3EF6576B0}'; diff --git a/Source/uSVGSettings.pas b/Source/uSettings.pas similarity index 91% rename from Source/uSVGSettings.pas rename to Source/uSettings.pas index 8a7f71a..dc73f3a 100644 --- a/Source/uSVGSettings.pas +++ b/Source/uSettings.pas @@ -27,7 +27,7 @@ { Portions created by Rodrigo Ruz V. are Copyright 2011-2021 Rodrigo Ruz V. } { All Rights Reserved. } {******************************************************************************} -unit uSVGSettings; +unit uSettings; interface @@ -38,6 +38,7 @@ interface SynEditHighlighter, System.Generics.Collections, SynEditOptionsDialog, + SVGIconUtils, IniFiles; const @@ -75,6 +76,10 @@ TSettings = class FActivePageIndex: Integer; FThemeSelection: TThemeSelection; FSVGEngine: TSVGEngine; + FPngExportSizes: TPngExportSizes; + FPngExportFormat: string; + FPngExportCustomSize: Integer; + FPngExportFolder: string; function GetUseDarkStyle: Boolean; procedure SetSVGEngine(const Value: TSVGEngine); procedure SetPreferD2D(const Value: Boolean); @@ -95,6 +100,8 @@ TSettings = class class var FSettingsPath: string; class property SettingsFileName: string read GetSettingsFileName; + procedure UpdateExportToPngSettings(ASizes: TPngExportSizes; const AFolder, AFormat: string; + ACustomSize: Integer); procedure UpdateSettings(const AFontName: string; AFontSize: Integer; AEditorVisible: Boolean); procedure ReadSettings(const ASynEditHighilighter: TSynCustomHighlighter; @@ -113,6 +120,10 @@ TSettings = class property SVGEngine: TSVGEngine read FSVGEngine write SetSVGEngine; property ActivePageIndex: Integer read FActivePageIndex write FActivePageIndex; property ThemeSelection: TThemeSelection read FThemeSelection write FThemeSelection; + property PngExportFolder: string read FPngExportFolder write FPngExportFolder; + property PngExportFormat: string read FPngExportFormat write FPngExportFormat; + property PngExportSizes: TPngExportSizes read FPngExportSizes write FPngExportSizes; + property PngExportCustomSize: Integer read FPngExportCustomSize write FPngExportCustomSize; end; TPreviewSettings = class(TSettings) @@ -317,6 +328,8 @@ procedure TSettings.ReadSettings(const ASynEditHighilighter: TSynCustomHighlight I: Integer; LPreferD2D: Integer; LAttribute: TSynHighlighterAttributes; + LValue: TPngExportSize; + LName: string; begin TLogPreview.Add('ReadSettings '+SettingsFileName); FFontSize := FIniFile.ReadInteger('Global', 'FontSize', 10); @@ -329,6 +342,17 @@ procedure TSettings.ReadSettings(const ASynEditHighilighter: TSynCustomHighlight FActivePageIndex := FIniFile.ReadInteger('Global', 'ActivePageIndex', 0); FStyleName := FIniFile.ReadString('Global', 'StyleName', DefaultStyleName); FThemeSelection := TThemeSelection(FIniFile.ReadInteger('Global', 'ThemeSelection', 0)); + FPngExportFolder := FIniFile.ReadString('PngExport', 'Folder', ''); + FPngExportFormat := FIniFile.ReadString('PngExport', 'Format', '%FileName%_%size%'); + + for LValue in AllPngExportSizes do + begin + LName := getEnumName(typeInfo(TPngExportSize), Ord(LValue)); + if FIniFile.ReadBool('PngExport', LName, True) then + FPngExportSizes := FPngExportSizes + [LValue]; + end; + FPngExportCustomSize := FIniFile.ReadInteger('PngExport', 'CustomSize', 0); + //Select Style by default on Actual Windows Theme if FThemeSelection = tsAsWindows then begin @@ -387,6 +411,26 @@ procedure TSettings.SetSVGEngine(const Value: TSVGEngine); end; end; +procedure TSettings.UpdateExportToPngSettings(ASizes: TPngExportSizes; + const AFolder, AFormat: string; ACustomSize: Integer); +var + LValue: TPngExportSize; + LName: string; +begin + FPngExportFormat := AFormat; + FIniFile.WriteString('PngExport', 'Format', FPngExportFormat); + FPngExportFolder := AFolder; + FIniFile.WriteString('PngExport', 'Folder', FPngExportFolder); + FPngExportCustomSize := ACustomSize; + FIniFile.WriteInteger('PngExport', 'CustomSize', FPngExportCustomSize); + for LValue in AllPngExportSizes do + begin + FPngExportSizes := ASizes; + LName := getEnumName(typeInfo(TPngExportSize), Ord(LValue)); + FIniFile.WriteBool('PngExport', LName, LValue in ASizes); + end; +end; + procedure TSettings.UpdateSettings(const AFontName: string; AFontSize: Integer; AEditorVisible: Boolean); begin diff --git a/Source/uStreamPreviewHandler.pas b/Source/uStreamPreviewHandler.pas index e75b144..989e574 100644 --- a/Source/uStreamPreviewHandler.pas +++ b/Source/uStreamPreviewHandler.pas @@ -33,7 +33,6 @@ interface type TStreamPreviewHandler = class abstract(TPreviewHandler) public - procedure DoPreview(Stream: TIStreamAdapter); virtual; abstract; class function GetComClass: TComClass; override; final; end; @@ -76,7 +75,6 @@ function TComStreamPreviewHandler.IInitializeWithStream_Initialize(const pstream FIStream := pstream; FMode := grfMode; Result := S_OK; - //Result := E_NOTIMPL; TLogPreview.Add('TComStreamPreviewHandler.IInitializeWithStream_Initialize'); end; @@ -94,7 +92,7 @@ procedure TComStreamPreviewHandler.InternalDoPreview; AStream := TIStreamAdapter.Create(FIStream); try CheckContainer; - PreviewHandler.DoPreview(AStream); + Container.LoadFromStream(AStream); finally AStream.Free; end; diff --git a/Source/uThumbnailHandlerRegister.pas b/Source/uThumbnailHandlerRegister.pas index 9d40dc3..b167cdc 100644 --- a/Source/uThumbnailHandlerRegister.pas +++ b/Source/uThumbnailHandlerRegister.pas @@ -37,7 +37,7 @@ interface TThumbnailHandlerRegister = class(TComObjectFactory) private FTThumbnailHandlerClass: TThumbnailHandlerClass; - class procedure DeleteRegValue(const Key, ValueName: string; RootKey: DWord); + class procedure DeleteRegValue(const Key, ValueName: string; RootKey: HKEY); protected public constructor Create(ATThumbnailHandlerClass: TThumbnailHandlerClass; @@ -73,7 +73,7 @@ function TThumbnailHandlerRegister.CreateComObject(const Controller: IUnknown): TComSVGThumbnailProvider(result).ThumbnailHandlerClass := TThumbnailHandlerClass; end; -class procedure TThumbnailHandlerRegister.DeleteRegValue(const Key, ValueName: string; RootKey: DWord); +class procedure TThumbnailHandlerRegister.DeleteRegValue(const Key, ValueName: string; RootKey: HKEY); var RegKey: HKEY; begin