2 Vampyre Imaging Library
4 http://imaginglib.sourceforge.net
6 The contents of this file are used with permission, subject to the Mozilla
7 Public License Version 1.1 (the "License"); you may not use this file except
8 in compliance with the License. You may obtain a copy of the License at
9 http://www.mozilla.org/MPL/MPL-1.1.html
11 Software distributed under the License is distributed on an "AS IS" basis,
12 WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
13 the specific language governing rights and limitations under the License.
15 Alternatively, the contents of this file may be used under the terms of the
16 GNU Lesser General Public License (the "LGPL License"), in which case the
17 provisions of the LGPL License are applicable instead of those above.
18 If you wish to allow use of your version of this file only under the terms
19 of the LGPL License and not to allow others to use your version of this file
20 under the MPL, indicate your decision by deleting the provisions above and
21 replace them with the notice and other provisions required by the LGPL
22 License. If you do not delete the provisions above, a recipient may use
23 your version of this file under either the MPL or the LGPL License.
25 For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
28 { This unit contains canvas classes for drawing and applying effects.}
31 {$I ImagingOptions.inc}
36 SysUtils
, Types
, Classes
, ImagingTypes
, Imaging
, ImagingClasses
,
37 ImagingFormats
, ImagingUtility
;
40 { Color constants in ifA8R8G8B8 format.}
56 pcFuchsia
= $FFFF00FF;
64 EImagingCanvasError
= class(EImagingError
);
65 EImagingCanvasBlendingError
= class(EImagingError
);
67 { Fill mode used when drawing filled objects on canvas.}
69 fmSolid
, // Solid fill using current fill color
70 fmClear
// No filling done
73 { Pen mode used when drawing lines, object outlines, and similar on canvas.}
75 pmSolid
, // Draws solid lines using current pen color.
76 pmClear
// No drawing done
79 { Source and destination blending factors for drawing functions with blending.
80 Blending formula: SrcColor * SrcFactor + DestColor * DestFactor }
82 bfIgnore
, // Don't care
83 bfZero
, // For Src and Dest, Factor = (0, 0, 0, 0)
84 bfOne
, // For Src and Dest, Factor = (1, 1, 1, 1)
85 bfSrcAlpha
, // For Src and Dest, Factor = (Src.A, Src.A, Src.A, Src.A)
86 bfOneMinusSrcAlpha
, // For Src and Dest, Factor = (1 - Src.A, 1 - Src.A, 1 - Src.A, 1 - Src.A)
87 bfDstAlpha
, // For Src and Dest, Factor = (Dest.A, Dest.A, Dest.A, Dest.A)
88 bfOneMinusDstAlpha
, // For Src and Dest, Factor = (1 - Dest.A, 1 - Dest.A, 1 - Dest.A, 1 - Dest.A)
89 bfSrcColor
, // For Dest, Factor = (Src.R, Src.R, Src.B, Src.A)
90 bfOneMinusSrcColor
, // For Dest, Factor = (1 - Src.R, 1 - Src.G, 1 - Src.B, 1 - Src.A)
91 bfDstColor
, // For Src, Factor = (Dest.R, Dest.G, Dest.B, Dest.A)
92 bfOneMinusDstColor
// For Src, Factor = (1 - Dest.R, 1 - Dest.G, 1 - Dest.B, 1 - Dest.A)
95 { Procedure for custom pixel write modes with blending.}
96 TPixelWriteProc
= procedure(const SrcPix
: TColorFPRec
; DestPtr
: PByte;
97 DestInfo
: PImageFormatInfo
; SrcFactor
, DestFactor
: TBlendingFactor
);
99 { Represents 3x3 convolution filter kernel.}
100 TConvolutionFilter3x3
= record
101 Kernel
: array[0..2, 0..2] of LongInt;
106 { Represents 5x5 convolution filter kernel.}
107 TConvolutionFilter5x5
= record
108 Kernel
: array[0..4, 0..4] of LongInt;
113 TPointTransformFunction
= function(const Pixel
: TColorFPRec
;
114 Param1
, Param2
, Param3
: Single): TColorFPRec
;
116 TDynFPPixelArray
= array of TColorFPRec
;
118 THistogramArray
= array[Byte] of Integer;
120 TSelectPixelFunction
= function(var Pixels
: TDynFPPixelArray
): TColorFPRec
;
122 { Base canvas class for drawing objects, applying effects, and other.
123 Constructor takes TBaseImage (or pointer to TImageData). Source image
124 bits are not copied but referenced so all canvas functions affect
125 source image and vice versa. When you change format or resolution of
126 source image you must call UpdateCanvasState method (so canvas could
127 recompute some data size related stuff).
129 TImagingCanvas works for all image data formats except special ones
130 (compressed). Because of this its methods are quite slow (they usually work
131 with colors in ifA32R32G32B32F format). If you want fast drawing you
132 can use one of fast canvas clases. These descendants of TImagingCanvas
133 work only for few select formats (or only one) but they are optimized thus
136 TImagingCanvas
= class(TObject
)
138 FDataSizeOnUpdate
: LongInt;
139 FLineRecursion
: Boolean;
140 function GetPixel32(X
, Y
: LongInt): TColor32
; virtual;
141 function GetPixelFP(X
, Y
: LongInt): TColorFPRec
; virtual;
142 function GetValid
: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
143 procedure SetPixel32(X
, Y
: LongInt; const Value
: TColor32
); virtual;
144 procedure SetPixelFP(X
, Y
: LongInt; const Value
: TColorFPRec
); virtual;
145 procedure SetPenColor32(const Value
: TColor32
); {$IFDEF USE_INLINE}inline;{$ENDIF}
146 procedure SetPenColorFP(const Value
: TColorFPRec
); {$IFDEF USE_INLINE}inline;{$ENDIF}
147 procedure SetPenWidth(const Value
: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
148 procedure SetFillColor32(const Value
: TColor32
); {$IFDEF USE_INLINE}inline;{$ENDIF}
149 procedure SetFillColorFP(const Value
: TColorFPRec
); {$IFDEF USE_INLINE}inline;{$ENDIF}
150 procedure SetClipRect(const Value
: TRect
);
151 procedure CheckBeforeBlending(SrcFactor
, DestFactor
: TBlendingFactor
; DestCanvas
: TImagingCanvas
);
155 FPenColorFP
: TColorFPRec
;
156 FPenColor32
: TColor32
;
159 FFillColorFP
: TColorFPRec
;
160 FFillColor32
: TColor32
;
161 FFillMode
: TFillMode
;
162 FNativeColor
: TColorFPRec
;
163 FFormatInfo
: TImageFormatInfo
;
165 { Returns pointer to pixel at given position.}
166 function GetPixelPointer(X
, Y
: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
167 { Translates given FP color to native format of canvas and stores it
168 in FNativeColor field (its bit copy) or user pointer (in overloaded method).}
169 procedure TranslateFPToNative(const Color
: TColorFPRec
); overload
; {$IFDEF USE_INLINE}inline;{$ENDIF}
170 procedure TranslateFPToNative(const Color
: TColorFPRec
; Native
: Pointer); overload
; {$IFDEF USE_INLINE}inline;{$ENDIF}
171 { Clipping function used by horizontal and vertical line drawing functions.}
172 function ClipAxisParallelLine(var A1
, A2
, B
: LongInt;
173 AStart
, AStop
, BStart
, BStop
: LongInt): Boolean;
174 { Internal horizontal line drawer used mainly for filling inside of objects
175 like ellipses and circles.}
176 procedure HorzLineInternal(X1
, X2
, Y
: LongInt; Color
: Pointer; Bpp
: LongInt); virtual;
177 procedure CopyPixelInternal(X
, Y
: LongInt; Pixel
: Pointer; Bpp
: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
178 procedure DrawInternal(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
179 DestX
, DestY
: Integer; SrcFactor
, DestFactor
: TBlendingFactor
; PixelWriteProc
: TPixelWriteProc
);
180 procedure StretchDrawInternal(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
181 const DestRect
: TRect
; SrcFactor
, DestFactor
: TBlendingFactor
;
182 Filter
: TResizeFilter
; PixelWriteProc
: TPixelWriteProc
);
184 constructor CreateForData(ImageDataPointer
: PImageData
);
185 constructor CreateForImage(Image
: TBaseImage
);
186 destructor Destroy
; override;
188 { Call this method when you change size or format of image this canvas
189 operates on (like calling ResizeImage, ConvertImage, or changing Format
190 property of TBaseImage descendants).}
191 procedure UpdateCanvasState
; virtual;
192 { Resets clipping rectangle to Rect(0, 0, ImageWidth, ImageHeight).}
193 procedure ResetClipRect
;
195 { Clears entire canvas with current fill color (ignores clipping rectangle
196 and always uses fmSolid fill mode).}
199 { Draws horizontal line with current pen settings.}
200 procedure HorzLine(X1
, X2
, Y
: LongInt); virtual;
201 { Draws vertical line with current pen settings.}
202 procedure VertLine(X
, Y1
, Y2
: LongInt); virtual;
203 { Draws line from [X1, Y1] to [X2, Y2] with current pen settings.}
204 procedure Line(X1
, Y1
, X2
, Y2
: LongInt); virtual;
205 { Draws a rectangle using current pen settings.}
206 procedure FrameRect(const Rect
: TRect
);
207 { Fills given rectangle with current fill settings.}
208 procedure FillRect(const Rect
: TRect
); virtual;
209 { Fills given rectangle with current fill settings and pixel blending.}
210 procedure FillRectBlend(const Rect
: TRect
; SrcFactor
, DestFactor
: TBlendingFactor
);
211 { Draws rectangle which is outlined by using the current pen settings and
212 filled by using the current fill settings.}
213 procedure Rectangle(const Rect
: TRect
);
214 { Draws ellipse which is outlined by using the current pen settings and
215 filled by using the current fill settings. Rect specifies bounding rectangle
216 of ellipse to be drawn.}
217 procedure Ellipse(const Rect
: TRect
);
218 { Fills area of canvas with current fill color starting at point [X, Y] and
219 coloring its neighbors. Default flood fill mode changes color of all
220 neighbors with the same color as pixel [X, Y]. With BoundaryFillMode
221 set to True neighbors are recolored regardless of their old color,
222 but area which will be recolored has boundary (specified by current pen color).}
223 procedure FloodFill(X
, Y
: Integer; BoundaryFillMode
: Boolean = False);
225 { Draws contents of this canvas onto another canvas with pixel blending.
226 Blending factors are chosen using TBlendingFactor parameters.
227 Resulting destination pixel color is:
228 SrcColor * SrcFactor + DstColor * DstFactor}
229 procedure DrawBlend(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
230 DestX
, DestY
: Integer; SrcFactor
, DestFactor
: TBlendingFactor
);
231 { Draws contents of this canvas onto another one with typical alpha
232 blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
233 procedure DrawAlpha(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
; DestX
, DestY
: Integer); virtual;
234 { Draws contents of this canvas onto another one using additive blending
235 (source and dest factors are bfOne).}
236 procedure DrawAdd(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
; DestX
, DestY
: Integer);
237 { Draws stretched and filtered contents of this canvas onto another canvas
238 with pixel blending. Blending factors are chosen using TBlendingFactor parameters.
239 Resulting destination pixel color is:
240 SrcColor * SrcFactor + DstColor * DstFactor}
241 procedure StretchDrawBlend(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
242 const DestRect
: TRect
; SrcFactor
, DestFactor
: TBlendingFactor
;
243 Filter
: TResizeFilter
= rfBilinear
);
244 { Draws contents of this canvas onto another one with typical alpha
245 blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
246 procedure StretchDrawAlpha(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
247 const DestRect
: TRect
; Filter
: TResizeFilter
= rfBilinear
); virtual;
248 { Draws contents of this canvas onto another one using additive blending
249 (source and dest factors are bfOne).}
250 procedure StretchDrawAdd(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
251 const DestRect
: TRect
; Filter
: TResizeFilter
= rfBilinear
);
253 { Convolves canvas' image with given 3x3 filter kernel. You can use
254 predefined filter kernels or define your own.}
255 procedure ApplyConvolution3x3(const Filter
: TConvolutionFilter3x3
);
256 { Convolves canvas' image with given 5x5 filter kernel. You can use
257 predefined filter kernels or define your own.}
258 procedure ApplyConvolution5x5(const Filter
: TConvolutionFilter5x5
);
259 { Computes 2D convolution of canvas' image and given filter kernel.
260 Kernel is in row format and KernelSize must be odd number >= 3. Divisor
261 is normalizing value based on Kernel (usually sum of all kernel's cells).
262 The Bias number shifts each color value by a fixed amount (color values
263 are usually in range [0, 1] during processing). If ClampChannels
264 is True all output color values are clamped to [0, 1]. You can use
265 predefined filter kernels or define your own.}
266 procedure ApplyConvolution(Kernel
: PLongInt; KernelSize
, Divisor
: LongInt;
267 Bias
: Single = 0.0; ClampChannels
: Boolean = True); virtual;
269 { Applies custom non-linear filter. Filter size is diameter of pixel
270 neighborhood. Typical values are 3, 5, or 7. }
271 procedure ApplyNonLinearFilter(FilterSize
: Integer; SelectFunc
: TSelectPixelFunction
);
272 { Applies median non-linear filter with user defined pixel neighborhood.
273 Selects median pixel from the neighborhood as new pixel
274 (current implementation is quite slow).}
275 procedure ApplyMedianFilter(FilterSize
: Integer);
276 { Applies min non-linear filter with user defined pixel neighborhood.
277 Selects min pixel from the neighborhood as new pixel.}
278 procedure ApplyMinFilter(FilterSize
: Integer);
279 { Applies max non-linear filter with user defined pixel neighborhood.
280 Selects max pixel from the neighborhood as new pixel.}
281 procedure ApplyMaxFilter(FilterSize
: Integer);
283 { Transforms pixels one by one by given function. Pixel neighbors are
284 not taken into account. Param 1-3 are optional parameters
285 for transform function.}
286 procedure PointTransform(Transform
: TPointTransformFunction
;
287 Param1
, Param2
, Param3
: Single);
288 { Modifies image contrast and brightness. Parameters should be
289 in range <-100; 100>.}
290 procedure ModifyContrastBrightness(Contrast
, Brightness
: Single);
291 { Gamma correction of individual color channels. Range is (0, +inf),
292 1.0 means no change.}
293 procedure GammaCorection(Red
, Green
, Blue
: Single);
294 { Inverts colors of all image pixels, makes negative image. Ignores alpha channel.}
295 procedure InvertColors
; virtual;
296 { Simple single level thresholding with threshold level (in range [0, 1])
297 for each color channel.}
298 procedure Threshold(Red
, Green
, Blue
: Single);
299 { Adjusts the color levels of the image by scaling the
300 colors falling between specified white and black points to full [0, 1] range.
301 The black point specifies the darkest color in the image, white point
302 specifies the lightest color, and mid point is gamma aplied to image.
303 Black and white point must be in range [0, 1].}
304 procedure AdjustColorLevels(BlackPoint
, WhitePoint
: Single; MidPoint
: Single = 1.0);
305 { Premultiplies color channel values by alpha. Needed for some platforms/APIs
306 to display images with alpha properly.}
307 procedure PremultiplyAlpha
;
308 { Reverses PremultiplyAlpha operation.}
309 procedure UnPremultiplyAlpha
;
311 { Calculates image histogram for each channel and also gray values. Each
312 channel has 256 values available. Channel values of data formats with higher
313 precision are scaled and rounded. Example: Red[126] specifies number of pixels
314 in image with red channel = 126.}
315 procedure GetHistogram(out Red
, Green
, Blue
, Alpha
, Gray
: THistogramArray
);
316 { Fills image channel with given value leaving other channels intact.
317 Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
319 procedure FillChannel(ChannelId
: Integer; NewChannelValue
: Byte); overload
;
320 { Fills image channel with given value leaving other channels intact.
321 Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
323 procedure FillChannelFP(ChannelId
: Integer; NewChannelValue
: Single); overload
;
325 { Color used when drawing lines, frames, and outlines of objects.}
326 property PenColor32
: TColor32 read FPenColor32 write SetPenColor32
;
327 { Color used when drawing lines, frames, and outlines of objects.}
328 property PenColorFP
: TColorFPRec read FPenColorFP write SetPenColorFP
;
329 { Pen mode used when drawing lines, object outlines, and similar on canvas.}
330 property PenMode
: TPenMode read FPenMode write FPenMode
;
331 { Width with which objects like lines, frames, etc. (everything which uses
332 PenColor) are drawn.}
333 property PenWidth
: LongInt read FPenWidth write SetPenWidth
;
334 { Color used for filling when drawing various objects.}
335 property FillColor32
: TColor32 read FFillColor32 write SetFillColor32
;
336 { Color used for filling when drawing various objects.}
337 property FillColorFP
: TColorFPRec read FFillColorFP write SetFillColorFP
;
338 { Fill mode used when drawing filled objects on canvas.}
339 property FillMode
: TFillMode read FFillMode write FFillMode
;
340 { Specifies the current color of the pixels of canvas. Native pixel is
341 read from canvas and then translated to 32bit ARGB. Reverse operation
342 is made when setting pixel color.}
343 property Pixels32
[X
, Y
: LongInt]: TColor32 read GetPixel32 write SetPixel32
;
344 { Specifies the current color of the pixels of canvas. Native pixel is
345 read from canvas and then translated to FP ARGB. Reverse operation
346 is made when setting pixel color.}
347 property PixelsFP
[X
, Y
: LongInt]: TColorFPRec read GetPixelFP write SetPixelFP
;
348 { Clipping rectangle of this canvas. No pixels outside this rectangle are
349 altered by canvas methods if Clipping property is True. Clip rect gets
350 reseted when UpdateCanvasState is called.}
351 property ClipRect
: TRect read FClipRect write SetClipRect
;
352 { Extended format information.}
353 property FormatInfo
: TImageFormatInfo read FFormatInfo
;
354 { Indicates that this canvas is in valid state. If False canvas oprations
356 property Valid
: Boolean read GetValid
;
358 { Returns all formats supported by this canvas class.}
359 class function GetSupportedFormats
: TImageFormats
; virtual;
362 TImagingCanvasClass
= class of TImagingCanvas
;
364 TScanlineArray
= array[0..MaxInt
div SizeOf(Pointer) - 1] of PColor32RecArray
;
365 PScanlineArray
= ^TScanlineArray
;
367 { Fast canvas class for ifA8R8G8B8 format images.}
368 TFastARGB32Canvas
= class(TImagingCanvas
)
370 FScanlines
: PScanlineArray
;
371 procedure AlphaBlendPixels(SrcPix
, DestPix
: PColor32Rec
); {$IFDEF USE_INLINE}inline;{$ENDIF}
372 function GetPixel32(X
, Y
: LongInt): TColor32
; override;
373 procedure SetPixel32(X
, Y
: LongInt; const Value
: TColor32
); override;
375 destructor Destroy
; override;
377 procedure UpdateCanvasState
; override;
379 procedure DrawAlpha(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
; DestX
, DestY
: Integer); override;
380 procedure StretchDrawAlpha(const SrcRect
: TRect
; DestCanvas
: TImagingCanvas
;
381 const DestRect
: TRect
; Filter
: TResizeFilter
= rfBilinear
); override;
382 procedure InvertColors
; override;
384 property Scanlines
: PScanlineArray read FScanlines
;
386 class function GetSupportedFormats
: TImageFormats
; override;
390 { Kernel for 3x3 average smoothing filter.}
391 FilterAverage3x3
: TConvolutionFilter3x3
= (
397 { Kernel for 5x5 average smoothing filter.}
398 FilterAverage5x5
: TConvolutionFilter5x5
= (
399 Kernel
: ((1, 1, 1, 1, 1),
406 { Kernel for 3x3 Gaussian smoothing filter.}
407 FilterGaussian3x3
: TConvolutionFilter3x3
= (
413 { Kernel for 5x5 Gaussian smoothing filter.}
414 FilterGaussian5x5
: TConvolutionFilter5x5
= (
415 Kernel
: ((1, 4, 6, 4, 1),
422 { Kernel for 3x3 Sobel horizontal edge detection filter (1st derivative approximation).}
423 FilterSobelHorz3x3
: TConvolutionFilter3x3
= (
429 { Kernel for 3x3 Sobel vertical edge detection filter (1st derivative approximation).}
430 FilterSobelVert3x3
: TConvolutionFilter3x3
= (
436 { Kernel for 3x3 Prewitt horizontal edge detection filter.}
437 FilterPrewittHorz3x3
: TConvolutionFilter3x3
= (
443 { Kernel for 3x3 Prewitt vertical edge detection filter.}
444 FilterPrewittVert3x3
: TConvolutionFilter3x3
= (
450 { Kernel for 3x3 Kirsh horizontal edge detection filter.}
451 FilterKirshHorz3x3
: TConvolutionFilter3x3
= (
457 { Kernel for 3x3 Kirsh vertical edge detection filter.}
458 FilterKirshVert3x3
: TConvolutionFilter3x3
= (
459 Kernel
: ((5, -3, -3),
464 { Kernel for 3x3 Laplace omni-directional edge detection filter
465 (2nd derivative approximation).}
466 FilterLaplace3x3
: TConvolutionFilter3x3
= (
467 Kernel
: ((-1, -1, -1),
472 { Kernel for 5x5 Laplace omni-directional edge detection filter
473 (2nd derivative approximation).}
474 FilterLaplace5x5
: TConvolutionFilter5x5
= (
475 Kernel
: ((-1, -1, -1, -1, -1),
476 (-1, -1, -1, -1, -1),
477 (-1, -1, 24, -1, -1),
478 (-1, -1, -1, -1, -1),
479 (-1, -1, -1, -1, -1));
482 { Kernel for 3x3 spharpening filter (Laplacian + original color).}
483 FilterSharpen3x3
: TConvolutionFilter3x3
= (
484 Kernel
: ((-1, -1, -1),
489 { Kernel for 5x5 spharpening filter (Laplacian + original color).}
490 FilterSharpen5x5
: TConvolutionFilter5x5
= (
491 Kernel
: ((-1, -1, -1, -1, -1),
492 (-1, -1, -1, -1, -1),
493 (-1, -1, 25, -1, -1),
494 (-1, -1, -1, -1, -1),
495 (-1, -1, -1, -1, -1));
498 { Kernel for 5x5 glow filter.}
499 FilterGlow5x5
: TConvolutionFilter5x5
= (
500 Kernel
: (( 1, 2, 2, 2, 1),
507 { Kernel for 3x3 edge enhancement filter.}
508 FilterEdgeEnhance3x3
: TConvolutionFilter3x3
= (
509 Kernel
: ((-1, -2, -1),
514 { Kernel for 3x3 contour enhancement filter.}
515 FilterTraceControur3x3
: TConvolutionFilter3x3
= (
516 Kernel
: ((-6, -6, -2),
522 { Kernel for filter that negates all images pixels.}
523 FilterNegative3x3
: TConvolutionFilter3x3
= (
530 { Kernel for 3x3 horz/vert embossing filter.}
531 FilterEmboss3x3
: TConvolutionFilter3x3
= (
539 { You can register your own canvas class. List of registered canvases is used
540 by FindBestCanvasForImage functions to find best canvas for given image.
541 If two different canvases which support the same image data format are
542 registered then the one that was registered later is returned (so you can
543 override builtin Imaging canvases).}
544 procedure RegisterCanvas(CanvasClass
: TImagingCanvasClass
);
545 { Returns best canvas for given TImageFormat.}
546 function FindBestCanvasForImage(ImageFormat
: TImageFormat
): TImagingCanvasClass
; overload
;
547 { Returns best canvas for given TImageData.}
548 function FindBestCanvasForImage(const ImageData
: TImageData
): TImagingCanvasClass
; overload
;
549 { Returns best canvas for given TBaseImage.}
550 function FindBestCanvasForImage(Image
: TBaseImage
): TImagingCanvasClass
; overload
;
555 SConstructorInvalidPointer
= 'Invalid pointer (%p) to TImageData passed to TImagingCanvas constructor.';
556 SConstructorInvalidImage
= 'Invalid image data passed to TImagingCanvas constructor (%s).';
557 SConstructorUnsupportedFormat
= 'Image passed to TImagingCanvas constructor is in unsupported format (%s)';
560 // list with all registered TImagingCanvas classes
561 CanvasClasses
: TList
= nil;
563 procedure RegisterCanvas(CanvasClass
: TImagingCanvasClass
);
565 Assert(CanvasClass
<> nil);
566 if CanvasClasses
= nil then
567 CanvasClasses
:= TList
.Create
;
568 if CanvasClasses
.IndexOf(CanvasClass
) < 0 then
569 CanvasClasses
.Add(CanvasClass
);
572 function FindBestCanvasForImage(ImageFormat
: TImageFormat
): TImagingCanvasClass
; overload
;
576 for I
:= CanvasClasses
.Count
- 1 downto 0 do
578 if ImageFormat
in TImagingCanvasClass(CanvasClasses
[I
]).GetSupportedFormats
then
580 Result
:= TImagingCanvasClass(CanvasClasses
[I
]);
584 Result
:= TImagingCanvas
;
587 function FindBestCanvasForImage(const ImageData
: TImageData
): TImagingCanvasClass
;
589 Result
:= FindBestCanvasForImage(ImageData
.Format
);
592 function FindBestCanvasForImage(Image
: TBaseImage
): TImagingCanvasClass
;
594 Result
:= FindBestCanvasForImage(Image
.Format
);
597 { Canvas helper functions }
599 procedure PixelBlendProc(const SrcPix
: TColorFPRec
; DestPtr
: PByte;
600 DestInfo
: PImageFormatInfo
; SrcFactor
, DestFactor
: TBlendingFactor
);
602 DestPix
, FSrc
, FDst
: TColorFPRec
;
604 // Get set pixel color
605 DestPix
:= DestInfo
.GetPixelFP(DestPtr
, DestInfo
, nil);
606 // Determine current blending factors
608 bfZero
: FSrc
:= ColorFP(0, 0, 0, 0);
609 bfOne
: FSrc
:= ColorFP(1, 1, 1, 1);
610 bfSrcAlpha
: FSrc
:= ColorFP(SrcPix
.A
, SrcPix
.A
, SrcPix
.A
, SrcPix
.A
);
611 bfOneMinusSrcAlpha
: FSrc
:= ColorFP(1 - SrcPix
.A
, 1 - SrcPix
.A
, 1 - SrcPix
.A
, 1 - SrcPix
.A
);
612 bfDstAlpha
: FSrc
:= ColorFP(DestPix
.A
, DestPix
.A
, DestPix
.A
, DestPix
.A
);
613 bfOneMinusDstAlpha
: FSrc
:= ColorFP(1 - DestPix
.A
, 1 - DestPix
.A
, 1 - DestPix
.A
, 1 - DestPix
.A
);
614 bfDstColor
: FSrc
:= ColorFP(DestPix
.A
, DestPix
.R
, DestPix
.G
, DestPix
.B
);
615 bfOneMinusDstColor
: FSrc
:= ColorFP(1 - DestPix
.A
, 1 - DestPix
.R
, 1 - DestPix
.G
, 1 - DestPix
.B
);
618 bfZero
: FDst
:= ColorFP(0, 0, 0, 0);
619 bfOne
: FDst
:= ColorFP(1, 1, 1, 1);
620 bfSrcAlpha
: FDst
:= ColorFP(SrcPix
.A
, SrcPix
.A
, SrcPix
.A
, SrcPix
.A
);
621 bfOneMinusSrcAlpha
: FDst
:= ColorFP(1 - SrcPix
.A
, 1 - SrcPix
.A
, 1 - SrcPix
.A
, 1 - SrcPix
.A
);
622 bfDstAlpha
: FDst
:= ColorFP(DestPix
.A
, DestPix
.A
, DestPix
.A
, DestPix
.A
);
623 bfOneMinusDstAlpha
: FDst
:= ColorFP(1 - DestPix
.A
, 1 - DestPix
.A
, 1 - DestPix
.A
, 1 - DestPix
.A
);
624 bfSrcColor
: FDst
:= ColorFP(SrcPix
.A
, SrcPix
.R
, SrcPix
.G
, SrcPix
.B
);
625 bfOneMinusSrcColor
: FDst
:= ColorFP(1 - SrcPix
.A
, 1 - SrcPix
.R
, 1 - SrcPix
.G
, 1 - SrcPix
.B
);
627 // Compute blending formula
628 DestPix
.R
:= SrcPix
.R
* FSrc
.R
+ DestPix
.R
* FDst
.R
;
629 DestPix
.G
:= SrcPix
.G
* FSrc
.G
+ DestPix
.G
* FDst
.G
;
630 DestPix
.B
:= SrcPix
.B
* FSrc
.B
+ DestPix
.B
* FDst
.B
;
631 DestPix
.A
:= SrcPix
.A
* FSrc
.A
+ DestPix
.A
* FDst
.A
;
632 // Write blended pixel
633 DestInfo
.SetPixelFP(DestPtr
, DestInfo
, nil, DestPix
);
636 procedure PixelAlphaProc(const SrcPix
: TColorFPRec
; DestPtr
: PByte;
637 DestInfo
: PImageFormatInfo
; SrcFactor
, DestFactor
: TBlendingFactor
);
639 DestPix
: TColorFPRec
;
640 SrcAlpha
, DestAlpha
: Single;
642 DestPix
:= DestInfo
.GetPixelFP(DestPtr
, DestInfo
, nil);
643 // Blend the two pixels (Src 'over' Dest alpha composition operation)
644 DestPix
.A
:= SrcPix
.A
+ DestPix
.A
- SrcPix
.A
* DestPix
.A
;
645 if DestPix
.A
= 0 then
648 SrcAlpha
:= 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 VertLine(X1
, Y1
, Y2
);
1056 HorzLine(X1
, X2
, Y1
);
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
, sfLanczos
);
1419 X
, Y
, I
, J
, SrcX
, SrcY
, SrcWidth
, SrcHeight
: Integer;
1420 DestX
, DestY
, DestWidth
, DestHeight
, SrcBpp
, DestBpp
: Integer;
1421 SrcPix
: 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
, InvFracY
, T1
, T2
: Integer;
1904 FracX
, FracY
: Cardinal;
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
:= Integer((Cardinal(InvFracY
) * FracX
) shr 16); // cast to Card, Int can overflow here
1989 Weight1
:= InvFracY
- Weight2
;
1990 Weight4
:= Integer((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 procedure TFastARGB32Canvas
.UpdateCanvasState
;
2017 inherited UpdateCanvasState
;
2019 // Realloc and update scanline array
2020 ReallocMem(FScanlines
, FPData
.Height
* SizeOf(PColor32RecArray
));
2021 ScanPos
:= FPData
.Bits
;
2023 for I
:= 0 to FPData
.Height
- 1 do
2025 FScanlines
[I
] := PColor32RecArray(ScanPos
);
2026 Inc(ScanPos
, FPData
.Width
);
2030 class function TFastARGB32Canvas
.GetSupportedFormats
: TImageFormats
;
2032 Result
:= [ifA8R8G8B8
];
2035 procedure TFastARGB32Canvas
.InvertColors
;
2038 PixPtr
: PColor32Rec
;
2040 for Y
:= FClipRect
.Top
to FClipRect
.Bottom
- 1 do
2042 PixPtr
:= @FScanlines
[Y
, FClipRect
.Left
];
2043 for X
:= FClipRect
.Left
to FClipRect
.Right
- 1 do
2045 PixPtr
.R
:= not PixPtr
.R
;
2046 PixPtr
.G
:= not PixPtr
.G
;
2047 PixPtr
.B
:= not PixPtr
.B
;
2054 RegisterCanvas(TFastARGB32Canvas
);
2057 FreeAndNil(CanvasClasses
);
2062 -- TODOS ----------------------------------------------------
2063 - more more more ...
2064 - implement pen width everywhere
2065 - more objects (arc, polygon)
2067 -- 0.26.5 Changes/Bug Fixes ---------------------------------
2068 - Fixed bug that could raise floating point error in DrawAlpha
2069 and StretchDrawAlpha.
2070 - Fixed bug in TImagingCanvas.Line that caused not drawing
2071 of horz or vert lines.
2073 -- 0.26.3 Changes/Bug Fixes ---------------------------------
2074 - Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha)
2075 - Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation.
2076 - Added PremultiplyAlpha and UnPremultiplyAlpha methods.
2078 -- 0.26.1 Changes/Bug Fixes ---------------------------------
2079 - Added FillChannel methods.
2080 - Added FloodFill method.
2081 - Added GetHistogram method.
2082 - Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes
2083 (thanks to Carlos González).
2084 - Added TImagingCanvas.AdjustColorLevels method.
2086 -- 0.25.0 Changes/Bug Fixes ---------------------------------
2087 - Fixed error that could cause AV in linear and nonlinear filters.
2088 - Added blended rect filling function FillRectBlend.
2089 - Added drawing function with blending (DrawAlpha, StretchDrawAlpha,
2090 StretchDrawAdd, DrawBlend, StretchDrawBlend, ...)
2091 - Added non-linear filters (min, max, median).
2092 - Added point transforms (invert, contrast, gamma, brightness).
2094 -- 0.21 Changes/Bug Fixes -----------------------------------
2095 - Added some new filter kernels for convolution.
2096 - Added FillMode and PenMode properties.
2097 - Added FrameRect, Rectangle, Ellipse, and Line methods.
2098 - Removed HorzLine and VertLine from TFastARGB32Canvas - new versions
2099 in general canvas is now as fast as those in TFastARGB32Canvas
2100 (only in case of A8R8G8B8 images of course).
2101 - Added PenWidth property, updated HorzLine and VertLine to use it.
2103 -- 0.19 Changes/Bug Fixes -----------------------------------
2104 - added TFastARGB32Canvas
2105 - added convolutions, hline, vline
2106 - unit created, intial stuff added