956f491876d1146fe4b8ab51ce8ffd640d1aa12c
2 $Id: ImagingFormats.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
29 { This unit manages information about all image data formats and contains
30 low level format conversion, manipulation, and other related functions.}
33 {$I ImagingOptions.inc}
38 ImagingTypes
, Imaging
, ImagingUtility
;
41 TImageFormatInfoArray
= array[TImageFormat
] of PImageFormatInfo
;
42 PImageFormatInfoArray
= ^TImageFormatInfoArray
;
45 { Additional image manipulation functions (usually used internally by Imaging unit) }
48 { Color reduction operations.}
49 TReduceColorsAction
= (raCreateHistogram
, raUpdateHistogram
, raMakeColorMap
,
51 TReduceColorsActions
= set of TReduceColorsAction
;
53 AllReduceColorsActions
= [raCreateHistogram
, raUpdateHistogram
,
54 raMakeColorMap
, raMapImage
];
55 { Reduces the number of colors of source. Src is bits of source image
56 (ARGB or floating point) and Dst is in some indexed format. MaxColors
57 is the number of colors to which reduce and DstPal is palette to which
58 the resulting colors are written and it must be allocated to at least
59 MaxColors entries. ChannelMask is 'anded' with every pixel's channel value
60 when creating color histogram. If $FF is used all 8bits of color channels
61 are used which can be slow for large images with many colors so you can
62 use lower masks to speed it up.}
63 procedure ReduceColorsMedianCut(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
64 DstInfo
: PImageFormatInfo
; MaxColors
: LongInt; ChannelMask
: Byte;
65 DstPal
: PPalette32
; Actions
: TReduceColorsActions
= AllReduceColorsActions
);
66 { Stretches rectangle in source image to rectangle in destination image
67 using nearest neighbor filtering. It is fast but results look blocky
68 because there is no interpolation used. SrcImage and DstImage must be
69 in the same data format. Works for all data formats except special formats.}
70 procedure StretchNearest(const SrcImage
: TImageData
; SrcX
, SrcY
, SrcWidth
,
71 SrcHeight
: LongInt; var DstImage
: TImageData
; DstX
, DstY
, DstWidth
,
74 { Built-in sampling filters.}
75 TSamplingFilter
= (sfNearest
, sfLinear
, sfCosine
, sfHermite
, sfQuadratic
,
76 sfGaussian
, sfSpline
, sfLanczos
, sfMitchell
, sfCatmullRom
);
77 { Type of custom sampling function}
78 TFilterFunction
= function(Value
: Single): Single;
80 { Default resampling filter used for bicubic resizing.}
81 DefaultCubicFilter
= sfCatmullRom
;
83 { Built-in filter functions.}
84 SamplingFilterFunctions
: array[TSamplingFilter
] of TFilterFunction
;
85 { Default radii of built-in filter functions.}
86 SamplingFilterRadii
: array[TSamplingFilter
] of Single;
88 { Stretches rectangle in source image to rectangle in destination image
89 with resampling. One of built-in resampling filters defined by
90 Filter is used. Set WrapEdges to True for seamlessly tileable images.
91 SrcImage and DstImage must be in the same data format.
92 Works for all data formats except special and indexed formats.}
93 procedure StretchResample(const SrcImage
: TImageData
; SrcX
, SrcY
, SrcWidth
,
94 SrcHeight
: LongInt; var DstImage
: TImageData
; DstX
, DstY
, DstWidth
,
95 DstHeight
: LongInt; Filter
: TSamplingFilter
; WrapEdges
: Boolean = False); overload
;
96 { Stretches rectangle in source image to rectangle in destination image
97 with resampling. You can use custom sampling function and filter radius.
98 Set WrapEdges to True for seamlessly tileable images. SrcImage and DstImage
99 must be in the same data format.
100 Works for all data formats except special and indexed formats.}
101 procedure StretchResample(const SrcImage
: TImageData
; SrcX
, SrcY
, SrcWidth
,
102 SrcHeight
: LongInt; var DstImage
: TImageData
; DstX
, DstY
, DstWidth
,
103 DstHeight
: LongInt; Filter
: TFilterFunction
; Radius
: Single;
104 WrapEdges
: Boolean = False); overload
;
105 { Helper for functions that create mipmap levels. BiggerLevel is
106 valid image and SmallerLevel is empty zeroed image. SmallerLevel is created
107 with Width and Height dimensions and it is filled with pixels of BiggerLevel
108 using resampling filter specified by ImagingMipMapFilter option.
109 Uses StretchNearest and StretchResample internally so the same image data format
111 procedure FillMipMapLevel(const BiggerLevel
: TImageData
; Width
, Height
: LongInt;
112 var SmallerLevel
: TImageData
);
115 { Various helper & support functions }
117 { Copies Src pixel to Dest pixel. It is faster than System.Move procedure.}
118 procedure CopyPixel(Src
, Dest
: Pointer; BytesPerPixel
: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
119 { Compares Src pixel and Dest pixel. It is faster than SysUtils.CompareMem function.}
120 function ComparePixels(PixelA
, PixelB
: Pointer; BytesPerPixel
: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
121 { Translates pixel color in SrcFormat to DstFormat.}
122 procedure TranslatePixel(SrcPixel
, DstPixel
: Pointer; SrcFormat
,
123 DstFormat
: TImageFormat
; SrcPalette
, DstPalette
: PPalette32
);
124 { Clamps floating point pixel channel values to [0.0, 1.0] range.}
125 procedure ClampFloatPixel(var PixF
: TColorFPRec
); {$IFDEF USE_INLINE}inline;{$ENDIF}
127 { Adds padding bytes at the ends of scanlines. Bpp is the number of bytes per
128 pixel of source and WidthBytes is the number of bytes per scanlines of dest.}
129 procedure AddPadBytes(DataIn
: Pointer; DataOut
: Pointer; Width
, Height
,
130 Bpp
, WidthBytes
: LongInt);
131 { Removes padding from image with scanlines that have aligned sizes. Bpp is
132 the number of bytes per pixel of dest and WidthBytes is the number of bytes
133 per scanlines of source.}
134 procedure RemovePadBytes(DataIn
: Pointer; DataOut
: Pointer; Width
, Height
,
135 Bpp
, WidthBytes
: LongInt);
137 { Converts 1bit image data to 8bit (without scaling). Used by file
138 loaders for formats supporting 1bit images.}
139 procedure Convert1To8(DataIn
, DataOut
: Pointer; Width
, Height
,
140 WidthBytes
: LongInt);
141 { Converts 2bit image data to 8bit (without scaling). Used by file
142 loaders for formats supporting 2bit images.}
143 procedure Convert2To8(DataIn
, DataOut
: Pointer; Width
, Height
,
144 WidthBytes
: LongInt);
145 { Converts 4bit image data to 8bit (without scaling). Used by file
146 loaders for formats supporting 4bit images.}
147 procedure Convert4To8(DataIn
, DataOut
: Pointer; Width
, Height
,
148 WidthBytes
: LongInt);
150 { Helper function for image file loaders. Some 15 bit images (targas, bitmaps)
151 may contain 1 bit alpha but there is no indication of it. This function checks
152 all 16 bit(should be X1R5G5B5 or A1R5G5B5 format) pixels and some of them have
153 alpha bit set it returns True, otherwise False.}
154 function Has16BitImageAlpha(NumPixels
: LongInt; Data
: PWord): Boolean;
155 { Helper function for image file loaders. This function checks is similar
156 to Has16BitImageAlpha but works with A8R8G8B8 format.}
157 function Has32BitImageAlpha(NumPixels
: LongInt; Data
: PLongWord): Boolean;
158 { Provides indexed access to each line of pixels. Does not work with special
160 function GetScanLine(ImageBits
: Pointer; const FormatInfo
: TImageFormatInfo
;
161 LineWidth
, Index
: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
162 { Returns True if Format is valid image data format identifier.}
163 function IsImageFormatValid(Format
: TImageFormat
): Boolean;
165 { Converts 16bit half floating point value to 32bit Single.}
166 function HalfToFloat(Half
: THalfFloat
): Single;
167 { Converts 32bit Single to 16bit half floating point.}
168 function FloatToHalf(Float
: Single): THalfFloat
;
170 { Converts half float color value to single-precision floating point color.}
171 function ColorHalfToFloat(ColorHF
: TColorHFRec
): TColorFPRec
; {$IFDEF USE_INLINE}inline;{$ENDIF}
172 { Converts single-precision floating point color to half float color.}
173 function ColorFloatToHalf(ColorFP
: TColorFPRec
): TColorHFRec
; {$IFDEF USE_INLINE}inline;{$ENDIF}
175 { Makes image PalEntries x 1 big where each pixel has color of one pal entry.}
176 procedure VisualizePalette(Pal
: PPalette32
; Entries
: Integer; out PalImage
: TImageData
);
183 TCluster
= array of TPointRec
;
184 TMappingTable
= array of TCluster
;
186 { Helper function for resampling.}
187 function BuildMappingTable(DstLow
, DstHigh
, SrcLow
, SrcHigh
, SrcImageWidth
: LongInt;
188 Filter
: TFilterFunction
; Radius
: Single; WrapEdges
: Boolean): TMappingTable
;
189 { Helper function for resampling.}
190 procedure FindExtremes(const Map
: TMappingTable
; var MinPos
, MaxPos
: LongInt);
193 { Pixel readers/writers for different image formats }
195 { Returns pixel of image in any ARGB format. Channel values are scaled to 16 bits.}
196 procedure ChannelGetSrcPixel(Src
: PByte; SrcInfo
: PImageFormatInfo
;
197 var Pix
: TColor64Rec
);
198 { Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.}
199 procedure ChannelSetDstPixel(Dst
: PByte; DstInfo
: PImageFormatInfo
;
200 const Pix
: TColor64Rec
);
202 { Returns pixel of image in any grayscale format. Gray value is scaled to 64 bits
203 and alpha to 16 bits.}
204 procedure GrayGetSrcPixel(Src
: PByte; SrcInfo
: PImageFormatInfo
;
205 var Gray
: TColor64Rec
; var Alpha
: Word);
206 { Sets pixel of image in any grayscale format. Gray value must be scaled to 64 bits
207 and alpha to 16 bits.}
208 procedure GraySetDstPixel(Dst
: PByte; DstInfo
: PImageFormatInfo
;
209 const Gray
: TColor64Rec
; Alpha
: Word);
211 { Returns pixel of image in any floating point format. Channel values are
212 in range <0.0, 1.0>.}
213 procedure FloatGetSrcPixel(Src
: PByte; SrcInfo
: PImageFormatInfo
;
214 var Pix
: TColorFPRec
);
215 { Sets pixel of image in any floating point format. Channel values must be
216 in range <0.0, 1.0>.}
217 procedure FloatSetDstPixel(Dst
: PByte; DstInfo
: PImageFormatInfo
;
218 const Pix
: TColorFPRec
);
220 { Returns pixel of image in any indexed format. Returned value is index to
222 procedure IndexGetSrcPixel(Src
: PByte; SrcInfo
: PImageFormatInfo
;
223 var Index
: LongWord);
224 { Sets pixel of image in any indexed format. Index is index to the palette.}
225 procedure IndexSetDstPixel(Dst
: PByte; DstInfo
: PImageFormatInfo
;
229 { Pixel readers/writers for 32bit and FP colors}
231 { Function for getting pixel colors. Native pixel is read from Image and
232 then translated to 32 bit ARGB.}
233 function GetPixel32Generic(Bits
: Pointer; Info
: PImageFormatInfo
;
234 Palette
: PPalette32
): TColor32Rec
;
235 { Procedure for setting pixel colors. Input 32 bit ARGB color is translated to
236 native format and then written to Image.}
237 procedure SetPixel32Generic(Bits
: Pointer; Info
: PImageFormatInfo
;
238 Palette
: PPalette32
; const Color
: TColor32Rec
);
239 { Function for getting pixel colors. Native pixel is read from Image and
240 then translated to FP ARGB.}
241 function GetPixelFPGeneric(Bits
: Pointer; Info
: PImageFormatInfo
;
242 Palette
: PPalette32
): TColorFPRec
;
243 { Procedure for setting pixel colors. Input FP ARGB color is translated to
244 native format and then written to Image.}
245 procedure SetPixelFPGeneric(Bits
: Pointer; Info
: PImageFormatInfo
;
246 Palette
: PPalette32
; const Color
: TColorFPRec
);
249 { Image format conversion functions }
251 { Converts any ARGB format to any ARGB format.}
252 procedure ChannelToChannel(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
253 DstInfo
: PImageFormatInfo
);
254 { Converts any ARGB format to any grayscale format.}
255 procedure ChannelToGray(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
256 DstInfo
: PImageFormatInfo
);
257 { Converts any ARGB format to any floating point format.}
258 procedure ChannelToFloat(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
259 DstInfo
: PImageFormatInfo
);
260 { Converts any ARGB format to any indexed format.}
261 procedure ChannelToIndex(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
262 DstInfo
: PImageFormatInfo
; DstPal
: PPalette32
);
264 { Converts any grayscale format to any grayscale format.}
265 procedure GrayToGray(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
266 DstInfo
: PImageFormatInfo
);
267 { Converts any grayscale format to any ARGB format.}
268 procedure GrayToChannel(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
269 DstInfo
: PImageFormatInfo
);
270 { Converts any grayscale format to any floating point format.}
271 procedure GrayToFloat(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
272 DstInfo
: PImageFormatInfo
);
273 { Converts any grayscale format to any indexed format.}
274 procedure GrayToIndex(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
275 DstInfo
: PImageFormatInfo
; DstPal
: PPalette32
);
277 { Converts any floating point format to any floating point format.}
278 procedure FloatToFloat(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
279 DstInfo
: PImageFormatInfo
);
280 { Converts any floating point format to any ARGB format.}
281 procedure FloatToChannel(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
282 DstInfo
: PImageFormatInfo
);
283 { Converts any floating point format to any grayscale format.}
284 procedure FloatToGray(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
285 DstInfo
: PImageFormatInfo
);
286 { Converts any floating point format to any indexed format.}
287 procedure FloatToIndex(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
288 DstInfo
: PImageFormatInfo
; DstPal
: PPalette32
);
290 { Converts any indexed format to any indexed format.}
291 procedure IndexToIndex(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
292 DstInfo
: PImageFormatInfo
; SrcPal
, DstPal
: PPalette32
);
293 { Converts any indexed format to any ARGB format.}
294 procedure IndexToChannel(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
295 DstInfo
: PImageFormatInfo
; SrcPal
: PPalette32
);
296 { Converts any indexed format to any grayscale format.}
297 procedure IndexToGray(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
298 DstInfo
: PImageFormatInfo
; SrcPal
: PPalette32
);
299 { Converts any indexed format to any floating point format.}
300 procedure IndexToFloat(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
301 DstInfo
: PImageFormatInfo
; SrcPal
: PPalette32
);
304 { Color constructor functions }
306 { Constructs TColor24Rec color.}
307 function Color24(R
, G
, B
: Byte): TColor24Rec
; {$IFDEF USE_INLINE}inline;{$ENDIF}
308 { Constructs TColor32Rec color.}
309 function Color32(A
, R
, G
, B
: Byte): TColor32Rec
; {$IFDEF USE_INLINE}inline;{$ENDIF}
310 { Constructs TColor48Rec color.}
311 function Color48(R
, G
, B
: Word): TColor48Rec
; {$IFDEF USE_INLINE}inline;{$ENDIF}
312 { Constructs TColor64Rec color.}
313 function Color64(A
, R
, G
, B
: Word): TColor64Rec
; {$IFDEF USE_INLINE}inline;{$ENDIF}
314 { Constructs TColorFPRec color.}
315 function ColorFP(A
, R
, G
, B
: Single): TColorFPRec
; {$IFDEF USE_INLINE}inline;{$ENDIF}
316 { Constructs TColorHFRec color.}
317 function ColorHF(A
, R
, G
, B
: THalfFloat
): TColorHFRec
; {$IFDEF USE_INLINE}inline;{$ENDIF}
320 { Special formats conversion functions }
322 { Converts image to/from/between special image formats (dxtc, ...).}
323 procedure ConvertSpecial(var Image
: TImageData
; SrcInfo
,
324 DstInfo
: PImageFormatInfo
);
327 { Inits all image format information. Called internally on startup.}
328 procedure InitImageFormats(var Infos
: TImageFormatInfoArray
);
331 // Grayscale conversion channel weights
332 GrayConv
: TColorFPRec
= (B
: 0.114; G
: 0.587; R
: 0.299; A
: 0.0);
334 // Contants for converting integer colors to floating point
335 OneDiv8Bit
: Single = 1.0 / 255.0;
336 OneDiv16Bit
: Single = 1.0 / 65535.0;
340 { TImageFormatInfo member functions }
342 { Returns size in bytes of image in given standard format where
343 Size = Width * Height * Bpp.}
344 function GetStdPixelsSize(Format
: TImageFormat
; Width
, Height
: LongInt): LongInt; forward;
345 { Checks if Width and Height are valid for given standard format.}
346 procedure CheckStdDimensions(Format
: TImageFormat
; var Width
, Height
: LongInt); forward;
347 { Returns size in bytes of image in given DXT format.}
348 function GetDXTPixelsSize(Format
: TImageFormat
; Width
, Height
: LongInt): LongInt; forward;
349 { Checks if Width and Height are valid for given DXT format. If they are
350 not valid, they are changed to pass the check.}
351 procedure CheckDXTDimensions(Format
: TImageFormat
; var Width
, Height
: LongInt); forward;
352 { Returns size in bytes of image in BTC format.}
353 function GetBTCPixelsSize(Format
: TImageFormat
; Width
, Height
: LongInt): LongInt; forward;
355 { Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }
357 function GetPixel32ifA8R8G8B8(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColor32Rec
; forward;
358 procedure SetPixel32ifA8R8G8B8(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColor32Rec
); forward;
359 function GetPixelFPifA8R8G8B8(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColorFPRec
; forward;
360 procedure SetPixelFPifA8R8G8B8(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColorFPRec
); forward;
362 function GetPixel32Channel8Bit(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColor32Rec
; forward;
363 procedure SetPixel32Channel8Bit(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColor32Rec
); forward;
364 function GetPixelFPChannel8Bit(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColorFPRec
; forward;
365 procedure SetPixelFPChannel8Bit(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColorFPRec
); forward;
367 function GetPixelFPFloat32(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColorFPRec
; forward;
368 procedure SetPixelFPFloat32(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColorFPRec
); forward;
371 PFR3G3B2
: TPixelFormatInfo
;
372 PFX5R1G1B1
: TPixelFormatInfo
;
373 PFR5G6B5
: TPixelFormatInfo
;
374 PFA1R5G5B5
: TPixelFormatInfo
;
375 PFA4R4G4B4
: TPixelFormatInfo
;
376 PFX1R5G5B5
: TPixelFormatInfo
;
377 PFX4R4G4B4
: TPixelFormatInfo
;
378 FInfos
: PImageFormatInfoArray
;
381 // Free Pascal generates hundreds of warnings here
385 Index8Info
: TImageFormatInfo
= (
391 HasAlphaChannel
: True;
393 GetPixelsSize
: GetStdPixelsSize
;
394 CheckDimensions
: CheckStdDimensions
;
395 GetPixel32
: GetPixel32Generic
;
396 GetPixelFP
: GetPixelFPGeneric
;
397 SetPixel32
: SetPixel32Generic
;
398 SetPixelFP
: SetPixelFPGeneric
);
401 Gray8Info
: TImageFormatInfo
= (
406 HasGrayChannel
: True;
407 GetPixelsSize
: GetStdPixelsSize
;
408 CheckDimensions
: CheckStdDimensions
;
409 GetPixel32
: GetPixel32Channel8Bit
;
410 GetPixelFP
: GetPixelFPChannel8Bit
;
411 SetPixel32
: SetPixel32Channel8Bit
;
412 SetPixelFP
: SetPixelFPChannel8Bit
);
414 A8Gray8Info
: TImageFormatInfo
= (
419 HasGrayChannel
: True;
420 HasAlphaChannel
: True;
421 GetPixelsSize
: GetStdPixelsSize
;
422 CheckDimensions
: CheckStdDimensions
;
423 GetPixel32
: GetPixel32Channel8Bit
;
424 GetPixelFP
: GetPixelFPChannel8Bit
;
425 SetPixel32
: SetPixel32Channel8Bit
;
426 SetPixelFP
: SetPixelFPChannel8Bit
);
428 Gray16Info
: TImageFormatInfo
= (
433 HasGrayChannel
: True;
434 GetPixelsSize
: GetStdPixelsSize
;
435 CheckDimensions
: CheckStdDimensions
;
436 GetPixel32
: GetPixel32Generic
;
437 GetPixelFP
: GetPixelFPGeneric
;
438 SetPixel32
: SetPixel32Generic
;
439 SetPixelFP
: SetPixelFPGeneric
);
441 Gray32Info
: TImageFormatInfo
= (
446 HasGrayChannel
: True;
447 GetPixelsSize
: GetStdPixelsSize
;
448 CheckDimensions
: CheckStdDimensions
;
449 GetPixel32
: GetPixel32Generic
;
450 GetPixelFP
: GetPixelFPGeneric
;
451 SetPixel32
: SetPixel32Generic
;
452 SetPixelFP
: SetPixelFPGeneric
);
454 Gray64Info
: TImageFormatInfo
= (
459 HasGrayChannel
: True;
460 GetPixelsSize
: GetStdPixelsSize
;
461 CheckDimensions
: CheckStdDimensions
;
462 GetPixel32
: GetPixel32Generic
;
463 GetPixelFP
: GetPixelFPGeneric
;
464 SetPixel32
: SetPixel32Generic
;
465 SetPixelFP
: SetPixelFPGeneric
);
467 A16Gray16Info
: TImageFormatInfo
= (
472 HasGrayChannel
: True;
473 HasAlphaChannel
: True;
474 GetPixelsSize
: GetStdPixelsSize
;
475 CheckDimensions
: CheckStdDimensions
;
476 GetPixel32
: GetPixel32Generic
;
477 GetPixelFP
: GetPixelFPGeneric
;
478 SetPixel32
: SetPixel32Generic
;
479 SetPixelFP
: SetPixelFPGeneric
);
482 X5R1G1B1Info
: TImageFormatInfo
= (
487 UsePixelFormat
: True;
488 PixelFormat
: @PFX5R1G1B1
;
489 GetPixelsSize
: GetStdPixelsSize
;
490 CheckDimensions
: CheckStdDimensions
;
491 GetPixel32
: GetPixel32Generic
;
492 GetPixelFP
: GetPixelFPGeneric
;
493 SetPixel32
: SetPixel32Generic
;
494 SetPixelFP
: SetPixelFPGeneric
);
496 R3G3B2Info
: TImageFormatInfo
= (
501 UsePixelFormat
: True;
502 PixelFormat
: @PFR3G3B2
;
503 GetPixelsSize
: GetStdPixelsSize
;
504 CheckDimensions
: CheckStdDimensions
;
505 GetPixel32
: GetPixel32Generic
;
506 GetPixelFP
: GetPixelFPGeneric
;
507 SetPixel32
: SetPixel32Generic
;
508 SetPixelFP
: SetPixelFPGeneric
);
510 R5G6B5Info
: TImageFormatInfo
= (
515 UsePixelFormat
: True;
516 PixelFormat
: @PFR5G6B5
;
517 GetPixelsSize
: GetStdPixelsSize
;
518 CheckDimensions
: CheckStdDimensions
;
519 GetPixel32
: GetPixel32Generic
;
520 GetPixelFP
: GetPixelFPGeneric
;
521 SetPixel32
: SetPixel32Generic
;
522 SetPixelFP
: SetPixelFPGeneric
);
524 A1R5G5B5Info
: TImageFormatInfo
= (
529 HasAlphaChannel
: True;
530 UsePixelFormat
: True;
531 PixelFormat
: @PFA1R5G5B5
;
532 GetPixelsSize
: GetStdPixelsSize
;
533 CheckDimensions
: CheckStdDimensions
;
534 GetPixel32
: GetPixel32Generic
;
535 GetPixelFP
: GetPixelFPGeneric
;
536 SetPixel32
: SetPixel32Generic
;
537 SetPixelFP
: SetPixelFPGeneric
);
539 A4R4G4B4Info
: TImageFormatInfo
= (
544 HasAlphaChannel
: True;
545 UsePixelFormat
: True;
546 PixelFormat
: @PFA4R4G4B4
;
547 GetPixelsSize
: GetStdPixelsSize
;
548 CheckDimensions
: CheckStdDimensions
;
549 GetPixel32
: GetPixel32Generic
;
550 GetPixelFP
: GetPixelFPGeneric
;
551 SetPixel32
: SetPixel32Generic
;
552 SetPixelFP
: SetPixelFPGeneric
);
554 X1R5G5B5Info
: TImageFormatInfo
= (
559 UsePixelFormat
: True;
560 PixelFormat
: @PFX1R5G5B5
;
561 GetPixelsSize
: GetStdPixelsSize
;
562 CheckDimensions
: CheckStdDimensions
;
563 GetPixel32
: GetPixel32Generic
;
564 GetPixelFP
: GetPixelFPGeneric
;
565 SetPixel32
: SetPixel32Generic
;
566 SetPixelFP
: SetPixelFPGeneric
);
568 X4R4G4B4Info
: TImageFormatInfo
= (
573 UsePixelFormat
: True;
574 PixelFormat
: @PFX4R4G4B4
;
575 GetPixelsSize
: GetStdPixelsSize
;
576 CheckDimensions
: CheckStdDimensions
;
577 GetPixel32
: GetPixel32Generic
;
578 GetPixelFP
: GetPixelFPGeneric
;
579 SetPixel32
: SetPixel32Generic
;
580 SetPixelFP
: SetPixelFPGeneric
);
582 R8G8B8Info
: TImageFormatInfo
= (
587 GetPixelsSize
: GetStdPixelsSize
;
588 CheckDimensions
: CheckStdDimensions
;
589 GetPixel32
: GetPixel32Channel8Bit
;
590 GetPixelFP
: GetPixelFPChannel8Bit
;
591 SetPixel32
: SetPixel32Channel8Bit
;
592 SetPixelFP
: SetPixelFPChannel8Bit
);
594 A8R8G8B8Info
: TImageFormatInfo
= (
599 HasAlphaChannel
: True;
600 GetPixelsSize
: GetStdPixelsSize
;
601 CheckDimensions
: CheckStdDimensions
;
602 GetPixel32
: GetPixel32ifA8R8G8B8
;
603 GetPixelFP
: GetPixelFPifA8R8G8B8
;
604 SetPixel32
: SetPixel32ifA8R8G8B8
;
605 SetPixelFP
: SetPixelFPifA8R8G8B8
);
607 X8R8G8B8Info
: TImageFormatInfo
= (
612 GetPixelsSize
: GetStdPixelsSize
;
613 CheckDimensions
: CheckStdDimensions
;
614 GetPixel32
: GetPixel32Channel8Bit
;
615 GetPixelFP
: GetPixelFPChannel8Bit
;
616 SetPixel32
: SetPixel32Channel8Bit
;
617 SetPixelFP
: SetPixelFPChannel8Bit
);
619 R16G16B16Info
: TImageFormatInfo
= (
624 RBSwapFormat
: ifB16G16R16
;
625 GetPixelsSize
: GetStdPixelsSize
;
626 CheckDimensions
: CheckStdDimensions
;
627 GetPixel32
: GetPixel32Generic
;
628 GetPixelFP
: GetPixelFPGeneric
;
629 SetPixel32
: SetPixel32Generic
;
630 SetPixelFP
: SetPixelFPGeneric
);
632 A16R16G16B16Info
: TImageFormatInfo
= (
633 Format
: ifA16R16G16B16
;
634 Name
: 'A16R16G16B16';
637 HasAlphaChannel
: True;
638 RBSwapFormat
: ifA16B16G16R16
;
639 GetPixelsSize
: GetStdPixelsSize
;
640 CheckDimensions
: CheckStdDimensions
;
641 GetPixel32
: GetPixel32Generic
;
642 GetPixelFP
: GetPixelFPGeneric
;
643 SetPixel32
: SetPixel32Generic
;
644 SetPixelFP
: SetPixelFPGeneric
);
646 B16G16R16Info
: TImageFormatInfo
= (
652 RBSwapFormat
: ifR16G16B16
;
653 GetPixelsSize
: GetStdPixelsSize
;
654 CheckDimensions
: CheckStdDimensions
;
655 GetPixel32
: GetPixel32Generic
;
656 GetPixelFP
: GetPixelFPGeneric
;
657 SetPixel32
: SetPixel32Generic
;
658 SetPixelFP
: SetPixelFPGeneric
);
660 A16B16G16R16Info
: TImageFormatInfo
= (
661 Format
: ifA16B16G16R16
;
662 Name
: 'A16B16G16R16';
665 HasAlphaChannel
: True;
667 RBSwapFormat
: ifA16R16G16B16
;
668 GetPixelsSize
: GetStdPixelsSize
;
669 CheckDimensions
: CheckStdDimensions
;
670 GetPixel32
: GetPixel32Generic
;
671 GetPixelFP
: GetPixelFPGeneric
;
672 SetPixel32
: SetPixel32Generic
;
673 SetPixelFP
: SetPixelFPGeneric
);
675 // floating point formats
676 R32FInfo
: TImageFormatInfo
= (
681 IsFloatingPoint
: True;
682 GetPixelsSize
: GetStdPixelsSize
;
683 CheckDimensions
: CheckStdDimensions
;
684 GetPixel32
: GetPixel32Generic
;
685 GetPixelFP
: GetPixelFPFloat32
;
686 SetPixel32
: SetPixel32Generic
;
687 SetPixelFP
: SetPixelFPFloat32
);
689 A32R32G32B32FInfo
: TImageFormatInfo
= (
690 Format
: ifA32R32G32B32F
;
691 Name
: 'A32R32G32B32F';
694 HasAlphaChannel
: True;
695 IsFloatingPoint
: True;
696 RBSwapFormat
: ifA32B32G32R32F
;
697 GetPixelsSize
: GetStdPixelsSize
;
698 CheckDimensions
: CheckStdDimensions
;
699 GetPixel32
: GetPixel32Generic
;
700 GetPixelFP
: GetPixelFPFloat32
;
701 SetPixel32
: SetPixel32Generic
;
702 SetPixelFP
: SetPixelFPFloat32
);
704 A32B32G32R32FInfo
: TImageFormatInfo
= (
705 Format
: ifA32B32G32R32F
;
706 Name
: 'A32B32G32R32F';
709 HasAlphaChannel
: True;
710 IsFloatingPoint
: True;
712 RBSwapFormat
: ifA32R32G32B32F
;
713 GetPixelsSize
: GetStdPixelsSize
;
714 CheckDimensions
: CheckStdDimensions
;
715 GetPixel32
: GetPixel32Generic
;
716 GetPixelFP
: GetPixelFPFloat32
;
717 SetPixel32
: SetPixel32Generic
;
718 SetPixelFP
: SetPixelFPFloat32
);
720 R16FInfo
: TImageFormatInfo
= (
725 IsFloatingPoint
: True;
726 GetPixelsSize
: GetStdPixelsSize
;
727 CheckDimensions
: CheckStdDimensions
;
728 GetPixel32
: GetPixel32Generic
;
729 GetPixelFP
: GetPixelFPGeneric
;
730 SetPixel32
: SetPixel32Generic
;
731 SetPixelFP
: SetPixelFPGeneric
);
733 A16R16G16B16FInfo
: TImageFormatInfo
= (
734 Format
: ifA16R16G16B16F
;
735 Name
: 'A16R16G16B16F';
738 HasAlphaChannel
: True;
739 IsFloatingPoint
: True;
740 RBSwapFormat
: ifA16B16G16R16F
;
741 GetPixelsSize
: GetStdPixelsSize
;
742 CheckDimensions
: CheckStdDimensions
;
743 GetPixel32
: GetPixel32Generic
;
744 GetPixelFP
: GetPixelFPGeneric
;
745 SetPixel32
: SetPixel32Generic
;
746 SetPixelFP
: SetPixelFPGeneric
);
748 A16B16G16R16FInfo
: TImageFormatInfo
= (
749 Format
: ifA16B16G16R16F
;
750 Name
: 'A16B16G16R16F';
753 HasAlphaChannel
: True;
754 IsFloatingPoint
: True;
756 RBSwapFormat
: ifA16R16G16B16F
;
757 GetPixelsSize
: GetStdPixelsSize
;
758 CheckDimensions
: CheckStdDimensions
;
759 GetPixel32
: GetPixel32Generic
;
760 GetPixelFP
: GetPixelFPGeneric
;
761 SetPixel32
: SetPixel32Generic
;
762 SetPixelFP
: SetPixelFPGeneric
);
765 DXT1Info
: TImageFormatInfo
= (
769 HasAlphaChannel
: True;
771 GetPixelsSize
: GetDXTPixelsSize
;
772 CheckDimensions
: CheckDXTDimensions
;
773 SpecialNearestFormat
: ifA8R8G8B8
);
775 DXT3Info
: TImageFormatInfo
= (
779 HasAlphaChannel
: True;
781 GetPixelsSize
: GetDXTPixelsSize
;
782 CheckDimensions
: CheckDXTDimensions
;
783 SpecialNearestFormat
: ifA8R8G8B8
);
785 DXT5Info
: TImageFormatInfo
= (
789 HasAlphaChannel
: True;
791 GetPixelsSize
: GetDXTPixelsSize
;
792 CheckDimensions
: CheckDXTDimensions
;
793 SpecialNearestFormat
: ifA8R8G8B8
);
795 BTCInfo
: TImageFormatInfo
= (
799 HasAlphaChannel
: False;
801 GetPixelsSize
: GetBTCPixelsSize
;
802 CheckDimensions
: CheckDXTDimensions
;
803 SpecialNearestFormat
: ifGray8
);
805 ATI1NInfo
: TImageFormatInfo
= (
809 HasAlphaChannel
: False;
811 GetPixelsSize
: GetDXTPixelsSize
;
812 CheckDimensions
: CheckDXTDimensions
;
813 SpecialNearestFormat
: ifGray8
);
815 ATI2NInfo
: TImageFormatInfo
= (
819 HasAlphaChannel
: False;
821 GetPixelsSize
: GetDXTPixelsSize
;
822 CheckDimensions
: CheckDXTDimensions
;
823 SpecialNearestFormat
: ifA8R8G8B8
);
827 function PixelFormat(ABitCount
, RBitCount
, GBitCount
, BBitCount
: Byte): TPixelFormatInfo
; forward;
829 procedure InitImageFormats(var Infos
: TImageFormatInfoArray
);
833 Infos
[ifDefault
] := @A8R8G8B8Info
;
835 Infos
[ifIndex8
] := @Index8Info
;
837 Infos
[ifGray8
] := @Gray8Info
;
838 Infos
[ifA8Gray8
] := @A8Gray8Info
;
839 Infos
[ifGray16
] := @Gray16Info
;
840 Infos
[ifGray32
] := @Gray32Info
;
841 Infos
[ifGray64
] := @Gray64Info
;
842 Infos
[ifA16Gray16
] := @A16Gray16Info
;
844 Infos
[ifX5R1G1B1
] := @X5R1G1B1Info
;
845 Infos
[ifR3G3B2
] := @R3G3B2Info
;
846 Infos
[ifR5G6B5
] := @R5G6B5Info
;
847 Infos
[ifA1R5G5B5
] := @A1R5G5B5Info
;
848 Infos
[ifA4R4G4B4
] := @A4R4G4B4Info
;
849 Infos
[ifX1R5G5B5
] := @X1R5G5B5Info
;
850 Infos
[ifX4R4G4B4
] := @X4R4G4B4Info
;
851 Infos
[ifR8G8B8
] := @R8G8B8Info
;
852 Infos
[ifA8R8G8B8
] := @A8R8G8B8Info
;
853 Infos
[ifX8R8G8B8
] := @X8R8G8B8Info
;
854 Infos
[ifR16G16B16
] := @R16G16B16Info
;
855 Infos
[ifA16R16G16B16
] := @A16R16G16B16Info
;
856 Infos
[ifB16G16R16
] := @B16G16R16Info
;
857 Infos
[ifA16B16G16R16
] := @A16B16G16R16Info
;
858 // floating point formats
859 Infos
[ifR32F
] := @R32FInfo
;
860 Infos
[ifA32R32G32B32F
] := @A32R32G32B32FInfo
;
861 Infos
[ifA32B32G32R32F
] := @A32B32G32R32FInfo
;
862 Infos
[ifR16F
] := @R16FInfo
;
863 Infos
[ifA16R16G16B16F
] := @A16R16G16B16FInfo
;
864 Infos
[ifA16B16G16R16F
] := @A16B16G16R16FInfo
;
866 Infos
[ifDXT1
] := @DXT1Info
;
867 Infos
[ifDXT3
] := @DXT3Info
;
868 Infos
[ifDXT5
] := @DXT5Info
;
869 Infos
[ifBTC
] := @BTCInfo
;
870 Infos
[ifATI1N
] := @ATI1NInfo
;
871 Infos
[ifATI2N
] := @ATI2NInfo
;
873 PFR3G3B2
:= PixelFormat(0, 3, 3, 2);
874 PFX5R1G1B1
:= PixelFormat(0, 1, 1, 1);
875 PFR5G6B5
:= PixelFormat(0, 5, 6, 5);
876 PFA1R5G5B5
:= PixelFormat(1, 5, 5, 5);
877 PFA4R4G4B4
:= PixelFormat(4, 4, 4, 4);
878 PFX1R5G5B5
:= PixelFormat(0, 5, 5, 5);
879 PFX4R4G4B4
:= PixelFormat(0, 4, 4, 4);
883 { Internal unit helper functions }
885 function PixelFormat(ABitCount
, RBitCount
, GBitCount
, BBitCount
: Byte): TPixelFormatInfo
;
887 Result
.ABitMask
:= ((1 shl ABitCount
) - 1) shl (RBitCount
+ GBitCount
+
889 Result
.RBitMask
:= ((1 shl RBitCount
) - 1) shl (GBitCount
+ BBitCount
);
890 Result
.GBitMask
:= ((1 shl GBitCount
) - 1) shl (BBitCount
);
891 Result
.BBitMask
:= (1 shl BBitCount
) - 1;
892 Result
.ABitCount
:= ABitCount
;
893 Result
.RBitCount
:= RBitCount
;
894 Result
.GBitCount
:= GBitCount
;
895 Result
.BBitCount
:= BBitCount
;
896 Result
.AShift
:= RBitCount
+ GBitCount
+ BBitCount
;
897 Result
.RShift
:= GBitCount
+ BBitCount
;
898 Result
.GShift
:= BBitCount
;
900 Result
.ARecDiv
:= Max(1, Pow2Int(Result
.ABitCount
) - 1);
901 Result
.RRecDiv
:= Max(1, Pow2Int(Result
.RBitCount
) - 1);
902 Result
.GRecDiv
:= Max(1, Pow2Int(Result
.GBitCount
) - 1);
903 Result
.BRecDiv
:= Max(1, Pow2Int(Result
.BBitCount
) - 1);
906 function PixelFormatMask(ABitMask
, RBitMask
, GBitMask
, BBitMask
: LongWord): TPixelFormatInfo
;
908 function GetBitCount(B
: LongWord): LongWord;
913 while (I
< 31) and (((1 shl I
) and B
) = 0) do
916 while ((1 shl I
) and B
) <> 0 do
924 Result
:= PixelFormat(GetBitCount(ABitMask
), GetBitCount(RBitMask
),
925 GetBitCount(GBitMask
), GetBitCount(BBitMask
));
928 function PFSetARGB(const PF
: TPixelFormatInfo
; A
, R
, G
, B
: Byte): TColor32
;
929 {$IFDEF USE_INLINE}inline;{$ENDIF}
933 (A
shl ABitCount
shr 8 shl AShift
) or
934 (R
shl RBitCount
shr 8 shl RShift
) or
935 (G
shl GBitCount
shr 8 shl GShift
) or
936 (B
shl BBitCount
shr 8 shl BShift
);
939 procedure PFGetARGB(const PF
: TPixelFormatInfo
; Color
: LongWord;
940 var A
, R
, G
, B
: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF}
944 A
:= (Color
and ABitMask
shr AShift
) * 255 div ARecDiv
;
945 R
:= (Color
and RBitMask
shr RShift
) * 255 div RRecDiv
;
946 G
:= (Color
and GBitMask
shr GShift
) * 255 div GRecDiv
;
947 B
:= (Color
and BBitMask
shl BShift
) * 255 div BRecDiv
;
951 function PFSetColor(const PF
: TPixelFormatInfo
; ARGB
: TColor32
): LongWord;
952 {$IFDEF USE_INLINE}inline;{$ENDIF}
956 (Byte(ARGB
shr 24) shl ABitCount
shr 8 shl AShift
) or
957 (Byte(ARGB
shr 16) shl RBitCount
shr 8 shl RShift
) or
958 (Byte(ARGB
shr 8) shl GBitCount
shr 8 shl GShift
) or
959 (Byte(ARGB
) shl BBitCount
shr 8 shl BShift
);
962 function PFGetColor(const PF
: TPixelFormatInfo
; Color
: LongWord): TColor32
;
963 {$IFDEF USE_INLINE}inline;{$ENDIF}
966 with PF
, TColor32Rec(Result
) do
968 A
:= (Color
and ABitMask
shr AShift
) * 255 div ARecDiv
;
969 R
:= (Color
and RBitMask
shr RShift
) * 255 div RRecDiv
;
970 G
:= (Color
and GBitMask
shr GShift
) * 255 div GRecDiv
;
971 B
:= (Color
and BBitMask
shl BShift
) * 255 div BRecDiv
;
976 { Color constructor functions }
979 function Color24(R
, G
, B
: Byte): TColor24Rec
;
986 function Color32(A
, R
, G
, B
: Byte): TColor32Rec
;
994 function Color48(R
, G
, B
: Word): TColor48Rec
;
1001 function Color64(A
, R
, G
, B
: Word): TColor64Rec
;
1009 function ColorFP(A
, R
, G
, B
: Single): TColorFPRec
;
1017 function ColorHF(A
, R
, G
, B
: THalfFloat
): TColorHFRec
;
1026 { Additional image manipulation functions (usually used internally by Imaging unit) }
1029 MaxPossibleColors
= 4096;
1037 PColorBin
= ^TColorBin
;
1044 THashTable
= array[0..HashSize
- 1] of PColorBin
;
1050 BMin
, BMax
: LongInt;
1052 Represented
: TColor32Rec
;
1058 Box
: array[0..MaxPossibleColors
- 1] of TColorBox
;
1060 BoxesCreated
: Boolean = False;
1062 procedure ReduceColorsMedianCut(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
1063 DstInfo
: PImageFormatInfo
; MaxColors
: LongInt; ChannelMask
: Byte;
1064 DstPal
: PPalette32
; Actions
: TReduceColorsActions
);
1066 procedure CreateHistogram (Src
: PByte; SrcInfo
: PImageFormatInfo
;
1074 for I
:= 0 to NumPixels
- 1 do
1076 Col
:= GetPixel32Generic(Src
, SrcInfo
, nil);
1077 A
:= Col
.A
and ChannelMask
;
1078 R
:= Col
.R
and ChannelMask
;
1079 G
:= Col
.G
and ChannelMask
;
1080 B
:= Col
.B
and ChannelMask
;
1082 Addr
:= (A
+ 11 * B
+ 59 * R
+ 119 * G
) mod HashSize
;
1085 while (PC
<> nil) and ((PC
.Color
.R
<> R
) or (PC
.Color
.G
<> G
) or
1086 (PC
.Color
.B
<> B
) or (PC
.Color
.A
<> A
)) do
1097 PC
.Next
:= Table
[Addr
];
1102 Inc(Src
, SrcInfo
.BytesPerPixel
);
1106 procedure InitBox (var Box
: TColorBox
);
1120 procedure ChangeBox (var Box
: TColorBox
; const C
: TColorBin
);
1124 if A
< Box
.AMin
then Box
.AMin
:= A
;
1125 if A
> Box
.AMax
then Box
.AMax
:= A
;
1126 if B
< Box
.BMin
then Box
.BMin
:= B
;
1127 if B
> Box
.BMax
then Box
.BMax
:= B
;
1128 if G
< Box
.GMin
then Box
.GMin
:= G
;
1129 if G
> Box
.GMax
then Box
.GMax
:= G
;
1130 if R
< Box
.RMin
then Box
.RMin
:= R
;
1131 if R
> Box
.RMax
then Box
.RMax
:= R
;
1133 Inc(Box
.Total
, C
.Number
);
1136 procedure MakeColormap
;
1140 Cut
, LargestIdx
, Largest
, Size
, S
: LongInt;
1141 CutA
, CutR
, CutG
, CutB
: Boolean;
1142 SumA
, SumR
, SumG
, SumB
: LongInt;
1148 while (I
< HashSize
) and (Table
[I
] = nil) do
1150 if I
< HashSize
then
1152 // put all colors into Box[0]
1156 while CP
.Next
<> nil do
1158 ChangeBox(Box
[0], CP
^);
1161 ChangeBox(Box
[0], CP
^);
1162 CP
.Next
:= Box
[0].List
;
1163 Box
[0].List
:= Table
[I
];
1167 until (I
= HashSize
) or (Table
[I
] <> nil);
1169 // now all colors are in Box[0]
1171 // cut one color box
1173 for I
:= 0 to Boxes
- 1 do
1176 Size
:= (AMax
- AMin
) * AlphaWeight
;
1177 S
:= (RMax
- RMin
) * RedWeight
;
1180 S
:= (GMax
- GMin
) * GreenWeight
;
1183 S
:= (BMax
- BMin
) * BlueWeight
;
1186 if Size
> Largest
then
1194 // cutting Box[LargestIdx] into Box[LargestIdx] and Box[Boxes]
1199 with Box
[LargestIdx
] do
1201 if (AMax
- AMin
) * AlphaWeight
= Largest
then
1203 Cut
:= (AMax
+ AMin
) shr 1;
1207 if (RMax
- RMin
) * RedWeight
= Largest
then
1209 Cut
:= (RMax
+ RMin
) shr 1;
1213 if (GMax
- GMin
) * GreenWeight
= Largest
then
1215 Cut
:= (GMax
+ GMin
) shr 1;
1220 Cut
:= (BMax
+ BMin
) shr 1;
1225 InitBox(Box
[LargestIdx
]);
1226 InitBox(Box
[Boxes
]);
1228 // distribute one color
1232 if (CutA
and (A
<= Cut
)) or (CutR
and (R
<= Cut
)) or
1233 (CutG
and (G
<= Cut
)) or (CutB
and (B
<= Cut
)) then
1238 CP
.Next
:= Box
[i
].List
;
1240 ChangeBox(Box
[i
], CP
^);
1245 until (Boxes
= MaxColors
) or (Largest
= 0);
1246 // compute box representation
1247 for I
:= 0 to Boxes
- 1 do
1255 Inc(SumR
, CP
.Color
.R
* CP
.Number
);
1256 Inc(SumG
, CP
.Color
.G
* CP
.Number
);
1257 Inc(SumB
, CP
.Color
.B
* CP
.Number
);
1258 Inc(SumA
, CP
.Color
.A
* CP
.Number
);
1259 Box
[I
].List
:= CP
.Next
;
1261 until Box
[I
].List
= nil;
1264 Represented
.A
:= SumA
div Total
;
1265 Represented
.R
:= SumR
div Total
;
1266 Represented
.G
:= SumG
div Total
;
1267 Represented
.B
:= SumB
div Total
;
1268 AMin
:= AMin
and ChannelMask
;
1269 RMin
:= RMin
and ChannelMask
;
1270 GMin
:= GMin
and ChannelMask
;
1271 BMin
:= BMin
and ChannelMask
;
1272 AMax
:= (AMax
and ChannelMask
) + (not ChannelMask
);
1273 RMax
:= (RMax
and ChannelMask
) + (not ChannelMask
);
1274 GMax
:= (GMax
and ChannelMask
) + (not ChannelMask
);
1275 BMax
:= (BMax
and ChannelMask
) + (not ChannelMask
);
1279 for I
:= 0 to Boxes
- 2 do
1282 for J
:= I
to Boxes
- 1 do
1283 if Box
[J
].Total
> Largest
then
1285 Largest
:= Box
[J
].Total
;
1288 if LargestIdx
<> I
then
1291 Box
[I
] := Box
[LargestIdx
];
1292 Box
[LargestIdx
] := Temp
;
1298 procedure FillOutputPalette
;
1302 FillChar(DstPal
^, SizeOf(TColor32Rec
) * MaxColors
, $FF);
1303 for I
:= 0 to MaxColors
- 1 do
1306 with Box
[I
].Represented
do
1314 DstPal
[I
].Color
:= $FF000000;
1318 function MapColor(const Col
: TColor32Rec
) : LongInt;
1324 while (I
< Boxes
) and ((Box
[I
].AMin
> A
) or (Box
[I
].AMax
< A
) or
1325 (Box
[I
].RMin
> R
) or (Box
[I
].RMax
< R
) or (Box
[I
].GMin
> G
) or
1326 (Box
[I
].GMax
< G
) or (Box
[I
].BMin
> B
) or (Box
[I
].BMax
< B
)) do
1334 procedure MapImage(Src
, Dst
: PByte; SrcInfo
, DstInfo
: PImageFormatInfo
);
1339 for I
:= 0 to NumPixels
- 1 do
1341 Col
:= GetPixel32Generic(Src
, SrcInfo
, nil);
1342 IndexSetDstPixel(Dst
, DstInfo
, MapColor(Col
));
1343 Inc(Src
, SrcInfo
.BytesPerPixel
);
1344 Inc(Dst
, DstInfo
.BytesPerPixel
);
1349 MaxColors
:= ClampInt(MaxColors
, 2, MaxPossibleColors
);
1351 if (raUpdateHistogram
in Actions
) or (raMapImage
in Actions
) then
1353 Assert(not SrcInfo
.IsSpecial
);
1354 Assert(not SrcInfo
.IsIndexed
);
1357 if raCreateHistogram
in Actions
then
1358 FillChar(Table
, SizeOf(Table
), 0);
1360 if raUpdateHistogram
in Actions
then
1361 CreateHistogram(Src
, SrcInfo
, ChannelMask
);
1363 if raMakeColorMap
in Actions
then
1369 if raMapImage
in Actions
then
1370 MapImage(Src
, Dst
, SrcInfo
, DstInfo
);
1373 procedure StretchNearest(const SrcImage
: TImageData
; SrcX
, SrcY
, SrcWidth
,
1374 SrcHeight
: LongInt; var DstImage
: TImageData
; DstX
, DstY
, DstWidth
,
1375 DstHeight
: LongInt);
1377 Info
: TImageFormatInfo
;
1378 ScaleX
, ScaleY
, X
, Y
, Xp
, Yp
: LongInt;
1379 DstPixel
, SrcLine
: PByte;
1381 GetImageFormatInfo(SrcImage
.Format
, Info
);
1382 Assert(SrcImage
.Format
= DstImage
.Format
);
1383 Assert(not Info
.IsSpecial
);
1384 // Use integers instead of floats for source image pixel coords
1385 // Xp and Yp coords must be shifted right to get read source image coords
1386 ScaleX
:= (SrcWidth
shl 16) div DstWidth
;
1387 ScaleY
:= (SrcHeight
shl 16) div DstHeight
;
1389 for Y
:= 0 to DstHeight
- 1 do
1392 SrcLine
:= @PByteArray(SrcImage
.Bits
)[((SrcY
+ Yp
shr 16) * SrcImage
.Width
+ SrcX
) * Info
.BytesPerPixel
];
1393 DstPixel
:= @PByteArray(DstImage
.Bits
)[((DstY
+ Y
) * DstImage
.Width
+ DstX
) * Info
.BytesPerPixel
];
1394 for X
:= 0 to DstWidth
- 1 do
1396 case Info
.BytesPerPixel
of
1397 1: PByte(DstPixel
)^ := PByteArray(SrcLine
)[Xp
shr 16];
1398 2: PWord(DstPixel
)^ := PWordArray(SrcLine
)[Xp
shr 16];
1399 3: PColor24Rec(DstPixel
)^ := PPalette24(SrcLine
)[Xp
shr 16];
1400 4: PColor32(DstPixel
)^ := PLongWordArray(SrcLine
)[Xp
shr 16];
1401 6: PColor48Rec(DstPixel
)^ := PColor48RecArray(SrcLine
)[Xp
shr 16];
1402 8: PColor64(DstPixel
)^ := PInt64Array(SrcLine
)[Xp
shr 16];
1403 16: PColorFPRec(DstPixel
)^ := PColorFPRecArray(SrcLine
)[Xp
shr 16];
1405 Inc(DstPixel
, Info
.BytesPerPixel
);
1412 { Filter function for nearest filtering. Also known as box filter.}
1413 function FilterNearest(Value
: Single): Single;
1415 if (Value
> -0.5) and (Value
<= 0.5) then
1421 { Filter function for linear filtering. Also known as triangle or Bartlett filter.}
1422 function FilterLinear(Value
: Single): Single;
1427 Result
:= 1.0 - Value
1433 function FilterCosine(Value
: Single): Single;
1436 if Abs(Value
) < 1 then
1437 Result
:= (Cos(Value
* Pi
) + 1) / 2;
1440 { f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1 }
1441 function FilterHermite(Value
: Single): Single;
1446 Result
:= (2 * Value
- 3) * Sqr(Value
) + 1
1451 { Quadratic filter. Also known as Bell.}
1452 function FilterQuadratic(Value
: Single): Single;
1457 Result
:= 0.75 - Sqr(Value
)
1461 Value
:= Value
- 1.5;
1462 Result
:= 0.5 * Sqr(Value
);
1469 function FilterGaussian(Value
: Single): Single;
1471 Result
:= Exp(-2.0 * Sqr(Value
)) * Sqrt(2.0 / Pi
);
1474 { 4th order (cubic) b-spline filter.}
1475 function FilterSpline(Value
: Single): Single;
1484 Result
:= 0.5 * Temp
* Value
- Temp
+ 2.0 / 3.0;
1489 Value
:= 2.0 - Value
;
1490 Result
:= Sqr(Value
) * Value
/ 6.0;
1496 { Lanczos-windowed sinc filter.}
1497 function FilterLanczos(Value
: Single): Single;
1499 function SinC(Value
: Single): Single;
1501 if Value
<> 0.0 then
1503 Value
:= Value
* Pi
;
1504 Result
:= Sin(Value
) / Value
;
1514 Result
:= SinC(Value
) * SinC(Value
/ 3.0)
1519 { Micthell cubic filter.}
1520 function FilterMitchell(Value
: Single): Single;
1532 Value
:= (((12.0 - 9.0 * B
- 6.0 * C
) * (Value
* Temp
)) +
1533 ((-18.0 + 12.0 * B
+ 6.0 * C
) * Temp
) +
1535 Result
:= Value
/ 6.0;
1540 Value
:= (((-B
- 6.0 * C
) * (Value
* Temp
)) +
1541 ((6.0 * B
+ 30.0 * C
) * Temp
) +
1542 ((-12.0 * B
- 48.0 * C
) * Value
) +
1543 (8.0 * B
+ 24.0 * C
));
1544 Result
:= Value
/ 6.0;
1550 { CatmullRom spline filter.}
1551 function FilterCatmullRom(Value
: Single): Single;
1556 Result
:= 0.5 * (2.0 + Sqr(Value
) * (-5.0 + 3.0 * Value
))
1559 Result
:= 0.5 * (4.0 + Value
* (-8.0 + Value
* (5.0 - Value
)))
1564 procedure StretchResample(const SrcImage
: TImageData
; SrcX
, SrcY
, SrcWidth
,
1565 SrcHeight
: LongInt; var DstImage
: TImageData
; DstX
, DstY
, DstWidth
,
1566 DstHeight
: LongInt; Filter
: TSamplingFilter
; WrapEdges
: Boolean);
1568 // Calls the other function with filter function and radius defined by Filter
1569 StretchResample(SrcImage
, SrcX
, SrcY
, SrcWidth
, SrcHeight
, DstImage
, DstX
, DstY
,
1570 DstWidth
, DstHeight
, SamplingFilterFunctions
[Filter
], SamplingFilterRadii
[Filter
],
1575 FullEdge
: Boolean = True;
1577 { The following resampling code is modified and extended code from Graphics32
1578 library by Alex A. Denisov.}
1579 function BuildMappingTable(DstLow
, DstHigh
, SrcLow
, SrcHigh
, SrcImageWidth
: LongInt;
1580 Filter
: TFilterFunction
; Radius
: Single; WrapEdges
: Boolean): TMappingTable
;
1582 I
, J
, K
, N
: LongInt;
1583 Left
, Right
, SrcWidth
, DstWidth
: LongInt;
1584 Weight
, Scale
, Center
, Count
: Single;
1588 SrcWidth
:= SrcHigh
- SrcLow
;
1589 DstWidth
:= DstHigh
- DstLow
;
1591 // Check some special cases
1592 if SrcWidth
= 1 then
1594 SetLength(Result
, DstWidth
);
1595 for I
:= 0 to DstWidth
- 1 do
1597 SetLength(Result
[I
], 1);
1598 Result
[I
][0].Pos
:= 0;
1599 Result
[I
][0].Weight
:= 1.0;
1604 if (SrcWidth
= 0) or (DstWidth
= 0) then
1608 Scale
:= DstWidth
/ SrcWidth
1610 Scale
:= (DstWidth
- 1) / (SrcWidth
- 1);
1612 SetLength(Result
, DstWidth
);
1614 // Pre-calculate filter contributions for a row or column
1617 Assert(Length(Result
) = 1);
1618 SetLength(Result
[0], 1);
1619 Result
[0][0].Pos
:= (SrcLow
+ SrcHigh
) div 2;
1620 Result
[0][0].Weight
:= 1.0;
1622 else if Scale
< 1.0 then
1624 // Sub-sampling - scales from bigger to smaller
1625 Radius
:= Radius
/ Scale
;
1626 for I
:= 0 to DstWidth
- 1 do
1629 Center
:= SrcLow
- 0.5 + (I
+ 0.5) / Scale
1631 Center
:= SrcLow
+ I
/ Scale
;
1632 Left
:= Floor(Center
- Radius
);
1633 Right
:= Ceil(Center
+ Radius
);
1635 for J
:= Left
to Right
do
1637 Weight
:= Filter((Center
- J
) * Scale
) * Scale
;
1638 if Weight
<> 0.0 then
1640 Count
:= Count
+ Weight
;
1641 K
:= Length(Result
[I
]);
1642 SetLength(Result
[I
], K
+ 1);
1643 Result
[I
][K
].Pos
:= ClampInt(J
, SrcLow
, SrcHigh
- 1);
1644 Result
[I
][K
].Weight
:= Weight
;
1647 if Length(Result
[I
]) = 0 then
1649 SetLength(Result
[I
], 1);
1650 Result
[I
][0].Pos
:= Floor(Center
);
1651 Result
[I
][0].Weight
:= 1.0;
1653 else if Count
<> 0.0 then
1654 Result
[I
][K
div 2].Weight
:= Result
[I
][K
div 2].Weight
- Count
;
1657 else // if Scale > 1.0 then
1659 // Super-sampling - scales from smaller to bigger
1660 Scale
:= 1.0 / Scale
;
1661 for I
:= 0 to DstWidth
- 1 do
1664 Center
:= SrcLow
- 0.5 + (I
+ 0.5) * Scale
1666 Center
:= SrcLow
+ I
* Scale
;
1667 Left
:= Floor(Center
- Radius
);
1668 Right
:= Ceil(Center
+ Radius
);
1670 for J
:= Left
to Right
do
1672 Weight
:= Filter(Center
- J
);
1673 if Weight
<> 0.0 then
1675 Count
:= Count
+ Weight
;
1676 K
:= Length(Result
[I
]);
1677 SetLength(Result
[I
], K
+ 1);
1682 N
:= SrcImageWidth
+ J
1683 else if J
>= SrcImageWidth
then
1684 N
:= J
- SrcImageWidth
1686 N
:= ClampInt(J
, SrcLow
, SrcHigh
- 1);
1689 N
:= ClampInt(J
, SrcLow
, SrcHigh
- 1);
1691 Result
[I
][K
].Pos
:= N
;
1692 Result
[I
][K
].Weight
:= Weight
;
1695 if Count
<> 0.0 then
1696 Result
[I
][K
div 2].Weight
:= Result
[I
][K
div 2].Weight
- Count
;
1701 procedure FindExtremes(const Map
: TMappingTable
; var MinPos
, MaxPos
: LongInt);
1705 if Length(Map
) > 0 then
1707 MinPos
:= Map
[0][0].Pos
;
1709 for I
:= 0 to Length(Map
) - 1 do
1710 for J
:= 0 to Length(Map
[I
]) - 1 do
1712 if MinPos
> Map
[I
][J
].Pos
then
1713 MinPos
:= Map
[I
][J
].Pos
;
1714 if MaxPos
< Map
[I
][J
].Pos
then
1715 MaxPos
:= Map
[I
][J
].Pos
;
1720 procedure StretchResample(const SrcImage
: TImageData
; SrcX
, SrcY
, SrcWidth
,
1721 SrcHeight
: LongInt; var DstImage
: TImageData
; DstX
, DstY
, DstWidth
,
1722 DstHeight
: LongInt; Filter
: TFilterFunction
; Radius
: Single; WrapEdges
: Boolean);
1724 Channel8BitMax
: Single = 255.0;
1726 TBufferItem
= record
1727 A
, R
, G
, B
: Integer;
1730 MapX
, MapY
: TMappingTable
;
1731 I
, J
, X
, Y
: LongInt;
1732 XMinimum
, XMaximum
: LongInt;
1733 LineBufferFP
: array of TColorFPRec
;
1734 LineBufferInt
: array of TBufferItem
;
1735 ClusterX
, ClusterY
: TCluster
;
1736 Weight
, AccumA
, AccumR
, AccumG
, AccumB
: Single;
1737 IWeight
, IAccumA
, IAccumR
, IAccumG
, IAccumB
: Integer;
1739 SrcColor
: TColor32Rec
;
1740 SrcFloat
: TColorFPRec
;
1741 Info
: TImageFormatInfo
;
1742 BytesPerChannel
: LongInt;
1743 ChannelValueMax
, InvChannelValueMax
: Single;
1744 UseOptimizedVersion
: Boolean;
1746 GetImageFormatInfo(SrcImage
.Format
, Info
);
1747 Assert(SrcImage
.Format
= DstImage
.Format
);
1748 Assert(not Info
.IsSpecial
and not Info
.IsIndexed
);
1749 BytesPerChannel
:= Info
.BytesPerPixel
div Info
.ChannelCount
;
1750 UseOptimizedVersion
:= (BytesPerChannel
= 1) and not Info
.UsePixelFormat
;
1752 // Create horizontal and vertical mapping tables
1753 MapX
:= BuildMappingTable(DstX
, DstX
+ DstWidth
, SrcX
, SrcX
+ SrcWidth
,
1754 SrcImage
.Width
, Filter
, Radius
, WrapEdges
);
1755 MapY
:= BuildMappingTable(DstY
, DstY
+ DstHeight
, SrcY
, SrcY
+ SrcHeight
,
1756 SrcImage
.Height
, Filter
, Radius
, WrapEdges
);
1758 if (MapX
= nil) or (MapY
= nil) then
1765 // Find min and max X coords of pixels that will contribute to target image
1766 FindExtremes(MapX
, XMinimum
, XMaximum
);
1768 if not UseOptimizedVersion
then
1770 SetLength(LineBufferFP
, XMaximum
- XMinimum
+ 1);
1771 // Following code works for the rest of data formats
1772 for J
:= 0 to DstHeight
- 1 do
1774 // First for each pixel in the current line sample vertically
1775 // and store results in LineBuffer. Then sample horizontally
1776 // using values in LineBuffer.
1777 ClusterY
:= MapY
[J
];
1778 for X
:= XMinimum
to XMaximum
do
1780 // Clear accumulators
1785 // For each pixel in line compute weighted sum of pixels
1786 // in source column that will contribute to this pixel
1787 for Y
:= 0 to Length(ClusterY
) - 1 do
1789 // Accumulate this pixel's weighted value
1790 Weight
:= ClusterY
[Y
].Weight
;
1791 SrcFloat
:= Info
.GetPixelFP(@PByteArray(SrcImage
.Bits
)[(ClusterY
[Y
].Pos
* SrcImage
.Width
+ X
) * Info
.BytesPerPixel
], @Info
, nil);
1792 AccumB
:= AccumB
+ SrcFloat
.B
* Weight
;
1793 AccumG
:= AccumG
+ SrcFloat
.G
* Weight
;
1794 AccumR
:= AccumR
+ SrcFloat
.R
* Weight
;
1795 AccumA
:= AccumA
+ SrcFloat
.A
* Weight
;
1797 // Store accumulated value for this pixel in buffer
1798 with LineBufferFP
[X
- XMinimum
] do
1807 DstLine
:= @PByteArray(DstImage
.Bits
)[((J
+ DstY
) * DstImage
.Width
+ DstX
) * Info
.BytesPerPixel
];
1808 // Now compute final colors for targte pixels in the current row
1809 // by sampling horizontally
1810 for I
:= 0 to DstWidth
- 1 do
1812 ClusterX
:= MapX
[I
];
1813 // Clear accumulator
1818 // Compute weighted sum of values (which are already
1819 // computed weighted sums of pixels in source columns stored in LineBuffer)
1820 // that will contribute to the current target pixel
1821 for X
:= 0 to Length(ClusterX
) - 1 do
1823 Weight
:= ClusterX
[X
].Weight
;
1824 with LineBufferFP
[ClusterX
[X
].Pos
- XMinimum
] do
1826 AccumB
:= AccumB
+ B
* Weight
;
1827 AccumG
:= AccumG
+ G
* Weight
;
1828 AccumR
:= AccumR
+ R
* Weight
;
1829 AccumA
:= AccumA
+ A
* Weight
;
1833 // Now compute final color to be written to dest image
1834 SrcFloat
.A
:= AccumA
;
1835 SrcFloat
.R
:= AccumR
;
1836 SrcFloat
.G
:= AccumG
;
1837 SrcFloat
.B
:= AccumB
;
1839 Info
.SetPixelFP(DstLine
, @Info
, nil, SrcFloat
);
1840 Inc(DstLine
, Info
.BytesPerPixel
);
1846 SetLength(LineBufferInt
, XMaximum
- XMinimum
+ 1);
1847 // Following code is optimized for images with 8 bit channels
1848 for J
:= 0 to DstHeight
- 1 do
1850 ClusterY
:= MapY
[J
];
1851 for X
:= XMinimum
to XMaximum
do
1857 for Y
:= 0 to Length(ClusterY
) - 1 do
1859 IWeight
:= Round(256 * ClusterY
[Y
].Weight
);
1861 @PByteArray(SrcImage
.Bits
)[(ClusterY
[Y
].Pos
* SrcImage
.Width
+ X
) * Info
.BytesPerPixel
],
1862 @SrcColor
, Info
.BytesPerPixel
);
1864 IAccumB
:= IAccumB
+ SrcColor
.B
* IWeight
;
1865 IAccumG
:= IAccumG
+ SrcColor
.G
* IWeight
;
1866 IAccumR
:= IAccumR
+ SrcColor
.R
* IWeight
;
1867 IAccumA
:= IAccumA
+ SrcColor
.A
* IWeight
;
1869 with LineBufferInt
[X
- XMinimum
] do
1878 DstLine
:= @PByteArray(DstImage
.Bits
)[((J
+ DstY
) * DstImage
.Width
+ DstX
)* Info
.BytesPerPixel
];
1880 for I
:= 0 to DstWidth
- 1 do
1882 ClusterX
:= MapX
[I
];
1887 for X
:= 0 to Length(ClusterX
) - 1 do
1889 IWeight
:= Round(256 * ClusterX
[X
].Weight
);
1890 with LineBufferInt
[ClusterX
[X
].Pos
- XMinimum
] do
1892 IAccumB
:= IAccumB
+ B
* IWeight
;
1893 IAccumG
:= IAccumG
+ G
* IWeight
;
1894 IAccumR
:= IAccumR
+ R
* IWeight
;
1895 IAccumA
:= IAccumA
+ A
* IWeight
;
1899 SrcColor
.B
:= ClampInt(IAccumB
, 0, $00FF0000) shr 16;
1900 SrcColor
.G
:= ClampInt(IAccumG
, 0, $00FF0000) shr 16;
1901 SrcColor
.R
:= ClampInt(IAccumR
, 0, $00FF0000) shr 16;
1902 SrcColor
.A
:= ClampInt(IAccumA
, 0, $00FF0000) shr 16;
1904 CopyPixel(@SrcColor
, DstLine
, Info
.BytesPerPixel
);
1905 Inc(DstLine
, Info
.BytesPerPixel
);
1916 procedure FillMipMapLevel(const BiggerLevel
: TImageData
; Width
, Height
: LongInt;
1917 var SmallerLevel
: TImageData
);
1919 Filter
: TSamplingFilter
;
1920 Info
: TImageFormatInfo
;
1921 CompatibleCopy
: TImageData
;
1923 Assert(TestImage(BiggerLevel
));
1924 Filter
:= TSamplingFilter(GetOption(ImagingMipMapFilter
));
1926 // If we have special format image we must create copy to allow pixel access
1927 GetImageFormatInfo(BiggerLevel
.Format
, Info
);
1928 if Info
.IsSpecial
then
1930 InitImage(CompatibleCopy
);
1931 CloneImage(BiggerLevel
, CompatibleCopy
);
1932 ConvertImage(CompatibleCopy
, ifDefault
);
1935 CompatibleCopy
:= BiggerLevel
;
1937 // Create new smaller image
1938 NewImage(Width
, Height
, CompatibleCopy
.Format
, SmallerLevel
);
1939 GetImageFormatInfo(CompatibleCopy
.Format
, Info
);
1940 // If input is indexed we must copy its palette
1941 if Info
.IsIndexed
then
1942 CopyPalette(CompatibleCopy
.Palette
, SmallerLevel
.Palette
, 0, 0, Info
.PaletteEntries
);
1944 if (Filter
= sfNearest
) or Info
.IsIndexed
then
1946 StretchNearest(CompatibleCopy
, 0, 0, CompatibleCopy
.Width
, CompatibleCopy
.Height
,
1947 SmallerLevel
, 0, 0, Width
, Height
);
1951 StretchResample(CompatibleCopy
, 0, 0, CompatibleCopy
.Width
, CompatibleCopy
.Height
,
1952 SmallerLevel
, 0, 0, Width
, Height
, Filter
);
1955 // Free copy and convert result to special format if necessary
1956 if CompatibleCopy
.Format
<> BiggerLevel
.Format
then
1958 ConvertImage(SmallerLevel
, BiggerLevel
.Format
);
1959 FreeImage(CompatibleCopy
);
1964 { Various format support functions }
1966 procedure CopyPixel(Src
, Dest
: Pointer; BytesPerPixel
: LongInt);
1968 case BytesPerPixel
of
1969 1: PByte(Dest
)^ := PByte(Src
)^;
1970 2: PWord(Dest
)^ := PWord(Src
)^;
1971 3: PColor24Rec(Dest
)^ := PColor24Rec(Src
)^;
1972 4: PLongWord(Dest
)^ := PLongWord(Src
)^;
1973 6: PColor48Rec(Dest
)^ := PColor48Rec(Src
)^;
1974 8: PInt64(Dest
)^ := PInt64(Src
)^;
1975 16: PColorFPRec(Dest
)^ := PColorFPRec(Src
)^;
1979 function ComparePixels(PixelA
, PixelB
: Pointer; BytesPerPixel
: LongInt): Boolean;
1981 case BytesPerPixel
of
1982 1: Result
:= PByte(PixelA
)^ = PByte(PixelB
)^;
1983 2: Result
:= PWord(PixelA
)^ = PWord(PixelB
)^;
1984 3: Result
:= (PWord(PixelA
)^ = PWord(PixelB
)^) and
1985 (PColor24Rec(PixelA
).R
= PColor24Rec(PixelB
).R
);
1986 4: Result
:= PLongWord(PixelA
)^ = PLongWord(PixelB
)^;
1987 6: Result
:= (PLongWord(PixelA
)^ = PLongWord(PixelB
)^) and
1988 (PColor48Rec(PixelA
).R
= PColor48Rec(PixelB
).R
);
1989 8: Result
:= PInt64(PixelA
)^ = PInt64(PixelB
)^;
1990 16: Result
:= (PFloatHelper(PixelA
).Data2
= PFloatHelper(PixelB
).Data2
) and
1991 (PFloatHelper(PixelA
).Data1
= PFloatHelper(PixelB
).Data1
);
1997 procedure TranslatePixel(SrcPixel
, DstPixel
: Pointer; SrcFormat
,
1998 DstFormat
: TImageFormat
; SrcPalette
, DstPalette
: PPalette32
);
2000 SrcInfo
, DstInfo
: PImageFormatInfo
;
2003 SrcInfo
:= FInfos
[SrcFormat
];
2004 DstInfo
:= FInfos
[DstFormat
];
2006 PixFP
:= GetPixelFPGeneric(SrcPixel
, SrcInfo
, SrcPalette
);
2007 SetPixelFPGeneric(DstPixel
, DstInfo
, DstPalette
, PixFP
);
2010 procedure ClampFloatPixel(var PixF
: TColorFPRec
);
2012 if PixF
.A
> 1.0 then
2014 if PixF
.R
> 1.0 then
2016 if PixF
.G
> 1.0 then
2018 if PixF
.B
> 1.0 then
2021 if PixF
.A
< 0.0 then
2023 if PixF
.R
< 0.0 then
2025 if PixF
.G
< 0.0 then
2027 if PixF
.B
< 0.0 then
2031 procedure AddPadBytes(DataIn
: Pointer; DataOut
: Pointer; Width
, Height
,
2032 Bpp
, WidthBytes
: LongInt);
2037 for I
:= 0 to Height
- 1 do
2038 Move(PByteArray(DataIn
)[I
* W
], PByteArray(DataOut
)[I
* WidthBytes
], W
);
2041 procedure RemovePadBytes(DataIn
: Pointer; DataOut
: Pointer; Width
, Height
,
2042 Bpp
, WidthBytes
: LongInt);
2047 for I
:= 0 to Height
- 1 do
2048 Move(PByteArray(DataIn
)[I
* WidthBytes
], PByteArray(DataOut
)[I
* W
], W
);
2051 procedure Convert1To8(DataIn
, DataOut
: Pointer; Width
, Height
,
2052 WidthBytes
: LongInt);
2054 Mask1
: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
2055 Shift1
: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0);
2059 for Y
:= 0 to Height
- 1 do
2060 for X
:= 0 to Width
- 1 do
2061 PByteArray(DataOut
)[Y
* Width
+ X
] :=
2062 (PByteArray(DataIn
)[Y
* WidthBytes
+ X
shr 3] and
2063 Mask1
[X
and 7]) shr Shift1
[X
and 7];
2066 procedure Convert2To8(DataIn
, DataOut
: Pointer; Width
, Height
,
2067 WidthBytes
: LongInt);
2069 Mask2
: array[0..3] of Byte = ($C0, $30, $0C, $03);
2070 Shift2
: array[0..3] of Byte = (6, 4, 2, 0);
2074 for Y
:= 0 to Height
- 1 do
2075 for X
:= 0 to Width
- 1 do
2076 PByteArray(DataOut
)[Y
* Width
+ X
] :=
2077 (PByteArray(DataIn
)[X
shr 2] and Mask2
[X
and 3]) shr
2081 procedure Convert4To8(DataIn
, DataOut
: Pointer; Width
, Height
,
2082 WidthBytes
: LongInt);
2084 Mask4
: array[0..1] of Byte = ($F0, $0F);
2085 Shift4
: array[0..1] of Byte = (4, 0);
2089 for Y
:= 0 to Height
- 1 do
2090 for X
:= 0 to Width
- 1 do
2091 PByteArray(DataOut
)[Y
* Width
+ X
] :=
2092 (PByteArray(DataIn
)[Y
* WidthBytes
+ X
shr 1] and
2093 Mask4
[X
and 1]) shr Shift4
[X
and 1];
2096 function Has16BitImageAlpha(NumPixels
: LongInt; Data
: PWord): Boolean;
2101 for I
:= 0 to NumPixels
- 1 do
2103 if Data
^ >= 1 shl 15 then
2112 function Has32BitImageAlpha(NumPixels
: LongInt; Data
: PLongWord): Boolean;
2117 for I
:= 0 to NumPixels
- 1 do
2119 if Data
^ >= 1 shl 24 then
2128 function GetScanLine(ImageBits
: Pointer; const FormatInfo
: TImageFormatInfo
;
2129 LineWidth
, Index
: LongInt): Pointer;
2133 Assert(not FormatInfo
.IsSpecial
);
2134 LineBytes
:= FormatInfo
.GetPixelsSize(FormatInfo
.Format
, LineWidth
, 1);
2135 Result
:= @PByteArray(ImageBits
)[Index
* LineBytes
];
2138 function IsImageFormatValid(Format
: TImageFormat
): Boolean;
2140 Result
:= FInfos
[Format
] <> nil;
2144 HalfMin
: Single = 5.96046448e-08; // Smallest positive half
2145 HalfMinNorm
: Single = 6.10351562e-05; // Smallest positive normalized half
2146 HalfMax
: Single = 65504.0; // Largest positive half
2147 HalfEpsilon
: Single = 0.00097656; // Smallest positive e for which half (1.0 + e) != half (1.0)
2148 HalfNaN
: THalfFloat
= 65535;
2149 HalfPosInf
: THalfFloat
= 31744;
2150 HalfNegInf
: THalfFloat
= 64512;
2155 Half/Float conversions inspired by half class from OpenEXR library.
2158 Float (Pascal Single type) is an IEEE 754 single-precision
2160 floating point number.
2162 Bit layout of Single:
2170 X XXXXXXXX XXXXXXXXXXXXXXXXXXXXXXX
2184 S is the sign-bit, e is the exponent and m is the significand (mantissa).
2188 function HalfToFloat(Half
: THalfFloat
): Single;
2190 Dst
, Sign
, Mantissa
: LongWord;
2193 // extract sign, exponent, and mantissa from half number
2194 Sign
:= Half
shr 15;
2195 Exp
:= (Half
and $7C00) shr 10;
2196 Mantissa
:= Half
and 1023;
2198 if (Exp
> 0) and (Exp
< 31) then
2200 // common normalized number
2201 Exp
:= Exp
+ (127 - 15);
2202 Mantissa
:= Mantissa
shl 13;
2203 Dst
:= (Sign
shl 31) or (LongWord(Exp
) shl 23) or Mantissa
;
2204 // Result := Power(-1, Sign) * Power(2, Exp - 15) * (1 + Mantissa / 1024);
2206 else if (Exp
= 0) and (Mantissa
= 0) then
2208 // zero - preserve sign
2211 else if (Exp
= 0) and (Mantissa
<> 0) then
2213 // denormalized number - renormalize it
2214 while (Mantissa
and $00000400) = 0 do
2216 Mantissa
:= Mantissa
shl 1;
2220 Mantissa
:= Mantissa
and not $00000400;
2221 // now assemble normalized number
2222 Exp
:= Exp
+ (127 - 15);
2223 Mantissa
:= Mantissa
shl 13;
2224 Dst
:= (Sign
shl 31) or (LongWord(Exp
) shl 23) or Mantissa
;
2225 // Result := Power(-1, Sign) * Power(2, -14) * (Mantissa / 1024);
2227 else if (Exp
= 31) and (Mantissa
= 0) then
2230 Dst
:= (Sign
shl 31) or $7F800000;
2232 else //if (Exp = 31) and (Mantisa <> 0) then
2234 // not a number - preserve sign and mantissa
2235 Dst
:= (Sign
shl 31) or $7F800000 or (Mantissa
shl 13);
2238 // reinterpret LongWord as Single
2239 Result
:= PSingle(@Dst
)^;
2242 function FloatToHalf(Float
: Single): THalfFloat
;
2245 Sign
, Exp
, Mantissa
: LongInt;
2247 Src
:= PLongWord(@Float
)^;
2248 // extract sign, exponent, and mantissa from Single number
2250 Exp
:= LongInt((Src
and $7F800000) shr 23) - 127 + 15;
2251 Mantissa
:= Src
and $007FFFFF;
2253 if (Exp
> 0) and (Exp
< 30) then
2255 // simple case - round the significand and combine it with the sign and exponent
2256 Result
:= (Sign
shl 15) or (Exp
shl 10) or ((Mantissa
+ $00001000) shr 13);
2258 else if Src
= 0 then
2260 // input float is zero - return zero
2265 // difficult case - lengthy conversion
2270 // input float's value is less than HalfMin, return zero
2275 // Float is a normalized Single whose magnitude is less than HalfNormMin.
2276 // We convert it to denormalized half.
2277 Mantissa
:= (Mantissa
or $00800000) shr (1 - Exp
);
2279 if (Mantissa
and $00001000) > 0 then
2280 Mantissa
:= Mantissa
+ $00002000;
2281 // assemble Sign and Mantissa (Exp is zero to get denotmalized number)
2282 Result
:= (Sign
shl 15) or (Mantissa
shr 13);
2285 else if Exp
= 255 - 127 + 15 then
2287 if Mantissa
= 0 then
2289 // input float is infinity, create infinity half with original sign
2290 Result
:= (Sign
shl 15) or $7C00;
2294 // input float is NaN, create half NaN with original sign and mantissa
2295 Result
:= (Sign
shl 15) or $7C00 or (Mantissa
shr 13);
2300 // Exp is > 0 so input float is normalized Single
2303 if (Mantissa
and $00001000) > 0 then
2305 Mantissa
:= Mantissa
+ $00002000;
2306 if (Mantissa
and $00800000) > 0 then
2315 // exponent overflow - return infinity half
2316 Result
:= (Sign
shl 15) or $7C00;
2319 // assemble normalized half
2320 Result
:= (Sign
shl 15) or (Exp
shl 10) or (Mantissa
shr 13);
2325 function ColorHalfToFloat(ColorHF
: TColorHFRec
): TColorFPRec
;
2327 Result
.A
:= HalfToFloat(ColorHF
.A
);
2328 Result
.R
:= HalfToFloat(ColorHF
.R
);
2329 Result
.G
:= HalfToFloat(ColorHF
.G
);
2330 Result
.B
:= HalfToFloat(ColorHF
.B
);
2333 function ColorFloatToHalf(ColorFP
: TColorFPRec
): TColorHFRec
;
2335 Result
.A
:= FloatToHalf(ColorFP
.A
);
2336 Result
.R
:= FloatToHalf(ColorFP
.R
);
2337 Result
.G
:= FloatToHalf(ColorFP
.G
);
2338 Result
.B
:= FloatToHalf(ColorFP
.B
);
2341 procedure VisualizePalette(Pal
: PPalette32
; Entries
: Integer; out PalImage
: TImageData
);
2346 InitImage(PalImage
);
2347 NewImage(Entries
, 1, ifA8R8G8B8
, PalImage
);
2348 Pix
:= PalImage
.Bits
;
2349 for I
:= 0 to Entries
- 1 do
2351 Pix
^ := Pal
[I
].Color
;
2357 { Pixel readers/writers for different image formats }
2359 procedure ChannelGetSrcPixel(Src
: PByte; SrcInfo
: PImageFormatInfo
;
2360 var Pix
: TColor64Rec
);
2364 FillChar(Pix
, SizeOf(Pix
), 0);
2369 // returns 64 bit color value with 16 bits for each channel
2370 case SrcInfo
.BytesPerPixel
of
2373 PFGetARGB(SrcInfo
.PixelFormat
^, Src
^, A
, R
, G
, B
);
2381 PFGetARGB(SrcInfo
.PixelFormat
^, PWord(Src
)^, A
, R
, G
, B
);
2390 R
:= MulDiv(PColor24Rec(Src
).R
, 65535, 255);
2391 G
:= MulDiv(PColor24Rec(Src
).G
, 65535, 255);
2392 B
:= MulDiv(PColor24Rec(Src
).B
, 65535, 255);
2397 A
:= MulDiv(PColor32Rec(Src
).A
, 65535, 255);
2398 R
:= MulDiv(PColor32Rec(Src
).R
, 65535, 255);
2399 G
:= MulDiv(PColor32Rec(Src
).G
, 65535, 255);
2400 B
:= MulDiv(PColor32Rec(Src
).B
, 65535, 255);
2405 R
:= PColor48Rec(Src
).R
;
2406 G
:= PColor48Rec(Src
).G
;
2407 B
:= PColor48Rec(Src
).B
;
2409 8: Pix
.Color
:= PColor64(Src
)^;
2411 // if src has no alpha, we set it to max (otherwise we would have to
2412 // test if dest has alpha or not in each ChannelToXXX function)
2413 if not SrcInfo
.HasAlphaChannel
then
2416 if SrcInfo
.IsRBSwapped
then
2417 SwapValues(Pix
.R
, Pix
.B
);
2420 procedure ChannelSetDstPixel(Dst
: PByte; DstInfo
: PImageFormatInfo
;
2421 const Pix
: TColor64Rec
);
2426 if DstInfo
.IsRBSwapped
then
2427 SwapValues(PixW
.R
, PixW
.B
);
2428 // Pix contains 64 bit color value with 16 bit for each channel
2429 case DstInfo
.BytesPerPixel
of
2430 1: Dst
^ := PFSetARGB(DstInfo
.PixelFormat
^, PixW
.A
shr 8,
2431 PixW
.R
shr 8, PixW
.G
shr 8, PixW
.B
shr 8);
2432 2: PWord(Dst
)^ := PFSetARGB(DstInfo
.PixelFormat
^, PixW
.A
shr 8,
2433 PixW
.R
shr 8, PixW
.G
shr 8, PixW
.B
shr 8);
2435 with PColor24Rec(Dst
)^ do
2437 R
:= MulDiv(PixW
.R
, 255, 65535);
2438 G
:= MulDiv(PixW
.G
, 255, 65535);
2439 B
:= MulDiv(PixW
.B
, 255, 65535);
2442 with PColor32Rec(Dst
)^ do
2444 A
:= MulDiv(PixW
.A
, 255, 65535);
2445 R
:= MulDiv(PixW
.R
, 255, 65535);
2446 G
:= MulDiv(PixW
.G
, 255, 65535);
2447 B
:= MulDiv(PixW
.B
, 255, 65535);
2450 with PColor48Rec(Dst
)^ do
2456 8: PColor64(Dst
)^ := PixW
.Color
;
2460 procedure GrayGetSrcPixel(Src
: PByte; SrcInfo
: PImageFormatInfo
;
2461 var Gray
: TColor64Rec
; var Alpha
: Word);
2463 FillChar(Gray
, SizeOf(Gray
), 0);
2464 // Source alpha is scaled to 16 bits and stored in Alpha,
2465 // grayscale value is scaled to 64 bits and stored in Gray
2466 case SrcInfo
.BytesPerPixel
of
2467 1: Gray
.A
:= MulDiv(Src
^, 65535, 255);
2469 if SrcInfo
.HasAlphaChannel
then
2470 with PWordRec(Src
)^ do
2472 Alpha
:= MulDiv(High
, 65535, 255);
2473 Gray
.A
:= MulDiv(Low
, 65535, 255);
2476 Gray
.A
:= PWord(Src
)^;
2478 if SrcInfo
.HasAlphaChannel
then
2479 with PLongWordRec(Src
)^ do
2485 with PLongWordRec(Src
)^ do
2490 8: Gray
.Color
:= PColor64(Src
)^;
2492 // if src has no alpha, we set it to max (otherwise we would have to
2493 // test if dest has alpha or not in each GrayToXXX function)
2494 if not SrcInfo
.HasAlphaChannel
then
2498 procedure GraySetDstPixel(Dst
: PByte; DstInfo
: PImageFormatInfo
;
2499 const Gray
: TColor64Rec
; Alpha
: Word);
2501 // Gray contains grayscale value scaled to 64 bits, Alpha contains
2502 // alpha value scaled to 16 bits
2503 case DstInfo
.BytesPerPixel
of
2504 1: Dst
^ := MulDiv(Gray
.A
, 255, 65535);
2506 if DstInfo
.HasAlphaChannel
then
2507 with PWordRec(Dst
)^ do
2509 High
:= MulDiv(Alpha
, 255, 65535);
2510 Low
:= MulDiv(Gray
.A
, 255, 65535);
2513 PWord(Dst
)^ := Gray
.A
;
2515 if DstInfo
.HasAlphaChannel
then
2516 with PLongWordRec(Dst
)^ do
2522 with PLongWordRec(Dst
)^ do
2527 8: PColor64(Dst
)^ := Gray
.Color
;
2531 procedure FloatGetSrcPixel(Src
: PByte; SrcInfo
: PImageFormatInfo
;
2532 var Pix
: TColorFPRec
);
2536 if SrcInfo
.BytesPerPixel
in [4, 16] then
2538 // IEEE 754 single-precision channels
2539 FillChar(Pix
, SizeOf(Pix
), 0);
2540 case SrcInfo
.BytesPerPixel
of
2541 4: Pix
.R
:= PSingle(Src
)^;
2542 16: Pix
:= PColorFPRec(Src
)^;
2547 // half float channels
2548 FillChar(PixHF
, SizeOf(PixHF
), 0);
2549 case SrcInfo
.BytesPerPixel
of
2550 2: PixHF
.R
:= PHalfFloat(Src
)^;
2551 8: PixHF
:= PColorHFRec(Src
)^;
2553 Pix
:= ColorHalfToFloat(PixHF
);
2555 // if src has no alpha, we set it to max (otherwise we would have to
2556 // test if dest has alpha or not in each FloatToXXX function)
2557 if not SrcInfo
.HasAlphaChannel
then
2559 if SrcInfo
.IsRBSwapped
then
2560 SwapValues(Pix
.R
, Pix
.B
);
2563 procedure FloatSetDstPixel(Dst
: PByte; DstInfo
: PImageFormatInfo
;
2564 const Pix
: TColorFPRec
);
2570 if DstInfo
.IsRBSwapped
then
2571 SwapValues(PixW
.R
, PixW
.B
);
2572 if DstInfo
.BytesPerPixel
in [4, 16] then
2574 case DstInfo
.BytesPerPixel
of
2575 4: PSingle(Dst
)^ := PixW
.R
;
2576 16: PColorFPRec(Dst
)^ := PixW
;
2581 PixHF
:= ColorFloatToHalf(PixW
);
2582 case DstInfo
.BytesPerPixel
of
2583 2: PHalfFloat(Dst
)^ := PixHF
.R
;
2584 8: PColorHFRec(Dst
)^ := PixHF
;
2589 procedure IndexGetSrcPixel(Src
: PByte; SrcInfo
: PImageFormatInfo
;
2590 var Index
: LongWord);
2592 case SrcInfo
.BytesPerPixel
of
2597 procedure IndexSetDstPixel(Dst
: PByte; DstInfo
: PImageFormatInfo
;
2600 case DstInfo
.BytesPerPixel
of
2601 1: Dst
^ := Byte(Index
);
2602 2: PWord(Dst
)^ := Word(Index
);
2603 4: PLongWord(Dst
)^ := Index
;
2608 { Pixel readers/writers for 32bit and FP colors}
2610 function GetPixel32Generic(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColor32Rec
;
2617 if Info
.Format
= ifA8R8G8B8
then
2619 Result
:= PColor32Rec(Bits
)^
2621 else if Info
.Format
= ifR8G8B8
then
2623 PColor24Rec(@Result
)^ := PColor24Rec(Bits
)^;
2626 else if Info
.IsFloatingPoint
then
2628 FloatGetSrcPixel(Bits
, Info
, PixF
);
2629 Result
.A
:= ClampToByte(Round(PixF
.A
* 255.0));
2630 Result
.R
:= ClampToByte(Round(PixF
.R
* 255.0));
2631 Result
.G
:= ClampToByte(Round(PixF
.G
* 255.0));
2632 Result
.B
:= ClampToByte(Round(PixF
.B
* 255.0));
2634 else if Info
.HasGrayChannel
then
2636 GrayGetSrcPixel(Bits
, Info
, Pix64
, Alpha
);
2637 Result
.A
:= MulDiv(Alpha
, 255, 65535);
2638 Result
.R
:= MulDiv(Pix64
.A
, 255, 65535);
2639 Result
.G
:= MulDiv(Pix64
.A
, 255, 65535);
2640 Result
.B
:= MulDiv(Pix64
.A
, 255, 65535);
2642 else if Info
.IsIndexed
then
2644 IndexGetSrcPixel(Bits
, Info
, Index
);
2645 Result
:= Palette
[Index
];
2649 ChannelGetSrcPixel(Bits
, Info
, Pix64
);
2650 Result
.A
:= MulDiv(Pix64
.A
, 255, 65535);
2651 Result
.R
:= MulDiv(Pix64
.R
, 255, 65535);
2652 Result
.G
:= MulDiv(Pix64
.G
, 255, 65535);
2653 Result
.B
:= MulDiv(Pix64
.B
, 255, 65535);
2657 procedure SetPixel32Generic(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColor32Rec
);
2664 if Info
.Format
= ifA8R8G8B8
then
2666 PColor32Rec(Bits
)^ := Color
2668 else if Info
.Format
= ifR8G8B8
then
2670 PColor24Rec(Bits
)^ := Color
.Color24Rec
;
2672 else if Info
.IsFloatingPoint
then
2674 PixF
.A
:= Color
.A
* OneDiv8Bit
;
2675 PixF
.R
:= Color
.R
* OneDiv8Bit
;
2676 PixF
.G
:= Color
.G
* OneDiv8Bit
;
2677 PixF
.B
:= Color
.B
* OneDiv8Bit
;
2678 FloatSetDstPixel(Bits
, Info
, PixF
);
2680 else if Info
.HasGrayChannel
then
2682 Alpha
:= MulDiv(Color
.A
, 65535, 255);
2684 Pix64
.A
:= MulDiv(Round(GrayConv
.R
* Color
.R
+ GrayConv
.G
* Color
.G
+
2685 GrayConv
.B
* Color
.B
), 65535, 255);
2686 GraySetDstPixel(Bits
, Info
, Pix64
, Alpha
);
2688 else if Info
.IsIndexed
then
2690 Index
:= FindColor(Palette
, Info
.PaletteEntries
, Color
.Color
);
2691 IndexSetDstPixel(Bits
, Info
, Index
);
2695 Pix64
.A
:= MulDiv(Color
.A
, 65535, 255);
2696 Pix64
.R
:= MulDiv(Color
.R
, 65535, 255);
2697 Pix64
.G
:= MulDiv(Color
.G
, 65535, 255);
2698 Pix64
.B
:= MulDiv(Color
.B
, 65535, 255);
2699 ChannelSetDstPixel(Bits
, Info
, Pix64
);
2703 function GetPixelFPGeneric(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColorFPRec
;
2710 if Info
.IsFloatingPoint
then
2712 FloatGetSrcPixel(Bits
, Info
, Result
);
2714 else if Info
.HasGrayChannel
then
2716 GrayGetSrcPixel(Bits
, Info
, Pix64
, Alpha
);
2717 Result
.A
:= Alpha
* OneDiv16Bit
;
2718 Result
.R
:= Pix64
.A
* OneDiv16Bit
;
2719 Result
.G
:= Pix64
.A
* OneDiv16Bit
;
2720 Result
.B
:= Pix64
.A
* OneDiv16Bit
;
2722 else if Info
.IsIndexed
then
2724 IndexGetSrcPixel(Bits
, Info
, Index
);
2725 Pix32
:= Palette
[Index
];
2726 Result
.A
:= Pix32
.A
* OneDiv8Bit
;
2727 Result
.R
:= Pix32
.R
* OneDiv8Bit
;
2728 Result
.G
:= Pix32
.G
* OneDiv8Bit
;
2729 Result
.B
:= Pix32
.B
* OneDiv8Bit
;
2733 ChannelGetSrcPixel(Bits
, Info
, Pix64
);
2734 Result
.A
:= Pix64
.A
* OneDiv16Bit
;
2735 Result
.R
:= Pix64
.R
* OneDiv16Bit
;
2736 Result
.G
:= Pix64
.G
* OneDiv16Bit
;
2737 Result
.B
:= Pix64
.B
* OneDiv16Bit
;
2741 procedure SetPixelFPGeneric(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColorFPRec
);
2748 if Info
.IsFloatingPoint
then
2750 FloatSetDstPixel(Bits
, Info
, Color
);
2752 else if Info
.HasGrayChannel
then
2754 Alpha
:= ClampToWord(Round(Color
.A
* 65535.0));
2756 Pix64
.A
:= ClampToWord(Round((GrayConv
.R
* Color
.R
+ GrayConv
.G
* Color
.G
+
2757 GrayConv
.B
* Color
.B
) * 65535.0));
2758 GraySetDstPixel(Bits
, Info
, Pix64
, Alpha
);
2760 else if Info
.IsIndexed
then
2762 Pix32
.A
:= ClampToByte(Round(Color
.A
* 255.0));
2763 Pix32
.R
:= ClampToByte(Round(Color
.R
* 255.0));
2764 Pix32
.G
:= ClampToByte(Round(Color
.G
* 255.0));
2765 Pix32
.B
:= ClampToByte(Round(Color
.B
* 255.0));
2766 Index
:= FindColor(Palette
, Info
.PaletteEntries
, Pix32
.Color
);
2767 IndexSetDstPixel(Bits
, Info
, Index
);
2771 Pix64
.A
:= ClampToWord(Round(Color
.A
* 65535.0));
2772 Pix64
.R
:= ClampToWord(Round(Color
.R
* 65535.0));
2773 Pix64
.G
:= ClampToWord(Round(Color
.G
* 65535.0));
2774 Pix64
.B
:= ClampToWord(Round(Color
.B
* 65535.0));
2775 ChannelSetDstPixel(Bits
, Info
, Pix64
);
2780 { Image format conversion functions }
2782 procedure ChannelToChannel(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
2783 DstInfo
: PImageFormatInfo
);
2788 // two most common conversions (RGB->ARGB and ARGB->RGB for 24/32 bit
2789 // images) are made separately from general ARGB conversion to
2791 if (SrcInfo
.BytesPerPixel
= 3) and (DstInfo
.BytesPerPixel
= 4) then
2792 for I
:= 0 to NumPixels
- 1 do
2794 PColor24Rec(Dst
)^ := PColor24Rec(Src
)^;
2795 if DstInfo
.HasAlphaChannel
then
2796 PColor32Rec(Dst
).A
:= 255;
2797 Inc(Src
, SrcInfo
.BytesPerPixel
);
2798 Inc(Dst
, DstInfo
.BytesPerPixel
);
2801 if (SrcInfo
.BytesPerPixel
= 4) and (DstInfo
.BytesPerPixel
= 3) then
2802 for I
:= 0 to NumPixels
- 1 do
2804 PColor24Rec(Dst
)^ := PColor24Rec(Src
)^;
2805 Inc(Src
, SrcInfo
.BytesPerPixel
);
2806 Inc(Dst
, DstInfo
.BytesPerPixel
);
2809 for I
:= 0 to NumPixels
- 1 do
2811 // general ARGB conversion
2812 ChannelGetSrcPixel(Src
, SrcInfo
, Pix64
);
2813 ChannelSetDstPixel(Dst
, DstInfo
, Pix64
);
2814 Inc(Src
, SrcInfo
.BytesPerPixel
);
2815 Inc(Dst
, DstInfo
.BytesPerPixel
);
2819 procedure ChannelToGray(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
2820 DstInfo
: PImageFormatInfo
);
2826 // two most common conversions (R8G8B8->Gray8 nad A8R8G8B8->Gray8)
2827 // are made separately from general conversions to make them faster
2828 if (SrcInfo
.BytesPerPixel
in [3, 4]) and (DstInfo
.Format
= ifGray8
) then
2829 for I
:= 0 to NumPixels
- 1 do
2831 Dst
^ := Round(GrayConv
.R
* PColor24Rec(Src
).R
+ GrayConv
.G
* PColor24Rec(Src
).G
+
2832 GrayConv
.B
* PColor24Rec(Src
).B
);
2833 Inc(Src
, SrcInfo
.BytesPerPixel
);
2834 Inc(Dst
, DstInfo
.BytesPerPixel
);
2837 for I
:= 0 to NumPixels
- 1 do
2839 ChannelGetSrcPixel(Src
, SrcInfo
, Pix64
);
2841 // alpha is saved from source pixel to Alpha,
2842 // Gray value is computed and set to highest word of Pix64 so
2843 // Pix64.Color contains grayscale value scaled to 64 bits
2846 Pix64
.A
:= Round(R
* Pix64
.R
+ G
* Pix64
.G
+ B
* Pix64
.B
);
2848 GraySetDstPixel(Dst
, DstInfo
, Pix64
, Alpha
);
2849 Inc(Src
, SrcInfo
.BytesPerPixel
);
2850 Inc(Dst
, DstInfo
.BytesPerPixel
);
2854 procedure ChannelToFloat(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
2855 DstInfo
: PImageFormatInfo
);
2861 for I
:= 0 to NumPixels
- 1 do
2863 ChannelGetSrcPixel(Src
, SrcInfo
, Pix64
);
2865 // floating point channel values are scaled to 1.0
2866 PixF
.A
:= Pix64
.A
* OneDiv16Bit
;
2867 PixF
.R
:= Pix64
.R
* OneDiv16Bit
;
2868 PixF
.G
:= Pix64
.G
* OneDiv16Bit
;
2869 PixF
.B
:= Pix64
.B
* OneDiv16Bit
;
2871 FloatSetDstPixel(Dst
, DstInfo
, PixF
);
2872 Inc(Src
, SrcInfo
.BytesPerPixel
);
2873 Inc(Dst
, DstInfo
.BytesPerPixel
);
2877 procedure ChannelToIndex(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
2878 DstInfo
: PImageFormatInfo
; DstPal
: PPalette32
);
2880 ReduceColorsMedianCut(NumPixels
, Src
, Dst
, SrcInfo
, DstInfo
, DstInfo
.PaletteEntries
,
2881 GetOption(ImagingColorReductionMask
), DstPal
);
2884 procedure GrayToGray(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
2885 DstInfo
: PImageFormatInfo
);
2891 // two most common conversions (Gray8->Gray16 nad Gray16->Gray8)
2892 // are made separately from general conversions to make them faster
2893 if (SrcInfo
.Format
= ifGray8
) and (DstInfo
.Format
= ifGray16
) then
2895 for I
:= 0 to NumPixels
- 1 do
2896 PWordArray(Dst
)[I
] := PByteArray(Src
)[I
] shl 8;
2899 if (DstInfo
.Format
= ifGray8
) and (SrcInfo
.Format
= ifGray16
) then
2901 for I
:= 0 to NumPixels
- 1 do
2902 PByteArray(Dst
)[I
] := PWordArray(Src
)[I
] shr 8;
2905 for I
:= 0 to NumPixels
- 1 do
2907 // general grayscale conversion
2908 GrayGetSrcPixel(Src
, SrcInfo
, Gray
, Alpha
);
2909 GraySetDstPixel(Dst
, DstInfo
, Gray
, Alpha
);
2910 Inc(Src
, SrcInfo
.BytesPerPixel
);
2911 Inc(Dst
, DstInfo
.BytesPerPixel
);
2915 procedure GrayToChannel(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
2916 DstInfo
: PImageFormatInfo
);
2922 // two most common conversions (Gray8->R8G8B8 nad Gray8->A8R8G8B8)
2923 // are made separately from general conversions to make them faster
2924 if (DstInfo
.BytesPerPixel
in [3, 4]) and (SrcInfo
.Format
= ifGray8
) then
2925 for I
:= 0 to NumPixels
- 1 do
2927 PColor24Rec(Dst
).R
:= Src
^;
2928 PColor24Rec(Dst
).G
:= Src
^;
2929 PColor24Rec(Dst
).B
:= Src
^;
2930 if DstInfo
.HasAlphaChannel
then
2931 PColor32Rec(Dst
).A
:= $FF;
2932 Inc(Src
, SrcInfo
.BytesPerPixel
);
2933 Inc(Dst
, DstInfo
.BytesPerPixel
);
2936 for I
:= 0 to NumPixels
- 1 do
2938 GrayGetSrcPixel(Src
, SrcInfo
, Pix64
, Alpha
);
2940 // most significant word of grayscale value is used for
2941 // each channel and alpha channel is set to Alpha
2947 ChannelSetDstPixel(Dst
, DstInfo
, Pix64
);
2948 Inc(Src
, SrcInfo
.BytesPerPixel
);
2949 Inc(Dst
, DstInfo
.BytesPerPixel
);
2953 procedure GrayToFloat(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
2954 DstInfo
: PImageFormatInfo
);
2961 for I
:= 0 to NumPixels
- 1 do
2963 GrayGetSrcPixel(Src
, SrcInfo
, Gray
, Alpha
);
2964 // most significant word of grayscale value is used for
2965 // each channel and alpha channel is set to Alpha
2966 // then all is scaled to 0..1
2967 PixF
.R
:= Gray
.A
* OneDiv16Bit
;
2968 PixF
.G
:= Gray
.A
* OneDiv16Bit
;
2969 PixF
.B
:= Gray
.A
* OneDiv16Bit
;
2970 PixF
.A
:= Alpha
* OneDiv16Bit
;
2972 FloatSetDstPixel(Dst
, DstInfo
, PixF
);
2973 Inc(Src
, SrcInfo
.BytesPerPixel
);
2974 Inc(Dst
, DstInfo
.BytesPerPixel
);
2978 procedure GrayToIndex(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
2979 DstInfo
: PImageFormatInfo
; DstPal
: PPalette32
);
2986 FillGrayscalePalette(DstPal
, DstInfo
.PaletteEntries
);
2987 Shift
:= Log2Int(DstInfo
.PaletteEntries
);
2988 // most common conversion (Gray8->Index8)
2989 // is made separately from general conversions to make it faster
2990 if (SrcInfo
.Format
= ifGray8
) and (DstInfo
.Format
= ifIndex8
) then
2991 for I
:= 0 to NumPixels
- 1 do
2994 Inc(Src
, SrcInfo
.BytesPerPixel
);
2995 Inc(Dst
, DstInfo
.BytesPerPixel
);
2998 for I
:= 0 to NumPixels
- 1 do
3000 // gray value is read from src and index to precomputed
3001 // grayscale palette is computed and written to dst
3002 // (we assume here that there will be no more than 65536 palette
3003 // entries in dst format, gray value is shifted so the highest
3004 // gray value match the highest possible index in palette)
3005 GrayGetSrcPixel(Src
, SrcInfo
, Gray
, Alpha
);
3006 Idx
:= Gray
.A
shr (16 - Shift
);
3007 IndexSetDstPixel(Dst
, DstInfo
, Idx
);
3008 Inc(Src
, SrcInfo
.BytesPerPixel
);
3009 Inc(Dst
, DstInfo
.BytesPerPixel
);
3013 procedure FloatToFloat(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
3014 DstInfo
: PImageFormatInfo
);
3019 for I
:= 0 to NumPixels
- 1 do
3021 // general floating point conversion
3022 FloatGetSrcPixel(Src
, SrcInfo
, PixF
);
3023 FloatSetDstPixel(Dst
, DstInfo
, PixF
);
3024 Inc(Src
, SrcInfo
.BytesPerPixel
);
3025 Inc(Dst
, DstInfo
.BytesPerPixel
);
3029 procedure FloatToChannel(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
3030 DstInfo
: PImageFormatInfo
);
3036 for I
:= 0 to NumPixels
- 1 do
3038 FloatGetSrcPixel(Src
, SrcInfo
, PixF
);
3039 ClampFloatPixel(PixF
);
3041 // floating point channel values are scaled to 1.0
3042 Pix64
.A
:= ClampToWord(Round(PixF
.A
* 65535));
3043 Pix64
.R
:= ClampToWord(Round(PixF
.R
* 65535));
3044 Pix64
.G
:= ClampToWord(Round(PixF
.G
* 65535));
3045 Pix64
.B
:= ClampToWord(Round(PixF
.B
* 65535));
3047 ChannelSetDstPixel(Dst
, DstInfo
, Pix64
);
3048 Inc(Src
, SrcInfo
.BytesPerPixel
);
3049 Inc(Dst
, DstInfo
.BytesPerPixel
);
3053 procedure FloatToGray(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
3054 DstInfo
: PImageFormatInfo
);
3061 for I
:= 0 to NumPixels
- 1 do
3063 FloatGetSrcPixel(Src
, SrcInfo
, PixF
);
3064 ClampFloatPixel(PixF
);
3066 // alpha is saved from source pixel to Alpha,
3067 // Gray value is computed and set to highest word of Pix64 so
3068 // Pix64.Color contains grayscale value scaled to 64 bits
3069 Alpha
:= ClampToWord(Round(PixF
.A
* 65535.0));
3070 Gray
.A
:= ClampToWord(Round((GrayConv
.R
* PixF
.R
+ GrayConv
.G
* PixF
.G
+
3071 GrayConv
.B
* PixF
.B
) * 65535.0));
3073 GraySetDstPixel(Dst
, DstInfo
, Gray
, Alpha
);
3074 Inc(Src
, SrcInfo
.BytesPerPixel
);
3075 Inc(Dst
, DstInfo
.BytesPerPixel
);
3079 procedure FloatToIndex(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
3080 DstInfo
: PImageFormatInfo
; DstPal
: PPalette32
);
3082 ReduceColorsMedianCut(NumPixels
, Src
, Dst
, SrcInfo
, DstInfo
, DstInfo
.PaletteEntries
,
3083 GetOption(ImagingColorReductionMask
), DstPal
);
3086 procedure IndexToIndex(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
3087 DstInfo
: PImageFormatInfo
; SrcPal
, DstPal
: PPalette32
);
3091 // there is only one indexed format now, so it is just a copy
3092 for I
:= 0 to NumPixels
- 1 do
3095 Inc(Src
, SrcInfo
.BytesPerPixel
);
3096 Inc(Dst
, DstInfo
.BytesPerPixel
);
3098 for I
:= 0 to SrcInfo
.PaletteEntries
- 1 do
3099 DstPal
[I
] := SrcPal
[I
];
3102 procedure IndexToChannel(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
3103 DstInfo
: PImageFormatInfo
; SrcPal
: PPalette32
);
3109 // two most common conversions (Index8->R8G8B8 nad Index8->A8R8G8B8)
3110 // are made separately from general conversions to make them faster
3111 if (SrcInfo
.Format
= ifIndex8
) and (DstInfo
.Format
in [ifR8G8B8
, ifA8R8G8B8
]) then
3112 for I
:= 0 to NumPixels
- 1 do
3114 with PColor24Rec(Dst
)^ do
3116 R
:= SrcPal
[Src
^].R
;
3117 G
:= SrcPal
[Src
^].G
;
3118 B
:= SrcPal
[Src
^].B
;
3120 if DstInfo
.Format
= ifA8R8G8B8
then
3121 PColor32Rec(Dst
).A
:= SrcPal
[Src
^].A
;
3122 Inc(Src
, SrcInfo
.BytesPerPixel
);
3123 Inc(Dst
, DstInfo
.BytesPerPixel
);
3126 for I
:= 0 to NumPixels
- 1 do
3128 // index to palette is read from source and color
3129 // is retrieved from palette entry. Color is then
3130 // scaled to 16bits and written to dest
3131 IndexGetSrcPixel(Src
, SrcInfo
, Idx
);
3134 A
:= SrcPal
[Idx
].A
shl 8;
3135 R
:= SrcPal
[Idx
].R
shl 8;
3136 G
:= SrcPal
[Idx
].G
shl 8;
3137 B
:= SrcPal
[Idx
].B
shl 8;
3139 ChannelSetDstPixel(Dst
, DstInfo
, Pix64
);
3140 Inc(Src
, SrcInfo
.BytesPerPixel
);
3141 Inc(Dst
, DstInfo
.BytesPerPixel
);
3145 procedure IndexToGray(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
3146 DstInfo
: PImageFormatInfo
; SrcPal
: PPalette32
);
3153 // most common conversion (Index8->Gray8)
3154 // is made separately from general conversions to make it faster
3155 if (SrcInfo
.Format
= ifIndex8
) and (DstInfo
.Format
= ifGray8
) then
3157 for I
:= 0 to NumPixels
- 1 do
3159 Dst
^ := Round(GrayConv
.R
* SrcPal
[Src
^].R
+ GrayConv
.G
* SrcPal
[Src
^].G
+
3160 GrayConv
.B
* SrcPal
[Src
^].B
);
3161 Inc(Src
, SrcInfo
.BytesPerPixel
);
3162 Inc(Dst
, DstInfo
.BytesPerPixel
);
3166 for I
:= 0 to NumPixels
- 1 do
3168 // index to palette is read from source and color
3169 // is retrieved from palette entry. Color is then
3170 // transformed to grayscale and assigned to the highest
3171 // byte of Gray value
3172 IndexGetSrcPixel(Src
, SrcInfo
, Idx
);
3173 Alpha
:= SrcPal
[Idx
].A
shl 8;
3174 Gray
.A
:= MulDiv(Round(GrayConv
.R
* SrcPal
[Idx
].R
+ GrayConv
.G
* SrcPal
[Idx
].G
+
3175 GrayConv
.B
* SrcPal
[Idx
].B
), 65535, 255);
3176 GraySetDstPixel(Dst
, DstInfo
, Gray
, Alpha
);
3177 Inc(Src
, SrcInfo
.BytesPerPixel
);
3178 Inc(Dst
, DstInfo
.BytesPerPixel
);
3182 procedure IndexToFloat(NumPixels
: LongInt; Src
, Dst
: PByte; SrcInfo
,
3183 DstInfo
: PImageFormatInfo
; SrcPal
: PPalette32
);
3189 for I
:= 0 to NumPixels
- 1 do
3191 // index to palette is read from source and color
3192 // is retrieved from palette entry. Color is then
3193 // scaled to 0..1 and written to dest
3194 IndexGetSrcPixel(Src
, SrcInfo
, Idx
);
3197 A
:= SrcPal
[Idx
].A
* OneDiv8Bit
;
3198 R
:= SrcPal
[Idx
].R
* OneDiv8Bit
;
3199 G
:= SrcPal
[Idx
].G
* OneDiv8Bit
;
3200 B
:= SrcPal
[Idx
].B
* OneDiv8Bit
;
3202 FloatSetDstPixel(Dst
, DstInfo
, PixF
);
3203 Inc(Src
, SrcInfo
.BytesPerPixel
);
3204 Inc(Dst
, DstInfo
.BytesPerPixel
);
3209 { Special formats conversion functions }
3212 // DXT RGB color block
3213 TDXTColorBlock
= packed record
3214 Color0
, Color1
: Word;
3217 PDXTColorBlock
= ^TDXTColorBlock
;
3219 // DXT explicit alpha for a block
3220 TDXTAlphaBlockExp
= packed record
3221 Alphas
: array[0..3] of Word;
3223 PDXTAlphaBlockExp
= ^TDXTAlphaBlockExp
;
3225 // DXT interpolated alpha for a block
3226 TDXTAlphaBlockInt
= packed record
3227 Alphas
: array[0..7] of Byte;
3229 PDXTAlphaBlockInt
= ^TDXTAlphaBlockInt
;
3237 TPixelBlock
= array[0..15] of TPixelInfo
;
3239 function DecodeCol(Color
: Word): TColor32Rec
;
3240 {$IFDEF USE_INLINE} inline; {$ENDIF}
3243 { Result.R := ((Color and $F800) shr 11) shl 3;
3244 Result.G := ((Color and $07E0) shr 5) shl 2;
3245 Result.B := (Color and $001F) shl 3;}
3246 // this color expansion is slower but gives better results
3247 Result
.R
:= (Color
shr 11) * 255 div 31;
3248 Result
.G
:= ((Color
shr 5) and $3F) * 255 div 63;
3249 Result
.B
:= (Color
and $1F) * 255 div 31;
3252 procedure DecodeDXT1(SrcBits
, DestBits
: PByte; Width
, Height
: LongInt);
3254 Sel
, X
, Y
, I
, J
, K
: LongInt;
3255 Block
: TDXTColorBlock
;
3256 Colors
: array[0..3] of TColor32Rec
;
3258 for Y
:= 0 to Height
div 4 - 1 do
3259 for X
:= 0 to Width
div 4 - 1 do
3261 Block
:= PDXTColorBlock(SrcBits
)^;
3262 Inc(SrcBits
, SizeOf(Block
));
3263 // we read and decode endpoint colors
3264 Colors
[0] := DecodeCol(Block
.Color0
);
3265 Colors
[1] := DecodeCol(Block
.Color1
);
3266 // and interpolate between them
3267 if Block
.Color0
> Block
.Color1
then
3269 // interpolation for block without alpha
3271 Colors
[2].R
:= (Colors
[0].R
shl 1 + Colors
[1].R
+ 1) div 3;
3272 Colors
[2].G
:= (Colors
[0].G
shl 1 + Colors
[1].G
+ 1) div 3;
3273 Colors
[2].B
:= (Colors
[0].B
shl 1 + Colors
[1].B
+ 1) div 3;
3275 Colors
[3].R
:= (Colors
[0].R
+ Colors
[1].R
shl 1 + 1) div 3;
3276 Colors
[3].G
:= (Colors
[0].G
+ Colors
[1].G
shl 1 + 1) div 3;
3277 Colors
[3].B
:= (Colors
[0].B
+ Colors
[1].B
shl 1 + 1) div 3;
3281 // interpolation for block with alpha
3283 Colors
[2].R
:= (Colors
[0].R
+ Colors
[1].R
) shr 1;
3284 Colors
[2].G
:= (Colors
[0].G
+ Colors
[1].G
) shr 1;
3285 Colors
[2].B
:= (Colors
[0].B
+ Colors
[1].B
) shr 1;
3287 Colors
[3].R
:= (Colors
[0].R
+ Colors
[1].R
shl 1 + 1) div 3;
3288 Colors
[3].G
:= (Colors
[0].G
+ Colors
[1].G
shl 1 + 1) div 3;
3289 Colors
[3].B
:= (Colors
[0].B
+ Colors
[1].B
shl 1 + 1) div 3;
3292 // we distribute the dxt block colors across the 4x4 block of the
3293 // destination image accroding to the dxt block mask
3298 Sel
:= (Block
.Mask
and (3 shl (K
shl 1))) shr (K
shl 1);
3299 if ((X
shl 2 + I
) < Width
) and ((Y
shl 2 + J
) < Height
) then
3300 PPalette32(DestBits
)[(Y
shl 2 + J
) * Width
+ X
shl 2 + I
] :=
3307 procedure DecodeDXT3(SrcBits
, DestBits
: PByte; Width
, Height
: LongInt);
3309 Sel
, X
, Y
, I
, J
, K
: LongInt;
3310 Block
: TDXTColorBlock
;
3311 AlphaBlock
: TDXTAlphaBlockExp
;
3312 Colors
: array[0..3] of TColor32Rec
;
3315 for Y
:= 0 to Height
div 4 - 1 do
3316 for X
:= 0 to Width
div 4 - 1 do
3318 AlphaBlock
:= PDXTAlphaBlockExp(SrcBits
)^;
3319 Inc(SrcBits
, SizeOf(AlphaBlock
));
3320 Block
:= PDXTColorBlock(SrcBits
)^;
3321 Inc(SrcBits
, SizeOf(Block
));
3322 // we read and decode endpoint colors
3323 Colors
[0] := DecodeCol(Block
.Color0
);
3324 Colors
[1] := DecodeCol(Block
.Color1
);
3325 // and interpolate between them
3326 Colors
[2].R
:= (Colors
[0].R
shl 1 + Colors
[1].R
+ 1) div 3;
3327 Colors
[2].G
:= (Colors
[0].G
shl 1 + Colors
[1].G
+ 1) div 3;
3328 Colors
[2].B
:= (Colors
[0].B
shl 1 + Colors
[1].B
+ 1) div 3;
3329 Colors
[3].R
:= (Colors
[0].R
+ Colors
[1].R
shl 1 + 1) div 3;
3330 Colors
[3].G
:= (Colors
[0].G
+ Colors
[1].G
shl 1 + 1) div 3;
3331 Colors
[3].B
:= (Colors
[0].B
+ Colors
[1].B
shl 1 + 1) div 3;
3333 // we distribute the dxt block colors and alphas
3334 // across the 4x4 block of the destination image
3335 // accroding to the dxt block mask and alpha block
3339 AWord
:= AlphaBlock
.Alphas
[J
];
3342 Sel
:= (Block
.Mask
and (3 shl (K
shl 1))) shr (K
shl 1);
3343 if (X
shl 2 + I
< Width
) and (Y
shl 2 + J
< Height
) then
3345 Colors
[Sel
].A
:= AWord
and $0F;
3346 Colors
[Sel
].A
:= Colors
[Sel
].A
or (Colors
[Sel
].A
shl 4);
3347 PPalette32(DestBits
)[(Y
shl 2 + J
) * Width
+ X
shl 2 + I
] :=
3351 AWord
:= AWord
shr 4;
3357 procedure GetInterpolatedAlphas(var AlphaBlock
: TDXTAlphaBlockInt
);
3360 if Alphas
[0] > Alphas
[1] then
3362 // Interpolation of six alphas
3363 Alphas
[2] := (6 * Alphas
[0] + 1 * Alphas
[1] + 3) div 7;
3364 Alphas
[3] := (5 * Alphas
[0] + 2 * Alphas
[1] + 3) div 7;
3365 Alphas
[4] := (4 * Alphas
[0] + 3 * Alphas
[1] + 3) div 7;
3366 Alphas
[5] := (3 * Alphas
[0] + 4 * Alphas
[1] + 3) div 7;
3367 Alphas
[6] := (2 * Alphas
[0] + 5 * Alphas
[1] + 3) div 7;
3368 Alphas
[7] := (1 * Alphas
[0] + 6 * Alphas
[1] + 3) div 7;
3372 // Interpolation of four alphas, two alphas are set directly
3373 Alphas
[2] := (4 * Alphas
[0] + 1 * Alphas
[1] + 2) div 5;
3374 Alphas
[3] := (3 * Alphas
[0] + 2 * Alphas
[1] + 2) div 5;
3375 Alphas
[4] := (2 * Alphas
[0] + 3 * Alphas
[1] + 2) div 5;
3376 Alphas
[5] := (1 * Alphas
[0] + 4 * Alphas
[1] + 2) div 5;
3382 procedure DecodeDXT5(SrcBits
, DestBits
: PByte; Width
, Height
: LongInt);
3384 Sel
, X
, Y
, I
, J
, K
: LongInt;
3385 Block
: TDXTColorBlock
;
3386 AlphaBlock
: TDXTAlphaBlockInt
;
3387 Colors
: array[0..3] of TColor32Rec
;
3388 AMask
: array[0..1] of LongWord;
3390 for Y
:= 0 to Height
div 4 - 1 do
3391 for X
:= 0 to Width
div 4 - 1 do
3393 AlphaBlock
:= PDXTAlphaBlockInt(SrcBits
)^;
3394 Inc(SrcBits
, SizeOf(AlphaBlock
));
3395 Block
:= PDXTColorBlock(SrcBits
)^;
3396 Inc(SrcBits
, SizeOf(Block
));
3397 // we read and decode endpoint colors
3398 Colors
[0] := DecodeCol(Block
.Color0
);
3399 Colors
[1] := DecodeCol(Block
.Color1
);
3400 // and interpolate between them
3401 Colors
[2].R
:= (Colors
[0].R
shl 1 + Colors
[1].R
+ 1) div 3;
3402 Colors
[2].G
:= (Colors
[0].G
shl 1 + Colors
[1].G
+ 1) div 3;
3403 Colors
[2].B
:= (Colors
[0].B
shl 1 + Colors
[1].B
+ 1) div 3;
3404 Colors
[3].R
:= (Colors
[0].R
+ Colors
[1].R
shl 1 + 1) div 3;
3405 Colors
[3].G
:= (Colors
[0].G
+ Colors
[1].G
shl 1 + 1) div 3;
3406 Colors
[3].B
:= (Colors
[0].B
+ Colors
[1].B
shl 1 + 1) div 3;
3407 // 6 bit alpha mask is copied into two long words for
3409 AMask
[0] := PLongWord(@AlphaBlock
.Alphas
[2])^ and $00FFFFFF;
3410 AMask
[1] := PLongWord(@AlphaBlock
.Alphas
[5])^ and $00FFFFFF;
3411 // alpha interpolation between two endpoint alphas
3412 GetInterpolatedAlphas(AlphaBlock
);
3414 // we distribute the dxt block colors and alphas
3415 // across the 4x4 block of the destination image
3416 // accroding to the dxt block mask and alpha block mask
3421 Sel
:= (Block
.Mask
and (3 shl (K
shl 1))) shr (K
shl 1);
3422 if ((X
shl 2 + I
) < Width
) and ((Y
shl 2 + J
) < Height
) then
3424 Colors
[Sel
].A
:= AlphaBlock
.Alphas
[AMask
[J
shr 1] and 7];
3425 PPalette32(DestBits
)[(Y
shl 2 + J
) * Width
+ (X
shl 2 + I
)] :=
3429 AMask
[J
shr 1] := AMask
[J
shr 1] shr 3;
3434 procedure GetBlock(var Block
: TPixelBlock
; SrcBits
: Pointer; XPos
, YPos
,
3435 Width
, Height
: LongInt);
3441 // 4x4 pixel block is filled with information about every
3442 // pixel in the block: alpha, original color, 565 color
3446 Src
:= @PPalette32(SrcBits
)[(YPos
shl 2 + Y
) * Width
+ XPos
shl 2 + X
];
3447 Block
[I
].Color
:= ((Src
.R
shr 3) shl 11) or ((Src
.G
shr 2) shl 5) or
3449 Block
[I
].Alpha
:= Src
.A
;
3450 Block
[I
].Orig
:= Src
^;
3455 function ColorDistance(const C1
, C2
: TColor32Rec
): LongInt;
3456 {$IFDEF USE_INLINE} inline;{$ENDIF}
3458 Result
:= (C1
.R
- C2
.R
) * (C1
.R
- C2
.R
) +
3459 (C1
.G
- C2
.G
) * (C1
.G
- C2
.G
) + (C1
.B
- C2
.B
) * (C1
.B
- C2
.B
);
3462 procedure GetEndpoints(const Block
: TPixelBlock
; var Ep0
, Ep1
: Word);
3464 I
, J
, Farthest
, Dist
: LongInt;
3465 Colors
: array[0..15] of TColor32Rec
;
3467 // we choose two colors from the pixel block which has the
3468 // largest distance between them
3470 Colors
[I
] := Block
[I
].Orig
;
3473 for J
:= I
+ 1 to 15 do
3475 Dist
:= ColorDistance(Colors
[I
], Colors
[J
]);
3476 if Dist
> Farthest
then
3479 Ep0
:= Block
[I
].Color
;
3480 Ep1
:= Block
[J
].Color
;
3485 procedure GetAlphaEndpoints(const Block
: TPixelBlock
; var Min
, Max
: Byte);
3491 // we choose the lowest and the highest alpha values
3494 if Block
[I
].Alpha
< Min
then
3495 Min
:= Block
[I
].Alpha
;
3496 if Block
[I
].Alpha
> Max
then
3497 Max
:= Block
[I
].Alpha
;
3501 procedure FixEndpoints(var Ep0
, Ep1
: Word; HasAlpha
: Boolean);
3505 // if dxt block has alpha information, Ep0 must be smaller
3506 // than Ep1, if the block has no alpha Ep1 must be smaller
3525 function GetColorMask(Ep0
, Ep1
: Word; NumCols
: LongInt;
3526 const Block
: TPixelBlock
): LongWord;
3528 I
, J
, Closest
, Dist
: LongInt;
3529 Colors
: array[0..3] of TColor32Rec
;
3530 Mask
: array[0..15] of Byte;
3532 FillChar(Mask
, sizeof(Mask
), 0);
3533 // we decode endpoint colors
3534 Colors
[0] := DecodeCol(Ep0
);
3535 Colors
[1] := DecodeCol(Ep1
);
3536 // and interpolate colors between (3 for DXT1 with alpha, 4 for the others)
3539 Colors
[2].R
:= (Colors
[0].R
+ Colors
[1].R
) shr 1;
3540 Colors
[2].G
:= (Colors
[0].G
+ Colors
[1].G
) shr 1;
3541 Colors
[2].B
:= (Colors
[0].B
+ Colors
[1].B
) shr 1;
3542 Colors
[3].R
:= (Colors
[0].R
+ Colors
[1].R
) shr 1;
3543 Colors
[3].G
:= (Colors
[0].G
+ Colors
[1].G
) shr 1;
3544 Colors
[3].B
:= (Colors
[0].B
+ Colors
[1].B
) shr 1;
3548 Colors
[2].R
:= (Colors
[0].R
shl 1 + Colors
[1].R
+ 1) div 3;
3549 Colors
[2].G
:= (Colors
[0].G
shl 1 + Colors
[1].G
+ 1) div 3;
3550 Colors
[2].B
:= (Colors
[0].B
shl 1 + Colors
[1].B
+ 1) div 3;
3551 Colors
[3].R
:= (Colors
[0].R
+ Colors
[1].R
shl 1 + 1) div 3;
3552 Colors
[3].G
:= (Colors
[0].G
+ Colors
[1].G
shl 1 + 1) div 3;
3553 Colors
[3].B
:= (Colors
[0].B
+ Colors
[1].B
shl 1 + 1) div 3;
3558 // this is only for DXT1 with alpha
3559 if (Block
[I
].Alpha
< 128) and (NumCols
= 3) then
3564 // for each of the 16 input pixels the nearest color in the
3565 // 4 dxt colors is found
3567 for J
:= 0 to NumCols
- 1 do
3569 Dist
:= ColorDistance(Block
[I
].Orig
, Colors
[J
]);
3570 if Dist
< Closest
then
3580 Result
:= Result
or (Mask
[I
] shl (I
shl 1));
3583 procedure GetAlphaMask(Ep0
, Ep1
: Byte; var Block
: TPixelBlock
; Mask
: PByteArray
);
3585 Alphas
: array[0..7] of Byte;
3586 M
: array[0..15] of Byte;
3587 I
, J
, Closest
, Dist
: LongInt;
3589 FillChar(M
, sizeof(M
), 0);
3592 // interpolation between two given alpha endpoints
3593 // (I use 6 interpolated values mode)
3594 Alphas
[2] := (6 * Alphas
[0] + 1 * Alphas
[1] + 3) div 7;
3595 Alphas
[3] := (5 * Alphas
[0] + 2 * Alphas
[1] + 3) div 7;
3596 Alphas
[4] := (4 * Alphas
[0] + 3 * Alphas
[1] + 3) div 7;
3597 Alphas
[5] := (3 * Alphas
[0] + 4 * Alphas
[1] + 3) div 7;
3598 Alphas
[6] := (2 * Alphas
[0] + 5 * Alphas
[1] + 3) div 7;
3599 Alphas
[7] := (1 * Alphas
[0] + 6 * Alphas
[1] + 3) div 7;
3601 // the closest interpolated values for each of the input alpha
3608 Dist
:= Abs(Alphas
[J
] - Block
[I
].Alpha
);
3609 if Dist
< Closest
then
3617 Mask
[0] := M
[0] or (M
[1] shl 3) or ((M
[2] and 3) shl 6);
3618 Mask
[1] := ((M
[2] and 4) shr 2) or (M
[3] shl 1) or (M
[4] shl 4) or
3619 ((M
[5] and 1) shl 7);
3620 Mask
[2] := ((M
[5] and 6) shr 1) or (M
[6] shl 2) or (M
[7] shl 5);
3621 Mask
[3] := M
[8] or (M
[9] shl 3) or ((M
[10] and 3) shl 6);
3622 Mask
[4] := ((M
[10] and 4) shr 2) or (M
[11] shl 1) or (M
[12] shl 4) or
3623 ((M
[13] and 1) shl 7);
3624 Mask
[5] := ((M
[13] and 6) shr 1) or (M
[14] shl 2) or (M
[15] shl 5);
3628 procedure EncodeDXT1(SrcBits
: PByte; DestBits
: PByte; Width
, Height
: LongInt);
3632 Block
: TDXTColorBlock
;
3633 Pixels
: TPixelBlock
;
3635 for Y
:= 0 to Height
div 4 - 1 do
3636 for X
:= 0 to Width
div 4 - 1 do
3638 GetBlock(Pixels
, SrcBits
, X
, Y
, Width
, Height
);
3641 if Pixels
[I
].Alpha
< 128 then
3646 GetEndpoints(Pixels
, Block
.Color0
, Block
.Color1
);
3647 FixEndpoints(Block
.Color0
, Block
.Color1
, HasAlpha
);
3649 Block
.Mask
:= GetColorMask(Block
.Color0
, Block
.Color1
, 3, Pixels
)
3651 Block
.Mask
:= GetColorMask(Block
.Color0
, Block
.Color1
, 4, Pixels
);
3652 PDXTColorBlock(DestBits
)^ := Block
;
3653 Inc(DestBits
, SizeOf(Block
));
3657 procedure EncodeDXT3(SrcBits
: Pointer; DestBits
: PByte; Width
, Height
: LongInt);
3660 Block
: TDXTColorBlock
;
3661 AlphaBlock
: TDXTAlphaBlockExp
;
3662 Pixels
: TPixelBlock
;
3664 for Y
:= 0 to Height
div 4 - 1 do
3665 for X
:= 0 to Width
div 4 - 1 do
3667 GetBlock(Pixels
, SrcBits
, X
, Y
, Width
, Height
);
3669 PByteArray(@AlphaBlock
.Alphas
)[I
] :=
3670 (Pixels
[I
shl 1].Alpha
shr 4) or ((Pixels
[I
shl 1 + 1].Alpha
shr 4) shl 4);
3671 GetEndpoints(Pixels
, Block
.Color0
, Block
.Color1
);
3672 FixEndpoints(Block
.Color0
, Block
.Color1
, False);
3673 Block
.Mask
:= GetColorMask(Block
.Color0
, Block
.Color1
, 4, Pixels
);
3674 PDXTAlphaBlockExp(DestBits
)^ := AlphaBlock
;
3675 Inc(DestBits
, SizeOf(AlphaBlock
));
3676 PDXTColorBlock(DestBits
)^ := Block
;
3677 Inc(DestBits
, SizeOf(Block
));
3681 procedure EncodeDXT5(SrcBits
: Pointer; DestBits
: PByte; Width
, Height
: LongInt);
3684 Block
: TDXTColorBlock
;
3685 AlphaBlock
: TDXTAlphaBlockInt
;
3686 Pixels
: TPixelBlock
;
3688 for Y
:= 0 to Height
div 4 - 1 do
3689 for X
:= 0 to Width
div 4 - 1 do
3691 GetBlock(Pixels
, SrcBits
, X
, Y
, Width
, Height
);
3692 GetEndpoints(Pixels
, Block
.Color0
, Block
.Color1
);
3693 FixEndpoints(Block
.Color0
, Block
.Color1
, False);
3694 Block
.Mask
:= GetColorMask(Block
.Color0
, Block
.Color1
, 4, Pixels
);
3695 GetAlphaEndPoints(Pixels
, AlphaBlock
.Alphas
[1], AlphaBlock
.Alphas
[0]);
3696 GetAlphaMask(AlphaBlock
.Alphas
[0], AlphaBlock
.Alphas
[1], Pixels
,
3697 PByteArray(@AlphaBlock
.Alphas
[2]));
3698 PDXTAlphaBlockInt(DestBits
)^ := AlphaBlock
;
3699 Inc(DestBits
, SizeOf(AlphaBlock
));
3700 PDXTColorBlock(DestBits
)^ := Block
;
3701 Inc(DestBits
, SizeOf(Block
));
3706 TBTCBlock
= packed record
3707 MLower
, MUpper
: Byte;
3710 PBTCBlock
= ^TBTCBlock
;
3712 procedure EncodeBTC(SrcBits
: Pointer; DestBits
: PByte; Width
, Height
: Integer);
3714 X
, Y
, I
, J
: Integer;
3716 M
, MLower
, MUpper
, K
: Integer;
3717 Pixels
: array[0..15] of Byte;
3719 for Y
:= 0 to Height
div 4 - 1 do
3720 for X
:= 0 to Width
div 4 - 1 do
3725 FillChar(Block
, SizeOf(Block
), 0);
3728 // Store 4x4 pixels and compute average, lower, and upper intensity levels
3732 Pixels
[K
] := PByteArray(SrcBits
)[(Y
shl 2 + I
) * Width
+ X
shl 2 + J
];
3740 // Now compute upper and lower levels, number of upper pixels,
3741 // and update bit field (1 when pixel is above avg. level M)
3744 if Pixels
[I
] > M
then
3746 Inc(MUpper
, Pixels
[I
]);
3748 Block
.BitField
:= Block
.BitField
or (1 shl I
);
3751 Inc(MLower
, Pixels
[I
]);
3754 // Scale levels and save them to block
3756 Block
.MUpper
:= ClampToByte(MUpper
div K
)
3759 Block
.MLower
:= ClampToByte(MLower
div (16 - K
));
3761 // Finally save block to dest data
3762 PBTCBlock(DestBits
)^ := Block
;
3763 Inc(DestBits
, SizeOf(Block
));
3767 procedure GetOneChannelBlock(var Block
: TPixelBlock
; SrcBits
: Pointer; XPos
, YPos
,
3768 Width
, Height
, BytesPP
, ChannelIdx
: Integer);
3774 // 4x4 pixel block is filled with information about every pixel in the block,
3775 // but only one channel value is stored in Alpha field
3779 Src
:= @PByteArray(SrcBits
)[(YPos
* 4 + Y
) * Width
* BytesPP
+
3780 (XPos
* 4 + X
) * BytesPP
+ ChannelIdx
];
3781 Block
[I
].Alpha
:= Src
^;
3786 procedure EncodeATI1N(SrcBits
: Pointer; DestBits
: PByte; Width
, Height
: Integer);
3789 AlphaBlock
: TDXTAlphaBlockInt
;
3790 Pixels
: TPixelBlock
;
3792 for Y
:= 0 to Height
div 4 - 1 do
3793 for X
:= 0 to Width
div 4 - 1 do
3795 // Encode one channel
3796 GetOneChannelBlock(Pixels
, SrcBits
, X
, Y
, Width
, Height
, 1, 0);
3797 GetAlphaEndPoints(Pixels
, AlphaBlock
.Alphas
[1], AlphaBlock
.Alphas
[0]);
3798 GetAlphaMask(AlphaBlock
.Alphas
[0], AlphaBlock
.Alphas
[1], Pixels
,
3799 PByteArray(@AlphaBlock
.Alphas
[2]));
3800 PDXTAlphaBlockInt(DestBits
)^ := AlphaBlock
;
3801 Inc(DestBits
, SizeOf(AlphaBlock
));
3805 procedure EncodeATI2N(SrcBits
: Pointer; DestBits
: PByte; Width
, Height
: Integer);
3808 AlphaBlock
: TDXTAlphaBlockInt
;
3809 Pixels
: TPixelBlock
;
3811 for Y
:= 0 to Height
div 4 - 1 do
3812 for X
:= 0 to Width
div 4 - 1 do
3814 // Encode Red/X channel
3815 GetOneChannelBlock(Pixels
, SrcBits
, X
, Y
, Width
, Height
, 4, ChannelRed
);
3816 GetAlphaEndPoints(Pixels
, AlphaBlock
.Alphas
[1], AlphaBlock
.Alphas
[0]);
3817 GetAlphaMask(AlphaBlock
.Alphas
[0], AlphaBlock
.Alphas
[1], Pixels
,
3818 PByteArray(@AlphaBlock
.Alphas
[2]));
3819 PDXTAlphaBlockInt(DestBits
)^ := AlphaBlock
;
3820 Inc(DestBits
, SizeOf(AlphaBlock
));
3821 // Encode Green/Y channel
3822 GetOneChannelBlock(Pixels
, SrcBits
, X
, Y
, Width
, Height
, 4, ChannelGreen
);
3823 GetAlphaEndPoints(Pixels
, AlphaBlock
.Alphas
[1], AlphaBlock
.Alphas
[0]);
3824 GetAlphaMask(AlphaBlock
.Alphas
[0], AlphaBlock
.Alphas
[1], Pixels
,
3825 PByteArray(@AlphaBlock
.Alphas
[2]));
3826 PDXTAlphaBlockInt(DestBits
)^ := AlphaBlock
;
3827 Inc(DestBits
, SizeOf(AlphaBlock
));
3831 procedure DecodeBTC(SrcBits
, DestBits
: PByte; Width
, Height
: Integer);
3833 X
, Y
, I
, J
, K
: Integer;
3837 for Y
:= 0 to Height
div 4 - 1 do
3838 for X
:= 0 to Width
div 4 - 1 do
3840 Block
:= PBTCBlock(SrcBits
)^;
3841 Inc(SrcBits
, SizeOf(Block
));
3844 // Just write MUpper when there is '1' in bit field and MLower
3845 // when there is '0'
3849 Dest
:= @PByteArray(DestBits
)[(Y
shl 2 + I
) * Width
+ X
shl 2 + J
];
3850 if Block
.BitField
and (1 shl K
) <> 0 then
3851 Dest
^ := Block
.MUpper
3853 Dest
^ := Block
.MLower
;
3859 procedure DecodeATI1N(SrcBits
, DestBits
: PByte; Width
, Height
: Integer);
3861 X
, Y
, I
, J
: Integer;
3862 AlphaBlock
: TDXTAlphaBlockInt
;
3863 AMask
: array[0..1] of LongWord;
3865 for Y
:= 0 to Height
div 4 - 1 do
3866 for X
:= 0 to Width
div 4 - 1 do
3868 AlphaBlock
:= PDXTAlphaBlockInt(SrcBits
)^;
3869 Inc(SrcBits
, SizeOf(AlphaBlock
));
3870 // 6 bit alpha mask is copied into two long words for
3872 AMask
[0] := PLongWord(@AlphaBlock
.Alphas
[2])^ and $00FFFFFF;
3873 AMask
[1] := PLongWord(@AlphaBlock
.Alphas
[5])^ and $00FFFFFF;
3874 // alpha interpolation between two endpoint alphas
3875 GetInterpolatedAlphas(AlphaBlock
);
3877 // we distribute the dxt block alphas
3878 // across the 4x4 block of the destination image
3882 PByteArray(DestBits
)[(Y
shl 2 + J
) * Width
+ (X
shl 2 + I
)] :=
3883 AlphaBlock
.Alphas
[AMask
[J
shr 1] and 7];
3884 AMask
[J
shr 1] := AMask
[J
shr 1] shr 3;
3889 procedure DecodeATI2N(SrcBits
, DestBits
: PByte; Width
, Height
: Integer);
3891 X
, Y
, I
, J
: Integer;
3893 AlphaBlock1
, AlphaBlock2
: TDXTAlphaBlockInt
;
3894 AMask1
: array[0..1] of LongWord;
3895 AMask2
: array[0..1] of LongWord;
3897 for Y
:= 0 to Height
div 4 - 1 do
3898 for X
:= 0 to Width
div 4 - 1 do
3900 // Read the first alpha block and get masks
3901 AlphaBlock1
:= PDXTAlphaBlockInt(SrcBits
)^;
3902 Inc(SrcBits
, SizeOf(AlphaBlock1
));
3903 AMask1
[0] := PLongWord(@AlphaBlock1
.Alphas
[2])^ and $00FFFFFF;
3904 AMask1
[1] := PLongWord(@AlphaBlock1
.Alphas
[5])^ and $00FFFFFF;
3905 // Read the secind alpha block and get masks
3906 AlphaBlock2
:= PDXTAlphaBlockInt(SrcBits
)^;
3907 Inc(SrcBits
, SizeOf(AlphaBlock2
));
3908 AMask2
[0] := PLongWord(@AlphaBlock2
.Alphas
[2])^ and $00FFFFFF;
3909 AMask2
[1] := PLongWord(@AlphaBlock2
.Alphas
[5])^ and $00FFFFFF;
3910 // alpha interpolation between two endpoint alphas
3911 GetInterpolatedAlphas(AlphaBlock1
);
3912 GetInterpolatedAlphas(AlphaBlock2
);
3917 // Distribute alpha block values across 4x4 pixel block,
3918 // first alpha block represents Red channel, second is Green.
3922 Color
.R
:= AlphaBlock1
.Alphas
[AMask1
[J
shr 1] and 7];
3923 Color
.G
:= AlphaBlock2
.Alphas
[AMask2
[J
shr 1] and 7];
3924 PColor32RecArray(DestBits
)[(Y
shl 2 + J
) * Width
+ (X
shl 2 + I
)] := Color
;
3925 AMask1
[J
shr 1] := AMask1
[J
shr 1] shr 3;
3926 AMask2
[J
shr 1] := AMask2
[J
shr 1] shr 3;
3931 procedure SpecialToUnSpecial(const SrcImage
: TImageData
; DestBits
: Pointer;
3932 SpecialFormat
: TImageFormat
);
3934 case SpecialFormat
of
3935 ifDXT1
: DecodeDXT1(SrcImage
.Bits
, DestBits
, SrcImage
.Width
, SrcImage
.Height
);
3936 ifDXT3
: DecodeDXT3(SrcImage
.Bits
, DestBits
, SrcImage
.Width
, SrcImage
.Height
);
3937 ifDXT5
: DecodeDXT5(SrcImage
.Bits
, DestBits
, SrcImage
.Width
, SrcImage
.Height
);
3938 ifBTC
: DecodeBTC (SrcImage
.Bits
, DestBits
, SrcImage
.Width
, SrcImage
.Height
);
3939 ifATI1N
: DecodeATI1N(SrcImage
.Bits
, DestBits
, SrcImage
.Width
, SrcImage
.Height
);
3940 ifATI2N
: DecodeATI2N(SrcImage
.Bits
, DestBits
, SrcImage
.Width
, SrcImage
.Height
);
3944 procedure UnSpecialToSpecial(SrcBits
: Pointer; const DestImage
: TImageData
;
3945 SpecialFormat
: TImageFormat
);
3947 case SpecialFormat
of
3948 ifDXT1
: EncodeDXT1(SrcBits
, DestImage
.Bits
, DestImage
.Width
, DestImage
.Height
);
3949 ifDXT3
: EncodeDXT3(SrcBits
, DestImage
.Bits
, DestImage
.Width
, DestImage
.Height
);
3950 ifDXT5
: EncodeDXT5(SrcBits
, DestImage
.Bits
, DestImage
.Width
, DestImage
.Height
);
3951 ifBTC
: EncodeBTC (SrcBits
, DestImage
.Bits
, DestImage
.Width
, DestImage
.Height
);
3952 ifATI1N
: EncodeATI1N(SrcBits
, DestImage
.Bits
, DestImage
.Width
, DestImage
.Height
);
3953 ifATI2N
: EncodeATI2N(SrcBits
, DestImage
.Bits
, DestImage
.Width
, DestImage
.Height
);
3957 procedure ConvertSpecial(var Image
: TImageData
;
3958 SrcInfo
, DstInfo
: PImageFormatInfo
);
3960 WorkImage
: TImageData
;
3962 procedure CheckSize(var Img
: TImageData
; Info
: PImageFormatInfo
);
3964 Width
, Height
: Integer;
3967 Height
:= Img
.Height
;
3968 DstInfo
.CheckDimensions(Info
.Format
, Width
, Height
);
3969 ResizeImage(Img
, Width
, Height
, rfNearest
);
3973 if SrcInfo
.IsSpecial
and DstInfo
.IsSpecial
then
3975 // Convert source to nearest 'normal' format
3976 InitImage(WorkImage
);
3977 NewImage(Image
.Width
, Image
.Height
, SrcInfo
.SpecialNearestFormat
, WorkImage
);
3978 SpecialToUnSpecial(Image
, WorkImage
.Bits
, SrcInfo
.Format
);
3980 // Make sure output of SpecialToUnSpecial is the same as input of
3981 // UnSpecialToSpecial
3982 if SrcInfo
.SpecialNearestFormat
<> DstInfo
.SpecialNearestFormat
then
3983 ConvertImage(WorkImage
, DstInfo
.SpecialNearestFormat
);
3984 // Convert work image to dest special format
3985 CheckSize(WorkImage
, DstInfo
);
3986 NewImage(WorkImage
.Width
, WorkImage
.Height
, DstInfo
.Format
, Image
);
3987 UnSpecialToSpecial(WorkImage
.Bits
, Image
, DstInfo
.Format
);
3988 FreeImage(WorkImage
);
3990 else if SrcInfo
.IsSpecial
and not DstInfo
.IsSpecial
then
3992 // Convert source to nearest 'normal' format
3993 InitImage(WorkImage
);
3994 NewImage(Image
.Width
, Image
.Height
, SrcInfo
.SpecialNearestFormat
, WorkImage
);
3995 SpecialToUnSpecial(Image
, WorkImage
.Bits
, SrcInfo
.Format
);
3997 // Now convert to dest format
3998 ConvertImage(WorkImage
, DstInfo
.Format
);
4001 else if not SrcInfo
.IsSpecial
and DstInfo
.IsSpecial
then
4003 // Convert source to nearest format
4005 ConvertImage(WorkImage
, DstInfo
.SpecialNearestFormat
);
4006 // Now convert from nearest to dest
4007 CheckSize(WorkImage
, DstInfo
);
4009 NewImage(WorkImage
.Width
, WorkImage
.Height
, DstInfo
.Format
, Image
);
4010 UnSpecialToSpecial(WorkImage
.Bits
, Image
, DstInfo
.Format
);
4011 FreeImage(WorkImage
);
4015 function GetStdPixelsSize(Format
: TImageFormat
; Width
, Height
: LongInt): LongInt;
4017 if FInfos
[Format
] <> nil then
4018 Result
:= Width
* Height
* FInfos
[Format
].BytesPerPixel
4023 procedure CheckStdDimensions(Format
: TImageFormat
; var Width
, Height
: LongInt);
4027 function GetDXTPixelsSize(Format
: TImageFormat
; Width
, Height
: LongInt): LongInt;
4029 // DXT can be used only for images with dimensions that are
4030 // multiples of four
4031 CheckDXTDimensions(Format
, Width
, Height
);
4032 Result
:= Width
* Height
;
4033 if Format
in [ifDXT1
, ifATI1N
] then
4034 Result
:= Result
div 2;
4037 procedure CheckDXTDimensions(Format
: TImageFormat
; var Width
, Height
: LongInt);
4039 // DXT image dimensions must be multiples of four
4040 Width
:= (Width
+ 3) and not 3; // div 4 * 4;
4041 Height
:= (Height
+ 3) and not 3; // div 4 * 4;
4044 function GetBTCPixelsSize(Format
: TImageFormat
; Width
, Height
: LongInt): LongInt;
4046 // BTC can be used only for images with dimensions that are
4047 // multiples of four
4048 CheckDXTDimensions(Format
, Width
, Height
);
4049 Result
:= Width
* Height
div 4; // 2bits/pixel
4052 { Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }
4054 function GetPixel32ifA8R8G8B8(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColor32Rec
;
4056 Result
.Color
:= PLongWord(Bits
)^;
4059 procedure SetPixel32ifA8R8G8B8(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColor32Rec
);
4061 PLongWord(Bits
)^ := Color
.Color
;
4064 function GetPixelFPifA8R8G8B8(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColorFPRec
;
4066 Result
.A
:= PColor32Rec(Bits
).A
* OneDiv8Bit
;
4067 Result
.R
:= PColor32Rec(Bits
).R
* OneDiv8Bit
;
4068 Result
.G
:= PColor32Rec(Bits
).G
* OneDiv8Bit
;
4069 Result
.B
:= PColor32Rec(Bits
).B
* OneDiv8Bit
;
4072 procedure SetPixelFPifA8R8G8B8(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColorFPRec
);
4074 PColor32Rec(Bits
).A
:= ClampToByte(Round(Color
.A
* 255.0));
4075 PColor32Rec(Bits
).R
:= ClampToByte(Round(Color
.R
* 255.0));
4076 PColor32Rec(Bits
).G
:= ClampToByte(Round(Color
.G
* 255.0));
4077 PColor32Rec(Bits
).B
:= ClampToByte(Round(Color
.B
* 255.0));
4080 function GetPixel32Channel8Bit(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColor32Rec
;
4087 ifR8G8B8
, ifX8R8G8B8
:
4090 PColor24Rec(@Result
)^ := PColor24Rec(Bits
)^;
4094 if Info
.HasAlphaChannel
then
4095 Result
.A
:= PWordRec(Bits
).High
4098 Result
.R
:= PWordRec(Bits
).Low
;
4099 Result
.G
:= PWordRec(Bits
).Low
;
4100 Result
.B
:= PWordRec(Bits
).Low
;
4105 procedure SetPixel32Channel8Bit(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColor32Rec
);
4108 ifR8G8B8
, ifX8R8G8B8
:
4110 PColor24Rec(Bits
)^ := PColor24Rec(@Color
)^;
4114 if Info
.HasAlphaChannel
then
4115 PWordRec(Bits
).High
:= Color
.A
;
4116 PWordRec(Bits
).Low
:= Round(GrayConv
.R
* Color
.R
+ GrayConv
.G
* Color
.G
+
4117 GrayConv
.B
* Color
.B
);
4122 function GetPixelFPChannel8Bit(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColorFPRec
;
4129 ifR8G8B8
, ifX8R8G8B8
:
4132 Result
.R
:= PColor24Rec(Bits
).R
* OneDiv8Bit
;
4133 Result
.G
:= PColor24Rec(Bits
).G
* OneDiv8Bit
;
4134 Result
.B
:= PColor24Rec(Bits
).B
* OneDiv8Bit
;
4138 if Info
.HasAlphaChannel
then
4139 Result
.A
:= PWordRec(Bits
).High
* OneDiv8Bit
4142 Result
.R
:= PWordRec(Bits
).Low
* OneDiv8Bit
;
4143 Result
.G
:= PWordRec(Bits
).Low
* OneDiv8Bit
;
4144 Result
.B
:= PWordRec(Bits
).Low
* OneDiv8Bit
;
4149 procedure SetPixelFPChannel8Bit(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColorFPRec
);
4152 ifR8G8B8
, ifX8R8G8B8
:
4154 PColor24Rec(Bits
).R
:= ClampToByte(Round(Color
.R
* 255.0));
4155 PColor24Rec(Bits
).G
:= ClampToByte(Round(Color
.G
* 255.0));
4156 PColor24Rec(Bits
).B
:= ClampToByte(Round(Color
.B
* 255.0));
4160 if Info
.HasAlphaChannel
then
4161 PWordRec(Bits
).High
:= ClampToByte(Round(Color
.A
* 255.0));
4162 PWordRec(Bits
).Low
:= ClampToByte(Round((GrayConv
.R
* Color
.R
+ GrayConv
.G
* Color
.G
+
4163 GrayConv
.B
* Color
.B
) * 255.0));
4168 function GetPixelFPFloat32(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
): TColorFPRec
;
4177 Result
:= PColorFPRec(Bits
)^;
4181 Result
:= PColorFPRec(Bits
)^;
4182 SwapValues(Result
.R
, Result
.B
);
4187 Result
.R
:= PSingle(Bits
)^;
4194 procedure SetPixelFPFloat32(Bits
: Pointer; Info
: PImageFormatInfo
; Palette
: PPalette32
; const Color
: TColorFPRec
);
4199 PColorFPRec(Bits
)^ := Color
;
4203 PColorFPRec(Bits
)^ := Color
;
4204 SwapValues(PColorFPRec(Bits
).R
, PColorFPRec(Bits
).B
);
4208 PSingle(Bits
)^ := Color
.R
;
4214 // Initialize default sampling filter function pointers and radii
4215 SamplingFilterFunctions
[sfNearest
] := FilterNearest
;
4216 SamplingFilterFunctions
[sfLinear
] := FilterLinear
;
4217 SamplingFilterFunctions
[sfCosine
] := FilterCosine
;
4218 SamplingFilterFunctions
[sfHermite
] := FilterHermite
;
4219 SamplingFilterFunctions
[sfQuadratic
] := FilterQuadratic
;
4220 SamplingFilterFunctions
[sfGaussian
] := FilterGaussian
;
4221 SamplingFilterFunctions
[sfSpline
] := FilterSpline
;
4222 SamplingFilterFunctions
[sfLanczos
] := FilterLanczos
;
4223 SamplingFilterFunctions
[sfMitchell
] := FilterMitchell
;
4224 SamplingFilterFunctions
[sfCatmullRom
] := FilterCatmullRom
;
4225 SamplingFilterRadii
[sfNearest
] := 1.0;
4226 SamplingFilterRadii
[sfLinear
] := 1.0;
4227 SamplingFilterRadii
[sfCosine
] := 1.0;
4228 SamplingFilterRadii
[sfHermite
] := 1.0;
4229 SamplingFilterRadii
[sfQuadratic
] := 1.5;
4230 SamplingFilterRadii
[sfGaussian
] := 1.25;
4231 SamplingFilterRadii
[sfSpline
] := 2.0;
4232 SamplingFilterRadii
[sfLanczos
] := 3.0;
4233 SamplingFilterRadii
[sfMitchell
] := 2.0;
4234 SamplingFilterRadii
[sfCatmullRom
] := 2.0;
4239 -- TODOS ----------------------------------------------------
4242 -- 0.26.3 Changes/Bug Fixes -----------------------------------
4243 - Filtered resampling ~10% faster now.
4244 - Fixed DXT3 alpha encoding.
4245 - ifIndex8 format now has HasAlphaChannel=True.
4247 -- 0.25.0 Changes/Bug Fixes -----------------------------------
4248 - Made some resampling stuff public so that it can be used in canvas class.
4249 - Added some color constructors.
4250 - Added VisualizePalette helper function.
4251 - Fixed ConvertSpecial, not very readable before and error when
4252 converting special->special.
4254 -- 0.24.3 Changes/Bug Fixes -----------------------------------
4255 - Some refactorings a changes to DXT based formats.
4256 - Added ifATI1N and ifATI2N image data formats support structures and functions.
4258 -- 0.23 Changes/Bug Fixes -----------------------------------
4259 - Added ifBTC image format support structures and functions.
4261 -- 0.21 Changes/Bug Fixes -----------------------------------
4262 - FillMipMapLevel now works well with indexed and special formats too.
4263 - Moved Convert1To8 and Convert4To8 functions from ImagingBitmaps here
4264 and created new Convert2To8 function. They are now used by more than one
4267 -- 0.19 Changes/Bug Fixes -----------------------------------
4268 - StretchResample now uses pixel get/set functions stored in
4269 TImageFormatInfo so it is much faster for formats that override
4270 them with optimized ones
4271 - added pixel set/get functions optimized for various image formats
4272 (to be stored in TImageFormatInfo)
4273 - bug in ConvertSpecial caused problems when converting DXTC images
4274 to bitmaps in ImagingCoponents
4275 - bug in StretchRect caused that it didn't work with ifR32F and
4277 - removed leftover code in FillMipMapLevel which disabled
4278 filtered resizing of images witch ChannelSize <> 8bits
4279 - added half float converting functions and support for half based
4280 image formats where needed
4281 - added TranslatePixel and IsImageFormatValid functions
4282 - fixed possible range overflows when converting from FP to integer images
4283 - added pixel set/get functions: GetPixel32Generic, GetPixelFPGeneric,
4284 SetPixel32Generic, SetPixelFPGeneric
4285 - fixed occasional range overflows in StretchResample
4287 -- 0.17 Changes/Bug Fixes -----------------------------------
4288 - added StretchNearest, StretchResample and some sampling functions
4289 - added ChannelCount values to TImageFormatInfo constants
4290 - added resolution validity check to GetDXTPixelsSize
4292 -- 0.15 Changes/Bug Fixes -----------------------------------
4293 - added RBSwapFormat values to some TImageFromatInfo definitions
4294 - fixed bug in ConvertSpecial (causing DXT images to convert only to 32bit)
4295 - added CopyPixel, ComparePixels helper functions
4297 -- 0.13 Changes/Bug Fixes -----------------------------------
4298 - replaced pixel format conversions for colors not to be
4299 darkened when converting from low bit counts
4300 - ReduceColorsMedianCut was updated to support creating one
4301 optimal palette for more images and it is somewhat faster
4303 - there was ugly bug in DXTC dimensions checking