2 $Id: ImagingCanvases.pas 174 2009-09-08 09:37:59Z galfar $
3 Vampyre Imaging Library
5 http://imaginglib.sourceforge.net
7 The contents of this file are used with permission, subject to the Mozilla
8 Public License Version 1.1 (the "License"); you may not use this file except
9 in compliance with the License. You may obtain a copy of the License at
10 http://www.mozilla.org/MPL/MPL-1.1.html
12 Software distributed under the License is distributed on an "AS IS" basis,
13 WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
14 the specific language governing rights and limitations under the License.
16 Alternatively, the contents of this file may be used under the terms of the
17 GNU Lesser General Public License (the "LGPL License"), in which case the
18 provisions of the LGPL License are applicable instead of those above.
19 If you wish to allow use of your version of this file only under the terms
20 of the LGPL License and not to allow others to use your version of this file
21 under the MPL, indicate your decision by deleting the provisions above and
22 replace them with the notice and other provisions required by the LGPL
23 License. If you do not delete the provisions above, a recipient may use
24 your version of this file under either the MPL or the LGPL License.
26 For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
30 This unit contains canvas classes for drawing and applying effects.
34 {$I ImagingOptions.inc}
39 SysUtils
, Types
, Classes
, ImagingTypes
, Imaging
, ImagingClasses
,
40 ImagingFormats
, ImagingUtility
;
43 { Color constants in ifA8R8G8B8 format.}
59 pcFuchsia
= $FFFF00FF;
67 EImagingCanvasError
= class(EImagingError
);
68 EImagingCanvasBlendingError
= class(EImagingError
);
70 { Fill mode used when drawing filled objects on canvas.}
72 fmSolid
, // Solid fill using current fill color
73 fmClear
// No filling done
76 { Pen mode used when drawing lines, object outlines, and similar on canvas.}
78 pmSolid
, // Draws solid lines using current pen color.
79 pmClear
// No drawing done
82 { Source and destination blending factors for drawing functions with blending.
83 Blending formula: SrcColor * SrcFactor + DestColor * DestFactor }
85 bfIgnore
, // Don't care
86 bfZero
, // For Src and Dest, Factor = (0, 0, 0, 0)
87 bfOne
, // For Src and Dest, Factor = (1, 1, 1, 1)
88 bfSrcAlpha
, // For Src and Dest, Factor = (Src.A, Src.A, Src.A, Src.A)
89 bfOneMinusSrcAlpha
, // For Src and Dest, Factor = (1 - Src.A, 1 - Src.A, 1 - Src.A, 1 - Src.A)
90 bfDstAlpha
, // For Src and Dest, Factor = (Dest.A, Dest.A, Dest.A, Dest.A)
91 bfOneMinusDstAlpha
, // For Src and Dest, Factor = (1 - Dest.A, 1 - Dest.A, 1 - Dest.A, 1 - Dest.A)
92 bfSrcColor
, // For Dest, Factor = (Src.R, Src.R, Src.B, Src.A)
93 bfOneMinusSrcColor
, // For Dest, Factor = (1 - Src.R, 1 - Src.G, 1 - Src.B, 1 - Src.A)
94 bfDstColor
, // For Src, Factor = (Dest.R, Dest.G, Dest.B, Dest.A)
95 bfOneMinusDstColor
// For Src, Factor = (1 - Dest.R, 1 - Dest.G, 1 - Dest.B, 1 - Dest.A)
98 { Procedure for custom pixel write modes with blending.}
99 TPixelWriteProc
= procedure(const SrcPix
: TColorFPRec
; DestPtr
: PByte;
100 DestInfo
: PImageFormatInfo
; SrcFactor
, DestFactor
: TBlendingFactor
);
102 { Represents 3x3 convolution filter kernel.}
103 TConvolutionFilter3x3
= record
104 Kernel
: array[0..2, 0..2] of LongInt;
109 { Represents 5x5 convolution filter kernel.}
110 TConvolutionFilter5x5
= record
111 Kernel
: array[0..4, 0..4] of LongInt;
116 TPointTransformFunction
= function(const Pixel
: TColorFPRec
;
117 Param1
, Param2
, Param3
: Single): TColorFPRec
;
119 TDynFPPixelArray
= array of TColorFPRec
;
121 THistogramArray
= array[Byte] of Integer;
123 TSelectPixelFunction
= function(var Pixels
: TDynFPPixelArray
): TColorFPRec
;
125 { Base canvas class for drawing objects, applying effects, and other.
126 Constructor takes TBaseImage (or pointer to TImageData). Source image
127 bits are not copied but referenced so all canvas functions affect
128 source image and vice versa. When you change format or resolution of
129 source image you must call UpdateCanvasState method (so canvas could
130 recompute some data size related stuff).
132 TImagingCanvas works for all image data formats except special ones
133 (compressed). Because of this its methods are quite slow (they usually work
134 with colors in ifA32R32G32B32F format). If you want fast drawing you
135 can use one of fast canvas clases. These descendants of TImagingCanvas
136 work only for few select formats (or only one) but they are optimized thus
139 TImagingCanvas
= class(TObject
)
141 FDataSizeOnUpdate
: LongInt;
142 FLineRecursion
: Boolean;
143 function GetPixel32(X
, Y
: LongInt): TColor32
; virtual;
144 function GetPixelFP(X
, Y
: LongInt): TColorFPRec
; virtual;
145 function GetValid
: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
146 procedure SetPixel32(X
, Y
: LongInt; const Value
: TColor32
); virtual;
147 procedure SetPixelFP(X
, Y
: LongInt; const Value
: TColorFPRec
); virtual;
148 procedure SetPenColor32(const Value
: TColor32
); {$IFDEF USE_INLINE}inline;{$ENDIF}
149 procedure SetPenColorFP(const Value
: TColorFPRec
); {$IFDEF USE_INLINE}inline;{$ENDIF}
150 procedure SetPenWidth(const Value
: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
151 procedure SetFillColor32(const Value
: TColor32
); {$IFDEF USE_INLINE}inline;{$ENDIF}
152 procedure SetFillColorFP(const Value
: TColorFPRec
); {$IFDEF USE_INLINE}inline;{$ENDIF}
153 procedure SetClipRect(const Value
: TRect
);
154 procedure CheckBeforeBlending(SrcFactor
, DestFactor
: TBlendingFactor
; DestCanvas
: TImagingCanvas
);
158 FPenColorFP
: TColorFPRec
;
159 FPenColor32
: TColor32
;
162 FFillColorFP
: TColorFPRec
;
163 FFillColor32
: TColor32
;
164 FFillMode
: TFillMode
;
165 FNativeColor
: TColorFPRec
;
166 FFormatInfo
: TImageFormatInfo
;
168 { Returns pointer to pixel at given position.}
169 function GetPixelPointer(X
, Y
: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
170 { Translates given FP color to native format of canvas and stores it
171 in FNativeColor field (its bit copy) or user pointer (in overloaded method).}
172 procedure TranslateFPToNative(const Color
: TColorFPRec
); overload
; {$IFDEF USE_INLINE}inline;{$ENDIF}
173 procedure TranslateFPToNative(const Color
: TColorFPRec
; Native
: Pointer); overload
; {$IFDEF USE_INLINE}inline;{$ENDIF}
174 { Clipping function used by horizontal and vertical line drawing functions.}
175 function ClipAxisParallelLine(var A1
, A2
, B
: LongInt;
176 AStart
, AStop
, BStart
, BStop
: LongInt): Boolean;
177 { Internal horizontal line drawer used mainly for filling inside of objects
178 like ellipses and circles.}
179 procedure HorzLineInternal(X1
, X2
, Y
: LongInt; Color
: Pointer; Bpp
: LongInt); virtual;
180 procedure CopyPixelInternal(X
, Y
: LongInt; Pixel
: Pointer; Bpp
: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
181 procedure DrawInternal(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
182 DestX
, DestY
: Integer; SrcFactor
, DestFactor
: TBlendingFactor
; PixelWriteProc
: TPixelWriteProc
);
183 procedure StretchDrawInternal(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
184 const DestRect
: TRect
; SrcFactor
, DestFactor
: TBlendingFactor
;
185 Filter
: TResizeFilter
; PixelWriteProc
: TPixelWriteProc
);
187 constructor CreateForData(ImageDataPointer
: PImageData
);
188 constructor CreateForImage(Image
: TBaseImage
);
189 destructor Destroy
; override;
191 { Call this method when you change size or format of image this canvas
192 operates on (like calling ResizeImage, ConvertImage, or changing Format
193 property of TBaseImage descendants).}
194 procedure UpdateCanvasState
; virtual;
195 { Resets clipping rectangle to Rect(0, 0, ImageWidth, ImageHeight).}
196 procedure ResetClipRect
;
198 { Clears entire canvas with current fill color (ignores clipping rectangle
199 and always uses fmSolid fill mode).}
202 { Draws horizontal line with current pen settings.}
203 procedure HorzLine(X1
, X2
, Y
: LongInt); virtual;
204 { Draws vertical line with current pen settings.}
205 procedure VertLine(X
, Y1
, Y2
: LongInt); virtual;
206 { Draws line from [X1, Y1] to [X2, Y2] with current pen settings.}
207 procedure Line(X1
, Y1
, X2
, Y2
: LongInt); virtual;
208 { Draws a rectangle using current pen settings.}
209 procedure FrameRect(const Rect
: TRect
);
210 { Fills given rectangle with current fill settings.}
211 procedure FillRect(const Rect
: TRect
); virtual;
212 { Fills given rectangle with current fill settings and pixel blending.}
213 procedure FillRectBlend(const Rect
: TRect
; SrcFactor
, DestFactor
: TBlendingFactor
);
214 { Draws rectangle which is outlined by using the current pen settings and
215 filled by using the current fill settings.}
216 procedure Rectangle(const Rect
: TRect
);
217 { Draws ellipse which is outlined by using the current pen settings and
218 filled by using the current fill settings. Rect specifies bounding rectangle
219 of ellipse to be drawn.}
220 procedure Ellipse(const Rect
: TRect
);
221 { Fills area of canvas with current fill color starting at point [X, Y] and
222 coloring its neighbors. Default flood fill mode changes color of all
223 neighbors with the same color as pixel [X, Y]. With BoundaryFillMode
224 set to True neighbors are recolored regardless of their old color,
225 but area which will be recolored has boundary (specified by current pen color).}
226 procedure FloodFill(X
, Y
: Integer; BoundaryFillMode
: Boolean = False);
228 { Draws contents of this canvas onto another canvas with pixel blending.
229 Blending factors are chosen using TBlendingFactor parameters.
230 Resulting destination pixel color is:
231 SrcColor * SrcFactor + DstColor * DstFactor}
232 procedure DrawBlend(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
233 DestX
, DestY
: Integer; SrcFactor
, DestFactor
: TBlendingFactor
);
234 { Draws contents of this canvas onto another one with typical alpha
235 blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
236 procedure DrawAlpha(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
; DestX
, DestY
: Integer); virtual;
237 { Draws contents of this canvas onto another one using additive blending
238 (source and dest factors are bfOne).}
239 procedure DrawAdd(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
; DestX
, DestY
: Integer);
240 { Draws stretched and filtered contents of this canvas onto another canvas
241 with pixel blending. Blending factors are chosen using TBlendingFactor parameters.
242 Resulting destination pixel color is:
243 SrcColor * SrcFactor + DstColor * DstFactor}
244 procedure StretchDrawBlend(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
245 const DestRect
: TRect
; SrcFactor
, DestFactor
: TBlendingFactor
;
246 Filter
: TResizeFilter
= rfBilinear
);
247 { Draws contents of this canvas onto another one with typical alpha
248 blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
249 procedure StretchDrawAlpha(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
250 const DestRect
: TRect
; Filter
: TResizeFilter
= rfBilinear
); virtual;
251 { Draws contents of this canvas onto another one using additive blending
252 (source and dest factors are bfOne).}
253 procedure StretchDrawAdd(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
254 const DestRect
: TRect
; Filter
: TResizeFilter
= rfBilinear
);
256 { Convolves canvas' image with given 3x3 filter kernel. You can use
257 predefined filter kernels or define your own.}
258 procedure ApplyConvolution3x3(const Filter
: TConvolutionFilter3x3
);
259 { Convolves canvas' image with given 5x5 filter kernel. You can use
260 predefined filter kernels or define your own.}
261 procedure ApplyConvolution5x5(const Filter
: TConvolutionFilter5x5
);
262 { Computes 2D convolution of canvas' image and given filter kernel.
263 Kernel is in row format and KernelSize must be odd number >= 3. Divisor
264 is normalizing value based on Kernel (usually sum of all kernel's cells).
265 The Bias number shifts each color value by a fixed amount (color values
266 are usually in range [0, 1] during processing). If ClampChannels
267 is True all output color values are clamped to [0, 1]. You can use
268 predefined filter kernels or define your own.}
269 procedure ApplyConvolution(Kernel
: PLongInt; KernelSize
, Divisor
: LongInt;
270 Bias
: Single = 0.0; ClampChannels
: Boolean = True); virtual;
272 { Applies custom non-linear filter. Filter size is diameter of pixel
273 neighborhood. Typical values are 3, 5, or 7. }
274 procedure ApplyNonLinearFilter(FilterSize
: Integer; SelectFunc
: TSelectPixelFunction
);
275 { Applies median non-linear filter with user defined pixel neighborhood.
276 Selects median pixel from the neighborhood as new pixel
277 (current implementation is quite slow).}
278 procedure ApplyMedianFilter(FilterSize
: Integer);
279 { Applies min non-linear filter with user defined pixel neighborhood.
280 Selects min pixel from the neighborhood as new pixel.}
281 procedure ApplyMinFilter(FilterSize
: Integer);
282 { Applies max non-linear filter with user defined pixel neighborhood.
283 Selects max pixel from the neighborhood as new pixel.}
284 procedure ApplyMaxFilter(FilterSize
: Integer);
286 { Transforms pixels one by one by given function. Pixel neighbors are
287 not taken into account. Param 1-3 are optional parameters
288 for transform function.}
289 procedure PointTransform(Transform
: TPointTransformFunction
;
290 Param1
, Param2
, Param3
: Single);
291 { Modifies image contrast and brightness. Parameters should be
292 in range <-100; 100>.}
293 procedure ModifyContrastBrightness(Contrast
, Brightness
: Single);
294 { Gamma correction of individual color channels. Range is (0, +inf),
295 1.0 means no change.}
296 procedure GammaCorection(Red
, Green
, Blue
: Single);
297 { Inverts colors of all image pixels, makes negative image. Ignores alpha channel.}
298 procedure InvertColors
; virtual;
299 { Simple single level thresholding with threshold level (in range [0, 1])
300 for each color channel.}
301 procedure Threshold(Red
, Green
, Blue
: Single);
302 { Adjusts the color levels of the image by scaling the
303 colors falling between specified white and black points to full [0, 1] range.
304 The black point specifies the darkest color in the image, white point
305 specifies the lightest color, and mid point is gamma aplied to image.
306 Black and white point must be in range [0, 1].}
307 procedure AdjustColorLevels(BlackPoint
, WhitePoint
: Single; MidPoint
: Single = 1.0);
308 { Premultiplies color channel values by alpha. Needed for some platforms/APIs
309 to display images with alpha properly.}
310 procedure PremultiplyAlpha
;
311 { Reverses PremultiplyAlpha operation.}
312 procedure UnPremultiplyAlpha
;
314 { Calculates image histogram for each channel and also gray values. Each
315 channel has 256 values available. Channel values of data formats with higher
316 precision are scaled and rounded. Example: Red[126] specifies number of pixels
317 in image with red channel = 126.}
318 procedure GetHistogram(out Red
, Green
, Blue
, Alpha
, Gray
: THistogramArray
);
319 { Fills image channel with given value leaving other channels intact.
320 Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
322 procedure FillChannel(ChannelId
: Integer; NewChannelValue
: Byte); overload
;
323 { Fills image channel with given value leaving other channels intact.
324 Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
326 procedure FillChannelFP(ChannelId
: Integer; NewChannelValue
: Single); overload
;
328 { Color used when drawing lines, frames, and outlines of objects.}
329 property PenColor32
: TColor32 read FPenColor32 write SetPenColor32
;
330 { Color used when drawing lines, frames, and outlines of objects.}
331 property PenColorFP
: TColorFPRec read FPenColorFP write SetPenColorFP
;
332 { Pen mode used when drawing lines, object outlines, and similar on canvas.}
333 property PenMode
: TPenMode read FPenMode write FPenMode
;
334 { Width with which objects like lines, frames, etc. (everything which uses
335 PenColor) are drawn.}
336 property PenWidth
: LongInt read FPenWidth write SetPenWidth
;
337 { Color used for filling when drawing various objects.}
338 property FillColor32
: TColor32 read FFillColor32 write SetFillColor32
;
339 { Color used for filling when drawing various objects.}
340 property FillColorFP
: TColorFPRec read FFillColorFP write SetFillColorFP
;
341 { Fill mode used when drawing filled objects on canvas.}
342 property FillMode
: TFillMode read FFillMode write FFillMode
;
343 { Specifies the current color of the pixels of canvas. Native pixel is
344 read from canvas and then translated to 32bit ARGB. Reverse operation
345 is made when setting pixel color.}
346 property Pixels32
[X
, Y
: LongInt]: TColor32 read GetPixel32 write SetPixel32
;
347 { Specifies the current color of the pixels of canvas. Native pixel is
348 read from canvas and then translated to FP ARGB. Reverse operation
349 is made when setting pixel color.}
350 property PixelsFP
[X
, Y
: LongInt]: TColorFPRec read GetPixelFP write SetPixelFP
;
351 { Clipping rectangle of this canvas. No pixels outside this rectangle are
352 altered by canvas methods if Clipping property is True. Clip rect gets
353 reseted when UpdateCanvasState is called.}
354 property ClipRect
: TRect read FClipRect write SetClipRect
;
355 { Extended format information.}
356 property FormatInfo
: TImageFormatInfo read FFormatInfo
;
357 { Indicates that this canvas is in valid state. If False canvas oprations
359 property Valid
: Boolean read GetValid
;
361 { Returns all formats supported by this canvas class.}
362 class function GetSupportedFormats
: TImageFormats
; virtual;
365 TImagingCanvasClass
= class of TImagingCanvas
;
367 TScanlineArray
= array[0..MaxInt
div SizeOf(Pointer) - 1] of PColor32RecArray
;
368 PScanlineArray
= ^TScanlineArray
;
370 { Fast canvas class for ifA8R8G8B8 format images.}
371 TFastARGB32Canvas
= class(TImagingCanvas
)
373 FScanlines
: PScanlineArray
;
374 procedure AlphaBlendPixels(SrcPix
, DestPix
: PColor32Rec
); {$IFDEF USE_INLINE}inline;{$ENDIF}
375 function GetPixel32(X
, Y
: LongInt): TColor32
; override;
376 procedure SetPixel32(X
, Y
: LongInt; const Value
: TColor32
); override;
378 destructor Destroy
; override;
380 procedure UpdateCanvasState
; override;
382 procedure DrawAlpha(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
; DestX
, DestY
: Integer); override;
383 procedure StretchDrawAlpha(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
384 const DestRect
: TRect
; Filter
: TResizeFilter
= rfBilinear
); override;
385 procedure InvertColors
; override;
387 property Scanlines
: PScanlineArray read FScanlines
;
389 class function GetSupportedFormats
: TImageFormats
; override;
393 { Kernel for 3x3 average smoothing filter.}
394 FilterAverage3x3
: TConvolutionFilter3x3
= (
400 { Kernel for 5x5 average smoothing filter.}
401 FilterAverage5x5
: TConvolutionFilter5x5
= (
402 Kernel
: ((1, 1, 1, 1, 1),
409 { Kernel for 3x3 Gaussian smoothing filter.}
410 FilterGaussian3x3
: TConvolutionFilter3x3
= (
416 { Kernel for 5x5 Gaussian smoothing filter.}
417 FilterGaussian5x5
: TConvolutionFilter5x5
= (
418 Kernel
: ((1, 4, 6, 4, 1),
425 { Kernel for 3x3 Sobel horizontal edge detection filter (1st derivative approximation).}
426 FilterSobelHorz3x3
: TConvolutionFilter3x3
= (
432 { Kernel for 3x3 Sobel vertical edge detection filter (1st derivative approximation).}
433 FilterSobelVert3x3
: TConvolutionFilter3x3
= (
439 { Kernel for 3x3 Prewitt horizontal edge detection filter.}
440 FilterPrewittHorz3x3
: TConvolutionFilter3x3
= (
446 { Kernel for 3x3 Prewitt vertical edge detection filter.}
447 FilterPrewittVert3x3
: TConvolutionFilter3x3
= (
453 { Kernel for 3x3 Kirsh horizontal edge detection filter.}
454 FilterKirshHorz3x3
: TConvolutionFilter3x3
= (
460 { Kernel for 3x3 Kirsh vertical edge detection filter.}
461 FilterKirshVert3x3
: TConvolutionFilter3x3
= (
462 Kernel
: ((5, -3, -3),
467 { Kernel for 3x3 Laplace omni-directional edge detection filter
468 (2nd derivative approximation).}
469 FilterLaplace3x3
: TConvolutionFilter3x3
= (
470 Kernel
: ((-1, -1, -1),
475 { Kernel for 5x5 Laplace omni-directional edge detection filter
476 (2nd derivative approximation).}
477 FilterLaplace5x5
: TConvolutionFilter5x5
= (
478 Kernel
: ((-1, -1, -1, -1, -1),
479 (-1, -1, -1, -1, -1),
480 (-1, -1, 24, -1, -1),
481 (-1, -1, -1, -1, -1),
482 (-1, -1, -1, -1, -1));
485 { Kernel for 3x3 spharpening filter (Laplacian + original color).}
486 FilterSharpen3x3
: TConvolutionFilter3x3
= (
487 Kernel
: ((-1, -1, -1),
492 { Kernel for 5x5 spharpening filter (Laplacian + original color).}
493 FilterSharpen5x5
: TConvolutionFilter5x5
= (
494 Kernel
: ((-1, -1, -1, -1, -1),
495 (-1, -1, -1, -1, -1),
496 (-1, -1, 25, -1, -1),
497 (-1, -1, -1, -1, -1),
498 (-1, -1, -1, -1, -1));
501 { Kernel for 5x5 glow filter.}
502 FilterGlow5x5
: TConvolutionFilter5x5
= (
503 Kernel
: (( 1, 2, 2, 2, 1),
510 { Kernel for 3x3 edge enhancement filter.}
511 FilterEdgeEnhance3x3
: TConvolutionFilter3x3
= (
512 Kernel
: ((-1, -2, -1),
517 { Kernel for 3x3 contour enhancement filter.}
518 FilterTraceControur3x3
: TConvolutionFilter3x3
= (
519 Kernel
: ((-6, -6, -2),
525 { Kernel for filter that negates all images pixels.}
526 FilterNegative3x3
: TConvolutionFilter3x3
= (
533 { Kernel for 3x3 horz/vert embossing filter.}
534 FilterEmboss3x3
: TConvolutionFilter3x3
= (
542 { You can register your own canvas class. List of registered canvases is used
543 by FindBestCanvasForImage functions to find best canvas for given image.
544 If two different canvases which support the same image data format are
545 registered then the one that was registered later is returned (so you can
546 override builtin Imaging canvases).}
547 procedure RegisterCanvas(CanvasClass
: TImagingCanvasClass
);
548 { Returns best canvas for given TImageFormat.}
549 function FindBestCanvasForImage(ImageFormat
: TImageFormat
): TImagingCanvasClass
; overload
;
550 { Returns best canvas for given TImageData.}
551 function FindBestCanvasForImage(const ImageData
: TImageData
): TImagingCanvasClass
; overload
;
552 { Returns best canvas for given TBaseImage.}
553 function FindBestCanvasForImage(Image
: TBaseImage
): TImagingCanvasClass
; overload
;
558 SConstructorInvalidPointer
= 'Invalid pointer (%p) to TImageData passed to TImagingCanvas constructor.';
559 SConstructorInvalidImage
= 'Invalid image data passed to TImagingCanvas constructor (%s).';
560 SConstructorUnsupportedFormat
= 'Image passed to TImagingCanvas constructor is in unsupported format (%s)';
563 // list with all registered TImagingCanvas classes
564 CanvasClasses
: TList
= nil;
566 procedure RegisterCanvas(CanvasClass
: TImagingCanvasClass
);
568 Assert(CanvasClass
<> nil);
569 if CanvasClasses
= nil then
570 CanvasClasses
:= TList
.Create
;
571 if CanvasClasses
.IndexOf(CanvasClass
) < 0 then
572 CanvasClasses
.Add(CanvasClass
);
575 function FindBestCanvasForImage(ImageFormat
: TImageFormat
): TImagingCanvasClass
; overload
;
579 for I
:= CanvasClasses
.Count
- 1 downto 0 do
581 if ImageFormat
in TImagingCanvasClass(CanvasClasses
[I
]).GetSupportedFormats
then
583 Result
:= TImagingCanvasClass(CanvasClasses
[I
]);
587 Result
:= TImagingCanvas
;
590 function FindBestCanvasForImage(const ImageData
: TImageData
): TImagingCanvasClass
;
592 Result
:= FindBestCanvasForImage(ImageData
.Format
);
595 function FindBestCanvasForImage(Image
: TBaseImage
): TImagingCanvasClass
;
597 Result
:= FindBestCanvasForImage(Image
.Format
);
600 { Canvas helper functions }
602 procedure PixelBlendProc(const SrcPix
: TColorFPRec
; DestPtr
: PByte;
603 DestInfo
: PImageFormatInfo
; SrcFactor
, DestFactor
: TBlendingFactor
);
605 DestPix
, FSrc
, FDst
: TColorFPRec
;
607 // Get set pixel color
608 DestPix
:= DestInfo
.GetPixelFP(DestPtr
, DestInfo
, nil);
609 // Determine current blending factors
611 bfZero
: FSrc
:= ColorFP(0, 0, 0, 0);
612 bfOne
: FSrc
:= ColorFP(1, 1, 1, 1);
613 bfSrcAlpha
: FSrc
:= ColorFP(SrcPix
.A
, SrcPix
.A
, SrcPix
.A
, SrcPix
.A
);
614 bfOneMinusSrcAlpha
: FSrc
:= ColorFP(1 - SrcPix
.A
, 1 - SrcPix
.A
, 1 - SrcPix
.A
, 1 - SrcPix
.A
);
615 bfDstAlpha
: FSrc
:= ColorFP(DestPix
.A
, DestPix
.A
, DestPix
.A
, DestPix
.A
);
616 bfOneMinusDstAlpha
: FSrc
:= ColorFP(1 - DestPix
.A
, 1 - DestPix
.A
, 1 - DestPix
.A
, 1 - DestPix
.A
);
617 bfDstColor
: FSrc
:= ColorFP(DestPix
.A
, DestPix
.R
, DestPix
.G
, DestPix
.B
);
618 bfOneMinusDstColor
: FSrc
:= ColorFP(1 - DestPix
.A
, 1 - DestPix
.R
, 1 - DestPix
.G
, 1 - DestPix
.B
);
621 bfZero
: FDst
:= ColorFP(0, 0, 0, 0);
622 bfOne
: FDst
:= ColorFP(1, 1, 1, 1);
623 bfSrcAlpha
: FDst
:= ColorFP(SrcPix
.A
, SrcPix
.A
, SrcPix
.A
, SrcPix
.A
);
624 bfOneMinusSrcAlpha
: FDst
:= ColorFP(1 - SrcPix
.A
, 1 - SrcPix
.A
, 1 - SrcPix
.A
, 1 - SrcPix
.A
);
625 bfDstAlpha
: FDst
:= ColorFP(DestPix
.A
, DestPix
.A
, DestPix
.A
, DestPix
.A
);
626 bfOneMinusDstAlpha
: FDst
:= ColorFP(1 - DestPix
.A
, 1 - DestPix
.A
, 1 - DestPix
.A
, 1 - DestPix
.A
);
627 bfSrcColor
: FDst
:= ColorFP(SrcPix
.A
, SrcPix
.R
, SrcPix
.G
, SrcPix
.B
);
628 bfOneMinusSrcColor
: FDst
:= ColorFP(1 - SrcPix
.A
, 1 - SrcPix
.R
, 1 - SrcPix
.G
, 1 - SrcPix
.B
);
630 // Compute blending formula
631 DestPix
.R
:= SrcPix
.R
* FSrc
.R
+ DestPix
.R
* FDst
.R
;
632 DestPix
.G
:= SrcPix
.G
* FSrc
.G
+ DestPix
.G
* FDst
.G
;
633 DestPix
.B
:= SrcPix
.B
* FSrc
.B
+ DestPix
.B
* FDst
.B
;
634 DestPix
.A
:= SrcPix
.A
* FSrc
.A
+ DestPix
.A
* FDst
.A
;
635 // Write blended pixel
636 DestInfo
.SetPixelFP(DestPtr
, DestInfo
, nil, DestPix
);
639 procedure PixelAlphaProc(const SrcPix
: TColorFPRec
; DestPtr
: PByte;
640 DestInfo
: PImageFormatInfo
; SrcFactor
, DestFactor
: TBlendingFactor
);
642 DestPix
: TColorFPRec
;
643 SrcAlpha
, DestAlpha
: Single;
645 DestPix
:= DestInfo
.GetPixelFP(DestPtr
, DestInfo
, nil);
646 // Blend the two pixels (Src 'over' Dest alpha composition operation)
647 DestPix
.A
:= SrcPix
.A
+ DestPix
.A
- SrcPix
.A
* DestPix
.A
;
648 SrcAlpha
:= IffFloat(DestPix
.A
= 0, 0, SrcPix
.A
/ DestPix
.A
);
649 DestAlpha
:= 1.0 - SrcAlpha
;
650 DestPix
.R
:= SrcPix
.R
* SrcAlpha
+ DestPix
.R
* DestAlpha
;
651 DestPix
.G
:= SrcPix
.G
* SrcAlpha
+ DestPix
.G
* DestAlpha
;
652 DestPix
.B
:= SrcPix
.B
* SrcAlpha
+ DestPix
.B
* DestAlpha
;
653 // Write blended pixel
654 DestInfo
.SetPixelFP(DestPtr
, DestInfo
, nil, DestPix
);
657 procedure PixelAddProc(const SrcPix
: TColorFPRec
; DestPtr
: PByte;
658 DestInfo
: PImageFormatInfo
; SrcFactor
, DestFactor
: TBlendingFactor
);
660 DestPix
: TColorFPRec
;
662 // Just add Src and Dest
663 DestPix
:= DestInfo
.GetPixelFP(DestPtr
, DestInfo
, nil);
664 DestPix
.R
:= SrcPix
.R
+ DestPix
.R
;
665 DestPix
.G
:= SrcPix
.G
+ DestPix
.G
;
666 DestPix
.B
:= SrcPix
.B
+ DestPix
.B
;
667 DestPix
.A
:= SrcPix
.A
+ DestPix
.A
;
668 DestInfo
.SetPixelFP(DestPtr
, DestInfo
, nil, DestPix
);
671 function CompareColors(const C1
, C2
: TColorFPRec
): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
673 Result
:= (C1
.R
* GrayConv
.R
+ C1
.G
* GrayConv
.G
+ C1
.B
* GrayConv
.B
) -
674 (C2
.R
* GrayConv
.R
+ C2
.G
* GrayConv
.G
+ C2
.B
* GrayConv
.B
);
677 function MedianSelect(var Pixels
: TDynFPPixelArray
): TColorFPRec
;
679 procedure QuickSort(L
, R
: Integer);
682 P
, Temp
: TColorFPRec
;
687 P
:= Pixels
[(L
+ R
) shr 1];
689 while CompareColors(Pixels
[I
], P
) < 0 do Inc(I
);
690 while CompareColors(Pixels
[J
], P
) > 0 do Dec(J
);
694 Pixels
[I
] := Pixels
[J
];
708 QuickSort(0, High(Pixels
));
709 // Select middle pixel
710 Result
:= Pixels
[Length(Pixels
) div 2];
713 function MinSelect(var Pixels
: TDynFPPixelArray
): TColorFPRec
;
718 for I
:= 1 to High(Pixels
) do
720 if CompareColors(Pixels
[I
], Result
) < 0 then
725 function MaxSelect(var Pixels
: TDynFPPixelArray
): TColorFPRec
;
730 for I
:= 1 to High(Pixels
) do
732 if CompareColors(Pixels
[I
], Result
) > 0 then
737 function TransformContrastBrightness(const Pixel
: TColorFPRec
; C
, B
, P3
: Single): TColorFPRec
;
740 Result
.R
:= Pixel
.R
* C
+ B
;
741 Result
.G
:= Pixel
.G
* C
+ B
;
742 Result
.B
:= Pixel
.B
* C
+ B
;
745 function TransformGamma(const Pixel
: TColorFPRec
; R
, G
, B
: Single): TColorFPRec
;
748 Result
.R
:= Power(Pixel
.R
, 1.0 / R
);
749 Result
.G
:= Power(Pixel
.G
, 1.0 / G
);
750 Result
.B
:= Power(Pixel
.B
, 1.0 / B
);
753 function TransformInvert(const Pixel
: TColorFPRec
; P1
, P2
, P3
: Single): TColorFPRec
;
756 Result
.R
:= 1.0 - Pixel
.R
;
757 Result
.G
:= 1.0 - Pixel
.G
;
758 Result
.B
:= 1.0 - Pixel
.B
;
761 function TransformThreshold(const Pixel
: TColorFPRec
; R
, G
, B
: Single): TColorFPRec
;
764 Result
.R
:= IffFloat(Pixel
.R
>= R
, 1.0, 0.0);
765 Result
.G
:= IffFloat(Pixel
.G
>= G
, 1.0, 0.0);
766 Result
.B
:= IffFloat(Pixel
.B
>= B
, 1.0, 0.0);
769 function TransformLevels(const Pixel
: TColorFPRec
; BlackPoint
, WhitePoint
, Exp
: Single): TColorFPRec
;
772 if Pixel
.R
> BlackPoint
then
773 Result
.R
:= Power((Pixel
.R
- BlackPoint
) / (WhitePoint
- BlackPoint
), Exp
)
776 if Pixel
.G
> BlackPoint
then
777 Result
.G
:= Power((Pixel
.G
- BlackPoint
) / (WhitePoint
- BlackPoint
), Exp
)
780 if Pixel
.B
> BlackPoint
then
781 Result
.B
:= Power((Pixel
.B
- BlackPoint
) / (WhitePoint
- BlackPoint
), Exp
)
786 function TransformPremultiplyAlpha(const Pixel
: TColorFPRec
; P1
, P2
, P3
: Single): TColorFPRec
;
789 Result
.R
:= Result
.R
* Pixel
.A
;
790 Result
.G
:= Result
.G
* Pixel
.A
;
791 Result
.B
:= Result
.B
* Pixel
.A
;
794 function TransformUnPremultiplyAlpha(const Pixel
: TColorFPRec
; P1
, P2
, P3
: Single): TColorFPRec
;
797 if Pixel
.A
<> 0.0 then
799 Result
.R
:= Result
.R
/ Pixel
.A
;
800 Result
.G
:= Result
.G
/ Pixel
.A
;
801 Result
.B
:= Result
.B
/ Pixel
.A
;
812 { TImagingCanvas class implementation }
814 constructor TImagingCanvas
.CreateForData(ImageDataPointer
: PImageData
);
816 if ImageDataPointer
= nil then
817 raise EImagingCanvasError
.CreateFmt(SConstructorInvalidPointer
, [ImageDataPointer
]);
819 if not TestImage(ImageDataPointer
^) then
820 raise EImagingCanvasError
.CreateFmt(SConstructorInvalidImage
, [Imaging
.ImageToStr(ImageDataPointer
^)]);
822 if not (ImageDataPointer
.Format
in GetSupportedFormats
) then
823 raise EImagingCanvasError
.CreateFmt(SConstructorUnsupportedFormat
, [Imaging
.ImageToStr(ImageDataPointer
^)]);
825 FPData
:= ImageDataPointer
;
827 SetPenColor32(pcWhite
);
828 SetFillColor32(pcBlack
);
829 FFillMode
:= fmSolid
;
834 constructor TImagingCanvas
.CreateForImage(Image
: TBaseImage
);
836 CreateForData(Image
.ImageDataPointer
);
839 destructor TImagingCanvas
.Destroy
;
844 function TImagingCanvas
.GetPixel32(X
, Y
: LongInt): TColor32
;
846 Result
:= Imaging
.GetPixel32(FPData
^, X
, Y
).Color
;
849 function TImagingCanvas
.GetPixelFP(X
, Y
: LongInt): TColorFPRec
;
851 Result
:= Imaging
.GetPixelFP(FPData
^, X
, Y
);
854 function TImagingCanvas
.GetValid
: Boolean;
856 Result
:= (FPData
<> nil) and (FDataSizeOnUpdate
= FPData
.Size
);
859 procedure TImagingCanvas
.SetPixel32(X
, Y
: LongInt; const Value
: TColor32
);
861 if (X
>= FClipRect
.Left
) and (Y
>= FClipRect
.Top
) and
862 (X
< FClipRect
.Right
) and (Y
< FClipRect
.Bottom
) then
864 Imaging
.SetPixel32(FPData
^, X
, Y
, TColor32Rec(Value
));
868 procedure TImagingCanvas
.SetPixelFP(X
, Y
: LongInt; const Value
: TColorFPRec
);
870 if (X
>= FClipRect
.Left
) and (Y
>= FClipRect
.Top
) and
871 (X
< FClipRect
.Right
) and (Y
< FClipRect
.Bottom
) then
873 Imaging
.SetPixelFP(FPData
^, X
, Y
, TColorFPRec(Value
));
877 procedure TImagingCanvas
.SetPenColor32(const Value
: TColor32
);
879 FPenColor32
:= Value
;
880 TranslatePixel(@FPenColor32
, @FPenColorFP
, ifA8R8G8B8
, ifA32R32G32B32F
, nil, nil);
883 procedure TImagingCanvas
.SetPenColorFP(const Value
: TColorFPRec
);
885 FPenColorFP
:= Value
;
886 TranslatePixel(@FPenColorFP
, @FPenColor32
, ifA32R32G32B32F
, ifA8R8G8B8
, nil, nil);
889 procedure TImagingCanvas
.SetPenWidth(const Value
: LongInt);
891 FPenWidth
:= ClampInt(Value
, 0, MaxPenWidth
);
894 procedure TImagingCanvas
.SetFillColor32(const Value
: TColor32
);
896 FFillColor32
:= Value
;
897 TranslatePixel(@FFillColor32
, @FFillColorFP
, ifA8R8G8B8
, ifA32R32G32B32F
, nil, nil);
900 procedure TImagingCanvas
.SetFillColorFP(const Value
: TColorFPRec
);
902 FFillColorFP
:= Value
;
903 TranslatePixel(@FFillColorFP
, @FFillColor32
, ifA32R32G32B32F
, ifA8R8G8B8
, nil, nil);
906 procedure TImagingCanvas
.SetClipRect(const Value
: TRect
);
909 SwapMin(FClipRect
.Left
, FClipRect
.Right
);
910 SwapMin(FClipRect
.Top
, FClipRect
.Bottom
);
911 IntersectRect(FClipRect
, FClipRect
, Rect(0, 0, FPData
.Width
, FPData
.Height
));
914 procedure TImagingCanvas
.CheckBeforeBlending(SrcFactor
,
915 DestFactor
: TBlendingFactor
; DestCanvas
: TImagingCanvas
);
917 if SrcFactor
in [bfSrcColor
, bfOneMinusSrcColor
] then
918 raise EImagingCanvasBlendingError
.Create('Invalid source blending factor. Check the documentation for TBlendingFactor.');
919 if DestFactor
in [bfDstColor
, bfOneMinusDstColor
] then
920 raise EImagingCanvasBlendingError
.Create('Invalid destination blending factor. Check the documentation for TBlendingFactor.');
921 if DestCanvas
.FormatInfo
.IsIndexed
then
922 raise EImagingCanvasBlendingError
.Create('Blending destination canvas cannot be in indexed mode.');
925 function TImagingCanvas
.GetPixelPointer(X
, Y
: LongInt): Pointer;
927 Result
:= @PByteArray(FPData
.Bits
)[(Y
* FPData
.Width
+ X
) * FFormatInfo
.BytesPerPixel
]
930 procedure TImagingCanvas
.TranslateFPToNative(const Color
: TColorFPRec
);
932 TranslateFPToNative(Color
, @FNativeColor
);
935 procedure TImagingCanvas
.TranslateFPToNative(const Color
: TColorFPRec
;
938 ImagingFormats
.TranslatePixel(@Color
, Native
, ifA32R32G32B32F
,
939 FPData
.Format
, nil, FPData
.Palette
);
942 procedure TImagingCanvas
.UpdateCanvasState
;
944 FDataSizeOnUpdate
:= FPData
.Size
;
946 Imaging
.GetImageFormatInfo(FPData
.Format
, FFormatInfo
)
949 procedure TImagingCanvas
.ResetClipRect
;
951 FClipRect
:= Rect(0, 0, FPData
.Width
, FPData
.Height
)
954 procedure TImagingCanvas
.Clear
;
956 TranslateFPToNative(FFillColorFP
);
957 Imaging
.FillRect(FPData
^, 0, 0, FPData
.Width
, FPData
.Height
, @FNativeColor
);
960 function TImagingCanvas
.ClipAxisParallelLine(var A1
, A2
, B
: LongInt;
961 AStart
, AStop
, BStart
, BStop
: LongInt): Boolean;
963 if (B
>= BStart
) and (B
< BStop
) then
966 if A1
< AStart
then A1
:= AStart
;
967 if A2
>= AStop
then A2
:= AStop
- 1;
974 procedure TImagingCanvas
.HorzLineInternal(X1
, X2
, Y
: LongInt; Color
: Pointer;
977 I
, WidthBytes
: LongInt;
980 if (Y
>= FClipRect
.Top
) and (Y
< FClipRect
.Bottom
) then
983 X1
:= Max(X1
, FClipRect
.Left
);
984 X2
:= Min(X2
, FClipRect
.Right
);
985 PixelPtr
:= GetPixelPointer(X1
, Y
);
986 WidthBytes
:= (X2
- X1
) * Bpp
;
988 1: FillMemoryByte(PixelPtr
, WidthBytes
, PByte(Color
)^);
989 2: FillMemoryWord(PixelPtr
, WidthBytes
, PWord(Color
)^);
990 4: FillMemoryLongWord(PixelPtr
, WidthBytes
, PLongWord(Color
)^);
994 ImagingFormats
.CopyPixel(Color
, PixelPtr
, Bpp
);
1001 procedure TImagingCanvas
.CopyPixelInternal(X
, Y
: LongInt; Pixel
: Pointer;
1004 if (X
>= FClipRect
.Left
) and (Y
>= FClipRect
.Top
) and
1005 (X
< FClipRect
.Right
) and (Y
< FClipRect
.Bottom
) then
1007 ImagingFormats
.CopyPixel(Pixel
, GetPixelPointer(X
, Y
), Bpp
);
1011 procedure TImagingCanvas
.HorzLine(X1
, X2
, Y
: LongInt);
1015 if FPenMode
= pmClear
then Exit
;
1017 if IntersectRect(DstRect
, Rect(X1
, Y
- FPenWidth
div 2, X2
,
1018 Y
+ FPenWidth
div 2 + FPenWidth
mod 2), FClipRect
) then
1020 TranslateFPToNative(FPenColorFP
);
1021 Imaging
.FillRect(FPData
^, DstRect
.Left
, DstRect
.Top
, DstRect
.Right
- DstRect
.Left
,
1022 DstRect
.Bottom
- DstRect
.Top
, @FNativeColor
);
1026 procedure TImagingCanvas
.VertLine(X
, Y1
, Y2
: LongInt);
1030 if FPenMode
= pmClear
then Exit
;
1032 if IntersectRect(DstRect
, Rect(X
- FPenWidth
div 2, Y1
,
1033 X
+ FPenWidth
div 2 + FPenWidth
mod 2, Y2
), FClipRect
) then
1035 TranslateFPToNative(FPenColorFP
);
1036 Imaging
.FillRect(FPData
^, DstRect
.Left
, DstRect
.Top
, DstRect
.Right
- DstRect
.Left
,
1037 DstRect
.Bottom
- DstRect
.Top
, @FNativeColor
);
1041 procedure TImagingCanvas
.Line(X1
, Y1
, X2
, Y2
: LongInt);
1044 Error
, YStep
, DeltaX
, DeltaY
, X
, Y
, I
, Bpp
, W1
, W2
, Code1
, Code2
: LongInt;
1046 if FPenMode
= pmClear
then Exit
;
1048 // If line is vertical or horizontal just call appropriate method
1051 HorzLine(X1
, X2
, Y1
);
1056 VertLine(X1
, Y1
, Y2
);
1060 // Determine if line is steep (angle with X-axis > 45 degrees)
1061 Steep
:= Abs(Y2
- Y1
) > Abs(X2
- X1
);
1063 // If we need to draw thick line we just draw more 1 pixel lines around
1064 // the one we already drawn. Setting FLineRecursion assures that we
1065 // won't be doing recursions till the end of the world.
1066 if (FPenWidth
> 1) and not FLineRecursion
then
1068 FLineRecursion
:= True;
1069 W1
:= FPenWidth
div 2;
1071 if FPenWidth
mod 2 = 0 then
1075 // Add lines left/right
1077 Line(X1
, Y1
- I
, X2
, Y2
- I
);
1079 Line(X1
, Y1
+ I
, X2
, Y2
+ I
);
1083 // Add lines above/under
1085 Line(X1
- I
, Y1
, X2
- I
, Y2
);
1087 Line(X1
+ I
, Y1
, X2
+ I
, Y2
);
1089 FLineRecursion
:= False;
1094 // Use part of Cohen-Sutherland line clipping to determine if any part of line
1096 Code1
:= Ord(X1
< Left
) + Ord(X1
> Right
) shl 1 + Ord(Y1
< Top
) shl 2 + Ord(Y1
> Bottom
) shl 3;
1097 Code2
:= Ord(X2
< Left
) + Ord(X2
> Right
) shl 1 + Ord(Y2
< Top
) shl 2 + Ord(Y2
> Bottom
) shl 3;
1100 if (Code1
and Code2
) = 0 then
1102 TranslateFPToNative(FPenColorFP
);
1103 Bpp
:= FFormatInfo
.BytesPerPixel
;
1105 // If line is steep swap X and Y coordinates so later we just have one loop
1106 // of two (where only one is used according to steepness).
1119 DeltaY
:= Abs(Y2
- Y1
);
1120 YStep
:= Iff(Y2
> Y1
, 1, -1);
1124 // Draw line using Bresenham algorithm. No real line clipping here,
1125 // just don't draw pixels outsize clip rect.
1126 for X
:= X1
to X2
do
1129 CopyPixelInternal(Y
, X
, @FNativeColor
, Bpp
)
1131 CopyPixelInternal(X
, Y
, @FNativeColor
, Bpp
);
1132 Error
:= Error
+ DeltaY
;
1133 if Error
* 2 >= DeltaX
then
1142 procedure TImagingCanvas
.FrameRect(const Rect
: TRect
);
1144 HalfPen
, PenMod
: LongInt;
1146 if FPenMode
= pmClear
then Exit
;
1147 HalfPen
:= FPenWidth
div 2;
1148 PenMod
:= FPenWidth
mod 2;
1149 HorzLine(Rect
.Left
- HalfPen
, Rect
.Right
+ HalfPen
+ PenMod
- 1, Rect
.Top
);
1150 HorzLine(Rect
.Left
- HalfPen
, Rect
.Right
+ HalfPen
+ PenMod
- 1, Rect
.Bottom
- 1);
1151 VertLine(Rect
.Left
, Rect
.Top
, Rect
.Bottom
);
1152 VertLine(Rect
.Right
- 1, Rect
.Top
, Rect
.Bottom
);
1155 procedure TImagingCanvas
.FillRect(const Rect
: TRect
);
1159 if (FFillMode
<> fmClear
) and IntersectRect(DstRect
, Rect
, FClipRect
) then
1161 TranslateFPToNative(FFillColorFP
);
1162 Imaging
.FillRect(FPData
^, DstRect
.Left
, DstRect
.Top
, DstRect
.Right
- DstRect
.Left
,
1163 DstRect
.Bottom
- DstRect
.Top
, @FNativeColor
);
1167 procedure TImagingCanvas
.FillRectBlend(const Rect
: TRect
; SrcFactor
,
1168 DestFactor
: TBlendingFactor
);
1174 if (FFillMode
<> fmClear
) and IntersectRect(DstRect
, Rect
, FClipRect
) then
1176 CheckBeforeBlending(SrcFactor
, DestFactor
, Self
);
1177 for Y
:= DstRect
.Top
to DstRect
.Bottom
- 1 do
1179 Line
:= @PByteArray(FPData
.Bits
)[(Y
* FPData
.Width
+ DstRect
.Left
) * FFormatInfo
.BytesPerPixel
];
1180 for X
:= DstRect
.Left
to DstRect
.Right
- 1 do
1182 PixelBlendProc(FFillColorFP
, Line
, @FFormatInfo
, SrcFactor
, DestFactor
);
1183 Inc(Line
, FFormatInfo
.BytesPerPixel
);
1189 procedure TImagingCanvas
.Rectangle(const Rect
: TRect
);
1195 procedure TImagingCanvas
.Ellipse(const Rect
: TRect
);
1197 RadX
, RadY
, DeltaX
, DeltaY
, R
, RX
, RY
: LongInt;
1198 X1
, X2
, Y1
, Y2
, Bpp
, OldY
: LongInt;
1199 Fill
, Pen
: TColorFPRec
;
1201 // TODO: Use PenWidth
1207 TranslateFPToNative(FPenColorFP
, @Pen
);
1208 TranslateFPToNative(FFillColorFP
, @Fill
);
1209 Bpp
:= FFormatInfo
.BytesPerPixel
;
1214 RadX
:= (X2
- X1
) div 2;
1215 RadY
:= (Y2
- Y1
) div 2;
1221 DeltaX
:= (RadX
* RadX
);
1222 DeltaY
:= (RadY
* RadY
);
1223 R
:= RadX
* RadY
* RadY
;
1227 if (FFillMode
<> fmClear
) then
1228 HorzLineInternal(X1
, X2
, Y1
, @Fill
, Bpp
);
1229 CopyPixelInternal(X1
, Y1
, @Pen
, Bpp
);
1230 CopyPixelInternal(X2
, Y1
, @Pen
, Bpp
);
1250 if (OldY
<> Y1
) and (FFillMode
<> fmClear
) then
1252 HorzLineInternal(X1
, X2
, Y1
, @Fill
, Bpp
);
1253 HorzLineInternal(X1
, X2
, Y2
, @Fill
, Bpp
);
1257 CopyPixelInternal(X1
, Y1
, @Pen
, Bpp
);
1258 CopyPixelInternal(X2
, Y1
, @Pen
, Bpp
);
1259 CopyPixelInternal(X1
, Y2
, @Pen
, Bpp
);
1260 CopyPixelInternal(X2
, Y2
, @Pen
, Bpp
);
1264 procedure TImagingCanvas
.FloodFill(X
, Y
: Integer; BoundaryFillMode
: Boolean);
1266 Stack
: array of TPoint
;
1267 StackPos
, Y1
: Integer;
1269 SpanLeft
, SpanRight
: Boolean;
1271 procedure Push(AX
, AY
: Integer);
1273 if StackPos
< High(Stack
) then
1276 Stack
[StackPos
].X
:= AX
;
1277 Stack
[StackPos
].Y
:= AY
;
1281 SetLength(Stack
, Length(Stack
) + FPData
.Width
);
1286 function Pop(out AX
, AY
: Integer): Boolean;
1288 if StackPos
> 0 then
1290 AX
:= Stack
[StackPos
].X
;
1291 AY
:= Stack
[StackPos
].Y
;
1299 function Compare(AX
, AY
: Integer): Boolean;
1303 Color
:= GetPixel32(AX
, AY
);
1304 if BoundaryFillMode
then
1305 Result
:= (Color
<> FFillColor32
) and (Color
<> FPenColor32
)
1307 Result
:= Color
= OldColor
;
1311 // Scanline Floodfill Algorithm With Stack
1312 // http://student.kuleuven.be/~m0216922/CG/floodfill.html
1314 if not PtInRect(FClipRect
, Point(X
, Y
)) then Exit
;
1316 SetLength(Stack
, FPData
.Width
* 4);
1319 OldColor
:= GetPixel32(X
, Y
);
1326 while (Y1
>= FClipRect
.Top
) and Compare(X
, Y1
) do
1333 while (Y1
< FClipRect
.Bottom
) and Compare(X
, Y1
) do
1335 SetPixel32(X
, Y1
, FFillColor32
);
1336 if not SpanLeft
and (X
> FClipRect
.Left
) and Compare(X
- 1, Y1
) then
1341 else if SpanLeft
and (X
> FClipRect
.Left
) and not Compare(X
- 1, Y1
) then
1343 else if not SpanRight
and (X
< FClipRect
.Right
- 1) and Compare(X
+ 1, Y1
)then
1348 else if SpanRight
and (X
< FClipRect
.Right
- 1) and not Compare(X
+ 1, Y1
) then
1356 procedure TImagingCanvas
.DrawInternal(const SrcRect
: TRect
;
1357 DestCanvas
: TImagingCanvas
; DestX
, DestY
: Integer; SrcFactor
,
1358 DestFactor
: TBlendingFactor
; PixelWriteProc
: TPixelWriteProc
);
1360 X
, Y
, SrcX
, SrcY
, Width
, Height
, SrcBpp
, DestBpp
: Integer;
1362 SrcPointer
, DestPointer
: PByte;
1364 CheckBeforeBlending(SrcFactor
, DestFactor
, DestCanvas
);
1365 SrcX
:= SrcRect
.Left
;
1366 SrcY
:= SrcRect
.Top
;
1367 Width
:= SrcRect
.Right
- SrcRect
.Left
;
1368 Height
:= SrcRect
.Bottom
- SrcRect
.Top
;
1369 SrcBpp
:= FFormatInfo
.BytesPerPixel
;
1370 DestBpp
:= DestCanvas
.FFormatInfo
.BytesPerPixel
;
1371 // Clip src and dst rects
1372 ClipCopyBounds(SrcX
, SrcY
, Width
, Height
, DestX
, DestY
,
1373 FPData
.Width
, FPData
.Height
, DestCanvas
.ClipRect
);
1375 for Y
:= 0 to Height
- 1 do
1377 // Get src and dst scanlines
1378 SrcPointer
:= @PByteArray(FPData
.Bits
)[((SrcY
+ Y
) * FPData
.Width
+ SrcX
) * SrcBpp
];
1379 DestPointer
:= @PByteArray(DestCanvas
.FPData
.Bits
)[((DestY
+ Y
) * DestCanvas
.FPData
.Width
+ DestX
) * DestBpp
];
1381 for X
:= 0 to Width
- 1 do
1383 PSrc
:= FFormatInfo
.GetPixelFP(SrcPointer
, @FFormatInfo
, FPData
.Palette
);
1384 // Call pixel writer procedure - combine source and dest pixels
1385 PixelWriteProc(PSrc
, DestPointer
, @DestCanvas
.FFormatInfo
, SrcFactor
, DestFactor
);
1386 // Increment pixel pointers
1387 Inc(SrcPointer
, SrcBpp
);
1388 Inc(DestPointer
, DestBpp
);
1393 procedure TImagingCanvas
.DrawBlend(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
1394 DestX
, DestY
: Integer; SrcFactor
, DestFactor
: TBlendingFactor
);
1396 DrawInternal(SrcRect
, DestCanvas
, DestX
, DestY
, SrcFactor
, DestFactor
, PixelBlendProc
);
1399 procedure TImagingCanvas
.DrawAlpha(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
1400 DestX
, DestY
: Integer);
1402 DrawInternal(SrcRect
, DestCanvas
, DestX
, DestY
, bfIgnore
, bfIgnore
, PixelAlphaProc
);
1405 procedure TImagingCanvas
.DrawAdd(const SrcRect
: TRect
;
1406 DestCanvas
: TImagingCanvas
; DestX
, DestY
: Integer);
1408 DrawInternal(SrcRect
, DestCanvas
, DestX
, DestY
, bfIgnore
, bfIgnore
, PixelAddProc
);
1411 procedure TImagingCanvas
.StretchDrawInternal(const SrcRect
: TRect
;
1412 DestCanvas
: TImagingCanvas
; const DestRect
: TRect
;
1413 SrcFactor
, DestFactor
: TBlendingFactor
; Filter
: TResizeFilter
;
1414 PixelWriteProc
: TPixelWriteProc
);
1416 FilterMapping
: array[TResizeFilter
] of TSamplingFilter
=
1417 (sfNearest
, sfLinear
, DefaultCubicFilter
);
1419 X
, Y
, I
, J
, SrcX
, SrcY
, SrcWidth
, SrcHeight
: Integer;
1420 DestX
, DestY
, DestWidth
, DestHeight
, SrcBpp
, DestBpp
: Integer;
1421 SrcPix
, PDest
: TColorFPRec
;
1422 MapX
, MapY
: TMappingTable
;
1423 XMinimum
, XMaximum
: Integer;
1424 LineBuffer
: array of TColorFPRec
;
1425 ClusterX
, ClusterY
: TCluster
;
1426 Weight
, AccumA
, AccumR
, AccumG
, AccumB
: Single;
1428 FilterFunction
: TFilterFunction
;
1431 CheckBeforeBlending(SrcFactor
, DestFactor
, DestCanvas
);
1432 SrcX
:= SrcRect
.Left
;
1433 SrcY
:= SrcRect
.Top
;
1434 SrcWidth
:= SrcRect
.Right
- SrcRect
.Left
;
1435 SrcHeight
:= SrcRect
.Bottom
- SrcRect
.Top
;
1436 DestX
:= DestRect
.Left
;
1437 DestY
:= DestRect
.Top
;
1438 DestWidth
:= DestRect
.Right
- DestRect
.Left
;
1439 DestHeight
:= DestRect
.Bottom
- DestRect
.Top
;
1440 SrcBpp
:= FFormatInfo
.BytesPerPixel
;
1441 DestBpp
:= DestCanvas
.FFormatInfo
.BytesPerPixel
;
1442 // Get actual resampling filter and radius
1443 FilterFunction
:= SamplingFilterFunctions
[FilterMapping
[Filter
]];
1444 Radius
:= SamplingFilterRadii
[FilterMapping
[Filter
]];
1445 // Clip src and dst rects
1446 ClipStretchBounds(SrcX
, SrcY
, SrcWidth
, SrcHeight
, DestX
, DestY
, DestWidth
, DestHeight
,
1447 FPData
.Width
, FPData
.Height
, DestCanvas
.ClipRect
);
1448 // Generate mapping tables
1449 MapX
:= BuildMappingTable(DestX
, DestX
+ DestWidth
, SrcX
, SrcX
+ SrcWidth
,
1450 FPData
.Width
, FilterFunction
, Radius
, False);
1451 MapY
:= BuildMappingTable(DestY
, DestY
+ DestHeight
, SrcY
, SrcY
+ SrcHeight
,
1452 FPData
.Height
, FilterFunction
, Radius
, False);
1453 FindExtremes(MapX
, XMinimum
, XMaximum
);
1454 SetLength(LineBuffer
, XMaximum
- XMinimum
+ 1);
1456 for J
:= 0 to DestHeight
- 1 do
1458 ClusterY
:= MapY
[J
];
1459 for X
:= XMinimum
to XMaximum
do
1465 for Y
:= 0 to Length(ClusterY
) - 1 do
1467 Weight
:= ClusterY
[Y
].Weight
;
1468 SrcPix
:= FFormatInfo
.GetPixelFP(@PByteArray(FPData
.Bits
)[(ClusterY
[Y
].Pos
* FPData
.Width
+ X
) * SrcBpp
],
1469 @FFormatInfo
, FPData
.Palette
);
1470 AccumB
:= AccumB
+ SrcPix
.B
* Weight
;
1471 AccumG
:= AccumG
+ SrcPix
.G
* Weight
;
1472 AccumR
:= AccumR
+ SrcPix
.R
* Weight
;
1473 AccumA
:= AccumA
+ SrcPix
.A
* Weight
;
1475 with LineBuffer
[X
- XMinimum
] do
1484 DestLine
:= @PByteArray(DestCanvas
.FPData
.Bits
)[((J
+ DestY
) * DestCanvas
.FPData
.Width
+ DestX
) * DestBpp
];
1486 for I
:= 0 to DestWidth
- 1 do
1488 ClusterX
:= MapX
[I
];
1493 for X
:= 0 to Length(ClusterX
) - 1 do
1495 Weight
:= ClusterX
[X
].Weight
;
1496 with LineBuffer
[ClusterX
[X
].Pos
- XMinimum
] do
1498 AccumB
:= AccumB
+ B
* Weight
;
1499 AccumG
:= AccumG
+ G
* Weight
;
1500 AccumR
:= AccumR
+ R
* Weight
;
1501 AccumA
:= AccumA
+ A
* Weight
;
1510 // Write resulting blended pixel
1511 PixelWriteProc(SrcPix
, DestLine
, @DestCanvas
.FFormatInfo
, SrcFactor
, DestFactor
);
1512 Inc(DestLine
, DestBpp
);
1517 procedure TImagingCanvas
.StretchDrawBlend(const SrcRect
: TRect
;
1518 DestCanvas
: TImagingCanvas
; const DestRect
: TRect
;
1519 SrcFactor
, DestFactor
: TBlendingFactor
; Filter
: TResizeFilter
);
1521 StretchDrawInternal(SrcRect
, DestCanvas
, DestRect
, SrcFactor
, DestFactor
, Filter
, PixelBlendProc
);
1524 procedure TImagingCanvas
.StretchDrawAlpha(const SrcRect
: TRect
;
1525 DestCanvas
: TImagingCanvas
; const DestRect
: TRect
; Filter
: TResizeFilter
);
1527 StretchDrawInternal(SrcRect
, DestCanvas
, DestRect
, bfIgnore
, bfIgnore
, Filter
, PixelAlphaProc
);
1530 procedure TImagingCanvas
.StretchDrawAdd(const SrcRect
: TRect
;
1531 DestCanvas
: TImagingCanvas
; const DestRect
: TRect
; Filter
: TResizeFilter
);
1533 StretchDrawInternal(SrcRect
, DestCanvas
, DestRect
, bfIgnore
, bfIgnore
, Filter
, PixelAddProc
);
1536 procedure TImagingCanvas
.ApplyConvolution(Kernel
: PLongInt; KernelSize
,
1537 Divisor
: LongInt; Bias
: Single; ClampChannels
: Boolean);
1539 X
, Y
, I
, J
, PosY
, PosX
, SizeDiv2
, KernelValue
, WidthBytes
, Bpp
: LongInt;
1540 R
, G
, B
, DivFloat
: Single;
1542 TempImage
: TImageData
;
1543 DstPointer
, SrcPointer
: PByte;
1545 SizeDiv2
:= KernelSize
div 2;
1546 DivFloat
:= IffFloat(Divisor
> 1, 1.0 / Divisor
, 1.0);
1547 Bpp
:= FFormatInfo
.BytesPerPixel
;
1548 WidthBytes
:= FPData
.Width
* Bpp
;
1550 InitImage(TempImage
);
1551 CloneImage(FPData
^, TempImage
);
1554 // For every pixel in clip rect
1555 for Y
:= FClipRect
.Top
to FClipRect
.Bottom
- 1 do
1557 DstPointer
:= @PByteArray(FPData
.Bits
)[Y
* WidthBytes
+ FClipRect
.Left
* Bpp
];
1559 for X
:= FClipRect
.Left
to FClipRect
.Right
- 1 do
1561 // Reset accumulators
1566 for J
:= 0 to KernelSize
- 1 do
1568 PosY
:= ClampInt(Y
+ J
- SizeDiv2
, FClipRect
.Top
, FClipRect
.Bottom
- 1);
1570 for I
:= 0 to KernelSize
- 1 do
1572 PosX
:= ClampInt(X
+ I
- SizeDiv2
, FClipRect
.Left
, FClipRect
.Right
- 1);
1573 SrcPointer
:= @PByteArray(TempImage
.Bits
)[PosY
* WidthBytes
+ PosX
* Bpp
];
1575 // Get pixels from neighbourhood of current pixel and add their
1576 // colors to accumulators weighted by filter kernel values
1577 Pixel
:= FFormatInfo
.GetPixelFP(SrcPointer
, @FFormatInfo
, TempImage
.Palette
);
1578 KernelValue
:= PLongIntArray(Kernel
)[J
* KernelSize
+ I
];
1580 R
:= R
+ Pixel
.R
* KernelValue
;
1581 G
:= G
+ Pixel
.G
* KernelValue
;
1582 B
:= B
+ Pixel
.B
* KernelValue
;
1586 Pixel
:= FFormatInfo
.GetPixelFP(DstPointer
, @FFormatInfo
, FPData
.Palette
);
1588 Pixel
.R
:= R
* DivFloat
+ Bias
;
1589 Pixel
.G
:= G
* DivFloat
+ Bias
;
1590 Pixel
.B
:= B
* DivFloat
+ Bias
;
1592 if ClampChannels
then
1593 ClampFloatPixel(Pixel
);
1595 // Set resulting pixel color
1596 FFormatInfo
.SetPixelFP(DstPointer
, @FFormatInfo
, FPData
.Palette
, Pixel
);
1598 Inc(DstPointer
, Bpp
);
1603 FreeImage(TempImage
);
1607 procedure TImagingCanvas
.ApplyConvolution3x3(const Filter
: TConvolutionFilter3x3
);
1609 ApplyConvolution(@Filter
.Kernel
, 3, Filter
.Divisor
, Filter
.Bias
, True);
1612 procedure TImagingCanvas
.ApplyConvolution5x5(const Filter
: TConvolutionFilter5x5
);
1614 ApplyConvolution(@Filter
.Kernel
, 5, Filter
.Divisor
, Filter
.Bias
, True);
1617 procedure TImagingCanvas
.ApplyNonLinearFilter(FilterSize
: Integer; SelectFunc
: TSelectPixelFunction
);
1619 X
, Y
, I
, J
, PosY
, PosX
, SizeDiv2
, WidthBytes
, Bpp
: LongInt;
1621 TempImage
: TImageData
;
1622 DstPointer
, SrcPointer
: PByte;
1623 NeighPixels
: TDynFPPixelArray
;
1625 SizeDiv2
:= FilterSize
div 2;
1626 Bpp
:= FFormatInfo
.BytesPerPixel
;
1627 WidthBytes
:= FPData
.Width
* Bpp
;
1628 SetLength(NeighPixels
, FilterSize
* FilterSize
);
1630 InitImage(TempImage
);
1631 CloneImage(FPData
^, TempImage
);
1634 // For every pixel in clip rect
1635 for Y
:= FClipRect
.Top
to FClipRect
.Bottom
- 1 do
1637 DstPointer
:= @PByteArray(FPData
.Bits
)[Y
* WidthBytes
+ FClipRect
.Left
* Bpp
];
1639 for X
:= FClipRect
.Left
to FClipRect
.Right
- 1 do
1641 for J
:= 0 to FilterSize
- 1 do
1643 PosY
:= ClampInt(Y
+ J
- SizeDiv2
, FClipRect
.Top
, FClipRect
.Bottom
- 1);
1645 for I
:= 0 to FilterSize
- 1 do
1647 PosX
:= ClampInt(X
+ I
- SizeDiv2
, FClipRect
.Left
, FClipRect
.Right
- 1);
1648 SrcPointer
:= @PByteArray(TempImage
.Bits
)[PosY
* WidthBytes
+ PosX
* Bpp
];
1650 // Get pixels from neighbourhood of current pixel and store them
1651 Pixel
:= FFormatInfo
.GetPixelFP(SrcPointer
, @FFormatInfo
, TempImage
.Palette
);
1652 NeighPixels
[J
* FilterSize
+ I
] := Pixel
;
1656 // Choose pixel using custom function
1657 Pixel
:= SelectFunc(NeighPixels
);
1658 // Set resulting pixel color
1659 FFormatInfo
.SetPixelFP(DstPointer
, @FFormatInfo
, FPData
.Palette
, Pixel
);
1661 Inc(DstPointer
, Bpp
);
1666 FreeImage(TempImage
);
1670 procedure TImagingCanvas
.ApplyMedianFilter(FilterSize
: Integer);
1672 ApplyNonLinearFilter(FilterSize
, MedianSelect
);
1675 procedure TImagingCanvas
.ApplyMinFilter(FilterSize
: Integer);
1677 ApplyNonLinearFilter(FilterSize
, MinSelect
);
1680 procedure TImagingCanvas
.ApplyMaxFilter(FilterSize
: Integer);
1682 ApplyNonLinearFilter(FilterSize
, MaxSelect
);
1685 procedure TImagingCanvas
.PointTransform(Transform
: TPointTransformFunction
;
1686 Param1
, Param2
, Param3
: Single);
1688 X
, Y
, Bpp
, WidthBytes
: Integer;
1692 Bpp
:= FFormatInfo
.BytesPerPixel
;
1693 WidthBytes
:= FPData
.Width
* Bpp
;
1695 // For every pixel in clip rect
1696 for Y
:= FClipRect
.Top
to FClipRect
.Bottom
- 1 do
1698 PixPointer
:= @PByteArray(FPData
.Bits
)[Y
* WidthBytes
+ FClipRect
.Left
* Bpp
];
1699 for X
:= FClipRect
.Left
to FClipRect
.Right
- 1 do
1701 Pixel
:= FFormatInfo
.GetPixelFP(PixPointer
, @FFormatInfo
, FPData
.Palette
);
1703 FFormatInfo
.SetPixelFP(PixPointer
, @FFormatInfo
, FPData
.Palette
,
1704 Transform(Pixel
, Param1
, Param2
, Param3
));
1706 Inc(PixPointer
, Bpp
);
1711 procedure TImagingCanvas
.ModifyContrastBrightness(Contrast
, Brightness
: Single);
1713 PointTransform(TransformContrastBrightness
, 1.0 + Contrast
/ 100,
1714 Brightness
/ 100, 0);
1717 procedure TImagingCanvas
.GammaCorection(Red
, Green
, Blue
: Single);
1719 PointTransform(TransformGamma
, Red
, Green
, Blue
);
1722 procedure TImagingCanvas
.InvertColors
;
1724 PointTransform(TransformInvert
, 0, 0, 0);
1727 procedure TImagingCanvas
.Threshold(Red
, Green
, Blue
: Single);
1729 PointTransform(TransformThreshold
, Red
, Green
, Blue
);
1732 procedure TImagingCanvas
.AdjustColorLevels(BlackPoint
, WhitePoint
, MidPoint
: Single);
1734 PointTransform(TransformLevels
, BlackPoint
, WhitePoint
, 1.0 / MidPoint
);
1737 procedure TImagingCanvas
.PremultiplyAlpha
;
1739 PointTransform(TransformPremultiplyAlpha
, 0, 0, 0);
1742 procedure TImagingCanvas
.UnPremultiplyAlpha
;
1744 PointTransform(TransformUnPremultiplyAlpha
, 0, 0, 0);
1747 procedure TImagingCanvas
.GetHistogram(out Red
, Green
, Blue
, Alpha
,
1748 Gray
: THistogramArray
);
1752 Color32
: TColor32Rec
;
1754 FillChar(Red
, SizeOf(Red
), 0);
1755 FillChar(Green
, SizeOf(Green
), 0);
1756 FillChar(Blue
, SizeOf(Blue
), 0);
1757 FillChar(Alpha
, SizeOf(Alpha
), 0);
1758 FillChar(Gray
, SizeOf(Gray
), 0);
1760 Bpp
:= FFormatInfo
.BytesPerPixel
;
1762 for Y
:= FClipRect
.Top
to FClipRect
.Bottom
- 1 do
1764 PixPointer
:= @PByteArray(FPData
.Bits
)[Y
* FPData
.Width
* Bpp
+ FClipRect
.Left
* Bpp
];
1765 for X
:= FClipRect
.Left
to FClipRect
.Right
- 1 do
1767 Color32
:= FFormatInfo
.GetPixel32(PixPointer
, @FFormatInfo
, FPData
.Palette
);
1769 Inc(Red
[Color32
.R
]);
1770 Inc(Green
[Color32
.G
]);
1771 Inc(Blue
[Color32
.B
]);
1772 Inc(Alpha
[Color32
.A
]);
1773 Inc(Gray
[Round(GrayConv
.R
* Color32
.R
+ GrayConv
.G
* Color32
.G
+ GrayConv
.B
* Color32
.B
)]);
1775 Inc(PixPointer
, Bpp
);
1780 procedure TImagingCanvas
.FillChannel(ChannelId
: Integer; NewChannelValue
: Byte);
1784 Color32
: TColor32Rec
;
1786 Bpp
:= FFormatInfo
.BytesPerPixel
;
1788 for Y
:= FClipRect
.Top
to FClipRect
.Bottom
- 1 do
1790 PixPointer
:= @PByteArray(FPData
.Bits
)[Y
* FPData
.Width
* Bpp
+ FClipRect
.Left
* Bpp
];
1791 for X
:= FClipRect
.Left
to FClipRect
.Right
- 1 do
1793 Color32
:= FFormatInfo
.GetPixel32(PixPointer
, @FFormatInfo
, FPData
.Palette
);
1794 Color32
.Channels
[ChannelId
] := NewChannelValue
;
1795 FFormatInfo
.SetPixel32(PixPointer
, @FFormatInfo
, FPData
.Palette
, Color32
);
1797 Inc(PixPointer
, Bpp
);
1802 procedure TImagingCanvas
.FillChannelFP(ChannelId
: Integer; NewChannelValue
: Single);
1806 ColorFP
: TColorFPRec
;
1808 Bpp
:= FFormatInfo
.BytesPerPixel
;
1810 for Y
:= FClipRect
.Top
to FClipRect
.Bottom
- 1 do
1812 PixPointer
:= @PByteArray(FPData
.Bits
)[Y
* FPData
.Width
* Bpp
+ FClipRect
.Left
* Bpp
];
1813 for X
:= FClipRect
.Left
to FClipRect
.Right
- 1 do
1815 ColorFP
:= FFormatInfo
.GetPixelFP(PixPointer
, @FFormatInfo
, FPData
.Palette
);
1816 ColorFP
.Channels
[ChannelId
] := NewChannelValue
;
1817 FFormatInfo
.SetPixelFP(PixPointer
, @FFormatInfo
, FPData
.Palette
, ColorFP
);
1819 Inc(PixPointer
, Bpp
);
1824 class function TImagingCanvas
.GetSupportedFormats
: TImageFormats
;
1826 Result
:= [ifIndex8
..Pred(ifDXT1
)];
1829 { TFastARGB32Canvas }
1831 destructor TFastARGB32Canvas
.Destroy
;
1833 FreeMem(FScanlines
);
1837 procedure TFastARGB32Canvas
.AlphaBlendPixels(SrcPix
, DestPix
: PColor32Rec
);
1839 SrcAlpha
, DestAlpha
, FinalAlpha
: Integer;
1841 FinalAlpha
:= SrcPix
.A
+ 1 + (DestPix
.A
* (256 - SrcPix
.A
)) shr 8;
1842 if FinalAlpha
= 0 then
1845 SrcAlpha
:= (SrcPix
.A
shl 8) div FinalAlpha
;
1846 DestAlpha
:= 256 - SrcAlpha
;
1848 DestPix
.A
:= ClampToByte(FinalAlpha
);
1849 DestPix
.R
:= (SrcPix
.R
* SrcAlpha
+ DestPix
.R
* DestAlpha
) shr 8;
1850 DestPix
.G
:= (SrcPix
.G
* SrcAlpha
+ DestPix
.G
* DestAlpha
) shr 8;
1851 DestPix
.B
:= (SrcPix
.B
* SrcAlpha
+ DestPix
.B
* DestAlpha
) shr 8;
1854 procedure TFastARGB32Canvas
.DrawAlpha(const SrcRect
: TRect
;
1855 DestCanvas
: TImagingCanvas
; DestX
, DestY
: Integer);
1857 X
, Y
, SrcX
, SrcY
, Width
, Height
: Integer;
1858 SrcPix
, DestPix
: PColor32Rec
;
1860 if DestCanvas
.ClassType
<> Self
.ClassType
then
1866 SrcX
:= SrcRect
.Left
;
1867 SrcY
:= SrcRect
.Top
;
1868 Width
:= SrcRect
.Right
- SrcRect
.Left
;
1869 Height
:= SrcRect
.Bottom
- SrcRect
.Top
;
1870 ClipCopyBounds(SrcX
, SrcY
, Width
, Height
, DestX
, DestY
,
1871 FPData
.Width
, FPData
.Height
, DestCanvas
.ClipRect
);
1873 for Y
:= 0 to Height
- 1 do
1875 SrcPix
:= @FScanlines
[SrcY
+ Y
, SrcX
];
1876 DestPix
:= @TFastARGB32Canvas(DestCanvas
).FScanlines
[DestY
+ Y
, DestX
];
1877 for X
:= 0 to Width
- 1 do
1879 AlphaBlendPixels(SrcPix
, DestPix
);
1886 function TFastARGB32Canvas
.GetPixel32(X
, Y
: LongInt): TColor32
;
1888 Result
:= FScanlines
[Y
, X
].Color
;
1891 procedure TFastARGB32Canvas
.SetPixel32(X
, Y
: LongInt; const Value
: TColor32
);
1893 if (X
>= FClipRect
.Left
) and (Y
>= FClipRect
.Top
) and
1894 (X
< FClipRect
.Right
) and (Y
< FClipRect
.Bottom
) then
1896 FScanlines
[Y
, X
].Color
:= Value
;
1900 procedure TFastARGB32Canvas
.StretchDrawAlpha(const SrcRect
: TRect
;
1901 DestCanvas
: TImagingCanvas
; const DestRect
: TRect
; Filter
: TResizeFilter
);
1903 X
, Y
, ScaleX
, ScaleY
, Yp
, Xp
, Weight1
, Weight2
, Weight3
, Weight4
,
1904 FracX
, FracY
, InvFracY
, T1
, T2
: Integer;
1905 SrcX
, SrcY
, SrcWidth
, SrcHeight
: Integer;
1906 DestX
, DestY
, DestWidth
, DestHeight
: Integer;
1907 SrcLine
, SrcLine2
: PColor32RecArray
;
1908 DestPix
: PColor32Rec
;
1911 if (Filter
= rfBicubic
) or (DestCanvas
.ClassType
<> Self
.ClassType
) then
1917 SrcX
:= SrcRect
.Left
;
1918 SrcY
:= SrcRect
.Top
;
1919 SrcWidth
:= SrcRect
.Right
- SrcRect
.Left
;
1920 SrcHeight
:= SrcRect
.Bottom
- SrcRect
.Top
;
1921 DestX
:= DestRect
.Left
;
1922 DestY
:= DestRect
.Top
;
1923 DestWidth
:= DestRect
.Right
- DestRect
.Left
;
1924 DestHeight
:= DestRect
.Bottom
- DestRect
.Top
;
1925 // Clip src and dst rects
1926 ClipStretchBounds(SrcX
, SrcY
, SrcWidth
, SrcHeight
, DestX
, DestY
, DestWidth
, DestHeight
,
1927 FPData
.Width
, FPData
.Height
, DestCanvas
.ClipRect
);
1928 ScaleX
:= (SrcWidth
shl 16) div DestWidth
;
1929 ScaleY
:= (SrcHeight
shl 16) div DestHeight
;
1931 // Nearest and linear filtering using fixed point math
1933 if Filter
= rfNearest
then
1936 for Y
:= DestY
to DestY
+ DestHeight
- 1 do
1939 SrcLine
:= @FScanlines
[SrcY
+ Yp
shr 16, SrcX
];
1940 DestPix
:= @TFastARGB32Canvas(DestCanvas
).FScanlines
[Y
, DestX
];
1941 for X
:= 0 to DestWidth
- 1 do
1943 AlphaBlendPixels(@SrcLine
[Xp
shr 16], DestPix
);
1952 Yp
:= (ScaleY
shr 1) - $8000;
1953 for Y
:= DestY
to DestY
+ DestHeight
- 1 do
1955 DestPix
:= @TFastARGB32Canvas(DestCanvas
).FScanlines
[Y
, DestX
];
1965 FracY
:= Yp
and $FFFF;
1966 InvFracY
:= (not Yp
and $FFFF) + 1;
1969 T2
:= Iff(T1
< SrcHeight
- 1, T1
+ 1, T1
);
1970 SrcLine
:= @Scanlines
[T1
+ SrcY
, SrcX
];
1971 SrcLine2
:= @Scanlines
[T2
+ SrcY
, SrcX
];
1972 Xp
:= (ScaleX
shr 1) - $8000;
1974 for X
:= 0 to DestWidth
- 1 do
1984 FracX
:= Xp
and $FFFF;
1987 T2
:= Iff(T1
< SrcWidth
- 1, T1
+ 1, T1
);
1988 Weight2
:= (Cardinal(InvFracY
) * FracX
) shr 16; // cast to Card, Int can overflow gere
1989 Weight1
:= InvFracY
- Weight2
;
1990 Weight4
:= (Cardinal(FracY
) * FracX
) shr 16;
1991 Weight3
:= FracY
- Weight4
;
1993 Accum
.B
:= (SrcLine
[T1
].B
* Weight1
+ SrcLine
[T2
].B
* Weight2
+
1994 SrcLine2
[T1
].B
* Weight3
+ SrcLine2
[T2
].B
* Weight4
+ $8000) shr 16;
1995 Accum
.G
:= (SrcLine
[T1
].G
* Weight1
+ SrcLine
[T2
].G
* Weight2
+
1996 SrcLine2
[T1
].G
* Weight3
+ SrcLine2
[T2
].G
* Weight4
+ $8000) shr 16;
1997 Accum
.R
:= (SrcLine
[T1
].R
* Weight1
+ SrcLine
[T2
].R
* Weight2
+
1998 SrcLine2
[T1
].R
* Weight3
+ SrcLine2
[T2
].R
* Weight4
+ $8000) shr 16;
1999 Accum
.A
:= (SrcLine
[T1
].A
* Weight1
+ SrcLine
[T2
].A
* Weight2
+
2000 SrcLine2
[T1
].A
* Weight3
+ SrcLine2
[T2
].A
* Weight4
+ $8000) shr 16;
2002 AlphaBlendPixels(@Accum
, DestPix
);
2012 // Generate mapping tables
2013 MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth,
2014 FPData.Width, FilterFunction, Radius, False);
2015 MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight,
2016 FPData.Height, FilterFunction, Radius, False);
2017 FindExtremes(MapX, XMinimum, XMaximum);
2018 SetLength(LineBuffer, XMaximum - XMinimum + 1);
2020 for J := 0 to DestHeight - 1 do
2022 ClusterY := MapY[J];
2023 for X := XMinimum to XMaximum do
2029 for Y := 0 to Length(ClusterY) - 1 do
2031 Weight := Round(ClusterY[Y].Weight * 256);
2032 SrcColor := FScanlines[ClusterY[Y].Pos, X];
2034 AccumB := AccumB + SrcColor.B * Weight;
2035 AccumG := AccumG + SrcColor.G * Weight;
2036 AccumR := AccumR + SrcColor.R * Weight;
2037 AccumA := AccumA + SrcColor.A * Weight;
2039 with LineBuffer[X - XMinimum] do
2048 DestPtr := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + J, DestX];
2050 for I := 0 to DestWidth - 1 do
2052 ClusterX := MapX[I];
2057 for X := 0 to Length(ClusterX) - 1 do
2059 Weight := Round(ClusterX[X].Weight * 256);
2060 with LineBuffer[ClusterX[X].Pos - XMinimum] do
2062 AccumB := AccumB + B * Weight;
2063 AccumG := AccumG + G * Weight;
2064 AccumR := AccumR + R * Weight;
2065 AccumA := AccumA + A * Weight;
2069 AccumA := ClampInt(AccumA, 0, $00FF0000);
2070 AccumR := ClampInt(AccumR, 0, $00FF0000);
2071 AccumG := ClampInt(AccumG, 0, $00FF0000);
2072 AccumB := ClampInt(AccumB, 0, $00FF0000);
2073 SrcColor.Color := (Cardinal(AccumA and $00FF0000) shl 8) or
2074 (AccumR and $00FF0000) or ((AccumG and $00FF0000) shr 8) or ((AccumB and $00FF0000) shr 16);
2076 AlphaBlendPixels(@SrcColor, DestPtr);
2083 procedure TFastARGB32Canvas
.UpdateCanvasState
;
2088 inherited UpdateCanvasState
;
2090 // Realloc and update scanline array
2091 ReallocMem(FScanlines
, FPData
.Height
* SizeOf(PColor32RecArray
));
2092 ScanPos
:= FPData
.Bits
;
2094 for I
:= 0 to FPData
.Height
- 1 do
2096 FScanlines
[I
] := PColor32RecArray(ScanPos
);
2097 Inc(ScanPos
, FPData
.Width
);
2101 class function TFastARGB32Canvas
.GetSupportedFormats
: TImageFormats
;
2103 Result
:= [ifA8R8G8B8
];
2106 procedure TFastARGB32Canvas
.InvertColors
;
2109 PixPtr
: PColor32Rec
;
2111 for Y
:= FClipRect
.Top
to FClipRect
.Bottom
- 1 do
2113 PixPtr
:= @FScanlines
[Y
, FClipRect
.Left
];
2114 for X
:= FClipRect
.Left
to FClipRect
.Right
- 1 do
2116 PixPtr
.R
:= not PixPtr
.R
;
2117 PixPtr
.G
:= not PixPtr
.G
;
2118 PixPtr
.B
:= not PixPtr
.B
;
2125 RegisterCanvas(TFastARGB32Canvas
);
2128 FreeAndNil(CanvasClasses
);
2133 -- TODOS ----------------------------------------------------
2134 - more more more ...
2135 - implement pen width everywhere
2136 - add blending (*image and object drawing)
2137 - more objects (arc, polygon)
2139 -- 0.26.3 Changes/Bug Fixes ---------------------------------
2140 - Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha)
2141 - Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation.
2142 - Added PremultiplyAlpha and UnPremultiplyAlpha methods.
2144 -- 0.26.1 Changes/Bug Fixes ---------------------------------
2145 - Added FillChannel methods.
2146 - Added FloodFill method.
2147 - Added GetHistogram method.
2148 - Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes
2149 (thanks to Carlos González).
2150 - Added TImagingCanvas.AdjustColorLevels method.
2152 -- 0.25.0 Changes/Bug Fixes ---------------------------------
2153 - Fixed error that could cause AV in linear and nonlinear filters.
2154 - Added blended rect filling function FillRectBlend.
2155 - Added drawing function with blending (DrawAlpha, StretchDrawAlpha,
2156 StretchDrawAdd, DrawBlend, StretchDrawBlend, ...)
2157 - Added non-linear filters (min, max, median).
2158 - Added point transforms (invert, contrast, gamma, brightness).
2160 -- 0.21 Changes/Bug Fixes -----------------------------------
2161 - Added some new filter kernels for convolution.
2162 - Added FillMode and PenMode properties.
2163 - Added FrameRect, Rectangle, Ellipse, and Line methods.
2164 - Removed HorzLine and VertLine from TFastARGB32Canvas - new versions
2165 in general canvas is now as fast as those in TFastARGB32Canvas
2166 (only in case of A8R8G8B8 images of course).
2167 - Added PenWidth property, updated HorzLine and VertLine to use it.
2169 -- 0.19 Changes/Bug Fixes -----------------------------------
2170 - added TFastARGB32Canvas
2171 - added convolutions, hline, vline
2172 - unit created, intial stuff added