diff --git a/Demo/D11/SVGIconImageCollectionIntoControlList.dproj b/Demo/D11/SVGIconImageCollectionIntoControlList.dproj index 4aa23f5a..60ac3c75 100644 --- a/Demo/D11/SVGIconImageCollectionIntoControlList.dproj +++ b/Demo/D11/SVGIconImageCollectionIntoControlList.dproj @@ -1,7 +1,7 @@ {424FFC3D-39D3-4BF9-8092-2889082C0FFA} - 19.3 + 19.4 VCL True Debug @@ -110,10 +110,6 @@
ControlListMainForm
dfm - - Cfg_2 - Base - Base @@ -121,6 +117,10 @@ Cfg_1 Base + + Cfg_2 + Base + Delphi.Personality.12 diff --git a/Demo/Source/UControlListMain.dfm b/Demo/Source/UControlListMain.dfm index 0b0b98db..bfc252f4 100644 --- a/Demo/Source/UControlListMain.dfm +++ b/Demo/Source/UControlListMain.dfm @@ -4186,19 +4186,15 @@ object ControlListMainForm: TControlListMainForm Top = 232 end object VirtualImageList: TVirtualImageList - DisabledGrayscale = False - DisabledSuffix = '_Disabled' Images = < item CollectionIndex = 0 CollectionName = 'about' - Disabled = False Name = 'about' end item CollectionIndex = 1 CollectionName = 'ok' - Disabled = False Name = 'ok' end> ImageCollection = SVGIconImageButtons diff --git a/Image32/ChangeLog.txt b/Image32/ChangeLog.txt new file mode 100644 index 00000000..164bed9b --- /dev/null +++ b/Image32/ChangeLog.txt @@ -0,0 +1,360 @@ + +Image32 - 2D graphics library for Delphi Pascal +Latest version: 4.11 +Released: 17 February 2022 + +Copyright © 2019-2022 Angus Johnson +Freeware released under Boost Software License +https://www.boost.org/LICENSE_1_0.txt + +Documentation : http://www.angusj.com/delphi/image32/Docs/ +Download : https://sourceforge.net/projects/image32/files/ + +Recent changes: + +Version 4.11 + Fixed compatibility issues with older versions of Delphi. + Updated Img32.Clipper to latest version of Clipper + +Version 4.1 +Img32.Vector + Fixed bug in Grow function (affecting line drawing) + +Version 4.0 +Img32.Layers + This unit has had another major overhaul primarily to add layer + persistence (save layer objects in the file system). + Added TLayer32.MakeRelative and TLayer32.MakeAbsolute methods + Added TLayer32.OuterMargin property (accommodates shadow effects) + Added TLayer32.OuterBounds property + Added TLayer32.InnerRect property + Renamed TLayer32.Bounds property to InnerBounds +Img32.Vector + Significantly improved Grow algorithm +Img32.Text + Renamed GetTextGlyphs to GetTextOutline + Renamed TGlyphCache to TFontCache +Img32.Extra + Added DrawShadowRect procedure + Added TileImage procedure +Sample Applications + Experimental CtrlDemo + Requires Delphi 2010 or newer + + +Version 3.4.1 + Img32.Extra + Bugfix HatchBackground function - + failed to redraw when the image wasn't clear + DrawEdgePath renamed to DrawEdge (now overloaded) + Img32.Layers + Bugfix TLayer32 - + failed to hide layer when Visible set to false + TLayeredImage32 + default BackgroundColor changed to clBtnFace + +Version 3.4 + Img32.SVG.Core + Split into 2 units Img32.SVG.Core & Img32.SVG.Path + Major class redesign to facilitate SVG editing + Img32.SVG.PathDesign + New unit to aid GUI editing of SVG paths + Sample Applications + New SVGPathDesign application + Img32.Layers + Minor bugfix to TLayer32.Move method + +Version 3.3.03 + Img32.Panels + Added TImage32Panel.CopyToImage method that accommodates repainting + small rectangular regions (to significantly improve performance.) + TImage32Panel's published property AllowScroll has been split into + two published properties - AllowKeyScroll & AllowScrnScroll + **Because of this Image32's runtime and designtime packages + (Img32_Library.dpk & Img32_VCL_Dsgn.dpk) should be reinstalled.** + Img32 + Minor bugfix in BlendToAlpha function. + +Version 3.3 + Img32.Layers + Minor bugfixes and performance tweaks + Img32.Extra + Added DrawEdge and DrawEdgePath functions + Img32 + dpiAwareI & dpiAwareD renamed to dpiAware1 & dpiAwareOne + Img32.SmoothPath + This unit has been removed as it will be replaced later + with another unit that will aid designing SVG Paths + Updated Layers301 example again + +Version 3.2.1 + Img32 + Renamed TImage32.BlockUpdate to BlockNotify + Renamed TImage32.UnblockUpdate to UnblockNotify + Img32.Layers + Fixed minor bugs preventing Delphi 7 compile + Updated Layers301 example + +Version 3.2 + Img32.Layers + * This unit has again been rewritten where all layers + can now contain other layers (in a tree like structure + under TLayeredImage32's Root layer). + * The TGroupLayer32 remains but is intended only as a + fully transparent container for other layers rather than + being a fully or even partially opaque surface to other layers. + * TLayer32 Bounds are now relative to their Parent such + that moving a layer will automatically move all contained + children. + * The Layers301 sample application demonstrates new features. + Img32.FMX + The DpiAwareFMX function replaced by the DpiAware function + +Version 3.1 + Img32 + renamed TRectD.Normalize to TRectD.NormalizeRect + to emulate Delphi's TRectF method naming + Img32.Vector + renamed TSizeD's sx and sy fields to cx and cy respectively + again to emulate Delphi's TSize field naming + add RectsOverlap function + add a UnionRect function that replaces the same function + in Delphi's Types unit. (The function in the Types unit + incorrectly unions empty rects which was causing problems) + Img32.Extra + fixed incorrect rotation angle in Draw3D function + Img32.Layers + added TLayer32.Move method + changed TLayer32 Tag property to UserData property + Added TGroupLayer32.ClipPath property + Fixed drawing bug with deeply nested group layers + Samples + Added Layers301 to demonstrate clipped and nested group layers + +Version 3.0 + The Library's unit structure has changed significantly. + (Please see the accompanying install instructions and + the accompanying upgrade utility.) + +Version 2.26 + Image32_SVG_Reader + minor bugfixes + Image32_Ttf + Added TFontManager class + Added FontManager function + +Version 2.25 + Image32_SVG + New unit added + for simple loading of SVG images into TImage32 + Image32_SVG_Reader + Fixed a significant bug (related to DecimalSeparator) + Added text encoding detection +Version 2.24 + Image32_SVG_Reader + New unit added + Image32_SVG_Writer + New unit added + Image32_Vector + DefaultMiterLimit changed to 4 (same as SVG specification) + Removed deprecated esClosed from TEndStyle + (use esPolygon instead) + Improved RoundRect function + Image32_Transform + Changed MatrixSkew parameters + Image32Panels + Renamed CenterImagePoint function to RecenterImageAt + Image32_SmoothPath + SmoothToBezier function moved to Image32_Extra + Image32_Resamplers + Added BoxDownSampling function + Image32_Draw + Added TGradientFillStyle parameter to + TSvgRadialGradientRenderer.SetParameters + Minor bugfix in gradient rendering + Image32_Extra + Modified Erase procedure + Added EraseInverted procedure + Replaced buggy BoxBlur function with + new FastGaussianBlur function + Examples + Added SVG & SVG2 example apps. + Numerous minor bugfixes + +Version 2.23 :) + +Version 2.22 + Image32_Resamplers + Fixed minor bug in BilinearResampler + Fixed minor transparency bug in BicubicResampler + Image32_Transform + Minor updates to SplineHorzTransform and + SplineVertTransform functions + Image32Panels + Minor update + Image32 + RegisterResampler function parameters changed + GetResamplerList procedure added + Image32_Vector + Added GetDistances and GetCumulativeDistances functions + +Version 2.21 + Image32_Resamplers + Fixed bug in BicubicResampler + Image32_Transform + Tidied up Spline transform algorithms + +Version 2.20 + Image32_Resamplers + New library unit added containing 3 resampler functions + NearestResampler - draft quality, fast + BilinearResampler - high quality , average speed (default) + BicubicResampler - best quality , slow + Image32 + DefaultResampler variable added + RegisterResampler function added + TImage32.AntiAliased property removed and replaced with a new + Resampler property (defaults to DefaultResampler) + Image32_Layers + TLayeredImage32.AntiAliased property removed and replaced + with a new Resampler property + Fixed broken layer opacity and other minor bugs + CreateRotatingButtonGroup parameters changed + Image32_Transform + Transform functions will now use the resampler associated + with the image being transformed + Image32_Ttf + TGlyphCache.GetTextGlyphs function result changed + TGlyphCache.GetAngledTextGlyphs function result changed + Image32_Vector + JoinPath procedure renamed AppendPath + Image32Panels + Implemented WM_MOUSEHWHEEL for horizontal scrolling + +Version 2.19 + Image32_Layers + Added AntiAliased property to TLayeredImage32 + Renamed TGroupLayer32.OnMerge property to OnBeforeMerge + Added TGroupLayer32.OnAfterMerge property + Added THitTestLayer32.ClearHitTesting method + Minor tidy up. + Image32_Transform + Transforms can now have antialiasing disabled + Added AffineTransformImageRaw procedure + Image32_Extra + Added ResizeAndCenterImgForRotation procedure + Added Image32Panels + which contains a TImage32 enhanced TPanel component + +Version 2.18 + Image32_Layers + Refactored and improved TRotateLayer32 + Improved TRotatingGroupLayer32 + Examples + Updated Layers201 example app. + Other minor tweaks. + +Version 2.17 + Image32 + Significantly sped up TImage32.CopyToDc + Image32_Layers + Bugfix TLayeredImage32.BackgroundColor + Image32_Ttf + Changed TGlyphCache.GetTextGlyphs function + Image32_Vector + Minor bugfix in Grow function + Other minor tweaks. + +Version 2.16a + Fixed broken SmoothPaths Demo. + Otherwise, a few minor tweaks. + +Version 2.16 + Image32 + TImage32.Antialias property is applied + more consistently with transforms + TImage32.Skew parameters modified + Bugfixes related to rotation direction + Significant code tidy. + +Version 2.15 + Image32_Layers + Further revisions + Other minor updates + +Version 2.14 + Image32_Layers + Bugfix. + +Version 2.13 + Image32_Layers + Bugfix - invisible layers were 'clickable' + Image32_SmoothPath + Bugfix and significant code tidy + +Version 2.12 + Image32 + Added ClockwiseRotationIsAnglePositive global variable. + IMPORTANT: This variable defaults to true, which reverses + the previous direction of rotation. The default direction + now copies that of other Delphi graphics libraries. + Image32_Extra + Added SymmetricCropTransparent procedure + VCL_Image32 Package + Fixed broken link to deleted Image32_Text unit. + +Version 2.11 + Image32_Layers + Minor updates to TRasterLayer32 and TVectorLayer32 + Documentation + A number of minor corrections. + +Version 2.1 + Image32_Layers + Bugfix to TLayeredImage32 - partial merging was broken + Major updates to TRasterLayer32 and TVectorLayer32 + Image32_Vector + Moved all Matrix functions to Image32_Transform + Moved SmoothToBezier function to Image32_SmoothPath + Moved RamerDouglasPeucker function to Image32_Extra + Sample Applications + Updated Layers101 and Layers201 + +Version 2.02 + Minor updates to several Example applications. + +Version 2.01 + Fixed a significant bug in Image32_Ttf. + +Version 2.0 + This is a major update. There are many changes (mainly + to the Image32_Layers unit), and some of these changes + are very likely to break your existing code. Sorry. + + The Image32_Layers unit has been completely rewritten. + The old unit was poorly written and cumbersome to use. + The most significant change in the new layers unit is the + use of nested groups of layers that form a tree structure + under TLayeredImage32.Root. This structure provides several + advantages over the old flat layer structure. These include + faster merges, and much simpler control over layer groups. + Hit-testing has also been dramatically improved, being + both much simpler to setup, and faster at detecting the + correct layer. + + The Image32_Text unit that was deprecated has been removed. + The Image32_Ttf unit provides all the functionality of the + old Image32_Text unit but, unlike its predecessor, supports + cross-platform development. + + Other units have had attention with minor bug fixes and + assorted embellishments, including a significant code tidy + of the esoteric Image32_SmoothPath unit. + + The sample applications have also had significant revision. + Some overly complicated apps have been removed, while others + have been rewritten and simplified. + + The documentation has also been updated to address most if + not all these changes. + \ No newline at end of file diff --git a/Image32/source/Img32.CQ.pas b/Image32/source/Img32.CQ.pas index 95fa0c79..5f1e1927 100644 --- a/Image32/source/Img32.CQ.pas +++ b/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/Image32/source/Img32.Draw.pas b/Image32/source/Img32.Draw.pas index d4cded6e..f6d9d3a5 100644 --- a/Image32/source/Img32.Draw.pas +++ b/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/Image32/source/Img32.Extra.pas b/Image32/source/Img32.Extra.pas index 97653994..db69c1a0 100644 --- a/Image32/source/Img32.Extra.pas +++ b/Image32/source/Img32.Extra.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 * * * @@ -150,6 +150,13 @@ function SmoothToBezier(const path: TPathD; closed: Boolean; function SmoothToBezier(const paths: TPathsD; closed: Boolean; tolerance: double; minSegLength: double = 2): TPathsD; overload; +//GetSmoothPath - uses cubic bezier interpolation and produces +//a series of cubic bezier control points. +//nb: This is very different to the above function which could +//be better named (ie should be renamed) +function GetSmoothPath(const path: TPathD; pathIsClosed: Boolean; + percentOffset, maxCtrlOffset: double; symmetric: Boolean): TPathD; + //InterpolatePoints: smooths a simple line chart. //Points should be left to right and equidistant along the X axis function InterpolatePoints(const points: TPathD; tension: integer = 0): TPathD; @@ -2063,7 +2070,7 @@ function Vectorize(img: TImage32; compareColor: TColor32; //------------------------------------------------------------------------------ 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; @@ -2819,6 +2826,81 @@ function InterpolateY(const y1,y2,y3,y4: double; end; //------------------------------------------------------------------------------ +procedure MakeSymmetric(var val1, val2: double); +begin + val1 := (val1 + val2) * 0.5; + val2 := val1; +end; +//------------------------------------------------------------------------------ + +function GetSmoothPath(const path: TPathD; pathIsClosed: Boolean; + percentOffset, maxCtrlOffset: double; + symmetric: Boolean): TPathD; +var + i, len, prev: integer; + vec: TPointD; + pl: TArrayOfDouble; + unitVecs: TPathD; + d, d1,d2: double; +begin +// GetSmoothPath - returns cubic bezier control points +// parameters: 1. path for smoothing +// 2. whether or not the smoothed path will closed +// 3. percent smoothness (0..100) +// 4. maximum dist control pts from path pts (0 = no limit) +// 5. symmetric vs asymmmetric control pts + + Result := nil; + len := Length(path); + if len < 3 then Exit; + d := Max(0, Min(100, percentOffset))/200; + if maxCtrlOffset <= 0 then maxCtrlOffset := MaxDouble; + + SetLength(Result, len *3 +1); + prev := len-1; + SetLength(pl, len); + SetLength(unitVecs, len); + for i := 0 to len -1 do + begin + pl[i] := Distance(path[prev], path[i]); + unitVecs[i] := GetUnitVector(path[prev], path[i]); + prev := i; + end; + + Result[len*3] := path[0]; + for i := 0 to len -1 do + begin + if i = len -1 then + begin + vec := GetAvgUnitVector(unitVecs[i], unitVecs[0]); + d2 := pl[0]*d; + end else + begin + vec := GetAvgUnitVector(unitVecs[i], unitVecs[i+1]); + d2 := pl[i+1]*d; + end; + d1 := pl[i]*d; + if symmetric then MakeSymmetric(d1, d2); + if i = 0 then + Result[len*3-1] := OffsetPoint(path[i], + -vec.X * Min(maxCtrlOffset, d1), -vec.Y * Min(maxCtrlOffset, d1)) + else + Result[i*3-1] := OffsetPoint(path[i], + -vec.X * Min(maxCtrlOffset, d1), -vec.Y * Min(maxCtrlOffset, d1)); + Result[i*3] := path[i]; + Result[i*3+1] := OffsetPoint(path[i], + vec.X * Min(maxCtrlOffset, d2), vec.Y * Min(maxCtrlOffset, d2)); + end; + if not pathIsClosed then + begin + Result[1] := Result[0]; + dec(len); + Result[len*3-1] := Result[len*3]; + SetLength(Result, Len*3 +1); + end; +end; +//------------------------------------------------------------------------------ + function InterpolatePoints(const points: TPathD; tension: integer): TPathD; var i, j, len, len2: integer; @@ -2848,6 +2930,7 @@ function InterpolatePoints(const points: TPathD; tension: integer): TPathD; AppendPoint(Result, p[len]); end; + //------------------------------------------------------------------------------ // GaussianBlur //------------------------------------------------------------------------------ diff --git a/Image32/source/Img32.FMX.pas b/Image32/source/Img32.FMX.pas index e5b6ea2c..aa809344 100644 --- a/Image32/source/Img32.FMX.pas +++ b/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/Image32/source/Img32.Fmt.BMP.pas b/Image32/source/Img32.Fmt.BMP.pas index 5671caae..2990eb99 100644 --- a/Image32/source/Img32.Fmt.BMP.pas +++ b/Image32/source/Img32.Fmt.BMP.pas @@ -1,1035 +1,1035 @@ -unit Img32.Fmt.BMP; - -(******************************************************************************* -* Author : Angus Johnson * -* Version : 3.0 * -* Date : 20 July 2021 * -* Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2021 * -* Purpose : BMP file format extension for TImage32 * -* License : http://www.boost.org/LICENSE_1_0.txt * -*******************************************************************************) - -interface - -{$I Img32.inc} - -uses - {$IFDEF MSWINDOWS} Windows,{$ENDIF} SysUtils, Classes, Math, Img32; - -type - - //TImage32Fmt_BMP.LoadFromFile() loads correctly all 'good' BMP images - //in Jason Summers' test suite - see http://entropymine.com/jason/bmpsuite/ - //For notes on RLE bitmap compression, see ... - //https://docs.microsoft.com/en-us/windows/desktop/gdi/bitmap-compression - - TImageFormat_BMP = class(TImageFormat) - private - fUseClipboardFormat: Boolean; - fIncludeFileHeaderInSaveStream: Boolean; - public - class function IsValidImageStream(stream: TStream): Boolean; override; - function LoadFromStream(stream: TStream; img32: TImage32): Boolean; override; - function SaveToFile(const filename: string; img32: TImage32): Boolean; override; - procedure SaveToStream(stream: TStream; img32: TImage32); override; -{$IFDEF MSWINDOWS} - class function CanCopyToClipboard: Boolean; override; - class function CopyToClipboard(img32: TImage32): Boolean; override; - class function CanPasteFromClipboard: Boolean; override; - class function PasteFromClipboard(img32: TImage32): Boolean; override; -{$ENDIF} - property IncludeFileHeaderInSaveStream: Boolean read - fIncludeFileHeaderInSaveStream write fIncludeFileHeaderInSaveStream; - end; - -{$IFDEF MSWINDOWS} - function LoadFromHBITMAP(img32: TImage32; bm: HBITMAP; pal: HPALETTE = 0): Boolean; -{$ENDIF} - -implementation - -resourcestring - s_cf_dib_error = 'TImage32 - clipboard CF_DIB format error'; - -type - PTriColor32 = ^TTriColor32; - TTriColor32 = array [0..2] of TColor32; - TArrayOfByte = array of Byte; - - TBitmapFileHeader = packed record - bfType: Word; - bfSize: Cardinal; - bfReserved1: Word; - bfReserved2: Word; - bfOffBits: Cardinal; - end; - - TBitmapInfoHeader = packed record - biSize: Cardinal; - biWidth: Longint; - biHeight: Longint; - biPlanes: Word; - biBitCount: Word; - biCompression: Cardinal; - biSizeImage: Cardinal; - biXPelsPerMeter: Longint; - biYPelsPerMeter: Longint; - biClrUsed: Cardinal; - biClrImportant: Cardinal; - end; - - PBitmapCoreHeader = ^TBitmapCoreHeader; - TBitmapCoreHeader = packed record - bcSize: Cardinal; - bcWidth: Word; - bcHeight: Word; - bcPlanes: Word; - bcBitCount: Word; - end; - - TCIEXYZ = record - ciexyzX: Longint; - ciexyzY: Longint; - ciexyzZ: Longint; - end; - - TCIEXYZTriple = record - ciexyzRed: TCIEXYZ; - ciexyzGreen: TCIEXYZ; - ciexyzBlue: TCIEXYZ; - end; - - TBitmapV4Header = packed record - bV4Size: Cardinal; - bV4Width: Longint; - bV4Height: Longint; - bV4Planes: Word; - bV4BitCount: Word; - bV4V4Compression: Cardinal; - bV4SizeImage: Cardinal; - bV4XPelsPerMeter: Longint; - bV4YPelsPerMeter: Longint; - bV4ClrUsed: Cardinal; - bV4ClrImportant: Cardinal; - bV4RedMask: Cardinal; - bV4GreenMask: Cardinal; - bV4BlueMask: Cardinal; - bV4AlphaMask: Cardinal; - bV4CSType: Cardinal; - bV4Endpoints: TCIEXYZTriple; - bV4GammaRed: Cardinal; - bV4GammaGreen: Cardinal; - bV4GammaBlue: Cardinal; - end; - -const - BI_RGB = 0; - BI_RLE24 = 4; - BI_RLE8 = 1; - BI_RLE4 = 2; - BI_BITFIELDS = 3; - -//------------------------------------------------------------------------------ -// Loading (reading) BMP images from file ... -//------------------------------------------------------------------------------ - -function StreamReadPalette(stream: TStream; - count, size: integer): TArrayOfColor32; -var - i: integer; - c: TARGB; -begin - setLength(Result, count); - for i := 0 to count -1 do - begin - stream.Read(c, size); - with c do result[i] := $FF000000 + R shl 16 + G shl 8 + B; - end; -end; -//------------------------------------------------------------------------------ - -function StreamReadImageWithBitfields(stream: TStream; width, height, - bpp: integer; bitfields: TTriColor32): TArrayOfColor32; -var - i,j,bytesPerRow, bytesPerPix: integer; - shift, size: array[0..2] of byte; - buffer: PByte; - dstPixel: PARGB; - b: PCardinal; -begin - Result := nil; - - //from the 3 bitfields, get each bit mask offset (shift) and bit mask size - for i := 0 to 2 do - begin - size[i] := 0; - shift[i] := 0; - for j := 0 to 31 do - if (size[i] > 0) then - begin - if bitfields[i] and (1 shl j) > 0 then inc(size[i]) - else break; - end - else if bitfields[i] and (1 shl j) > 0 then - begin - shift[i] := j; - size[i] := 1; - end; - end; - - for i := 0 to 2 do - begin - //bitfields larger than 8 aren't supported - if size[i] > 8 then Exit; - //colorXBit.R = (buffer^ and bitfields[0]) shr shift[0] - //and the largest possible value for colorXBit.R = (1 shl size[i]) - 1 - //so convert size[x] to the maximum possible value for colorXBit.R ... - size[i] := (1 shl size[i]) - 1; - end; - - bytesPerPix := bpp div 8; - bytesPerRow := ((31 + bpp * width) div 32) * 4; - setLength(Result, width * height); - GetMem(buffer, bytesPerRow); - try - for i := 0 to height -1 do - begin - stream.Read(buffer^, bytesPerRow); - b := PCardinal(buffer); - dstPixel := @result[i * width]; - for j := 0 to width -1 do - begin - dstPixel.A := 255; - //convert colorXBit.R to color32bit.R ... - //dstPixel.R = colorXBit.R * 255 div size[0] - dstPixel.R := DivTable[(b^ and bitfields[0]) shr shift[0], size[0]]; - dstPixel.G := DivTable[(b^ and bitfields[1]) shr shift[1], size[1]]; - dstPixel.B := DivTable[(b^ and bitfields[2]) shr shift[2], size[2]]; - inc(dstPixel); - inc(PByte(b), bytesPerPix); - end; - end; - finally - FreeMem(buffer); - end; -end; -//------------------------------------------------------------------------------ - -{$RANGECHECKS OFF} -function StreamReadImageWithPalette(stream: TStream; - width, height, bpp: integer; - const palette: TArrayOfColor32): TArrayOfColor32; -var - i,j, bytesPerRow, palHigh, pxCnt: integer; - buffer: TArrayOfByte; - b: PByte; - dstPixel: PColor32; - c, shift: byte; -begin - shift := 8 - bpp; - bytesPerRow := ((31 + bpp * width) div 32) * 4; - setLength(Result, width * height); - palHigh := High(palette); - SetLength(buffer, bytesPerRow); - for i := 0 to height -1 do - begin - stream.Read(buffer[0], bytesPerRow); - b := @buffer[0]; - dstPixel := @result[i * width]; - pxCnt := 0; - for j := 0 to width -1 do - begin - pxCnt := (pxCnt + bpp) mod 8; - c := Ord(b^) shr shift; - if c > palHigh then dstPixel^ := clNone32 - else dstPixel^ := palette[c]; - if pxCnt = 0 then inc(b) - else Byte(b^) := Ord(b^) shl bpp; - inc(dstPixel); - end; - end; -end; -//------------------------------------------------------------------------------ - -function GetByte(stream: TStream): Byte; -{$IFDEF INLINE} inline; {$ENDIF} -begin - stream.Read(Result, 1); -end; -//------------------------------------------------------------------------------ - -function GetNibble(stream: TStream; var bitsOffset: integer): Byte; -begin - stream.Read(Result, 1); - if bitsOffset = 4 then - begin - result := result and $F; - bitsOffset := 0; - end else - begin - Stream.Position := Stream.Position -1; - result := result shr 4; - bitsOffset := 4; - end; -end; -//------------------------------------------------------------------------------ - -function ReadRLE4orRLE8Compression(stream: TStream; - width, height, bpp: integer; - const palette: TArrayOfColor32): TArrayOfColor32; -var - i,j,k, cnt, idx: integer; - w, delta, bitOffset: integer; - dst: PColor32; - byte1, byte2: byte; -const - COMMAND_BYTE = 0; - DELTA_MODE = 2; -begin - setLength(Result, width * height); - for i := 0 to height -1 do - begin - dst := @result[i * width]; - w := 0; idx := 0; - while w < width do - begin - byte1 := GetByte(stream); - byte2 := GetByte(stream); - if byte1 = COMMAND_BYTE then - begin - if byte2 < 2 then Exit //error - else if byte2 = DELTA_MODE then - begin - cnt := GetByte(stream); - delta := GetByte(stream); - if delta > 0 then Exit; //Y-delta never seen & not supported - for k := 1 to cnt do - begin - dst^ := palette[idx]; - inc(w); - inc(dst); - end; - end - else //'absolute mode' - begin - cnt := byte2; - bitOffset := 0; - for k := 1 to cnt do - begin - if bpp = 4 then - idx := GetNibble(stream, bitOffset) else - idx := GetByte(stream); - dst^ := palette[idx]; - inc(w); - if w = width then break; - inc(dst); - end; - if bitOffset > 0 then GetByte(stream); - if Odd(stream.Position) then - GetByte(stream); //ie must be WORD aligned - end; - end else //'encoded mode' - begin - cnt := byte1; - if bpp = 4 then - begin - for j := 1 to cnt do - begin - if Odd(j) then - idx := byte2 shr 4 else - idx := byte2 and $F; - dst^ := palette[idx]; - inc(w); - if w = width then break; - inc(dst); - end; - end else - begin - idx := byte2; - for j := 1 to cnt do - begin - dst^ := palette[idx]; - inc(w); - inc(dst); - end; - end; - end; - end; - byte1 := GetByte(stream); - byte2 := GetByte(stream); - if (byte1 <> 0) or (byte2 <> 0) then Exit; - end; -end; -//------------------------------------------------------------------------------ - -function IsValidBitFields(const bitFields: TTriColor32): boolean; -begin - //make sure each color channel has a mask and that they don't overlap ... - result := (bitFields[0] <> 0) and (bitFields[1] <> 0) and - (bitFields[2] <> 0) and (bitFields[0] and bitFields[1] = 0) and - (bitFields[0] and bitFields[2] = 0) and (bitFields[1] and bitFields[2] = 0); -end; -//------------------------------------------------------------------------------ - -function AlphaChannelAllZero(img32: TImage32): Boolean; -var - i: integer; - pc: PARGB; -begin - result := false; - pc := PARGB(img32.PixelBase); - for i := 0 to img32.Width * img32.Height -1 do - begin - if (pc.A > 0) then Exit; - inc(pc); - end; - result := true; -end; -//------------------------------------------------------------------------------ - -procedure ResetAlphaChannel(img32: TImage32); -var - i: integer; - pc: PARGB; -begin - pc := PARGB(img32.PixelBase); - for i := 0 to img32.Width * img32.Height -1 do - begin - pc.A := 255; - inc(pc); - end; -end; -//------------------------------------------------------------------------------ - -class function TImageFormat_BMP.IsValidImageStream(stream: TStream): Boolean; -var - savedPos: integer; - flag: Cardinal; -const - SizeOfBitmapInfoHeader = 40; - SizeOfBitmapV4Header = 108; - SizeOfBitmapV5Header = 124; -begin - Result := false; - savedPos := stream.position; - if stream.size - savedPos <= 4 then Exit; - stream.read(flag, SizeOf(flag)); - stream.Position := savedPos; - Result := ((flag and $FFFF) = $4D42) or - (flag = SizeOfBitmapInfoHeader) or - (flag = SizeOfBitmapV4Header) or - (flag = SizeOfBitmapV5Header); -end; -//------------------------------------------------------------------------------ - -function TImageFormat_BMP.LoadFromStream(stream: TStream; - img32: TImage32): Boolean; -var - palEntrySize: integer; - bihStart: cardinal; - bfh: TBitmapFileHeader; - bih: TBitmapInfoHeader; - tmp, pal: TArrayOfColor32; - bitfields: TTriColor32; - isTopDown, hasValidBitFields: boolean; - pb: PByteArray; -begin - result := false; - with stream do - begin - if Size < sizeof(bih) then Exit; - bihStart := stream.Position; - - //some streams (eg resource streams) omit the file header ... - Read(bfh, SizeOf(bfh)); - if bfh.bfType = $4D42 then - begin - inc(bihStart, SizeOf(bfh)) - end else - begin - bfh.bfOffBits := 0; - stream.Position := bihStart; - end; - - Read(bih, sizeof(bih)); - - if bih.biSize < sizeof(bih) then //accommodate dodgy TBitmapInfoHeader's - begin - if bih.biSize 32) or - (bih.biWidth > $3FFF) or (bih.biHeight > $3FFF) or //16,383 - (bih.biCompression > BI_BITFIELDS) then Exit; - - isTopDown := bih.biHeight < 0; - bih.biHeight := abs(bih.biHeight); - - if ((bih.biCompression and BI_BITFIELDS) = BI_BITFIELDS) then - begin - stream.Position := bihStart + 40; - stream.Read(bitfields[0], Sizeof(TTriColor32)); - hasValidBitFields := IsValidBitFields(bitfields); - if stream.Position < bihStart + bih.biSize then - stream.Position := bihStart + bih.biSize; - end else - begin - hasValidBitFields := false; - stream.Position := bihStart + bih.biSize; - end; - - if not hasValidBitFields then - begin - if bih.biBitCount = 24 then - begin - bitfields[0] := $FF shl 16; - bitfields[1] := $FF shl 8; - bitfields[2] := $FF; - hasValidBitFields := true; - end - else if bih.biBitCount = 16 then - begin - bitfields[0] := $1F shl 10; - bitfields[1] := $1F shl 5; - bitfields[2] := $1F; - hasValidBitFields := true; - end; - end; - - if bih.biClrUsed > 256 then bih.biClrUsed := 0; - - if (bih.biClrUsed = 0) and (bih.biBitCount < 16) then - bih.biClrUsed := Trunc(Power(2, bih.biBitCount)); - - if bih.biClrUsed > 0 then - pal := StreamReadPalette(stream, bih.biClrUsed, palEntrySize); - - tmp := nil; - result := true; - img32.BeginUpdate; - try - img32.SetSize(bih.biWidth, bih.biHeight); - - //read pixels .... - if stream.Position < bfh.bfOffBits then stream.Position := bfh.bfOffBits; - - if hasValidBitFields then - tmp := StreamReadImageWithBitfields( - stream, img32.Width, img32.Height, bih.biBitCount, bitfields) - - else if (bih.biBitCount = 32) then - begin - Read(img32.Pixels[0], bih.biWidth * bih.biHeight * sizeof(TColor32)); - if AlphaChannelAllZero(img32) then ResetAlphaChannel(img32); - end - - else if (bih.biCompression = BI_RLE8) or (bih.biCompression = BI_RLE4) then - tmp := ReadRLE4orRLE8Compression( - stream, img32.Width, img32.Height, bih.biBitCount, pal) - - else tmp := StreamReadImageWithPalette( - stream, img32.Width, img32.Height, bih.biBitCount, pal); - - if assigned(tmp) and (length(tmp) = img32.Width * img32.Height) then - move(tmp[0], img32.Pixels[0], length(tmp) * sizeof(TColor32)); - - if not isTopDown then img32.FlipVertical; - finally - img32.EndUpdate; - end; - end; -end; - -//------------------------------------------------------------------------------ -// Saving (writing) BMP images to file ... -//------------------------------------------------------------------------------ - -function GetFileHeaderFromInfoHeader(stream: TStream; - BitmapInfoHeaderOffset: integer): TBitmapFileHeader; -var - bih: TBitmapInfoHeader; -begin - FillChar(Result, sizeof(Result), #0); - Result.bfType := $4D42; - stream.Position := BitmapInfoHeaderOffset; - stream.Read(bih, sizeof(bih)); - if (bih.biWidth = 0) or (bih.biHeight = 0) then Exit; - Result.bfSize := bih.biSizeImage; - Result.bfOffBits := (stream.Size - bih.biSizeImage); -end; -//------------------------------------------------------------------------------ - -function MakeBitfields: TTriColor32; -begin - result[0] := $FF0000; - result[1] := $00FF00; - result[2] := $0000FF; -end; -//------------------------------------------------------------------------------ - -function GetRowSize(bitCount, imageWidth: integer): integer; -begin - result := ((31 + BitCount * imageWidth) div 32) * 4; -end; -//------------------------------------------------------------------------------ - -function Find(color: TColor32; const colors: TArrayOfColor32; - colorsCnt: integer; out idx: integer): Boolean; -var - i,l,r: integer; -begin - //binary search a sorted list ... - Result := False; - l := 0; r := colorsCnt -1; - while l <= r do - begin - idx := (l + r) shr 1; - - i := integer(colors[idx]) - integer(color); - if i < 0 then l := idx +1 - else - begin - r := idx -1; - if i = 0 then - begin - result := true; - l := idx; - end; - end; - end; - idx := l; -end; -//------------------------------------------------------------------------------ - -function IndexOf(color: TColor32; const colors: TArrayOfColor32): integer; -var - i,l,r: integer; -begin - //binary search a sorted list ... - l := 0; r := Length(colors) -1; - while l <= r do - begin - result := (l + r) shr 1; - i := integer(colors[result]) - integer(color); - if i < 0 then l := result +1 - else - begin - r := result -1; - if i = 0 then l := result; - end; - end; - result := l; -end; -//------------------------------------------------------------------------------ - -procedure Insert256(color: TColor32; - var colors256: TArrayOfColor32; cnt, idx: integer); -begin - if idx < cnt then - move(colors256[idx], colors256[idx +1], (cnt - idx) * SizeOf(TColor32)); - colors256[idx] := color; -end; -//------------------------------------------------------------------------------ - -function GetPaletteColors(img32: TImage32): TArrayOfColor32; -var - i, idx, palLen: integer; - c: TColor32; - pc: PColor32; -begin - Result := nil; - if img32.IsEmpty then Exit; - SetLength(Result, 256); - palLen := 0; - pc := PColor32(img32.PixelBase); - for i := 0 to img32.Width * img32.Height -1 do - begin - c := pc^ and $FFFFFF; - if not Find(c, result, palLen, idx) then - begin - if palLen = 256 then - begin - result := nil; //too many colors for a palette - Exit; - end; - Insert256(c, result, palLen, idx); - inc(palLen); - end; - inc(pc); - end; - SetLength(Result, palLen); -end; -//------------------------------------------------------------------------------ - -procedure StreamWriteLoBitImage(img32: TImage32; const pals: TArrayOfColor32; - BitCount: integer; stream: TStream); -var - i, j, k, pxlPerByte, rowSize, delta, shiftSize, totalBytes: integer; - buffer: TArrayOfByte; - pSrc: PColor32; - pDst: PByte; -begin - pxlPerByte := 8 div BitCount; - rowSize := GetRowSize(BitCount, img32.Width); - delta := rowSize - img32.Width div pxlPerByte; - //delphi doesn't handle modulo of negatives as expected so ... - shiftSize := img32.Width mod pxlPerByte; - if shiftSize > 0 then shiftSize := pxlPerByte - shiftSize; - totalBytes := rowSize * img32.Height; - SetLength(buffer, totalBytes); - fillChar(buffer[0], totalBytes, 0); - pSrc := img32.PixelBase; - pDst := @buffer[0]; - for i := 1 to img32.Height do - begin - k := 0; - for j := 1 to img32.Width do - begin - k := k shl BitCount + IndexOf(pSrc^ and $FFFFFF, pals); - if (j mod pxlPerByte = 0) then - begin - Byte(pDst^) := k; - inc(pDst); - k := 0; - end; - inc(pSrc); - end; - if shiftSize > 0 then Byte(pDst^) := k shl shiftSize; - inc(pDst, delta); - end; - stream.Write(buffer[0], totalBytes); -end; -//------------------------------------------------------------------------------ - -procedure StreamWrite24BitImage(img32: TImage32; stream: TStream); -var - i,j, delta, rowSize, totalBytes: integer; - buffer: TArrayOfByte; - pc: PColor32; - pb: PByte; -begin - rowSize := GetRowSize(24, img32.Width); - delta := rowSize - (img32.Width *3); - totalBytes := rowSize * img32.Height; - setLength(buffer, totalBytes); - fillChar(buffer[0], totalBytes, 0); - pb := @buffer[0]; - pc := img32.PixelBase; - for i := 0 to img32.Height -1 do - begin - for j := 0 to img32.Width -1 do - begin - Move(pc^, pb^, 3); //ie skipping the alpha byte - inc(pc); inc(pb, 3); - end; - inc(pb, delta); - end; - stream.Write(buffer[0], totalBytes); //much faster to do this once -end; -//------------------------------------------------------------------------------ - -procedure TImageFormat_BMP.SaveToStream(stream: TStream; img32: TImage32); -var - bfh: TBitmapFileHeader; - bih: TBitmapV4Header; - palCnt, BitCount, rowSize, infoHeaderOffset: integer; - UsesAlpha: Boolean; - pals: TArrayOfColor32; - tmp: TImage32; - writeValue: TTriColor32; -begin - //write everything except a BMP file header because some streams - //(eg resource streams) don't need a file header - - if fUseClipboardFormat then - UsesAlpha := false else - UsesAlpha := img32.HasTransparency; - - if fUseClipboardFormat or UsesAlpha then - begin - BitCount := 32; - palCnt := 0; - end else - begin - pals := GetPaletteColors(img32); - palCnt := Length(pals); - if palCnt = 0 then BitCount := 24 - else if palCnt > 16 then BitCount := 8 - else if palCnt > 2 then BitCount := 4 - else BitCount := 1; - end; - - if fIncludeFileHeaderInSaveStream then - begin - //Write empty BitmapFileHeader ... - FillChar(bfh, sizeof(bfh), #0); - stream.Write(bfh, sizeOf(bfh)); - end; - infoHeaderOffset := stream.Position; - - FillChar(bih, sizeof(bih), #0); - rowSize := GetRowSize(BitCount, img32.Width); - bih.bV4Width := img32.Width; - bih.bV4Height := img32.Height; - bih.bV4Planes := 1; - bih.bV4BitCount := BitCount; - bih.bV4ClrUsed := palCnt; - bih.bV4SizeImage := rowSize * img32.Height; - if UsesAlpha then - begin - bih.bV4Size := sizeof(TBitmapV4Header); - bih.bV4V4Compression := BI_BITFIELDS; - bih.bV4RedMask := $FF shl 16; - bih.bV4GreenMask := $FF shl 8; - bih.bV4BlueMask := $FF; - bih.bV4AlphaMask := Cardinal($FF) shl 24; - end else - begin - bih.bV4Size := sizeof(TBitmapInfoHeader); //Version2 header - bih.bV4V4Compression := BI_RGB; - end; - - tmp := TImage32.Create(img32); - try - tmp.FlipVertical; - - case BitCount of - 1,4,8: - begin - stream.Write(bih, bih.bV4Size); - SetLength(pals, palCnt); - stream.Write(pals[0], palCnt * 4); - StreamWriteLoBitImage(tmp, pals, BitCount, stream); - end; - 24: - begin - bih.bV4V4Compression := BI_BITFIELDS; - stream.Write(bih, bih.bV4Size); - writeValue := MakeBitfields; - stream.Write(writeValue, SizeOf(TTriColor32)); - StreamWrite24BitImage(tmp, stream); - end - else - begin - stream.Write(bih, bih.bV4Size); - stream.Write(tmp.Pixels[0], tmp.Width * tmp.Height * sizeof(TColor32)); - end; - end; - finally - tmp.Free; - end; - - if fIncludeFileHeaderInSaveStream then - begin - //finally update BitmapFileHeader ... - bfh := GetFileHeaderFromInfoHeader(stream, infoHeaderOffset); - stream.Position := infoHeaderOffset - sizeOf(bfh); - stream.Write(bfh, sizeOf(bfh)); - end; - -end; -//------------------------------------------------------------------------------ - -function TImageFormat_BMP.SaveToFile(const filename: string; - img32: TImage32): Boolean; -var - SaveStateIncludeFileHeader: Boolean; - stream: TFilestream; -begin - result := not img32.IsEmpty; - if not result then Exit; - SaveStateIncludeFileHeader := fIncludeFileHeaderInSaveStream; - stream := TFileStream.Create(filename, fmCreate); - try - fIncludeFileHeaderInSaveStream := true; - fUseClipboardFormat := false; - SaveToStream(stream, img32); - finally - stream.Free; - fIncludeFileHeaderInSaveStream := SaveStateIncludeFileHeader; - end; -end; -//------------------------------------------------------------------------------ - -{$IFDEF MSWINDOWS} - -class function TImageFormat_BMP.CanCopyToClipboard: Boolean; -begin - Result := true; -end; -//------------------------------------------------------------------------------ - -class function TImageFormat_BMP.CopyToClipboard(img32: TImage32): Boolean; -var - dataHdl: THandle; - dataPtr: pointer; - ms: TMemoryStream; -begin - result := OpenClipboard(0); - if not Result then Exit; - ms := TMemoryStream.Create; - try - with TImageFormat_BMP.Create do - try - fUseClipboardFormat := true; - SaveToStream(ms, img32); - finally - free; - end; - - dataHdl := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE, ms.Size); - try - dataPtr := GlobalLock(dataHdl); - try - Move(ms.Memory^, dataPtr^, ms.Size); - finally - GlobalUnlock(dataHdl); - end; - if SetClipboardData(CF_DIB, dataHdl) = 0 then - raise Exception.Create(s_cf_dib_error); - except - GlobalFree(dataHdl); - raise; - end; - - finally - ms.free; - CloseClipboard; - end; -end; -//------------------------------------------------------------------------------ - -class function TImageFormat_BMP.CanPasteFromClipboard: Boolean; -begin - result := IsClipboardFormatAvailable(CF_DIB) or - IsClipboardFormatAvailable(CF_BITMAP); -end; -//------------------------------------------------------------------------------ - -class function TImageFormat_BMP.PasteFromClipboard(img32: TImage32): Boolean; -var - dataHdl: THandle; - bitmapHdl: HBITMAP; - paletteHdl: HPALETTE; - dataPtr: pointer; - ms: TMemoryStream; -begin - result := OpenClipboard(0); - if not Result then Exit; - - try - if IsClipboardFormatAvailable(CF_DIB) then - begin - ms := TMemoryStream.Create; - try - dataHdl := GetClipboardData(CF_DIB); - result := dataHdl > 0; - if not result then Exit; - - ms.SetSize(GlobalSize(dataHdl)); - dataPtr := GlobalLock(dataHdl); - try - Move(dataPtr^, ms.Memory^, ms.Size); - finally - GlobalUnlock(dataHdl); - end; - - ms.Position := 0; - with TImageFormat_BMP.Create do - try - LoadFromStream(ms, img32); - finally - Free; - end; - finally - ms.free; - end; - - end - else if IsClipboardFormatAvailable(CF_BITMAP) then - begin - bitmapHdl := GetClipboardData(CF_BITMAP); - if IsClipboardFormatAvailable(CF_PALETTE) then - paletteHdl := GetClipboardData(CF_PALETTE) else - paletteHdl := 0; - result := bitmapHdl > 0; - if result then - LoadFromHBITMAP(img32, bitmapHdl, paletteHdl); - end; - - finally - CloseClipboard; - end; -end; - -//------------------------------------------------------------------------------ - -function LoadFromHBITMAP(img32: TImage32; bm: HBITMAP; pal: HPALETTE): Boolean; -var - w, h: integer; - memDc: HDC; - oldBitmap, oldPalette: HGDIOBJ; - bi: BITMAPINFO; -begin - result := false; - memDC := CreateCompatibleDC(0); - try - oldBitmap := SelectObject(memDC, bm); - if (pal > 0) then - begin - oldPalette := SelectPalette(memDC, pal, FALSE); - RealizePalette(memDc); - end else - oldPalette := 0; - - FillChar(bi, SizeOf(bi), 0); - bi.bmiHeader.biSize := SizeOf(bi); - if GetDIBits(memDc, bm, 0, 0, nil, bi, DIB_RGB_COLORS) = 0 then Exit; - h := abs(bi.bmiHeader.biHeight); - bi.bmiHeader.biHeight := h; - w := bi.bmiHeader.biWidth; - bi.bmiHeader.biBitCount := 32; - bi.bmiHeader.biCompression := BI_RGB; - - img32.BeginUpdate; - try - img32.SetSize(w, h); - if GetDIBits(memDc, bm, 0, h, - PByte(img32.PixelBase), bi, DIB_RGB_COLORS) = 0 then Exit; - img32.FlipVertical; - finally - img32.EndUpdate; - end; - - SelectObject(memDC, oldBitmap); - if (oldPalette > 0) then - SelectObject(memDC, oldPalette); - Result := true; - finally - DeleteDC(memDC); - end; -end; -//------------------------------------------------------------------------------ -{$ENDIF} - -initialization - TImage32.RegisterImageFormatClass('BMP', TImageFormat_BMP, cpLow); - -end. +unit Img32.Fmt.BMP; + +(******************************************************************************* +* Author : Angus Johnson * +* Version : 4.2 * +* Date : 30 May 2022 * +* Website : http://www.angusj.com * +* Copyright : Angus Johnson 2019-2021 * +* Purpose : BMP file format extension for TImage32 * +* License : http://www.boost.org/LICENSE_1_0.txt * +*******************************************************************************) + +interface + +{$I Img32.inc} + +uses + {$IFDEF MSWINDOWS} Windows,{$ENDIF} SysUtils, Classes, Math, Img32; + +type + + //TImage32Fmt_BMP.LoadFromFile() loads correctly all 'good' BMP images + //in Jason Summers' test suite - see http://entropymine.com/jason/bmpsuite/ + //For notes on RLE bitmap compression, see ... + //https://docs.microsoft.com/en-us/windows/desktop/gdi/bitmap-compression + + TImageFormat_BMP = class(TImageFormat) + private + fUseClipboardFormat: Boolean; + fIncludeFileHeaderInSaveStream: Boolean; + public + class function IsValidImageStream(stream: TStream): Boolean; override; + function LoadFromStream(stream: TStream; img32: TImage32): Boolean; override; + function SaveToFile(const filename: string; img32: TImage32): Boolean; override; + procedure SaveToStream(stream: TStream; img32: TImage32); override; +{$IFDEF MSWINDOWS} + class function CanCopyToClipboard: Boolean; override; + class function CopyToClipboard(img32: TImage32): Boolean; override; + class function CanPasteFromClipboard: Boolean; override; + class function PasteFromClipboard(img32: TImage32): Boolean; override; +{$ENDIF} + property IncludeFileHeaderInSaveStream: Boolean read + fIncludeFileHeaderInSaveStream write fIncludeFileHeaderInSaveStream; + end; + +{$IFDEF MSWINDOWS} + function LoadFromHBITMAP(img32: TImage32; bm: HBITMAP; pal: HPALETTE = 0): Boolean; +{$ENDIF} + +implementation + +resourcestring + s_cf_dib_error = 'TImage32 - clipboard CF_DIB format error'; + +type + PTriColor32 = ^TTriColor32; + TTriColor32 = array [0..2] of TColor32; + TArrayOfByte = array of Byte; + + TBitmapFileHeader = packed record + bfType: Word; + bfSize: Cardinal; + bfReserved1: Word; + bfReserved2: Word; + bfOffBits: Cardinal; + end; + + TBitmapInfoHeader = packed record + biSize: Cardinal; + biWidth: Longint; + biHeight: Longint; + biPlanes: Word; + biBitCount: Word; + biCompression: Cardinal; + biSizeImage: Cardinal; + biXPelsPerMeter: Longint; + biYPelsPerMeter: Longint; + biClrUsed: Cardinal; + biClrImportant: Cardinal; + end; + + PBitmapCoreHeader = ^TBitmapCoreHeader; + TBitmapCoreHeader = packed record + bcSize: Cardinal; + bcWidth: Word; + bcHeight: Word; + bcPlanes: Word; + bcBitCount: Word; + end; + + TCIEXYZ = record + ciexyzX: Longint; + ciexyzY: Longint; + ciexyzZ: Longint; + end; + + TCIEXYZTriple = record + ciexyzRed: TCIEXYZ; + ciexyzGreen: TCIEXYZ; + ciexyzBlue: TCIEXYZ; + end; + + TBitmapV4Header = packed record + bV4Size: Cardinal; + bV4Width: Longint; + bV4Height: Longint; + bV4Planes: Word; + bV4BitCount: Word; + bV4V4Compression: Cardinal; + bV4SizeImage: Cardinal; + bV4XPelsPerMeter: Longint; + bV4YPelsPerMeter: Longint; + bV4ClrUsed: Cardinal; + bV4ClrImportant: Cardinal; + bV4RedMask: Cardinal; + bV4GreenMask: Cardinal; + bV4BlueMask: Cardinal; + bV4AlphaMask: Cardinal; + bV4CSType: Cardinal; + bV4Endpoints: TCIEXYZTriple; + bV4GammaRed: Cardinal; + bV4GammaGreen: Cardinal; + bV4GammaBlue: Cardinal; + end; + +const + BI_RGB = 0; + BI_RLE24 = 4; + BI_RLE8 = 1; + BI_RLE4 = 2; + BI_BITFIELDS = 3; + +//------------------------------------------------------------------------------ +// Loading (reading) BMP images from file ... +//------------------------------------------------------------------------------ + +function StreamReadPalette(stream: TStream; + count, size: integer): TArrayOfColor32; +var + i: integer; + c: TARGB; +begin + setLength(Result, count); + for i := 0 to count -1 do + begin + stream.Read(c, size); + with c do result[i] := $FF000000 + R shl 16 + G shl 8 + B; + end; +end; +//------------------------------------------------------------------------------ + +function StreamReadImageWithBitfields(stream: TStream; width, height, + bpp: integer; bitfields: TTriColor32): TArrayOfColor32; +var + i,j,bytesPerRow, bytesPerPix: integer; + shift, size: array[0..2] of byte; + buffer: PByte; + dstPixel: PARGB; + b: PCardinal; +begin + Result := nil; + + //from the 3 bitfields, get each bit mask offset (shift) and bit mask size + for i := 0 to 2 do + begin + size[i] := 0; + shift[i] := 0; + for j := 0 to 31 do + if (size[i] > 0) then + begin + if bitfields[i] and (1 shl j) > 0 then inc(size[i]) + else break; + end + else if bitfields[i] and (1 shl j) > 0 then + begin + shift[i] := j; + size[i] := 1; + end; + end; + + for i := 0 to 2 do + begin + //bitfields larger than 8 aren't supported + if size[i] > 8 then Exit; + //colorXBit.R = (buffer^ and bitfields[0]) shr shift[0] + //and the largest possible value for colorXBit.R = (1 shl size[i]) - 1 + //so convert size[x] to the maximum possible value for colorXBit.R ... + size[i] := (1 shl size[i]) - 1; + end; + + bytesPerPix := bpp div 8; + bytesPerRow := ((31 + bpp * width) div 32) * 4; + setLength(Result, width * height); + GetMem(buffer, bytesPerRow); + try + for i := 0 to height -1 do + begin + stream.Read(buffer^, bytesPerRow); + b := PCardinal(buffer); + dstPixel := @result[i * width]; + for j := 0 to width -1 do + begin + dstPixel.A := 255; + //convert colorXBit.R to color32bit.R ... + //dstPixel.R = colorXBit.R * 255 div size[0] + dstPixel.R := DivTable[(b^ and bitfields[0]) shr shift[0], size[0]]; + dstPixel.G := DivTable[(b^ and bitfields[1]) shr shift[1], size[1]]; + dstPixel.B := DivTable[(b^ and bitfields[2]) shr shift[2], size[2]]; + inc(dstPixel); + inc(PByte(b), bytesPerPix); + end; + end; + finally + FreeMem(buffer); + end; +end; +//------------------------------------------------------------------------------ + +{$RANGECHECKS OFF} +function StreamReadImageWithPalette(stream: TStream; + width, height, bpp: integer; + const palette: TArrayOfColor32): TArrayOfColor32; +var + i,j, bytesPerRow, palHigh, pxCnt: integer; + buffer: TArrayOfByte; + b: PByte; + dstPixel: PColor32; + c, shift: byte; +begin + shift := 8 - bpp; + bytesPerRow := ((31 + bpp * width) div 32) * 4; + setLength(Result, width * height); + palHigh := High(palette); + SetLength(buffer, bytesPerRow); + for i := 0 to height -1 do + begin + stream.Read(buffer[0], bytesPerRow); + b := @buffer[0]; + dstPixel := @result[i * width]; + pxCnt := 0; + for j := 0 to width -1 do + begin + pxCnt := (pxCnt + bpp) mod 8; + c := Ord(b^) shr shift; + if c > palHigh then dstPixel^ := clNone32 + else dstPixel^ := palette[c]; + if pxCnt = 0 then inc(b) + else Byte(b^) := Ord(b^) shl bpp; + inc(dstPixel); + end; + end; +end; +//------------------------------------------------------------------------------ + +function GetByte(stream: TStream): Byte; +{$IFDEF INLINE} inline; {$ENDIF} +begin + stream.Read(Result, 1); +end; +//------------------------------------------------------------------------------ + +function GetNibble(stream: TStream; var bitsOffset: integer): Byte; +begin + stream.Read(Result, 1); + if bitsOffset = 4 then + begin + result := result and $F; + bitsOffset := 0; + end else + begin + Stream.Position := Stream.Position -1; + result := result shr 4; + bitsOffset := 4; + end; +end; +//------------------------------------------------------------------------------ + +function ReadRLE4orRLE8Compression(stream: TStream; + width, height, bpp: integer; + const palette: TArrayOfColor32): TArrayOfColor32; +var + i,j,k, cnt, idx: integer; + w, delta, bitOffset: integer; + dst: PColor32; + byte1, byte2: byte; +const + COMMAND_BYTE = 0; + DELTA_MODE = 2; +begin + setLength(Result, width * height); + for i := 0 to height -1 do + begin + dst := @result[i * width]; + w := 0; idx := 0; + while w < width do + begin + byte1 := GetByte(stream); + byte2 := GetByte(stream); + if byte1 = COMMAND_BYTE then + begin + if byte2 < 2 then Exit //error + else if byte2 = DELTA_MODE then + begin + cnt := GetByte(stream); + delta := GetByte(stream); + if delta > 0 then Exit; //Y-delta never seen & not supported + for k := 1 to cnt do + begin + dst^ := palette[idx]; + inc(w); + inc(dst); + end; + end + else //'absolute mode' + begin + cnt := byte2; + bitOffset := 0; + for k := 1 to cnt do + begin + if bpp = 4 then + idx := GetNibble(stream, bitOffset) else + idx := GetByte(stream); + dst^ := palette[idx]; + inc(w); + if w = width then break; + inc(dst); + end; + if bitOffset > 0 then GetByte(stream); + if Odd(stream.Position) then + GetByte(stream); //ie must be WORD aligned + end; + end else //'encoded mode' + begin + cnt := byte1; + if bpp = 4 then + begin + for j := 1 to cnt do + begin + if Odd(j) then + idx := byte2 shr 4 else + idx := byte2 and $F; + dst^ := palette[idx]; + inc(w); + if w = width then break; + inc(dst); + end; + end else + begin + idx := byte2; + for j := 1 to cnt do + begin + dst^ := palette[idx]; + inc(w); + inc(dst); + end; + end; + end; + end; + byte1 := GetByte(stream); + byte2 := GetByte(stream); + if (byte1 <> 0) or (byte2 <> 0) then Exit; + end; +end; +//------------------------------------------------------------------------------ + +function IsValidBitFields(const bitFields: TTriColor32): boolean; +begin + //make sure each color channel has a mask and that they don't overlap ... + result := (bitFields[0] <> 0) and (bitFields[1] <> 0) and + (bitFields[2] <> 0) and (bitFields[0] and bitFields[1] = 0) and + (bitFields[0] and bitFields[2] = 0) and (bitFields[1] and bitFields[2] = 0); +end; +//------------------------------------------------------------------------------ + +function AlphaChannelAllZero(img32: TImage32): Boolean; +var + i: integer; + pc: PARGB; +begin + result := false; + pc := PARGB(img32.PixelBase); + for i := 0 to img32.Width * img32.Height -1 do + begin + if (pc.A > 0) then Exit; + inc(pc); + end; + result := true; +end; +//------------------------------------------------------------------------------ + +procedure ResetAlphaChannel(img32: TImage32); +var + i: integer; + pc: PARGB; +begin + pc := PARGB(img32.PixelBase); + for i := 0 to img32.Width * img32.Height -1 do + begin + pc.A := 255; + inc(pc); + end; +end; +//------------------------------------------------------------------------------ + +class function TImageFormat_BMP.IsValidImageStream(stream: TStream): Boolean; +var + savedPos: integer; + flag: Cardinal; +const + SizeOfBitmapInfoHeader = 40; + SizeOfBitmapV4Header = 108; + SizeOfBitmapV5Header = 124; +begin + Result := false; + savedPos := stream.position; + if stream.size - savedPos <= 4 then Exit; + stream.read(flag, SizeOf(flag)); + stream.Position := savedPos; + Result := ((flag and $FFFF) = $4D42) or + (flag = SizeOfBitmapInfoHeader) or + (flag = SizeOfBitmapV4Header) or + (flag = SizeOfBitmapV5Header); +end; +//------------------------------------------------------------------------------ + +function TImageFormat_BMP.LoadFromStream(stream: TStream; + img32: TImage32): Boolean; +var + palEntrySize: integer; + bihStart: cardinal; + bfh: TBitmapFileHeader; + bih: TBitmapInfoHeader; + tmp, pal: TArrayOfColor32; + bitfields: TTriColor32; + isTopDown, hasValidBitFields: boolean; + pb: PByteArray; +begin + result := false; + with stream do + begin + if Size < sizeof(bih) then Exit; + bihStart := stream.Position; + + //some streams (eg resource streams) omit the file header ... + Read(bfh, SizeOf(bfh)); + if bfh.bfType = $4D42 then + begin + inc(bihStart, SizeOf(bfh)) + end else + begin + bfh.bfOffBits := 0; + stream.Position := bihStart; + end; + + Read(bih, sizeof(bih)); + + if bih.biSize < sizeof(bih) then //accommodate dodgy TBitmapInfoHeader's + begin + if bih.biSize 32) or + (bih.biWidth > $3FFF) or (bih.biHeight > $3FFF) or //16,383 + (bih.biCompression > BI_BITFIELDS) then Exit; + + isTopDown := bih.biHeight < 0; + bih.biHeight := abs(bih.biHeight); + + if ((bih.biCompression and BI_BITFIELDS) = BI_BITFIELDS) then + begin + stream.Position := bihStart + 40; + stream.Read(bitfields[0], Sizeof(TTriColor32)); + hasValidBitFields := IsValidBitFields(bitfields); + if stream.Position < bihStart + bih.biSize then + stream.Position := bihStart + bih.biSize; + end else + begin + hasValidBitFields := false; + stream.Position := bihStart + bih.biSize; + end; + + if not hasValidBitFields then + begin + if bih.biBitCount = 24 then + begin + bitfields[0] := $FF shl 16; + bitfields[1] := $FF shl 8; + bitfields[2] := $FF; + hasValidBitFields := true; + end + else if bih.biBitCount = 16 then + begin + bitfields[0] := $1F shl 10; + bitfields[1] := $1F shl 5; + bitfields[2] := $1F; + hasValidBitFields := true; + end; + end; + + if bih.biClrUsed > 256 then bih.biClrUsed := 0; + + if (bih.biClrUsed = 0) and (bih.biBitCount < 16) then + bih.biClrUsed := Trunc(Power(2, bih.biBitCount)); + + if bih.biClrUsed > 0 then + pal := StreamReadPalette(stream, bih.biClrUsed, palEntrySize); + + tmp := nil; + result := true; + img32.BeginUpdate; + try + img32.SetSize(bih.biWidth, bih.biHeight); + + //read pixels .... + if stream.Position < bfh.bfOffBits then stream.Position := bfh.bfOffBits; + + if hasValidBitFields then + tmp := StreamReadImageWithBitfields( + stream, img32.Width, img32.Height, bih.biBitCount, bitfields) + + else if (bih.biBitCount = 32) then + begin + Read(img32.Pixels[0], bih.biWidth * bih.biHeight * sizeof(TColor32)); + if AlphaChannelAllZero(img32) then ResetAlphaChannel(img32); + end + + else if (bih.biCompression = BI_RLE8) or (bih.biCompression = BI_RLE4) then + tmp := ReadRLE4orRLE8Compression( + stream, img32.Width, img32.Height, bih.biBitCount, pal) + + else tmp := StreamReadImageWithPalette( + stream, img32.Width, img32.Height, bih.biBitCount, pal); + + if assigned(tmp) and (length(tmp) = img32.Width * img32.Height) then + move(tmp[0], img32.Pixels[0], length(tmp) * sizeof(TColor32)); + + if not isTopDown then img32.FlipVertical; + finally + img32.EndUpdate; + end; + end; +end; + +//------------------------------------------------------------------------------ +// Saving (writing) BMP images to file ... +//------------------------------------------------------------------------------ + +function GetFileHeaderFromInfoHeader(stream: TStream; + BitmapInfoHeaderOffset: integer): TBitmapFileHeader; +var + bih: TBitmapInfoHeader; +begin + FillChar(Result, sizeof(Result), #0); + Result.bfType := $4D42; + stream.Position := BitmapInfoHeaderOffset; + stream.Read(bih, sizeof(bih)); + if (bih.biWidth = 0) or (bih.biHeight = 0) then Exit; + Result.bfSize := bih.biSizeImage; + Result.bfOffBits := (stream.Size - bih.biSizeImage); +end; +//------------------------------------------------------------------------------ + +function MakeBitfields: TTriColor32; +begin + result[0] := $FF0000; + result[1] := $00FF00; + result[2] := $0000FF; +end; +//------------------------------------------------------------------------------ + +function GetRowSize(bitCount, imageWidth: integer): integer; +begin + result := ((31 + BitCount * imageWidth) div 32) * 4; +end; +//------------------------------------------------------------------------------ + +function Find(color: TColor32; const colors: TArrayOfColor32; + colorsCnt: integer; out idx: integer): Boolean; +var + i,l,r: integer; +begin + //binary search a sorted list ... + Result := False; + l := 0; r := colorsCnt -1; + while l <= r do + begin + idx := (l + r) shr 1; + + i := integer(colors[idx]) - integer(color); + if i < 0 then l := idx +1 + else + begin + r := idx -1; + if i = 0 then + begin + result := true; + l := idx; + end; + end; + end; + idx := l; +end; +//------------------------------------------------------------------------------ + +function IndexOf(color: TColor32; const colors: TArrayOfColor32): integer; +var + i,l,r: integer; +begin + //binary search a sorted list ... + l := 0; r := Length(colors) -1; + while l <= r do + begin + result := (l + r) shr 1; + i := integer(colors[result]) - integer(color); + if i < 0 then l := result +1 + else + begin + r := result -1; + if i = 0 then l := result; + end; + end; + result := l; +end; +//------------------------------------------------------------------------------ + +procedure Insert256(color: TColor32; + var colors256: TArrayOfColor32; cnt, idx: integer); +begin + if idx < cnt then + move(colors256[idx], colors256[idx +1], (cnt - idx) * SizeOf(TColor32)); + colors256[idx] := color; +end; +//------------------------------------------------------------------------------ + +function GetPaletteColors(img32: TImage32): TArrayOfColor32; +var + i, idx, palLen: integer; + c: TColor32; + pc: PColor32; +begin + Result := nil; + if img32.IsEmpty then Exit; + SetLength(Result, 256); + palLen := 0; + pc := PColor32(img32.PixelBase); + for i := 0 to img32.Width * img32.Height -1 do + begin + c := pc^ and $FFFFFF; + if not Find(c, result, palLen, idx) then + begin + if palLen = 256 then + begin + result := nil; //too many colors for a palette + Exit; + end; + Insert256(c, result, palLen, idx); + inc(palLen); + end; + inc(pc); + end; + SetLength(Result, palLen); +end; +//------------------------------------------------------------------------------ + +procedure StreamWriteLoBitImage(img32: TImage32; const pals: TArrayOfColor32; + BitCount: integer; stream: TStream); +var + i, j, k, pxlPerByte, rowSize, delta, shiftSize, totalBytes: integer; + buffer: TArrayOfByte; + pSrc: PColor32; + pDst: PByte; +begin + pxlPerByte := 8 div BitCount; + rowSize := GetRowSize(BitCount, img32.Width); + delta := rowSize - img32.Width div pxlPerByte; + //delphi doesn't handle modulo of negatives as expected so ... + shiftSize := img32.Width mod pxlPerByte; + if shiftSize > 0 then shiftSize := pxlPerByte - shiftSize; + totalBytes := rowSize * img32.Height; + SetLength(buffer, totalBytes); + fillChar(buffer[0], totalBytes, 0); + pSrc := img32.PixelBase; + pDst := @buffer[0]; + for i := 1 to img32.Height do + begin + k := 0; + for j := 1 to img32.Width do + begin + k := k shl BitCount + IndexOf(pSrc^ and $FFFFFF, pals); + if (j mod pxlPerByte = 0) then + begin + Byte(pDst^) := k; + inc(pDst); + k := 0; + end; + inc(pSrc); + end; + if shiftSize > 0 then Byte(pDst^) := k shl shiftSize; + inc(pDst, delta); + end; + stream.Write(buffer[0], totalBytes); +end; +//------------------------------------------------------------------------------ + +procedure StreamWrite24BitImage(img32: TImage32; stream: TStream); +var + i,j, delta, rowSize, totalBytes: integer; + buffer: TArrayOfByte; + pc: PColor32; + pb: PByte; +begin + rowSize := GetRowSize(24, img32.Width); + delta := rowSize - (img32.Width *3); + totalBytes := rowSize * img32.Height; + setLength(buffer, totalBytes); + fillChar(buffer[0], totalBytes, 0); + pb := @buffer[0]; + pc := img32.PixelBase; + for i := 0 to img32.Height -1 do + begin + for j := 0 to img32.Width -1 do + begin + Move(pc^, pb^, 3); //ie skipping the alpha byte + inc(pc); inc(pb, 3); + end; + inc(pb, delta); + end; + stream.Write(buffer[0], totalBytes); //much faster to do this once +end; +//------------------------------------------------------------------------------ + +procedure TImageFormat_BMP.SaveToStream(stream: TStream; img32: TImage32); +var + bfh: TBitmapFileHeader; + bih: TBitmapV4Header; + palCnt, BitCount, rowSize, infoHeaderOffset: integer; + UsesAlpha: Boolean; + pals: TArrayOfColor32; + tmp: TImage32; + writeValue: TTriColor32; +begin + //write everything except a BMP file header because some streams + //(eg resource streams) don't need a file header + + if fUseClipboardFormat then + UsesAlpha := false else + UsesAlpha := img32.HasTransparency; + + if fUseClipboardFormat or UsesAlpha then + begin + BitCount := 32; + palCnt := 0; + end else + begin + pals := GetPaletteColors(img32); + palCnt := Length(pals); + if palCnt = 0 then BitCount := 24 + else if palCnt > 16 then BitCount := 8 + else if palCnt > 2 then BitCount := 4 + else BitCount := 1; + end; + + if fIncludeFileHeaderInSaveStream then + begin + //Write empty BitmapFileHeader ... + FillChar(bfh, sizeof(bfh), #0); + stream.Write(bfh, sizeOf(bfh)); + end; + infoHeaderOffset := stream.Position; + + FillChar(bih, sizeof(bih), #0); + rowSize := GetRowSize(BitCount, img32.Width); + bih.bV4Width := img32.Width; + bih.bV4Height := img32.Height; + bih.bV4Planes := 1; + bih.bV4BitCount := BitCount; + bih.bV4ClrUsed := palCnt; + bih.bV4SizeImage := rowSize * img32.Height; + if UsesAlpha then + begin + bih.bV4Size := sizeof(TBitmapV4Header); + bih.bV4V4Compression := BI_BITFIELDS; + bih.bV4RedMask := $FF shl 16; + bih.bV4GreenMask := $FF shl 8; + bih.bV4BlueMask := $FF; + bih.bV4AlphaMask := Cardinal($FF) shl 24; + end else + begin + bih.bV4Size := sizeof(TBitmapInfoHeader); //Version2 header + bih.bV4V4Compression := BI_RGB; + end; + + tmp := TImage32.Create(img32); + try + tmp.FlipVertical; + + case BitCount of + 1,4,8: + begin + stream.Write(bih, bih.bV4Size); + SetLength(pals, palCnt); + stream.Write(pals[0], palCnt * 4); + StreamWriteLoBitImage(tmp, pals, BitCount, stream); + end; + 24: + begin + bih.bV4V4Compression := BI_BITFIELDS; + stream.Write(bih, bih.bV4Size); + writeValue := MakeBitfields; + stream.Write(writeValue, SizeOf(TTriColor32)); + StreamWrite24BitImage(tmp, stream); + end + else + begin + stream.Write(bih, bih.bV4Size); + stream.Write(tmp.Pixels[0], tmp.Width * tmp.Height * sizeof(TColor32)); + end; + end; + finally + tmp.Free; + end; + + if fIncludeFileHeaderInSaveStream then + begin + //finally update BitmapFileHeader ... + bfh := GetFileHeaderFromInfoHeader(stream, infoHeaderOffset); + stream.Position := infoHeaderOffset - sizeOf(bfh); + stream.Write(bfh, sizeOf(bfh)); + end; + +end; +//------------------------------------------------------------------------------ + +function TImageFormat_BMP.SaveToFile(const filename: string; + img32: TImage32): Boolean; +var + SaveStateIncludeFileHeader: Boolean; + stream: TFilestream; +begin + result := not img32.IsEmpty; + if not result then Exit; + SaveStateIncludeFileHeader := fIncludeFileHeaderInSaveStream; + stream := TFileStream.Create(filename, fmCreate); + try + fIncludeFileHeaderInSaveStream := true; + fUseClipboardFormat := false; + SaveToStream(stream, img32); + finally + stream.Free; + fIncludeFileHeaderInSaveStream := SaveStateIncludeFileHeader; + end; +end; +//------------------------------------------------------------------------------ + +{$IFDEF MSWINDOWS} + +class function TImageFormat_BMP.CanCopyToClipboard: Boolean; +begin + Result := true; +end; +//------------------------------------------------------------------------------ + +class function TImageFormat_BMP.CopyToClipboard(img32: TImage32): Boolean; +var + dataHdl: THandle; + dataPtr: pointer; + ms: TMemoryStream; +begin + result := OpenClipboard(0); + if not Result then Exit; + ms := TMemoryStream.Create; + try + with TImageFormat_BMP.Create do + try + fUseClipboardFormat := true; + SaveToStream(ms, img32); + finally + free; + end; + + dataHdl := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE, ms.Size); + try + dataPtr := GlobalLock(dataHdl); + try + Move(ms.Memory^, dataPtr^, ms.Size); + finally + GlobalUnlock(dataHdl); + end; + if SetClipboardData(CF_DIB, dataHdl) = 0 then + raise Exception.Create(s_cf_dib_error); + except + GlobalFree(dataHdl); + raise; + end; + + finally + ms.free; + CloseClipboard; + end; +end; +//------------------------------------------------------------------------------ + +class function TImageFormat_BMP.CanPasteFromClipboard: Boolean; +begin + result := IsClipboardFormatAvailable(CF_DIB) or + IsClipboardFormatAvailable(CF_BITMAP); +end; +//------------------------------------------------------------------------------ + +class function TImageFormat_BMP.PasteFromClipboard(img32: TImage32): Boolean; +var + dataHdl: THandle; + bitmapHdl: HBITMAP; + paletteHdl: HPALETTE; + dataPtr: pointer; + ms: TMemoryStream; +begin + result := OpenClipboard(0); + if not Result then Exit; + + try + if IsClipboardFormatAvailable(CF_DIB) then + begin + ms := TMemoryStream.Create; + try + dataHdl := GetClipboardData(CF_DIB); + result := dataHdl > 0; + if not result then Exit; + + ms.SetSize(GlobalSize(dataHdl)); + dataPtr := GlobalLock(dataHdl); + try + Move(dataPtr^, ms.Memory^, ms.Size); + finally + GlobalUnlock(dataHdl); + end; + + ms.Position := 0; + with TImageFormat_BMP.Create do + try + LoadFromStream(ms, img32); + finally + Free; + end; + finally + ms.free; + end; + + end + else if IsClipboardFormatAvailable(CF_BITMAP) then + begin + bitmapHdl := GetClipboardData(CF_BITMAP); + if IsClipboardFormatAvailable(CF_PALETTE) then + paletteHdl := GetClipboardData(CF_PALETTE) else + paletteHdl := 0; + result := bitmapHdl > 0; + if result then + LoadFromHBITMAP(img32, bitmapHdl, paletteHdl); + end; + + finally + CloseClipboard; + end; +end; + +//------------------------------------------------------------------------------ + +function LoadFromHBITMAP(img32: TImage32; bm: HBITMAP; pal: HPALETTE): Boolean; +var + w, h: integer; + memDc: HDC; + oldBitmap, oldPalette: HGDIOBJ; + bi: BITMAPINFO; +begin + result := false; + memDC := CreateCompatibleDC(0); + try + oldBitmap := SelectObject(memDC, bm); + if (pal > 0) then + begin + oldPalette := SelectPalette(memDC, pal, FALSE); + RealizePalette(memDc); + end else + oldPalette := 0; + + FillChar(bi, SizeOf(bi), 0); + bi.bmiHeader.biSize := SizeOf(bi); + if GetDIBits(memDc, bm, 0, 0, nil, bi, DIB_RGB_COLORS) = 0 then Exit; + h := abs(bi.bmiHeader.biHeight); + bi.bmiHeader.biHeight := h; + w := bi.bmiHeader.biWidth; + bi.bmiHeader.biBitCount := 32; + bi.bmiHeader.biCompression := BI_RGB; + + img32.BeginUpdate; + try + img32.SetSize(w, h); + if GetDIBits(memDc, bm, 0, h, + PByte(img32.PixelBase), bi, DIB_RGB_COLORS) = 0 then Exit; + img32.FlipVertical; + finally + img32.EndUpdate; + end; + + SelectObject(memDC, oldBitmap); + if (oldPalette > 0) then + SelectObject(memDC, oldPalette); + Result := true; + finally + DeleteDC(memDC); + end; +end; +//------------------------------------------------------------------------------ +{$ENDIF} + +initialization + TImage32.RegisterImageFormatClass('BMP', TImageFormat_BMP, cpLow); + +end. diff --git a/Image32/source/Img32.Fmt.GIF.pas b/Image32/source/Img32.Fmt.GIF.pas index a73d0017..dc148063 100644 --- a/Image32/source/Img32.Fmt.GIF.pas +++ b/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/Image32/source/Img32.Fmt.JPG.pas b/Image32/source/Img32.Fmt.JPG.pas index 019f6a42..901fb304 100644 --- a/Image32/source/Img32.Fmt.JPG.pas +++ b/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/Image32/source/Img32.Fmt.PNG.pas b/Image32/source/Img32.Fmt.PNG.pas index eb4ad5fe..659b7ffd 100644 --- a/Image32/source/Img32.Fmt.PNG.pas +++ b/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/Image32/source/Img32.Fmt.QOI.pas b/Image32/source/Img32.Fmt.QOI.pas index f34d3282..aa65ab89 100644 --- a/Image32/source/Img32.Fmt.QOI.pas +++ b/Image32/source/Img32.Fmt.QOI.pas @@ -1,8 +1,8 @@ unit Img32.Fmt.QOI; (******************************************************************************* * Author : Angus Johnson * -* Version : 4.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/Image32/source/Img32.Fmt.SVG.pas b/Image32/source/Img32.Fmt.SVG.pas index a2e12258..106949b0 100644 --- a/Image32/source/Img32.Fmt.SVG.pas +++ b/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/Image32/source/Img32.Layers.pas b/Image32/source/Img32.Layers.pas index 2bb21f73..926541f5 100644 --- a/Image32/source/Img32.Layers.pas +++ b/Image32/source/Img32.Layers.pas @@ -2,8 +2,8 @@ (******************************************************************************* * Author : Angus Johnson * -* Version : 4.01 * -* Date : 28 January 2022 * +* Version : 4.2 * +* Date : 30 May 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; @@ -848,6 +856,7 @@ procedure TLayer32.SetOuterMargin(value: double); end; //------------------------------------------------------------------------------ +{$IFNDEF NO_STORAGE} procedure TLayer32.BeginRead; var stgParent: TStorage; @@ -906,6 +915,7 @@ procedure TLayer32.WriteProperties; if not Visible then WriteBoolProp('Visible', false); end; //------------------------------------------------------------------------------ +{$ENDIF} procedure TLayer32.SetOpacity(value: Byte); begin @@ -1593,6 +1603,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 +1625,7 @@ procedure TRotLayer32.WriteProperties; WritePointDProp('PivotPt', PivotPt); WriteBoolProp('AutoPivot', AutoPivot) end; +{$ENDIF} //------------------------------------------------------------------------------ // TVectorLayer32 class @@ -2151,6 +2163,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 +2188,7 @@ procedure TLayeredImage32.WriteProperties; WriteIntProp('Height', Height); end; //------------------------------------------------------------------------------ +{$ENDIF} procedure TLayeredImage32.SetSize(width, height: integer); begin @@ -2727,8 +2741,10 @@ initialization InitDashes; DefaultButtonSize := dpiAware1*10; +{$IFNDEF NO_STORAGE} RegisterStorageClass(TLayeredImage32); RegisterStorageClass(TLayer32); RegisterStorageClass(TGroupLayer32); +{$ENDIF} end. diff --git a/Image32/source/Img32.Resamplers.pas b/Image32/source/Img32.Resamplers.pas index 4d417d5c..213ee126 100644 --- a/Image32/source/Img32.Resamplers.pas +++ b/Image32/source/Img32.Resamplers.pas @@ -1,426 +1,426 @@ -unit Img32.Resamplers; - -(******************************************************************************* -* Author : Angus Johnson * -* Version : 3.0 * -* Date : 20 July 2021 * -* Website : http://www.angusj.com * -* Copyright : Angus Johnson 2019-2021 * -* Purpose : For image transformations (scaling, rotating etc.) * -* License : http://www.boost.org/LICENSE_1_0.txt * -*******************************************************************************) - -interface - -{$I Img32.inc} - -uses - SysUtils, Classes, Types, Img32; - -//BoxDownSampling: As the name implies, this routine is only intended for -//image down-sampling (ie when shrinking images) where it generally performs -//better than other resamplers which tend to lose too much detail. However, -//because this routine is inferior to other resamplers when performing other -//transformations (ie when enlarging, rotating, and skewing images), it's not -//intended as a general purpose resampler. -procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer); - -(* The following functions are registered in the initialization section below -function NearestResampler(img: TImage32; x256, y256: Integer): TColor32; -function BilinearResample(img: TImage32; x256, y256: Integer): TColor32; -function BicubicResample(img: TImage32; x256, y256: Integer): TColor32; -*) - -implementation - -uses - Img32.Vector, Img32.Transform; - -//------------------------------------------------------------------------------ -// NearestNeighbor resampler -//------------------------------------------------------------------------------ - -function NearestResampler(img: TImage32; x256, y256: Integer): TColor32; -begin - if (x256 < -$7f) then - begin - Result := clNone32; - Exit; - end; - - if (y256 < -$7f) then - begin - Result := clNone32; - Exit; - end; - - if (x256 and $FF > $7F) then inc(x256, $100); - x256 := x256 shr 8; - if y256 and $FF > $7F then inc(y256, $100); - y256 := y256 shr 8; - - if (x256 < 0) or (x256 >= img.Width) or - (y256 < 0) or (y256 >= img.Height) then - Result := clNone32 else - Result := img.Pixels[y256 * img.Width + x256]; -end; - -//------------------------------------------------------------------------------ -// BiLinear resampler -//------------------------------------------------------------------------------ - -function BilinearResample(img: TImage32; x256, y256: Integer): TColor32; -var - xi,yi, weight: Integer; - iw, ih: integer; - pixels: TArrayOfColor32; - color: TWeightedColor; - xf, yf: cardinal; -begin - iw := img.Width; - ih := img.Height; - pixels := img.Pixels; - - if (x256 <= -$100) or (x256 >= iw *$100) or - (y256 <= -$100) or (y256 >= ih *$100) then - begin - result := clNone32; - Exit; - end; - - if x256 < 0 then xi := -1 - else xi := x256 shr 8; - - if y256 < 0 then yi := -1 - else yi := y256 shr 8; - - xf := x256 and $FF; - yf := y256 and $FF; - - color.Reset; - - weight := (($100 - xf) * ($100 - yf)) shr 8; //top-left - if (xi < 0) or (yi < 0) then - color.AddWeight(weight) else - color.Add(pixels[xi + yi * iw], weight); - - weight := (xf * ($100 - yf)) shr 8; //top-right - if ((xi+1) >= iw) or (yi < 0) then - color.AddWeight(weight) else - color.Add(pixels[(xi+1) + yi * iw], weight); - - weight := (($100 - xf) * yf) shr 8; //bottom-left - if (xi < 0) or ((yi+1) >= ih) then - color.AddWeight(weight) else - color.Add(pixels[(xi) + (yi+1) * iw], weight); - - weight := (xf * yf) shr 8; //bottom-right - if (xi + 1 >= iw) or (yi + 1 >= ih) then - color.AddWeight(weight) else - color.Add(pixels[(xi+1) + (yi+1) * iw], weight); - - Result := color.Color; -end; - -//------------------------------------------------------------------------------ -// BiCubic resampler -//------------------------------------------------------------------------------ - -type - TBiCubicEdgeAdjust = (eaNone, eaOne, eaTwo, eaThree, eaFour); - -var - byteFrac: array [0..255] of double; - byteFracSq: array [0..255] of double; - byteFracCubed: array [0..255] of double; - -//------------------------------------------------------------------------------ - -function CubicHermite(aclr: PColor32; t: Byte; bce: TBiCubicEdgeAdjust): TColor32; -var - a,b,c,d: PARGB; - q: TARGB; - aa, bb, cc: integer; - t1, t2, t3: double; - res: TARGB absolute Result; -const - clTrans: TColor32 = clNone32; -begin - case bce of - eaOne: - begin - a := @clTrans; - b := @clTrans; - c := PARGB(aclr); - Inc(aclr); - d := PARGB(aclr); - end; - eaTwo: - begin - a := PARGB(aclr); - b := a; - Inc(aclr); - c := PARGB(aclr); - Inc(aclr); - d := PARGB(aclr); - end; - eaThree: - begin - a := PARGB(aclr); - Inc(aclr); - b := PARGB(aclr); - Inc(aclr); - c := PARGB(aclr); - d := c; - end; - eaFour: - begin - a := PARGB(aclr); - Inc(aclr); - b := PARGB(aclr); - c := @clTrans; - d := @clTrans; - end; - else - begin - a := PARGB(aclr); - Inc(aclr); - b := PARGB(aclr); - Inc(aclr); - c := PARGB(aclr); - Inc(aclr); - d := PARGB(aclr); - end; - end; - - if (b.A = 0) and (c.A = 0) then - begin - result := clNone32; - Exit; - end - else if b.A = 0 then - begin - q := c^; - q.A := 0; - b := @q; - end; - if c.A = 0 then - begin - q := b^; - q.A := 0; - c := @q; - end; - - t1 := byteFrac[t]; - t2 := byteFracSq[t]; - t3 := byteFracCubed[t]; - - aa := Integer(-a.A + 3*b.A - 3*c.A + d.A) div 2; - bb := Integer(2*a.A - 5*b.A + 4*c.A - d.A) div 2; - cc := Integer(-a.A + c.A) div 2; - Res.A := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.A); - - aa := Integer(-a.R + 3*b.R - 3*c.R + d.R) div 2; - bb := Integer(2*a.R - 5*b.R + 4*c.R - d.R) div 2; - cc := Integer(-a.R + c.R) div 2; - Res.R := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.R); - - aa := Integer(-a.G + 3*b.G - 3*c.G + d.G) div 2; - bb := Integer(2*a.G - 5*b.G + 4*c.G - d.G) div 2; - cc := Integer(-a.G + c.G) div 2; - Res.G := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.G); - - aa := Integer(-a.B + 3*b.B - 3*c.B + d.B) div 2; - bb := Integer(2*a.B - 5*b.B + 4*c.B - d.B) div 2; - cc := Integer(-a.B + c.B) div 2; - Res.B := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.B); -end; -//------------------------------------------------------------------------------ - -function BicubicResample(img: TImage32; x256, y256: Integer): TColor32; -var - i, dx,dy, pi, iw, w,h: Integer; - c: array[0..3] of TColor32; - x, y: Integer; - bceX, bceY: TBiCubicEdgeAdjust; -begin - Result := clNone32; - - iw := img.Width; - w := iw -1; - h := img.Height -1; - - x := Abs(x256) shr 8; - y := Abs(y256) shr 8; - - if (x256 < -$FF) or (x > w) or (y256 < -$FF) or (y > h) then Exit; - - if (x256 < 0) then bceX := eaOne - else if (x = 0) then bceX := eaTwo - else if (x256 > w shl 8) then bceX := eaFour - else if (x256 > (w -1) shl 8) then bceX := eaThree - else bceX := eaNone; - - if (bceX = eaOne) or (bceX = eaTwo) then dx := 1 - else dx := 0; - - if (y256 < 0) then bceY := eaOne - else if y = 0 then bceY := eaTwo - else if y = h -1 then bceY := eaThree - else if y = h then bceY := eaFour - else bceY := eaNone; - - if (bceY = eaOne) or (bceY = eaTwo) then dy := 1 - else dy := 0; - - pi := (y -1 +dy) * iw + (x -1 + dx); - - if bceY = eaFour then dx := 2 - else if bceY = eaThree then dx := 1 - else dx := 0; - - for i := dy to 3 -dx do - begin - c[i] := CubicHermite(@img.Pixels[pi], x256 and $FF, bceX); - inc(pi, iw); - end; - Result := CubicHermite(@c[dy], y256 and $FF, bceY); -end; - -//------------------------------------------------------------------------------ -// BoxDownSampling and related functions -//------------------------------------------------------------------------------ - -function GetWeightedColor(const srcBits: TArrayOfColor32; - x256, y256, xx256, yy256, maxX: Integer): TColor32; -var - i, j, xi, yi, xxi, yyi, weight: Integer; - xf, yf, xxf, yyf: cardinal; - color: TWeightedColor; -begin - //This function performs 'box sampling' and differs from GetWeightedPixel - //(bilinear resampling) in one important aspect - it accommodates weighting - //any number of pixels (rather than just adjacent pixels) and this produces - //better image quality when significantly downsizing. - - //Note: there's no range checking here, so the precondition is that the - //supplied boundary values are within the bounds of the srcBits array. - - color.Reset; - - xi := x256 shr 8; xf := x256 and $FF; - yi := y256 shr 8; yf := y256 and $FF; - xxi := xx256 shr 8; xxf := xx256 and $FF; - yyi := yy256 shr 8; yyf := yy256 and $FF; - - //1. average the corners ... - weight := (($100 - xf) * ($100 - yf)) shr 8; - color.Add(srcBits[xi + yi * maxX], weight); - weight := (xxf * ($100 - yf)) shr 8; - if (weight <> 0) then color.Add(srcBits[xxi + yi * maxX], weight); - weight := (($100 - xf) * yyf) shr 8; - if (weight <> 0) then color.Add(srcBits[xi + yyi * maxX], weight); - weight := (xxf * yyf) shr 8; - if (weight <> 0) then color.Add(srcBits[xxi + yyi * maxX], weight); - - //2. average the edges - if (yi +1 < yyi) then - begin - xf := $100 - xf; - for i := yi + 1 to yyi - 1 do - color.Add(srcBits[xi + i * maxX], xf); - if (xxf <> 0) then - for i := yi + 1 to yyi - 1 do - color.Add(srcBits[xxi + i * maxX], xxf); - end; - if (xi + 1 < xxi) then - begin - yf := $100 - yf; - for i := xi + 1 to xxi - 1 do - color.Add(srcBits[i + yi * maxX], yf); - if (yyf <> 0) then - for i := xi + 1 to xxi - 1 do - color.Add(srcBits[i + yyi * maxX], yyf); - end; - - //3. average the non-fractional pixel 'internals' ... - for i := xi + 1 to xxi - 1 do - for j := yi + 1 to yyi - 1 do - color.Add(srcBits[i + j * maxX], $100); - - //4. finally get the weighted color ... - if color.AddCount = 0 then - Result := srcBits[xi + yi * maxX] else - Result := color.Color; -end; -//------------------------------------------------------------------------------ - -procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer); -var - x,y, x256,y256,xx256,yy256: Integer; - sx,sy: double; - tmp: TArrayOfColor32; - pc: PColor32; - scaledX: array of Integer; -begin - sx := Image.Width/newWidth * 256; - sy := Image.Height/newHeight * 256; - SetLength(tmp, newWidth * newHeight); - - SetLength(scaledX, newWidth +1); //+1 for fractional overrun - for x := 0 to newWidth -1 do - scaledX[x] := Round((x+1) * sx); - - y256 := 0; - pc := @tmp[0]; - for y := 0 to newHeight - 1 do - begin - x256 := 0; - yy256 := Round((y+1) * sy); - for x := 0 to newWidth - 1 do - begin - xx256 := scaledX[x]; - pc^ := GetWeightedColor(Image.Pixels, - x256, y256, xx256, yy256, Image.Width); - x256 := xx256; - inc(pc); - end; - y256 := yy256; - end; - - Image.BeginUpdate; - Image.SetSize(newWidth, newHeight); - Move(tmp[0], Image.Pixels[0], newWidth * newHeight * SizeOf(TColor32)); - Image.EndUpdate; -end; -//------------------------------------------------------------------------------ -//------------------------------------------------------------------------------ - -procedure InitByteExponents; -var - i: integer; -const - inv255 : double = 1/255; - inv255sqrd : double = 1/(255*255); - inv255cubed: double = 1/(255*255*255); -begin - for i := 0 to 255 do - begin - byteFrac[i] := i *inv255; - byteFracSq[i] := i*i *inv255sqrd; - byteFracCubed[i] := i*i*i *inv255cubed; - end; -end; -//------------------------------------------------------------------------------ - -initialization - InitByteExponents; - - rNearestResampler := RegisterResampler(NearestResampler, 'NearestNeighbor'); - rBilinearResampler := RegisterResampler(BilinearResample, 'Bilinear'); - rBicubicResampler := RegisterResampler(BicubicResample, 'HermiteBicubic'); - DefaultResampler := rBilinearResampler; - -end. - - +unit Img32.Resamplers; + +(******************************************************************************* +* Author : Angus Johnson * +* Version : 4.2 * +* Date : 30 May 2022 * +* Website : http://www.angusj.com * +* Copyright : Angus Johnson 2019-2021 * +* Purpose : For image transformations (scaling, rotating etc.) * +* License : http://www.boost.org/LICENSE_1_0.txt * +*******************************************************************************) + +interface + +{$I Img32.inc} + +uses + SysUtils, Classes, Types, Img32; + +//BoxDownSampling: As the name implies, this routine is only intended for +//image down-sampling (ie when shrinking images) where it generally performs +//better than other resamplers which tend to lose too much detail. However, +//because this routine is inferior to other resamplers when performing other +//transformations (ie when enlarging, rotating, and skewing images), it's not +//intended as a general purpose resampler. +procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer); + +(* The following functions are registered in the initialization section below +function NearestResampler(img: TImage32; x256, y256: Integer): TColor32; +function BilinearResample(img: TImage32; x256, y256: Integer): TColor32; +function BicubicResample(img: TImage32; x256, y256: Integer): TColor32; +*) + +implementation + +uses + Img32.Vector, Img32.Transform; + +//------------------------------------------------------------------------------ +// NearestNeighbor resampler +//------------------------------------------------------------------------------ + +function NearestResampler(img: TImage32; x256, y256: Integer): TColor32; +begin + if (x256 < -$7f) then + begin + Result := clNone32; + Exit; + end; + + if (y256 < -$7f) then + begin + Result := clNone32; + Exit; + end; + + if (x256 and $FF > $7F) then inc(x256, $100); + x256 := x256 shr 8; + if y256 and $FF > $7F then inc(y256, $100); + y256 := y256 shr 8; + + if (x256 < 0) or (x256 >= img.Width) or + (y256 < 0) or (y256 >= img.Height) then + Result := clNone32 else + Result := img.Pixels[y256 * img.Width + x256]; +end; + +//------------------------------------------------------------------------------ +// BiLinear resampler +//------------------------------------------------------------------------------ + +function BilinearResample(img: TImage32; x256, y256: Integer): TColor32; +var + xi,yi, weight: Integer; + iw, ih: integer; + pixels: TArrayOfColor32; + color: TWeightedColor; + xf, yf: cardinal; +begin + iw := img.Width; + ih := img.Height; + pixels := img.Pixels; + + if (x256 <= -$100) or (x256 >= iw *$100) or + (y256 <= -$100) or (y256 >= ih *$100) then + begin + result := clNone32; + Exit; + end; + + if x256 < 0 then xi := -1 + else xi := x256 shr 8; + + if y256 < 0 then yi := -1 + else yi := y256 shr 8; + + xf := x256 and $FF; + yf := y256 and $FF; + + color.Reset; + + weight := (($100 - xf) * ($100 - yf)) shr 8; //top-left + if (xi < 0) or (yi < 0) then + color.AddWeight(weight) else + color.Add(pixels[xi + yi * iw], weight); + + weight := (xf * ($100 - yf)) shr 8; //top-right + if ((xi+1) >= iw) or (yi < 0) then + color.AddWeight(weight) else + color.Add(pixels[(xi+1) + yi * iw], weight); + + weight := (($100 - xf) * yf) shr 8; //bottom-left + if (xi < 0) or ((yi+1) >= ih) then + color.AddWeight(weight) else + color.Add(pixels[(xi) + (yi+1) * iw], weight); + + weight := (xf * yf) shr 8; //bottom-right + if (xi + 1 >= iw) or (yi + 1 >= ih) then + color.AddWeight(weight) else + color.Add(pixels[(xi+1) + (yi+1) * iw], weight); + + Result := color.Color; +end; + +//------------------------------------------------------------------------------ +// BiCubic resampler +//------------------------------------------------------------------------------ + +type + TBiCubicEdgeAdjust = (eaNone, eaOne, eaTwo, eaThree, eaFour); + +var + byteFrac: array [0..255] of double; + byteFracSq: array [0..255] of double; + byteFracCubed: array [0..255] of double; + +//------------------------------------------------------------------------------ + +function CubicHermite(aclr: PColor32; t: Byte; bce: TBiCubicEdgeAdjust): TColor32; +var + a,b,c,d: PARGB; + q: TARGB; + aa, bb, cc: integer; + t1, t2, t3: double; + res: TARGB absolute Result; +const + clTrans: TColor32 = clNone32; +begin + case bce of + eaOne: + begin + a := @clTrans; + b := @clTrans; + c := PARGB(aclr); + Inc(aclr); + d := PARGB(aclr); + end; + eaTwo: + begin + a := PARGB(aclr); + b := a; + Inc(aclr); + c := PARGB(aclr); + Inc(aclr); + d := PARGB(aclr); + end; + eaThree: + begin + a := PARGB(aclr); + Inc(aclr); + b := PARGB(aclr); + Inc(aclr); + c := PARGB(aclr); + d := c; + end; + eaFour: + begin + a := PARGB(aclr); + Inc(aclr); + b := PARGB(aclr); + c := @clTrans; + d := @clTrans; + end; + else + begin + a := PARGB(aclr); + Inc(aclr); + b := PARGB(aclr); + Inc(aclr); + c := PARGB(aclr); + Inc(aclr); + d := PARGB(aclr); + end; + end; + + if (b.A = 0) and (c.A = 0) then + begin + result := clNone32; + Exit; + end + else if b.A = 0 then + begin + q := c^; + q.A := 0; + b := @q; + end; + if c.A = 0 then + begin + q := b^; + q.A := 0; + c := @q; + end; + + t1 := byteFrac[t]; + t2 := byteFracSq[t]; + t3 := byteFracCubed[t]; + + aa := Integer(-a.A + 3*b.A - 3*c.A + d.A) div 2; + bb := Integer(2*a.A - 5*b.A + 4*c.A - d.A) div 2; + cc := Integer(-a.A + c.A) div 2; + Res.A := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.A); + + aa := Integer(-a.R + 3*b.R - 3*c.R + d.R) div 2; + bb := Integer(2*a.R - 5*b.R + 4*c.R - d.R) div 2; + cc := Integer(-a.R + c.R) div 2; + Res.R := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.R); + + aa := Integer(-a.G + 3*b.G - 3*c.G + d.G) div 2; + bb := Integer(2*a.G - 5*b.G + 4*c.G - d.G) div 2; + cc := Integer(-a.G + c.G) div 2; + Res.G := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.G); + + aa := Integer(-a.B + 3*b.B - 3*c.B + d.B) div 2; + bb := Integer(2*a.B - 5*b.B + 4*c.B - d.B) div 2; + cc := Integer(-a.B + c.B) div 2; + Res.B := ClampByte(aa*t3 + bb*t2 + cc*t1 + b.B); +end; +//------------------------------------------------------------------------------ + +function BicubicResample(img: TImage32; x256, y256: Integer): TColor32; +var + i, dx,dy, pi, iw, w,h: Integer; + c: array[0..3] of TColor32; + x, y: Integer; + bceX, bceY: TBiCubicEdgeAdjust; +begin + Result := clNone32; + + iw := img.Width; + w := iw -1; + h := img.Height -1; + + x := Abs(x256) shr 8; + y := Abs(y256) shr 8; + + if (x256 < -$FF) or (x > w) or (y256 < -$FF) or (y > h) then Exit; + + if (x256 < 0) then bceX := eaOne + else if (x = 0) then bceX := eaTwo + else if (x256 > w shl 8) then bceX := eaFour + else if (x256 > (w -1) shl 8) then bceX := eaThree + else bceX := eaNone; + + if (bceX = eaOne) or (bceX = eaTwo) then dx := 1 + else dx := 0; + + if (y256 < 0) then bceY := eaOne + else if y = 0 then bceY := eaTwo + else if y = h -1 then bceY := eaThree + else if y = h then bceY := eaFour + else bceY := eaNone; + + if (bceY = eaOne) or (bceY = eaTwo) then dy := 1 + else dy := 0; + + pi := (y -1 +dy) * iw + (x -1 + dx); + + if bceY = eaFour then dx := 2 + else if bceY = eaThree then dx := 1 + else dx := 0; + + for i := dy to 3 -dx do + begin + c[i] := CubicHermite(@img.Pixels[pi], x256 and $FF, bceX); + inc(pi, iw); + end; + Result := CubicHermite(@c[dy], y256 and $FF, bceY); +end; + +//------------------------------------------------------------------------------ +// BoxDownSampling and related functions +//------------------------------------------------------------------------------ + +function GetWeightedColor(const srcBits: TArrayOfColor32; + x256, y256, xx256, yy256, maxX: Integer): TColor32; +var + i, j, xi, yi, xxi, yyi, weight: Integer; + xf, yf, xxf, yyf: cardinal; + color: TWeightedColor; +begin + //This function performs 'box sampling' and differs from GetWeightedPixel + //(bilinear resampling) in one important aspect - it accommodates weighting + //any number of pixels (rather than just adjacent pixels) and this produces + //better image quality when significantly downsizing. + + //Note: there's no range checking here, so the precondition is that the + //supplied boundary values are within the bounds of the srcBits array. + + color.Reset; + + xi := x256 shr 8; xf := x256 and $FF; + yi := y256 shr 8; yf := y256 and $FF; + xxi := xx256 shr 8; xxf := xx256 and $FF; + yyi := yy256 shr 8; yyf := yy256 and $FF; + + //1. average the corners ... + weight := (($100 - xf) * ($100 - yf)) shr 8; + color.Add(srcBits[xi + yi * maxX], weight); + weight := (xxf * ($100 - yf)) shr 8; + if (weight <> 0) then color.Add(srcBits[xxi + yi * maxX], weight); + weight := (($100 - xf) * yyf) shr 8; + if (weight <> 0) then color.Add(srcBits[xi + yyi * maxX], weight); + weight := (xxf * yyf) shr 8; + if (weight <> 0) then color.Add(srcBits[xxi + yyi * maxX], weight); + + //2. average the edges + if (yi +1 < yyi) then + begin + xf := $100 - xf; + for i := yi + 1 to yyi - 1 do + color.Add(srcBits[xi + i * maxX], xf); + if (xxf <> 0) then + for i := yi + 1 to yyi - 1 do + color.Add(srcBits[xxi + i * maxX], xxf); + end; + if (xi + 1 < xxi) then + begin + yf := $100 - yf; + for i := xi + 1 to xxi - 1 do + color.Add(srcBits[i + yi * maxX], yf); + if (yyf <> 0) then + for i := xi + 1 to xxi - 1 do + color.Add(srcBits[i + yyi * maxX], yyf); + end; + + //3. average the non-fractional pixel 'internals' ... + for i := xi + 1 to xxi - 1 do + for j := yi + 1 to yyi - 1 do + color.Add(srcBits[i + j * maxX], $100); + + //4. finally get the weighted color ... + if color.AddCount = 0 then + Result := srcBits[xi + yi * maxX] else + Result := color.Color; +end; +//------------------------------------------------------------------------------ + +procedure BoxDownSampling(Image: TImage32; newWidth, newHeight: Integer); +var + x,y, x256,y256,xx256,yy256: Integer; + sx,sy: double; + tmp: TArrayOfColor32; + pc: PColor32; + scaledX: array of Integer; +begin + sx := Image.Width/newWidth * 256; + sy := Image.Height/newHeight * 256; + SetLength(tmp, newWidth * newHeight); + + SetLength(scaledX, newWidth +1); //+1 for fractional overrun + for x := 0 to newWidth -1 do + scaledX[x] := Round((x+1) * sx); + + y256 := 0; + pc := @tmp[0]; + for y := 0 to newHeight - 1 do + begin + x256 := 0; + yy256 := Round((y+1) * sy); + for x := 0 to newWidth - 1 do + begin + xx256 := scaledX[x]; + pc^ := GetWeightedColor(Image.Pixels, + x256, y256, xx256, yy256, Image.Width); + x256 := xx256; + inc(pc); + end; + y256 := yy256; + end; + + Image.BeginUpdate; + Image.SetSize(newWidth, newHeight); + Move(tmp[0], Image.Pixels[0], newWidth * newHeight * SizeOf(TColor32)); + Image.EndUpdate; +end; +//------------------------------------------------------------------------------ +//------------------------------------------------------------------------------ + +procedure InitByteExponents; +var + i: integer; +const + inv255 : double = 1/255; + inv255sqrd : double = 1/(255*255); + inv255cubed: double = 1/(255*255*255); +begin + for i := 0 to 255 do + begin + byteFrac[i] := i *inv255; + byteFracSq[i] := i*i *inv255sqrd; + byteFracCubed[i] := i*i*i *inv255cubed; + end; +end; +//------------------------------------------------------------------------------ + +initialization + InitByteExponents; + + rNearestResampler := RegisterResampler(NearestResampler, 'NearestNeighbor'); + rBilinearResampler := RegisterResampler(BilinearResample, 'Bilinear'); + rBicubicResampler := RegisterResampler(BicubicResample, 'HermiteBicubic'); + DefaultResampler := rBilinearResampler; + +end. + + diff --git a/Image32/source/Img32.SVG.Core.pas b/Image32/source/Img32.SVG.Core.pas index bc1efd7e..96f7dae9 100644 --- a/Image32/source/Img32.SVG.Core.pas +++ b/Image32/source/Img32.SVG.Core.pas @@ -2,10 +2,10 @@ (******************************************************************************* * 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 * +* Copyright : Angus Johnson 2019-2022 * * * * Purpose : Essential structures and functions to read SVG files * * * @@ -1187,11 +1187,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; - -{$IF Defined(ANDROID) or Defined(MACOS) or Defined(MACOSX)} +{$IF DEFINED(ANDROID) OR DEFINED(MACOS) OR DEFINED(MACOSX)} color := SwapRedBlue(color); {$IFEND} - Result := true; end; //------------------------------------------------------------------------------ diff --git a/Image32/source/Img32.SVG.Path.pas b/Image32/source/Img32.SVG.Path.pas index 88c670be..2e3ffa2f 100644 --- a/Image32/source/Img32.SVG.Path.pas +++ b/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/Image32/source/Img32.SVG.PathDesign.pas b/Image32/source/Img32.SVG.PathDesign.pas index 20859b9a..2adfe959 100644 --- a/Image32/source/Img32.SVG.PathDesign.pas +++ b/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/Image32/source/Img32.SVG.Reader.pas b/Image32/source/Img32.SVG.Reader.pas index 258dc054..a9936b6d 100644 --- a/Image32/source/Img32.SVG.Reader.pas +++ b/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/Image32/source/Img32.SVG.Writer.pas b/Image32/source/Img32.SVG.Writer.pas deleted file mode 100644 index 5cd9f59d..00000000 --- a/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/Image32/source/Img32.Storage.pas b/Image32/source/Img32.Storage.pas index f31e38f0..094f6f69 100644 --- a/Image32/source/Img32.Storage.pas +++ b/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/Image32/source/Img32.Text.pas b/Image32/source/Img32.Text.pas index a4278eb8..ffc94e8a 100644 --- a/Image32/source/Img32.Text.pas +++ b/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/Image32/source/Img32.Transform.pas b/Image32/source/Img32.Transform.pas index 7ecf3a07..81362f03 100644 --- a/Image32/source/Img32.Transform.pas +++ b/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/Image32/source/Img32.Vector.pas b/Image32/source/Img32.Vector.pas index 6c874eed..39f55b88 100644 --- a/Image32/source/Img32.Vector.pas +++ b/Image32/source/Img32.Vector.pas @@ -1,8 +1,8 @@ unit Img32.Vector; (******************************************************************************* * Author : Angus Johnson * -* Version : 4.12 * -* Date : 4 March 2022 * +* Version : 4.2 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * * @@ -23,6 +23,7 @@ interface 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; @@ -178,7 +179,7 @@ interface 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 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; @@ -253,6 +254,8 @@ interface 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 @@ -933,8 +936,7 @@ function GetUnitNormal(const pt1, pt2: TPointD): TPointD; begin if PointsNearEqual(pt1, pt2, 0.001) then begin - Result.X := 0; - Result.Y := 0; + Result := NullPointD; Exit; end; dx := (pt2.X - pt1.X); @@ -947,6 +949,23 @@ function GetUnitNormal(const pt1, pt2: TPointD): TPointD; end; //------------------------------------------------------------------------------ +function GetAvgUnitVector(const vec1, vec2: TPointD): TPointD; +var + h, inverseHypot: Double; +begin + Result := PointD((vec1.X + vec2.X) * 0.5, (vec1.Y + vec2.Y) * 0.5); + h := Hypot(Result.X, Result.Y); + if ValueAlmostZero(h, 0.001) then + begin + Result := NullPointD; + Exit; + end; + inverseHypot := 1 / h; + Result.X := Result.X * inverseHypot; + Result.Y := Result.Y * inverseHypot; +end; +//------------------------------------------------------------------------------ + function Paths(const path: TPathD): TPathsD; begin SetLength(Result, 1); @@ -1476,8 +1495,8 @@ function ClosestPoint(const pt, linePt1, linePt2: TPointD; 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); + Result.X := (1-q)*linePt1.X + q*linePt2.X; + Result.Y := (1-q)*linePt1.Y + q*linePt2.Y; end; end; //------------------------------------------------------------------------------ @@ -3503,29 +3522,6 @@ function FlattenQSpline(const pts: TPathD; tolerance: double = 0.0): TPathD; 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; diff --git a/Image32/source/Img32.inc b/Image32/source/Img32.inc index 63ce553e..b445b02d 100644 --- a/Image32/source/Img32.inc +++ b/Image32/source/Img32.inc @@ -1,3 +1,6 @@ +{$DEFINE NO_STORAGE} +{$DEFINE REVERSE_ORIENTATION} + {$IFDEF FPC} {$MODE DELPHI} {$DEFINE ABSTRACT_CLASSES} @@ -14,43 +17,44 @@ 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/Image32/source/Img32.pas b/Image32/source/Img32.pas index edec94ad..b4dad84b 100644 --- a/Image32/source/Img32.pas +++ b/Image32/source/Img32.pas @@ -3,7 +3,7 @@ (******************************************************************************* * Author : Angus Johnson * * Version : 4.2 * -* Date : 11 March 2022 * +* Date : 30 May 2022 * * Website : http://www.angusj.com * * Copyright : Angus Johnson 2019-2022 * * * @@ -1225,9 +1225,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) OR DEFINED(MACOS) OR DEFINED(MACOSX)} color := SwapRedBlue(color); -{$ENDIF} +{$IFEND} r := rgba.R; g := rgba.G; b := rgba.B; maxRGB := Max(r, Max(g, b)); @@ -1288,9 +1288,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) OR DEFINED(MACOS) OR DEFINED(MACOSX)} Result := SwapRedBlue(Result); -{$ENDIF} +{$IFEND} end; //------------------------------------------------------------------------------ @@ -3444,6 +3444,7 @@ procedure CleanUpResamplerClassList; initialization CreateImageFormatList; MakeBlendTables; + {$IFDEF MSWINDOWS} GetScreenScale; {$ENDIF} diff --git a/README.md b/README.md index b5e00db6..bdc59a43 100644 --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ ## Four engines to render SVG (Delphi Image32, Delphi TSVG, SKIA4Delphi, Direct2D wrapper) and four components to simplify use of SVG images (resize, fixedcolor, grayscale...) -### Actual official version 3.8.3 (VCL+FMX) +### Actual official version 3.9.0 (VCL+FMX) | Component | Description | | - | - | @@ -81,6 +81,10 @@ You can use [SVG Shell Extensions](https://github.com/EtheaDev/SVGShellExtension Follow the [guide in Wiki section](https://github.com/EtheaDev/SVGIconImageList/wiki) to known how to use those components to modernize your Delphi VCL or FMX Windows applications scalable, colored and beautiful with few lines of code. ### RELEASE NOTES +15 Jun 2022: version 3.9.0 (VCL+FMX) +- Updated to Image32 4.2 library +- Fixed Blueish tint on Android and MacOS-X + 08 May 2022: version 3.8.3 (VCL+FMX) - Updated to Skia4Delphi 3.4.0 llibrary - SVGExplorer example moved under "Demo" folder diff --git a/Source/FMX.SVGIconImageList.pas b/Source/FMX.SVGIconImageList.pas index ea573160..42804b79 100644 --- a/Source/FMX.SVGIconImageList.pas +++ b/Source/FMX.SVGIconImageList.pas @@ -47,7 +47,7 @@ interface ; const - SVGIconImageListVersion = '3.8.3'; + SVGIconImageListVersion = '3.9.0'; DEFAULT_SIZE = 32; ZOOM_DEFAULT = 100; SVG_INHERIT_COLOR = TAlphaColors.Null; diff --git a/Source/SVGIconImageListBase.pas b/Source/SVGIconImageListBase.pas index 0e024c9e..a5172510 100644 --- a/Source/SVGIconImageListBase.pas +++ b/Source/SVGIconImageListBase.pas @@ -48,7 +48,7 @@ interface SvgInterfaces; const - SVGIconImageListVersion = '3.8.3'; + SVGIconImageListVersion = '3.9.0'; DEFAULT_SIZE = 16; type