{ $Id: ImagingCanvases.pas 174 2009-09-08 09:37:59Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net The contents of this file are used with permission, subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/MPL-1.1.html Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the specific language governing rights and limitations under the License. Alternatively, the contents of this file may be used under the terms of the GNU Lesser General Public License (the "LGPL License"), in which case the provisions of the LGPL License are applicable instead of those above. If you wish to allow use of your version of this file only under the terms of the LGPL License and not to allow others to use your version of this file under the MPL, indicate your decision by deleting the provisions above and replace them with the notice and other provisions required by the LGPL License. If you do not delete the provisions above, a recipient may use your version of this file under either the MPL or the LGPL License. For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html } { This unit contains canvas classes for drawing and applying effects. } unit ImagingCanvases; {$I ImagingOptions.inc} interface uses SysUtils, Types, Classes, ImagingTypes, Imaging, ImagingClasses, ImagingFormats, ImagingUtility; const { Color constants in ifA8R8G8B8 format.} pcClear = $00000000; pcBlack = $FF000000; pcWhite = $FFFFFFFF; pcMaroon = $FF800000; pcGreen = $FF008000; pcOlive = $FF808000; pcNavy = $FF000080; pcPurple = $FF800080; pcTeal = $FF008080; pcGray = $FF808080; pcSilver = $FFC0C0C0; pcRed = $FFFF0000; pcLime = $FF00FF00; pcYellow = $FFFFFF00; pcBlue = $FF0000FF; pcFuchsia = $FFFF00FF; pcAqua = $FF00FFFF; pcLtGray = $FFC0C0C0; pcDkGray = $FF808080; MaxPenWidth = 256; type EImagingCanvasError = class(EImagingError); EImagingCanvasBlendingError = class(EImagingError); { Fill mode used when drawing filled objects on canvas.} TFillMode = ( fmSolid, // Solid fill using current fill color fmClear // No filling done ); { Pen mode used when drawing lines, object outlines, and similar on canvas.} TPenMode = ( pmSolid, // Draws solid lines using current pen color. pmClear // No drawing done ); { Source and destination blending factors for drawing functions with blending. Blending formula: SrcColor * SrcFactor + DestColor * DestFactor } TBlendingFactor = ( bfIgnore, // Don't care bfZero, // For Src and Dest, Factor = (0, 0, 0, 0) bfOne, // For Src and Dest, Factor = (1, 1, 1, 1) bfSrcAlpha, // For Src and Dest, Factor = (Src.A, Src.A, Src.A, Src.A) bfOneMinusSrcAlpha, // For Src and Dest, Factor = (1 - Src.A, 1 - Src.A, 1 - Src.A, 1 - Src.A) bfDstAlpha, // For Src and Dest, Factor = (Dest.A, Dest.A, Dest.A, Dest.A) bfOneMinusDstAlpha, // For Src and Dest, Factor = (1 - Dest.A, 1 - Dest.A, 1 - Dest.A, 1 - Dest.A) bfSrcColor, // For Dest, Factor = (Src.R, Src.R, Src.B, Src.A) bfOneMinusSrcColor, // For Dest, Factor = (1 - Src.R, 1 - Src.G, 1 - Src.B, 1 - Src.A) bfDstColor, // For Src, Factor = (Dest.R, Dest.G, Dest.B, Dest.A) bfOneMinusDstColor // For Src, Factor = (1 - Dest.R, 1 - Dest.G, 1 - Dest.B, 1 - Dest.A) ); { Procedure for custom pixel write modes with blending.} TPixelWriteProc = procedure(const SrcPix: TColorFPRec; DestPtr: PByte; DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); { Represents 3x3 convolution filter kernel.} TConvolutionFilter3x3 = record Kernel: array[0..2, 0..2] of LongInt; Divisor: LongInt; Bias: Single; end; { Represents 5x5 convolution filter kernel.} TConvolutionFilter5x5 = record Kernel: array[0..4, 0..4] of LongInt; Divisor: LongInt; Bias: Single; end; TPointTransformFunction = function(const Pixel: TColorFPRec; Param1, Param2, Param3: Single): TColorFPRec; TDynFPPixelArray = array of TColorFPRec; THistogramArray = array[Byte] of Integer; TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec; { Base canvas class for drawing objects, applying effects, and other. Constructor takes TBaseImage (or pointer to TImageData). Source image bits are not copied but referenced so all canvas functions affect source image and vice versa. When you change format or resolution of source image you must call UpdateCanvasState method (so canvas could recompute some data size related stuff). TImagingCanvas works for all image data formats except special ones (compressed). Because of this its methods are quite slow (they usually work with colors in ifA32R32G32B32F format). If you want fast drawing you can use one of fast canvas clases. These descendants of TImagingCanvas work only for few select formats (or only one) but they are optimized thus much faster. } TImagingCanvas = class(TObject) private FDataSizeOnUpdate: LongInt; FLineRecursion: Boolean; function GetPixel32(X, Y: LongInt): TColor32; virtual; function GetPixelFP(X, Y: LongInt): TColorFPRec; virtual; function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetPixel32(X, Y: LongInt; const Value: TColor32); virtual; procedure SetPixelFP(X, Y: LongInt; const Value: TColorFPRec); virtual; procedure SetPenColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetPenColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetPenWidth(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetFillColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetFillColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetClipRect(const Value: TRect); procedure CheckBeforeBlending(SrcFactor, DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas); protected FPData: PImageData; FClipRect: TRect; FPenColorFP: TColorFPRec; FPenColor32: TColor32; FPenMode: TPenMode; FPenWidth: LongInt; FFillColorFP: TColorFPRec; FFillColor32: TColor32; FFillMode: TFillMode; FNativeColor: TColorFPRec; FFormatInfo: TImageFormatInfo; { Returns pointer to pixel at given position.} function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF} { Translates given FP color to native format of canvas and stores it in FNativeColor field (its bit copy) or user pointer (in overloaded method).} procedure TranslateFPToNative(const Color: TColorFPRec); overload; {$IFDEF USE_INLINE}inline;{$ENDIF} procedure TranslateFPToNative(const Color: TColorFPRec; Native: Pointer); overload; {$IFDEF USE_INLINE}inline;{$ENDIF} { Clipping function used by horizontal and vertical line drawing functions.} function ClipAxisParallelLine(var A1, A2, B: LongInt; AStart, AStop, BStart, BStop: LongInt): Boolean; { Internal horizontal line drawer used mainly for filling inside of objects like ellipses and circles.} procedure HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); virtual; procedure CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; Bpp: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure DrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc); procedure StretchDrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas; const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc); public constructor CreateForData(ImageDataPointer: PImageData); constructor CreateForImage(Image: TBaseImage); destructor Destroy; override; { Call this method when you change size or format of image this canvas operates on (like calling ResizeImage, ConvertImage, or changing Format property of TBaseImage descendants).} procedure UpdateCanvasState; virtual; { Resets clipping rectangle to Rect(0, 0, ImageWidth, ImageHeight).} procedure ResetClipRect; { Clears entire canvas with current fill color (ignores clipping rectangle and always uses fmSolid fill mode).} procedure Clear; { Draws horizontal line with current pen settings.} procedure HorzLine(X1, X2, Y: LongInt); virtual; { Draws vertical line with current pen settings.} procedure VertLine(X, Y1, Y2: LongInt); virtual; { Draws line from [X1, Y1] to [X2, Y2] with current pen settings.} procedure Line(X1, Y1, X2, Y2: LongInt); virtual; { Draws a rectangle using current pen settings.} procedure FrameRect(const Rect: TRect); { Fills given rectangle with current fill settings.} procedure FillRect(const Rect: TRect); virtual; { Fills given rectangle with current fill settings and pixel blending.} procedure FillRectBlend(const Rect: TRect; SrcFactor, DestFactor: TBlendingFactor); { Draws rectangle which is outlined by using the current pen settings and filled by using the current fill settings.} procedure Rectangle(const Rect: TRect); { Draws ellipse which is outlined by using the current pen settings and filled by using the current fill settings. Rect specifies bounding rectangle of ellipse to be drawn.} procedure Ellipse(const Rect: TRect); { Fills area of canvas with current fill color starting at point [X, Y] and coloring its neighbors. Default flood fill mode changes color of all neighbors with the same color as pixel [X, Y]. With BoundaryFillMode set to True neighbors are recolored regardless of their old color, but area which will be recolored has boundary (specified by current pen color).} procedure FloodFill(X, Y: Integer; BoundaryFillMode: Boolean = False); { Draws contents of this canvas onto another canvas with pixel blending. Blending factors are chosen using TBlendingFactor parameters. Resulting destination pixel color is: SrcColor * SrcFactor + DstColor * DstFactor} procedure DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor); { Draws contents of this canvas onto another one with typical alpha blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)} procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); virtual; { Draws contents of this canvas onto another one using additive blending (source and dest factors are bfOne).} procedure DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); { Draws stretched and filtered contents of this canvas onto another canvas with pixel blending. Blending factors are chosen using TBlendingFactor parameters. Resulting destination pixel color is: SrcColor * SrcFactor + DstColor * DstFactor} procedure StretchDrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter = rfBilinear); { Draws contents of this canvas onto another one with typical alpha blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)} procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter = rfBilinear); virtual; { Draws contents of this canvas onto another one using additive blending (source and dest factors are bfOne).} procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter = rfBilinear); { Convolves canvas' image with given 3x3 filter kernel. You can use predefined filter kernels or define your own.} procedure ApplyConvolution3x3(const Filter: TConvolutionFilter3x3); { Convolves canvas' image with given 5x5 filter kernel. You can use predefined filter kernels or define your own.} procedure ApplyConvolution5x5(const Filter: TConvolutionFilter5x5); { Computes 2D convolution of canvas' image and given filter kernel. Kernel is in row format and KernelSize must be odd number >= 3. Divisor is normalizing value based on Kernel (usually sum of all kernel's cells). The Bias number shifts each color value by a fixed amount (color values are usually in range [0, 1] during processing). If ClampChannels is True all output color values are clamped to [0, 1]. You can use predefined filter kernels or define your own.} procedure ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt; Bias: Single = 0.0; ClampChannels: Boolean = True); virtual; { Applies custom non-linear filter. Filter size is diameter of pixel neighborhood. Typical values are 3, 5, or 7. } procedure ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction); { Applies median non-linear filter with user defined pixel neighborhood. Selects median pixel from the neighborhood as new pixel (current implementation is quite slow).} procedure ApplyMedianFilter(FilterSize: Integer); { Applies min non-linear filter with user defined pixel neighborhood. Selects min pixel from the neighborhood as new pixel.} procedure ApplyMinFilter(FilterSize: Integer); { Applies max non-linear filter with user defined pixel neighborhood. Selects max pixel from the neighborhood as new pixel.} procedure ApplyMaxFilter(FilterSize: Integer); { Transforms pixels one by one by given function. Pixel neighbors are not taken into account. Param 1-3 are optional parameters for transform function.} procedure PointTransform(Transform: TPointTransformFunction; Param1, Param2, Param3: Single); { Modifies image contrast and brightness. Parameters should be in range <-100; 100>.} procedure ModifyContrastBrightness(Contrast, Brightness: Single); { Gamma correction of individual color channels. Range is (0, +inf), 1.0 means no change.} procedure GammaCorection(Red, Green, Blue: Single); { Inverts colors of all image pixels, makes negative image. Ignores alpha channel.} procedure InvertColors; virtual; { Simple single level thresholding with threshold level (in range [0, 1]) for each color channel.} procedure Threshold(Red, Green, Blue: Single); { Adjusts the color levels of the image by scaling the colors falling between specified white and black points to full [0, 1] range. The black point specifies the darkest color in the image, white point specifies the lightest color, and mid point is gamma aplied to image. Black and white point must be in range [0, 1].} procedure AdjustColorLevels(BlackPoint, WhitePoint: Single; MidPoint: Single = 1.0); { Premultiplies color channel values by alpha. Needed for some platforms/APIs to display images with alpha properly.} procedure PremultiplyAlpha; { Reverses PremultiplyAlpha operation.} procedure UnPremultiplyAlpha; { Calculates image histogram for each channel and also gray values. Each channel has 256 values available. Channel values of data formats with higher precision are scaled and rounded. Example: Red[126] specifies number of pixels in image with red channel = 126.} procedure GetHistogram(out Red, Green, Blue, Alpha, Gray: THistogramArray); { Fills image channel with given value leaving other channels intact. Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as channel identifier.} procedure FillChannel(ChannelId: Integer; NewChannelValue: Byte); overload; { Fills image channel with given value leaving other channels intact. Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as channel identifier.} procedure FillChannelFP(ChannelId: Integer; NewChannelValue: Single); overload; { Color used when drawing lines, frames, and outlines of objects.} property PenColor32: TColor32 read FPenColor32 write SetPenColor32; { Color used when drawing lines, frames, and outlines of objects.} property PenColorFP: TColorFPRec read FPenColorFP write SetPenColorFP; { Pen mode used when drawing lines, object outlines, and similar on canvas.} property PenMode: TPenMode read FPenMode write FPenMode; { Width with which objects like lines, frames, etc. (everything which uses PenColor) are drawn.} property PenWidth: LongInt read FPenWidth write SetPenWidth; { Color used for filling when drawing various objects.} property FillColor32: TColor32 read FFillColor32 write SetFillColor32; { Color used for filling when drawing various objects.} property FillColorFP: TColorFPRec read FFillColorFP write SetFillColorFP; { Fill mode used when drawing filled objects on canvas.} property FillMode: TFillMode read FFillMode write FFillMode; { Specifies the current color of the pixels of canvas. Native pixel is read from canvas and then translated to 32bit ARGB. Reverse operation is made when setting pixel color.} property Pixels32[X, Y: LongInt]: TColor32 read GetPixel32 write SetPixel32; { Specifies the current color of the pixels of canvas. Native pixel is read from canvas and then translated to FP ARGB. Reverse operation is made when setting pixel color.} property PixelsFP[X, Y: LongInt]: TColorFPRec read GetPixelFP write SetPixelFP; { Clipping rectangle of this canvas. No pixels outside this rectangle are altered by canvas methods if Clipping property is True. Clip rect gets reseted when UpdateCanvasState is called.} property ClipRect: TRect read FClipRect write SetClipRect; { Extended format information.} property FormatInfo: TImageFormatInfo read FFormatInfo; { Indicates that this canvas is in valid state. If False canvas oprations may crash.} property Valid: Boolean read GetValid; { Returns all formats supported by this canvas class.} class function GetSupportedFormats: TImageFormats; virtual; end; TImagingCanvasClass = class of TImagingCanvas; TScanlineArray = array[0..MaxInt div SizeOf(Pointer) - 1] of PColor32RecArray; PScanlineArray = ^TScanlineArray; { Fast canvas class for ifA8R8G8B8 format images.} TFastARGB32Canvas = class(TImagingCanvas) protected FScanlines: PScanlineArray; procedure AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); {$IFDEF USE_INLINE}inline;{$ENDIF} function GetPixel32(X, Y: LongInt): TColor32; override; procedure SetPixel32(X, Y: LongInt; const Value: TColor32); override; public destructor Destroy; override; procedure UpdateCanvasState; override; procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); override; procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter = rfBilinear); override; procedure InvertColors; override; property Scanlines: PScanlineArray read FScanlines; class function GetSupportedFormats: TImageFormats; override; end; const { Kernel for 3x3 average smoothing filter.} FilterAverage3x3: TConvolutionFilter3x3 = ( Kernel: ((1, 1, 1), (1, 1, 1), (1, 1, 1)); Divisor: 9); { Kernel for 5x5 average smoothing filter.} FilterAverage5x5: TConvolutionFilter5x5 = ( Kernel: ((1, 1, 1, 1, 1), (1, 1, 1, 1, 1), (1, 1, 1, 1, 1), (1, 1, 1, 1, 1), (1, 1, 1, 1, 1)); Divisor: 25); { Kernel for 3x3 Gaussian smoothing filter.} FilterGaussian3x3: TConvolutionFilter3x3 = ( Kernel: ((1, 2, 1), (2, 4, 2), (1, 2, 1)); Divisor: 16); { Kernel for 5x5 Gaussian smoothing filter.} FilterGaussian5x5: TConvolutionFilter5x5 = ( Kernel: ((1, 4, 6, 4, 1), (4, 16, 24, 16, 4), (6, 24, 36, 24, 6), (4, 16, 24, 16, 4), (1, 4, 6, 4, 1)); Divisor: 256); { Kernel for 3x3 Sobel horizontal edge detection filter (1st derivative approximation).} FilterSobelHorz3x3: TConvolutionFilter3x3 = ( Kernel: (( 1, 2, 1), ( 0, 0, 0), (-1, -2, -1)); Divisor: 1); { Kernel for 3x3 Sobel vertical edge detection filter (1st derivative approximation).} FilterSobelVert3x3: TConvolutionFilter3x3 = ( Kernel: ((-1, 0, 1), (-2, 0, 2), (-1, 0, 1)); Divisor: 1); { Kernel for 3x3 Prewitt horizontal edge detection filter.} FilterPrewittHorz3x3: TConvolutionFilter3x3 = ( Kernel: (( 1, 1, 1), ( 0, 0, 0), (-1, -1, -1)); Divisor: 1); { Kernel for 3x3 Prewitt vertical edge detection filter.} FilterPrewittVert3x3: TConvolutionFilter3x3 = ( Kernel: ((-1, 0, 1), (-1, 0, 1), (-1, 0, 1)); Divisor: 1); { Kernel for 3x3 Kirsh horizontal edge detection filter.} FilterKirshHorz3x3: TConvolutionFilter3x3 = ( Kernel: (( 5, 5, 5), (-3, 0, -3), (-3, -3, -3)); Divisor: 1); { Kernel for 3x3 Kirsh vertical edge detection filter.} FilterKirshVert3x3: TConvolutionFilter3x3 = ( Kernel: ((5, -3, -3), (5, 0, -3), (5, -3, -3)); Divisor: 1); { Kernel for 3x3 Laplace omni-directional edge detection filter (2nd derivative approximation).} FilterLaplace3x3: TConvolutionFilter3x3 = ( Kernel: ((-1, -1, -1), (-1, 8, -1), (-1, -1, -1)); Divisor: 1); { Kernel for 5x5 Laplace omni-directional edge detection filter (2nd derivative approximation).} FilterLaplace5x5: TConvolutionFilter5x5 = ( Kernel: ((-1, -1, -1, -1, -1), (-1, -1, -1, -1, -1), (-1, -1, 24, -1, -1), (-1, -1, -1, -1, -1), (-1, -1, -1, -1, -1)); Divisor: 1); { Kernel for 3x3 spharpening filter (Laplacian + original color).} FilterSharpen3x3: TConvolutionFilter3x3 = ( Kernel: ((-1, -1, -1), (-1, 9, -1), (-1, -1, -1)); Divisor: 1); { Kernel for 5x5 spharpening filter (Laplacian + original color).} FilterSharpen5x5: TConvolutionFilter5x5 = ( Kernel: ((-1, -1, -1, -1, -1), (-1, -1, -1, -1, -1), (-1, -1, 25, -1, -1), (-1, -1, -1, -1, -1), (-1, -1, -1, -1, -1)); Divisor: 1); { Kernel for 5x5 glow filter.} FilterGlow5x5: TConvolutionFilter5x5 = ( Kernel: (( 1, 2, 2, 2, 1), ( 2, 0, 0, 0, 2), ( 2, 0, -20, 0, 2), ( 2, 0, 0, 0, 2), ( 1, 2, 2, 2, 1)); Divisor: 8); { Kernel for 3x3 edge enhancement filter.} FilterEdgeEnhance3x3: TConvolutionFilter3x3 = ( Kernel: ((-1, -2, -1), (-2, 16, -2), (-1, -2, -1)); Divisor: 4); { Kernel for 3x3 contour enhancement filter.} FilterTraceControur3x3: TConvolutionFilter3x3 = ( Kernel: ((-6, -6, -2), (-1, 32, -1), (-6, -2, -6)); Divisor: 4; Bias: 240/255); { Kernel for filter that negates all images pixels.} FilterNegative3x3: TConvolutionFilter3x3 = ( Kernel: ((0, 0, 0), (0, -1, 0), (0, 0, 0)); Divisor: 1; Bias: 1); { Kernel for 3x3 horz/vert embossing filter.} FilterEmboss3x3: TConvolutionFilter3x3 = ( Kernel: ((2, 0, 0), (0, -1, 0), (0, 0, -1)); Divisor: 1; Bias: 0.5); { You can register your own canvas class. List of registered canvases is used by FindBestCanvasForImage functions to find best canvas for given image. If two different canvases which support the same image data format are registered then the one that was registered later is returned (so you can override builtin Imaging canvases).} procedure RegisterCanvas(CanvasClass: TImagingCanvasClass); { Returns best canvas for given TImageFormat.} function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload; { Returns best canvas for given TImageData.} function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass; overload; { Returns best canvas for given TBaseImage.} function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass; overload; implementation resourcestring SConstructorInvalidPointer = 'Invalid pointer (%p) to TImageData passed to TImagingCanvas constructor.'; SConstructorInvalidImage = 'Invalid image data passed to TImagingCanvas constructor (%s).'; SConstructorUnsupportedFormat = 'Image passed to TImagingCanvas constructor is in unsupported format (%s)'; var // list with all registered TImagingCanvas classes CanvasClasses: TList = nil; procedure RegisterCanvas(CanvasClass: TImagingCanvasClass); begin Assert(CanvasClass <> nil); if CanvasClasses = nil then CanvasClasses := TList.Create; if CanvasClasses.IndexOf(CanvasClass) < 0 then CanvasClasses.Add(CanvasClass); end; function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload; var I: LongInt; begin for I := CanvasClasses.Count - 1 downto 0 do begin if ImageFormat in TImagingCanvasClass(CanvasClasses[I]).GetSupportedFormats then begin Result := TImagingCanvasClass(CanvasClasses[I]); Exit; end; end; Result := TImagingCanvas; end; function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass; begin Result := FindBestCanvasForImage(ImageData.Format); end; function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass; begin Result := FindBestCanvasForImage(Image.Format); end; { Canvas helper functions } procedure PixelBlendProc(const SrcPix: TColorFPRec; DestPtr: PByte; DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); var DestPix, FSrc, FDst: TColorFPRec; begin // Get set pixel color DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); // Determine current blending factors case SrcFactor of bfZero: FSrc := ColorFP(0, 0, 0, 0); bfOne: FSrc := ColorFP(1, 1, 1, 1); bfSrcAlpha: FSrc := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A); bfOneMinusSrcAlpha: FSrc := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A); bfDstAlpha: FSrc := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A); bfOneMinusDstAlpha: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A); bfDstColor: FSrc := ColorFP(DestPix.A, DestPix.R, DestPix.G, DestPix.B); bfOneMinusDstColor: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.R, 1 - DestPix.G, 1 - DestPix.B); end; case DestFactor of bfZero: FDst := ColorFP(0, 0, 0, 0); bfOne: FDst := ColorFP(1, 1, 1, 1); bfSrcAlpha: FDst := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A); bfOneMinusSrcAlpha: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A); bfDstAlpha: FDst := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A); bfOneMinusDstAlpha: FDst := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A); bfSrcColor: FDst := ColorFP(SrcPix.A, SrcPix.R, SrcPix.G, SrcPix.B); bfOneMinusSrcColor: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.R, 1 - SrcPix.G, 1 - SrcPix.B); end; // Compute blending formula DestPix.R := SrcPix.R * FSrc.R + DestPix.R * FDst.R; DestPix.G := SrcPix.G * FSrc.G + DestPix.G * FDst.G; DestPix.B := SrcPix.B * FSrc.B + DestPix.B * FDst.B; DestPix.A := SrcPix.A * FSrc.A + DestPix.A * FDst.A; // Write blended pixel DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); end; procedure PixelAlphaProc(const SrcPix: TColorFPRec; DestPtr: PByte; DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); var DestPix: TColorFPRec; SrcAlpha, DestAlpha: Single; begin DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); // Blend the two pixels (Src 'over' Dest alpha composition operation) DestPix.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A; SrcAlpha := IffFloat(DestPix.A = 0, 0, SrcPix.A / DestPix.A); DestAlpha := 1.0 - SrcAlpha; DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha; DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha; DestPix.B := SrcPix.B * SrcAlpha + DestPix.B * DestAlpha; // Write blended pixel DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); end; procedure PixelAddProc(const SrcPix: TColorFPRec; DestPtr: PByte; DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); var DestPix: TColorFPRec; begin // Just add Src and Dest DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); DestPix.R := SrcPix.R + DestPix.R; DestPix.G := SrcPix.G + DestPix.G; DestPix.B := SrcPix.B + DestPix.B; DestPix.A := SrcPix.A + DestPix.A; DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); end; function CompareColors(const C1, C2: TColorFPRec): Single; {$IFDEF USE_INLINE}inline;{$ENDIF} begin Result := (C1.R * GrayConv.R + C1.G * GrayConv.G + C1.B * GrayConv.B) - (C2.R * GrayConv.R + C2.G * GrayConv.G + C2.B * GrayConv.B); end; function MedianSelect(var Pixels: TDynFPPixelArray): TColorFPRec; procedure QuickSort(L, R: Integer); var I, J: Integer; P, Temp: TColorFPRec; begin repeat I := L; J := R; P := Pixels[(L + R) shr 1]; repeat while CompareColors(Pixels[I], P) < 0 do Inc(I); while CompareColors(Pixels[J], P) > 0 do Dec(J); if I <= J then begin Temp := Pixels[I]; Pixels[I] := Pixels[J]; Pixels[J] := Temp; Inc(I); Dec(J); end; until I > J; if L < J then QuickSort(L, J); L := I; until I >= R; end; begin // First sort pixels QuickSort(0, High(Pixels)); // Select middle pixel Result := Pixels[Length(Pixels) div 2]; end; function MinSelect(var Pixels: TDynFPPixelArray): TColorFPRec; var I: Integer; begin Result := Pixels[0]; for I := 1 to High(Pixels) do begin if CompareColors(Pixels[I], Result) < 0 then Result := Pixels[I]; end; end; function MaxSelect(var Pixels: TDynFPPixelArray): TColorFPRec; var I: Integer; begin Result := Pixels[0]; for I := 1 to High(Pixels) do begin if CompareColors(Pixels[I], Result) > 0 then Result := Pixels[I]; end; end; function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, P3: Single): TColorFPRec; begin Result.A := Pixel.A; Result.R := Pixel.R * C + B; Result.G := Pixel.G * C + B; Result.B := Pixel.B * C + B; end; function TransformGamma(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec; begin Result.A := Pixel.A; Result.R := Power(Pixel.R, 1.0 / R); Result.G := Power(Pixel.G, 1.0 / G); Result.B := Power(Pixel.B, 1.0 / B); end; function TransformInvert(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec; begin Result.A := Pixel.A; Result.R := 1.0 - Pixel.R; Result.G := 1.0 - Pixel.G; Result.B := 1.0 - Pixel.B; end; function TransformThreshold(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec; begin Result.A := Pixel.A; Result.R := IffFloat(Pixel.R >= R, 1.0, 0.0); Result.G := IffFloat(Pixel.G >= G, 1.0, 0.0); Result.B := IffFloat(Pixel.B >= B, 1.0, 0.0); end; function TransformLevels(const Pixel: TColorFPRec; BlackPoint, WhitePoint, Exp: Single): TColorFPRec; begin Result.A := Pixel.A; if Pixel.R > BlackPoint then Result.R := Power((Pixel.R - BlackPoint) / (WhitePoint - BlackPoint), Exp) else Result.R := 0.0; if Pixel.G > BlackPoint then Result.G := Power((Pixel.G - BlackPoint) / (WhitePoint - BlackPoint), Exp) else Result.G := 0.0; if Pixel.B > BlackPoint then Result.B := Power((Pixel.B - BlackPoint) / (WhitePoint - BlackPoint), Exp) else Result.B := 0.0; end; function TransformPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec; begin Result.A := Pixel.A; Result.R := Result.R * Pixel.A; Result.G := Result.G * Pixel.A; Result.B := Result.B * Pixel.A; end; function TransformUnPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec; begin Result.A := Pixel.A; if Pixel.A <> 0.0 then begin Result.R := Result.R / Pixel.A; Result.G := Result.G / Pixel.A; Result.B := Result.B / Pixel.A; end else begin Result.R := 0; Result.G := 0; Result.B := 0; end; end; { TImagingCanvas class implementation } constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData); begin if ImageDataPointer = nil then raise EImagingCanvasError.CreateFmt(SConstructorInvalidPointer, [ImageDataPointer]); if not TestImage(ImageDataPointer^) then raise EImagingCanvasError.CreateFmt(SConstructorInvalidImage, [Imaging.ImageToStr(ImageDataPointer^)]); if not (ImageDataPointer.Format in GetSupportedFormats) then raise EImagingCanvasError.CreateFmt(SConstructorUnsupportedFormat, [Imaging.ImageToStr(ImageDataPointer^)]); FPData := ImageDataPointer; FPenWidth := 1; SetPenColor32(pcWhite); SetFillColor32(pcBlack); FFillMode := fmSolid; UpdateCanvasState; end; constructor TImagingCanvas.CreateForImage(Image: TBaseImage); begin CreateForData(Image.ImageDataPointer); end; destructor TImagingCanvas.Destroy; begin inherited Destroy; end; function TImagingCanvas.GetPixel32(X, Y: LongInt): TColor32; begin Result := Imaging.GetPixel32(FPData^, X, Y).Color; end; function TImagingCanvas.GetPixelFP(X, Y: LongInt): TColorFPRec; begin Result := Imaging.GetPixelFP(FPData^, X, Y); end; function TImagingCanvas.GetValid: Boolean; begin Result := (FPData <> nil) and (FDataSizeOnUpdate = FPData.Size); end; procedure TImagingCanvas.SetPixel32(X, Y: LongInt; const Value: TColor32); begin if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and (X < FClipRect.Right) and (Y < FClipRect.Bottom) then begin Imaging.SetPixel32(FPData^, X, Y, TColor32Rec(Value)); end; end; procedure TImagingCanvas.SetPixelFP(X, Y: LongInt; const Value: TColorFPRec); begin if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and (X < FClipRect.Right) and (Y < FClipRect.Bottom) then begin Imaging.SetPixelFP(FPData^, X, Y, TColorFPRec(Value)); end; end; procedure TImagingCanvas.SetPenColor32(const Value: TColor32); begin FPenColor32 := Value; TranslatePixel(@FPenColor32, @FPenColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil); end; procedure TImagingCanvas.SetPenColorFP(const Value: TColorFPRec); begin FPenColorFP := Value; TranslatePixel(@FPenColorFP, @FPenColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil); end; procedure TImagingCanvas.SetPenWidth(const Value: LongInt); begin FPenWidth := ClampInt(Value, 0, MaxPenWidth); end; procedure TImagingCanvas.SetFillColor32(const Value: TColor32); begin FFillColor32 := Value; TranslatePixel(@FFillColor32, @FFillColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil); end; procedure TImagingCanvas.SetFillColorFP(const Value: TColorFPRec); begin FFillColorFP := Value; TranslatePixel(@FFillColorFP, @FFillColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil); end; procedure TImagingCanvas.SetClipRect(const Value: TRect); begin FClipRect := Value; SwapMin(FClipRect.Left, FClipRect.Right); SwapMin(FClipRect.Top, FClipRect.Bottom); IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height)); end; procedure TImagingCanvas.CheckBeforeBlending(SrcFactor, DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas); begin if SrcFactor in [bfSrcColor, bfOneMinusSrcColor] then raise EImagingCanvasBlendingError.Create('Invalid source blending factor. Check the documentation for TBlendingFactor.'); if DestFactor in [bfDstColor, bfOneMinusDstColor] then raise EImagingCanvasBlendingError.Create('Invalid destination blending factor. Check the documentation for TBlendingFactor.'); if DestCanvas.FormatInfo.IsIndexed then raise EImagingCanvasBlendingError.Create('Blending destination canvas cannot be in indexed mode.'); end; function TImagingCanvas.GetPixelPointer(X, Y: LongInt): Pointer; begin Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * FFormatInfo.BytesPerPixel] end; procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec); begin TranslateFPToNative(Color, @FNativeColor); end; procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec; Native: Pointer); begin ImagingFormats.TranslatePixel(@Color, Native, ifA32R32G32B32F, FPData.Format, nil, FPData.Palette); end; procedure TImagingCanvas.UpdateCanvasState; begin FDataSizeOnUpdate := FPData.Size; ResetClipRect; Imaging.GetImageFormatInfo(FPData.Format, FFormatInfo) end; procedure TImagingCanvas.ResetClipRect; begin FClipRect := Rect(0, 0, FPData.Width, FPData.Height) end; procedure TImagingCanvas.Clear; begin TranslateFPToNative(FFillColorFP); Imaging.FillRect(FPData^, 0, 0, FPData.Width, FPData.Height, @FNativeColor); end; function TImagingCanvas.ClipAxisParallelLine(var A1, A2, B: LongInt; AStart, AStop, BStart, BStop: LongInt): Boolean; begin if (B >= BStart) and (B < BStop) then begin SwapMin(A1, A2); if A1 < AStart then A1 := AStart; if A2 >= AStop then A2 := AStop - 1; Result := True; end else Result := False; end; procedure TImagingCanvas.HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); var I, WidthBytes: LongInt; PixelPtr: PByte; begin if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then begin SwapMin(X1, X2); X1 := Max(X1, FClipRect.Left); X2 := Min(X2, FClipRect.Right); PixelPtr := GetPixelPointer(X1, Y); WidthBytes := (X2 - X1) * Bpp; case Bpp of 1: FillMemoryByte(PixelPtr, WidthBytes, PByte(Color)^); 2: FillMemoryWord(PixelPtr, WidthBytes, PWord(Color)^); 4: FillMemoryLongWord(PixelPtr, WidthBytes, PLongWord(Color)^); else for I := X1 to X2 do begin ImagingFormats.CopyPixel(Color, PixelPtr, Bpp); Inc(PixelPtr, Bpp); end; end; end; end; procedure TImagingCanvas.CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; Bpp: LongInt); begin if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and (X < FClipRect.Right) and (Y < FClipRect.Bottom) then begin ImagingFormats.CopyPixel(Pixel, GetPixelPointer(X, Y), Bpp); end; end; procedure TImagingCanvas.HorzLine(X1, X2, Y: LongInt); var DstRect: TRect; begin if FPenMode = pmClear then Exit; SwapMin(X1, X2); if IntersectRect(DstRect, Rect(X1, Y - FPenWidth div 2, X2, Y + FPenWidth div 2 + FPenWidth mod 2), FClipRect) then begin TranslateFPToNative(FPenColorFP); Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, @FNativeColor); end; end; procedure TImagingCanvas.VertLine(X, Y1, Y2: LongInt); var DstRect: TRect; begin if FPenMode = pmClear then Exit; SwapMin(Y1, Y2); if IntersectRect(DstRect, Rect(X - FPenWidth div 2, Y1, X + FPenWidth div 2 + FPenWidth mod 2, Y2), FClipRect) then begin TranslateFPToNative(FPenColorFP); Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, @FNativeColor); end; end; procedure TImagingCanvas.Line(X1, Y1, X2, Y2: LongInt); var Steep: Boolean; Error, YStep, DeltaX, DeltaY, X, Y, I, Bpp, W1, W2, Code1, Code2: LongInt; begin if FPenMode = pmClear then Exit; // If line is vertical or horizontal just call appropriate method if X2 - X1 = 0 then begin HorzLine(X1, X2, Y1); Exit; end; if Y2 - Y1 = 0 then begin VertLine(X1, Y1, Y2); Exit; end; // Determine if line is steep (angle with X-axis > 45 degrees) Steep := Abs(Y2 - Y1) > Abs(X2 - X1); // If we need to draw thick line we just draw more 1 pixel lines around // the one we already drawn. Setting FLineRecursion assures that we // won't be doing recursions till the end of the world. if (FPenWidth > 1) and not FLineRecursion then begin FLineRecursion := True; W1 := FPenWidth div 2; W2 := W1; if FPenWidth mod 2 = 0 then Dec(W1); if Steep then begin // Add lines left/right for I := 1 to W1 do Line(X1, Y1 - I, X2, Y2 - I); for I := 1 to W2 do Line(X1, Y1 + I, X2, Y2 + I); end else begin // Add lines above/under for I := 1 to W1 do Line(X1 - I, Y1, X2 - I, Y2); for I := 1 to W2 do Line(X1 + I, Y1, X2 + I, Y2); end; FLineRecursion := False; end; with FClipRect do begin // Use part of Cohen-Sutherland line clipping to determine if any part of line // is in ClipRect Code1 := Ord(X1 < Left) + Ord(X1 > Right) shl 1 + Ord(Y1 < Top) shl 2 + Ord(Y1 > Bottom) shl 3; Code2 := Ord(X2 < Left) + Ord(X2 > Right) shl 1 + Ord(Y2 < Top) shl 2 + Ord(Y2 > Bottom) shl 3; end; if (Code1 and Code2) = 0 then begin TranslateFPToNative(FPenColorFP); Bpp := FFormatInfo.BytesPerPixel; // If line is steep swap X and Y coordinates so later we just have one loop // of two (where only one is used according to steepness). if Steep then begin SwapValues(X1, Y1); SwapValues(X2, Y2); end; if X1 > X2 then begin SwapValues(X1, X2); SwapValues(Y1, Y2); end; DeltaX := X2 - X1; DeltaY := Abs(Y2 - Y1); YStep := Iff(Y2 > Y1, 1, -1); Error := 0; Y := Y1; // Draw line using Bresenham algorithm. No real line clipping here, // just don't draw pixels outsize clip rect. for X := X1 to X2 do begin if Steep then CopyPixelInternal(Y, X, @FNativeColor, Bpp) else CopyPixelInternal(X, Y, @FNativeColor, Bpp); Error := Error + DeltaY; if Error * 2 >= DeltaX then begin Inc(Y, YStep); Dec(Error, DeltaX); end; end; end; end; procedure TImagingCanvas.FrameRect(const Rect: TRect); var HalfPen, PenMod: LongInt; begin if FPenMode = pmClear then Exit; HalfPen := FPenWidth div 2; PenMod := FPenWidth mod 2; HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Top); HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Bottom - 1); VertLine(Rect.Left, Rect.Top, Rect.Bottom); VertLine(Rect.Right - 1, Rect.Top, Rect.Bottom); end; procedure TImagingCanvas.FillRect(const Rect: TRect); var DstRect: TRect; begin if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then begin TranslateFPToNative(FFillColorFP); Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, @FNativeColor); end; end; procedure TImagingCanvas.FillRectBlend(const Rect: TRect; SrcFactor, DestFactor: TBlendingFactor); var DstRect: TRect; X, Y: Integer; Line: PByte; begin if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then begin CheckBeforeBlending(SrcFactor, DestFactor, Self); for Y := DstRect.Top to DstRect.Bottom - 1 do begin Line := @PByteArray(FPData.Bits)[(Y * FPData.Width + DstRect.Left) * FFormatInfo.BytesPerPixel]; for X := DstRect.Left to DstRect.Right - 1 do begin PixelBlendProc(FFillColorFP, Line, @FFormatInfo, SrcFactor, DestFactor); Inc(Line, FFormatInfo.BytesPerPixel); end; end; end; end; procedure TImagingCanvas.Rectangle(const Rect: TRect); begin FillRect(Rect); FrameRect(Rect); end; procedure TImagingCanvas.Ellipse(const Rect: TRect); var RadX, RadY, DeltaX, DeltaY, R, RX, RY: LongInt; X1, X2, Y1, Y2, Bpp, OldY: LongInt; Fill, Pen: TColorFPRec; begin // TODO: Use PenWidth X1 := Rect.Left; X2 := Rect.Right; Y1 := Rect.Top; Y2 := Rect.Bottom; TranslateFPToNative(FPenColorFP, @Pen); TranslateFPToNative(FFillColorFP, @Fill); Bpp := FFormatInfo.BytesPerPixel; SwapMin(X1, X2); SwapMin(Y1, Y2); RadX := (X2 - X1) div 2; RadY := (Y2 - Y1) div 2; Y1 := Y1 + RadY; Y2 := Y1; OldY := Y1; DeltaX := (RadX * RadX); DeltaY := (RadY * RadY); R := RadX * RadY * RadY; RX := R; RY := 0; if (FFillMode <> fmClear) then HorzLineInternal(X1, X2, Y1, @Fill, Bpp); CopyPixelInternal(X1, Y1, @Pen, Bpp); CopyPixelInternal(X2, Y1, @Pen, Bpp); while RadX > 0 do begin if R > 0 then begin Inc(Y1); Dec(Y2); Inc(RY, DeltaX); Dec(R, RY); end; if R <= 0 then begin Dec(RadX); Inc(X1); Dec(X2); Dec(RX, DeltaY); Inc(R, RX); end; if (OldY <> Y1) and (FFillMode <> fmClear) then begin HorzLineInternal(X1, X2, Y1, @Fill, Bpp); HorzLineInternal(X1, X2, Y2, @Fill, Bpp); end; OldY := Y1; CopyPixelInternal(X1, Y1, @Pen, Bpp); CopyPixelInternal(X2, Y1, @Pen, Bpp); CopyPixelInternal(X1, Y2, @Pen, Bpp); CopyPixelInternal(X2, Y2, @Pen, Bpp); end; end; procedure TImagingCanvas.FloodFill(X, Y: Integer; BoundaryFillMode: Boolean); var Stack: array of TPoint; StackPos, Y1: Integer; OldColor: TColor32; SpanLeft, SpanRight: Boolean; procedure Push(AX, AY: Integer); begin if StackPos < High(Stack) then begin Inc(StackPos); Stack[StackPos].X := AX; Stack[StackPos].Y := AY; end else begin SetLength(Stack, Length(Stack) + FPData.Width); Push(AX, AY); end; end; function Pop(out AX, AY: Integer): Boolean; begin if StackPos > 0 then begin AX := Stack[StackPos].X; AY := Stack[StackPos].Y; Dec(StackPos); Result := True; end else Result := False; end; function Compare(AX, AY: Integer): Boolean; var Color: TColor32; begin Color := GetPixel32(AX, AY); if BoundaryFillMode then Result := (Color <> FFillColor32) and (Color <> FPenColor32) else Result := Color = OldColor; end; begin // Scanline Floodfill Algorithm With Stack // http://student.kuleuven.be/~m0216922/CG/floodfill.html if not PtInRect(FClipRect, Point(X, Y)) then Exit; SetLength(Stack, FPData.Width * 4); StackPos := 0; OldColor := GetPixel32(X, Y); Push(X, Y); while Pop(X, Y) do begin Y1 := Y; while (Y1 >= FClipRect.Top) and Compare(X, Y1) do Dec(Y1); Inc(Y1); SpanLeft := False; SpanRight := False; while (Y1 < FClipRect.Bottom) and Compare(X, Y1) do begin SetPixel32(X, Y1, FFillColor32); if not SpanLeft and (X > FClipRect.Left) and Compare(X - 1, Y1) then begin Push(X - 1, Y1); SpanLeft := True; end else if SpanLeft and (X > FClipRect.Left) and not Compare(X - 1, Y1) then SpanLeft := False else if not SpanRight and (X < FClipRect.Right - 1) and Compare(X + 1, Y1)then begin Push(X + 1, Y1); SpanRight := True; end else if SpanRight and (X < FClipRect.Right - 1) and not Compare(X + 1, Y1) then SpanRight := False; Inc(Y1); end; end; end; procedure TImagingCanvas.DrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc); var X, Y, SrcX, SrcY, Width, Height, SrcBpp, DestBpp: Integer; PSrc: TColorFPRec; SrcPointer, DestPointer: PByte; begin CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas); SrcX := SrcRect.Left; SrcY := SrcRect.Top; Width := SrcRect.Right - SrcRect.Left; Height := SrcRect.Bottom - SrcRect.Top; SrcBpp := FFormatInfo.BytesPerPixel; DestBpp := DestCanvas.FFormatInfo.BytesPerPixel; // Clip src and dst rects ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY, FPData.Width, FPData.Height, DestCanvas.ClipRect); for Y := 0 to Height - 1 do begin // Get src and dst scanlines SrcPointer := @PByteArray(FPData.Bits)[((SrcY + Y) * FPData.Width + SrcX) * SrcBpp]; DestPointer := @PByteArray(DestCanvas.FPData.Bits)[((DestY + Y) * DestCanvas.FPData.Width + DestX) * DestBpp]; for X := 0 to Width - 1 do begin PSrc := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, FPData.Palette); // Call pixel writer procedure - combine source and dest pixels PixelWriteProc(PSrc, DestPointer, @DestCanvas.FFormatInfo, SrcFactor, DestFactor); // Increment pixel pointers Inc(SrcPointer, SrcBpp); Inc(DestPointer, DestBpp); end; end; end; procedure TImagingCanvas.DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor); begin DrawInternal(SrcRect, DestCanvas, DestX, DestY, SrcFactor, DestFactor, PixelBlendProc); end; procedure TImagingCanvas.DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); begin DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAlphaProc); end; procedure TImagingCanvas.DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); begin DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAddProc); end; procedure TImagingCanvas.StretchDrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas; const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc); const FilterMapping: array[TResizeFilter] of TSamplingFilter = (sfNearest, sfLinear, DefaultCubicFilter); var X, Y, I, J, SrcX, SrcY, SrcWidth, SrcHeight: Integer; DestX, DestY, DestWidth, DestHeight, SrcBpp, DestBpp: Integer; SrcPix, PDest: TColorFPRec; MapX, MapY: TMappingTable; XMinimum, XMaximum: Integer; LineBuffer: array of TColorFPRec; ClusterX, ClusterY: TCluster; Weight, AccumA, AccumR, AccumG, AccumB: Single; DestLine: PByte; FilterFunction: TFilterFunction; Radius: Single; begin CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas); SrcX := SrcRect.Left; SrcY := SrcRect.Top; SrcWidth := SrcRect.Right - SrcRect.Left; SrcHeight := SrcRect.Bottom - SrcRect.Top; DestX := DestRect.Left; DestY := DestRect.Top; DestWidth := DestRect.Right - DestRect.Left; DestHeight := DestRect.Bottom - DestRect.Top; SrcBpp := FFormatInfo.BytesPerPixel; DestBpp := DestCanvas.FFormatInfo.BytesPerPixel; // Get actual resampling filter and radius FilterFunction := SamplingFilterFunctions[FilterMapping[Filter]]; Radius := SamplingFilterRadii[FilterMapping[Filter]]; // Clip src and dst rects ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight, FPData.Width, FPData.Height, DestCanvas.ClipRect); // Generate mapping tables MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth, FPData.Width, FilterFunction, Radius, False); MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight, FPData.Height, FilterFunction, Radius, False); FindExtremes(MapX, XMinimum, XMaximum); SetLength(LineBuffer, XMaximum - XMinimum + 1); for J := 0 to DestHeight - 1 do begin ClusterY := MapY[J]; for X := XMinimum to XMaximum do begin AccumA := 0.0; AccumR := 0.0; AccumG := 0.0; AccumB := 0.0; for Y := 0 to Length(ClusterY) - 1 do begin Weight := ClusterY[Y].Weight; SrcPix := FFormatInfo.GetPixelFP(@PByteArray(FPData.Bits)[(ClusterY[Y].Pos * FPData.Width + X) * SrcBpp], @FFormatInfo, FPData.Palette); AccumB := AccumB + SrcPix.B * Weight; AccumG := AccumG + SrcPix.G * Weight; AccumR := AccumR + SrcPix.R * Weight; AccumA := AccumA + SrcPix.A * Weight; end; with LineBuffer[X - XMinimum] do begin A := AccumA; R := AccumR; G := AccumG; B := AccumB; end; end; DestLine := @PByteArray(DestCanvas.FPData.Bits)[((J + DestY) * DestCanvas.FPData.Width + DestX) * DestBpp]; for I := 0 to DestWidth - 1 do begin ClusterX := MapX[I]; AccumA := 0.0; AccumR := 0.0; AccumG := 0.0; AccumB := 0.0; for X := 0 to Length(ClusterX) - 1 do begin Weight := ClusterX[X].Weight; with LineBuffer[ClusterX[X].Pos - XMinimum] do begin AccumB := AccumB + B * Weight; AccumG := AccumG + G * Weight; AccumR := AccumR + R * Weight; AccumA := AccumA + A * Weight; end; end; SrcPix.A := AccumA; SrcPix.R := AccumR; SrcPix.G := AccumG; SrcPix.B := AccumB; // Write resulting blended pixel PixelWriteProc(SrcPix, DestLine, @DestCanvas.FFormatInfo, SrcFactor, DestFactor); Inc(DestLine, DestBpp); end; end; end; procedure TImagingCanvas.StretchDrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas; const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter); begin StretchDrawInternal(SrcRect, DestCanvas, DestRect, SrcFactor, DestFactor, Filter, PixelBlendProc); end; procedure TImagingCanvas.StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); begin StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAlphaProc); end; procedure TImagingCanvas.StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); begin StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAddProc); end; procedure TImagingCanvas.ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt; Bias: Single; ClampChannels: Boolean); var X, Y, I, J, PosY, PosX, SizeDiv2, KernelValue, WidthBytes, Bpp: LongInt; R, G, B, DivFloat: Single; Pixel: TColorFPRec; TempImage: TImageData; DstPointer, SrcPointer: PByte; begin SizeDiv2 := KernelSize div 2; DivFloat := IffFloat(Divisor > 1, 1.0 / Divisor, 1.0); Bpp := FFormatInfo.BytesPerPixel; WidthBytes := FPData.Width * Bpp; InitImage(TempImage); CloneImage(FPData^, TempImage); try // For every pixel in clip rect for Y := FClipRect.Top to FClipRect.Bottom - 1 do begin DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp]; for X := FClipRect.Left to FClipRect.Right - 1 do begin // Reset accumulators R := 0.0; G := 0.0; B := 0.0; for J := 0 to KernelSize - 1 do begin PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1); for I := 0 to KernelSize - 1 do begin PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1); SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp]; // Get pixels from neighbourhood of current pixel and add their // colors to accumulators weighted by filter kernel values Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette); KernelValue := PLongIntArray(Kernel)[J * KernelSize + I]; R := R + Pixel.R * KernelValue; G := G + Pixel.G * KernelValue; B := B + Pixel.B * KernelValue; end; end; Pixel := FFormatInfo.GetPixelFP(DstPointer, @FFormatInfo, FPData.Palette); Pixel.R := R * DivFloat + Bias; Pixel.G := G * DivFloat + Bias; Pixel.B := B * DivFloat + Bias; if ClampChannels then ClampFloatPixel(Pixel); // Set resulting pixel color FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel); Inc(DstPointer, Bpp); end; end; finally FreeImage(TempImage); end; end; procedure TImagingCanvas.ApplyConvolution3x3(const Filter: TConvolutionFilter3x3); begin ApplyConvolution(@Filter.Kernel, 3, Filter.Divisor, Filter.Bias, True); end; procedure TImagingCanvas.ApplyConvolution5x5(const Filter: TConvolutionFilter5x5); begin ApplyConvolution(@Filter.Kernel, 5, Filter.Divisor, Filter.Bias, True); end; procedure TImagingCanvas.ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction); var X, Y, I, J, PosY, PosX, SizeDiv2, WidthBytes, Bpp: LongInt; Pixel: TColorFPRec; TempImage: TImageData; DstPointer, SrcPointer: PByte; NeighPixels: TDynFPPixelArray; begin SizeDiv2 := FilterSize div 2; Bpp := FFormatInfo.BytesPerPixel; WidthBytes := FPData.Width * Bpp; SetLength(NeighPixels, FilterSize * FilterSize); InitImage(TempImage); CloneImage(FPData^, TempImage); try // For every pixel in clip rect for Y := FClipRect.Top to FClipRect.Bottom - 1 do begin DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp]; for X := FClipRect.Left to FClipRect.Right - 1 do begin for J := 0 to FilterSize - 1 do begin PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1); for I := 0 to FilterSize - 1 do begin PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1); SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp]; // Get pixels from neighbourhood of current pixel and store them Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette); NeighPixels[J * FilterSize + I] := Pixel; end; end; // Choose pixel using custom function Pixel := SelectFunc(NeighPixels); // Set resulting pixel color FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel); Inc(DstPointer, Bpp); end; end; finally FreeImage(TempImage); end; end; procedure TImagingCanvas.ApplyMedianFilter(FilterSize: Integer); begin ApplyNonLinearFilter(FilterSize, MedianSelect); end; procedure TImagingCanvas.ApplyMinFilter(FilterSize: Integer); begin ApplyNonLinearFilter(FilterSize, MinSelect); end; procedure TImagingCanvas.ApplyMaxFilter(FilterSize: Integer); begin ApplyNonLinearFilter(FilterSize, MaxSelect); end; procedure TImagingCanvas.PointTransform(Transform: TPointTransformFunction; Param1, Param2, Param3: Single); var X, Y, Bpp, WidthBytes: Integer; PixPointer: PByte; Pixel: TColorFPRec; begin Bpp := FFormatInfo.BytesPerPixel; WidthBytes := FPData.Width * Bpp; // For every pixel in clip rect for Y := FClipRect.Top to FClipRect.Bottom - 1 do begin PixPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp]; for X := FClipRect.Left to FClipRect.Right - 1 do begin Pixel := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette); FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, Transform(Pixel, Param1, Param2, Param3)); Inc(PixPointer, Bpp); end; end; end; procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single); begin PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100, Brightness / 100, 0); end; procedure TImagingCanvas.GammaCorection(Red, Green, Blue: Single); begin PointTransform(TransformGamma, Red, Green, Blue); end; procedure TImagingCanvas.InvertColors; begin PointTransform(TransformInvert, 0, 0, 0); end; procedure TImagingCanvas.Threshold(Red, Green, Blue: Single); begin PointTransform(TransformThreshold, Red, Green, Blue); end; procedure TImagingCanvas.AdjustColorLevels(BlackPoint, WhitePoint, MidPoint: Single); begin PointTransform(TransformLevels, BlackPoint, WhitePoint, 1.0 / MidPoint); end; procedure TImagingCanvas.PremultiplyAlpha; begin PointTransform(TransformPremultiplyAlpha, 0, 0, 0); end; procedure TImagingCanvas.UnPremultiplyAlpha; begin PointTransform(TransformUnPremultiplyAlpha, 0, 0, 0); end; procedure TImagingCanvas.GetHistogram(out Red, Green, Blue, Alpha, Gray: THistogramArray); var X, Y, Bpp: Integer; PixPointer: PByte; Color32: TColor32Rec; begin FillChar(Red, SizeOf(Red), 0); FillChar(Green, SizeOf(Green), 0); FillChar(Blue, SizeOf(Blue), 0); FillChar(Alpha, SizeOf(Alpha), 0); FillChar(Gray, SizeOf(Gray), 0); Bpp := FFormatInfo.BytesPerPixel; for Y := FClipRect.Top to FClipRect.Bottom - 1 do begin PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp]; for X := FClipRect.Left to FClipRect.Right - 1 do begin Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette); Inc(Red[Color32.R]); Inc(Green[Color32.G]); Inc(Blue[Color32.B]); Inc(Alpha[Color32.A]); Inc(Gray[Round(GrayConv.R * Color32.R + GrayConv.G * Color32.G + GrayConv.B * Color32.B)]); Inc(PixPointer, Bpp); end; end; end; procedure TImagingCanvas.FillChannel(ChannelId: Integer; NewChannelValue: Byte); var X, Y, Bpp: Integer; PixPointer: PByte; Color32: TColor32Rec; begin Bpp := FFormatInfo.BytesPerPixel; for Y := FClipRect.Top to FClipRect.Bottom - 1 do begin PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp]; for X := FClipRect.Left to FClipRect.Right - 1 do begin Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette); Color32.Channels[ChannelId] := NewChannelValue; FFormatInfo.SetPixel32(PixPointer, @FFormatInfo, FPData.Palette, Color32); Inc(PixPointer, Bpp); end; end; end; procedure TImagingCanvas.FillChannelFP(ChannelId: Integer; NewChannelValue: Single); var X, Y, Bpp: Integer; PixPointer: PByte; ColorFP: TColorFPRec; begin Bpp := FFormatInfo.BytesPerPixel; for Y := FClipRect.Top to FClipRect.Bottom - 1 do begin PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp]; for X := FClipRect.Left to FClipRect.Right - 1 do begin ColorFP := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette); ColorFP.Channels[ChannelId] := NewChannelValue; FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, ColorFP); Inc(PixPointer, Bpp); end; end; end; class function TImagingCanvas.GetSupportedFormats: TImageFormats; begin Result := [ifIndex8..Pred(ifDXT1)]; end; { TFastARGB32Canvas } destructor TFastARGB32Canvas.Destroy; begin FreeMem(FScanlines); inherited Destroy; end; procedure TFastARGB32Canvas.AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); var SrcAlpha, DestAlpha, FinalAlpha: Integer; begin FinalAlpha := SrcPix.A + 1 + (DestPix.A * (256 - SrcPix.A)) shr 8; if FinalAlpha = 0 then SrcAlpha := 0 else SrcAlpha := (SrcPix.A shl 8) div FinalAlpha; DestAlpha := 256 - SrcAlpha; DestPix.A := ClampToByte(FinalAlpha); DestPix.R := (SrcPix.R * SrcAlpha + DestPix.R * DestAlpha) shr 8; DestPix.G := (SrcPix.G * SrcAlpha + DestPix.G * DestAlpha) shr 8; DestPix.B := (SrcPix.B * SrcAlpha + DestPix.B * DestAlpha) shr 8; end; procedure TFastARGB32Canvas.DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); var X, Y, SrcX, SrcY, Width, Height: Integer; SrcPix, DestPix: PColor32Rec; begin if DestCanvas.ClassType <> Self.ClassType then begin inherited; Exit; end; SrcX := SrcRect.Left; SrcY := SrcRect.Top; Width := SrcRect.Right - SrcRect.Left; Height := SrcRect.Bottom - SrcRect.Top; ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY, FPData.Width, FPData.Height, DestCanvas.ClipRect); for Y := 0 to Height - 1 do begin SrcPix := @FScanlines[SrcY + Y, SrcX]; DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + Y, DestX]; for X := 0 to Width - 1 do begin AlphaBlendPixels(SrcPix, DestPix); Inc(SrcPix); Inc(DestPix); end; end; end; function TFastARGB32Canvas.GetPixel32(X, Y: LongInt): TColor32; begin Result := FScanlines[Y, X].Color; end; procedure TFastARGB32Canvas.SetPixel32(X, Y: LongInt; const Value: TColor32); begin if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and (X < FClipRect.Right) and (Y < FClipRect.Bottom) then begin FScanlines[Y, X].Color := Value; end; end; procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter); var X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4, FracX, FracY, InvFracY, T1, T2: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer; DestX, DestY, DestWidth, DestHeight: Integer; SrcLine, SrcLine2: PColor32RecArray; DestPix: PColor32Rec; Accum: TColor32Rec; begin if (Filter = rfBicubic) or (DestCanvas.ClassType <> Self.ClassType) then begin inherited; Exit; end; SrcX := SrcRect.Left; SrcY := SrcRect.Top; SrcWidth := SrcRect.Right - SrcRect.Left; SrcHeight := SrcRect.Bottom - SrcRect.Top; DestX := DestRect.Left; DestY := DestRect.Top; DestWidth := DestRect.Right - DestRect.Left; DestHeight := DestRect.Bottom - DestRect.Top; // Clip src and dst rects ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight, FPData.Width, FPData.Height, DestCanvas.ClipRect); ScaleX := (SrcWidth shl 16) div DestWidth; ScaleY := (SrcHeight shl 16) div DestHeight; // Nearest and linear filtering using fixed point math if Filter = rfNearest then begin Yp := 0; for Y := DestY to DestY + DestHeight - 1 do begin Xp := 0; SrcLine := @FScanlines[SrcY + Yp shr 16, SrcX]; DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX]; for X := 0 to DestWidth - 1 do begin AlphaBlendPixels(@SrcLine[Xp shr 16], DestPix); Inc(DestPix); Inc(Xp, ScaleX); end; Inc(Yp, ScaleY); end; end else begin Yp := (ScaleY shr 1) - $8000; for Y := DestY to DestY + DestHeight - 1 do begin DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX]; if Yp < 0 then begin T1 := 0; FracY := 0; InvFracY := $10000; end else begin T1 := Yp shr 16; FracY := Yp and $FFFF; InvFracY := (not Yp and $FFFF) + 1; end; T2 := Iff(T1 < SrcHeight - 1, T1 + 1, T1); SrcLine := @Scanlines[T1 + SrcY, SrcX]; SrcLine2 := @Scanlines[T2 + SrcY, SrcX]; Xp := (ScaleX shr 1) - $8000; for X := 0 to DestWidth - 1 do begin if Xp < 0 then begin T1 := 0; FracX := 0; end else begin T1 := Xp shr 16; FracX := Xp and $FFFF; end; T2 := Iff(T1 < SrcWidth - 1, T1 + 1, T1); Weight2:= (Cardinal(InvFracY) * FracX) shr 16; // cast to Card, Int can overflow gere Weight1:= InvFracY - Weight2; Weight4:= (Cardinal(FracY) * FracX) shr 16; Weight3:= FracY - Weight4; Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 + SrcLine2[T1].B * Weight3 + SrcLine2[T2].B * Weight4 + $8000) shr 16; Accum.G := (SrcLine[T1].G * Weight1 + SrcLine[T2].G * Weight2 + SrcLine2[T1].G * Weight3 + SrcLine2[T2].G * Weight4 + $8000) shr 16; Accum.R := (SrcLine[T1].R * Weight1 + SrcLine[T2].R * Weight2 + SrcLine2[T1].R * Weight3 + SrcLine2[T2].R * Weight4 + $8000) shr 16; Accum.A := (SrcLine[T1].A * Weight1 + SrcLine[T2].A * Weight2 + SrcLine2[T1].A * Weight3 + SrcLine2[T2].A * Weight4 + $8000) shr 16; AlphaBlendPixels(@Accum, DestPix); Inc(Xp, ScaleX); Inc(DestPix); end; Inc(Yp, ScaleY); end; end; { // Generate mapping tables MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth, FPData.Width, FilterFunction, Radius, False); MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight, FPData.Height, FilterFunction, Radius, False); FindExtremes(MapX, XMinimum, XMaximum); SetLength(LineBuffer, XMaximum - XMinimum + 1); for J := 0 to DestHeight - 1 do begin ClusterY := MapY[J]; for X := XMinimum to XMaximum do begin AccumA := 0; AccumR := 0; AccumG := 0; AccumB := 0; for Y := 0 to Length(ClusterY) - 1 do begin Weight := Round(ClusterY[Y].Weight * 256); SrcColor := FScanlines[ClusterY[Y].Pos, X]; AccumB := AccumB + SrcColor.B * Weight; AccumG := AccumG + SrcColor.G * Weight; AccumR := AccumR + SrcColor.R * Weight; AccumA := AccumA + SrcColor.A * Weight; end; with LineBuffer[X - XMinimum] do begin A := AccumA; R := AccumR; G := AccumG; B := AccumB; end; end; DestPtr := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + J, DestX]; for I := 0 to DestWidth - 1 do begin ClusterX := MapX[I]; AccumA := 0; AccumR := 0; AccumG := 0; AccumB := 0; for X := 0 to Length(ClusterX) - 1 do begin Weight := Round(ClusterX[X].Weight * 256); with LineBuffer[ClusterX[X].Pos - XMinimum] do begin AccumB := AccumB + B * Weight; AccumG := AccumG + G * Weight; AccumR := AccumR + R * Weight; AccumA := AccumA + A * Weight; end; end; AccumA := ClampInt(AccumA, 0, $00FF0000); AccumR := ClampInt(AccumR, 0, $00FF0000); AccumG := ClampInt(AccumG, 0, $00FF0000); AccumB := ClampInt(AccumB, 0, $00FF0000); SrcColor.Color := (Cardinal(AccumA and $00FF0000) shl 8) or (AccumR and $00FF0000) or ((AccumG and $00FF0000) shr 8) or ((AccumB and $00FF0000) shr 16); AlphaBlendPixels(@SrcColor, DestPtr); Inc(DestPtr); end; end; } end; procedure TFastARGB32Canvas.UpdateCanvasState; var I: LongInt; ScanPos: PLongWord; begin inherited UpdateCanvasState; // Realloc and update scanline array ReallocMem(FScanlines, FPData.Height * SizeOf(PColor32RecArray)); ScanPos := FPData.Bits; for I := 0 to FPData.Height - 1 do begin FScanlines[I] := PColor32RecArray(ScanPos); Inc(ScanPos, FPData.Width); end; end; class function TFastARGB32Canvas.GetSupportedFormats: TImageFormats; begin Result := [ifA8R8G8B8]; end; procedure TFastARGB32Canvas.InvertColors; var X, Y: Integer; PixPtr: PColor32Rec; begin for Y := FClipRect.Top to FClipRect.Bottom - 1 do begin PixPtr := @FScanlines[Y, FClipRect.Left]; for X := FClipRect.Left to FClipRect.Right - 1 do begin PixPtr.R := not PixPtr.R; PixPtr.G := not PixPtr.G; PixPtr.B := not PixPtr.B; Inc(PixPtr); end; end; end; initialization RegisterCanvas(TFastARGB32Canvas); finalization FreeAndNil(CanvasClasses); { File Notes: -- TODOS ---------------------------------------------------- - more more more ... - implement pen width everywhere - add blending (*image and object drawing) - more objects (arc, polygon) -- 0.26.3 Changes/Bug Fixes --------------------------------- - Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha) - Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation. - Added PremultiplyAlpha and UnPremultiplyAlpha methods. -- 0.26.1 Changes/Bug Fixes --------------------------------- - Added FillChannel methods. - Added FloodFill method. - Added GetHistogram method. - Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes (thanks to Carlos González). - Added TImagingCanvas.AdjustColorLevels method. -- 0.25.0 Changes/Bug Fixes --------------------------------- - Fixed error that could cause AV in linear and nonlinear filters. - Added blended rect filling function FillRectBlend. - Added drawing function with blending (DrawAlpha, StretchDrawAlpha, StretchDrawAdd, DrawBlend, StretchDrawBlend, ...) - Added non-linear filters (min, max, median). - Added point transforms (invert, contrast, gamma, brightness). -- 0.21 Changes/Bug Fixes ----------------------------------- - Added some new filter kernels for convolution. - Added FillMode and PenMode properties. - Added FrameRect, Rectangle, Ellipse, and Line methods. - Removed HorzLine and VertLine from TFastARGB32Canvas - new versions in general canvas is now as fast as those in TFastARGB32Canvas (only in case of A8R8G8B8 images of course). - Added PenWidth property, updated HorzLine and VertLine to use it. -- 0.19 Changes/Bug Fixes ----------------------------------- - added TFastARGB32Canvas - added convolutions, hline, vline - unit created, intial stuff added } end.