DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / d2df-sdl.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
profiler cosmetix
[d2df-sdl.git] / src / lib / vampimg / ImagingFormats.pas
1 {
2 Vampyre Imaging Library
3 by Marek Mauder
4 http://imaginglib.sourceforge.net
5
6 The contents of this file are used with permission, subject to the Mozilla
7 Public License Version 1.1 (the "License"); you may not use this file except
8 in compliance with the License. You may obtain a copy of the License at
9 http://www.mozilla.org/MPL/MPL-1.1.html
10
11 Software distributed under the License is distributed on an "AS IS" basis,
12 WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
13 the specific language governing rights and limitations under the License.
14
15 Alternatively, the contents of this file may be used under the terms of the
16 GNU Lesser General Public License (the "LGPL License"), in which case the
17 provisions of the LGPL License are applicable instead of those above.
18 If you wish to allow use of your version of this file only under the terms
19 of the LGPL License and not to allow others to use your version of this file
20 under the MPL, indicate your decision by deleting the provisions above and
21 replace them with the notice and other provisions required by the LGPL
22 License. If you do not delete the provisions above, a recipient may use
23 your version of this file under either the MPL or the LGPL License.
24
25 For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
26 }
27
28 { This unit manages information about all image data formats and contains
29 low level format conversion, manipulation, and other related functions.}
30 unit ImagingFormats;
31
32 {$I ImagingOptions.inc}
33
34 interface
35
36 uses
37 ImagingTypes, Imaging, ImagingUtility;
38
39 type
40 TImageFormatInfoArray = array[TImageFormat] of PImageFormatInfo;
41 PImageFormatInfoArray = ^TImageFormatInfoArray;
42
43
44 { Additional image manipulation functions (usually used internally by Imaging unit) }
45
46 type
47 { Color reduction operations.}
48 TReduceColorsAction = (raCreateHistogram, raUpdateHistogram, raMakeColorMap,
49 raMapImage);
50 TReduceColorsActions = set of TReduceColorsAction;
51 const
52 AllReduceColorsActions = [raCreateHistogram, raUpdateHistogram,
53 raMakeColorMap, raMapImage];
54 { Reduces the number of colors of source. Src is bits of source image
55 (ARGB or floating point) and Dst is in some indexed format. MaxColors
56 is the number of colors to which reduce and DstPal is palette to which
57 the resulting colors are written and it must be allocated to at least
58 MaxColors entries. ChannelMask is 'anded' with every pixel's channel value
59 when creating color histogram. If $FF is used all 8bits of color channels
60 are used which can be slow for large images with many colors so you can
61 use lower masks to speed it up.}
62 procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
63 DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte;
64 DstPal: PPalette32; Actions: TReduceColorsActions = AllReduceColorsActions);
65 { Stretches rectangle in source image to rectangle in destination image
66 using nearest neighbor filtering. It is fast but results look blocky
67 because there is no interpolation used. SrcImage and DstImage must be
68 in the same data format. Works for all data formats except special formats.}
69 procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
70 SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
71 DstHeight: LongInt);
72 type
73 { Built-in sampling filters.}
74 TSamplingFilter = (sfNearest, sfLinear, sfCosine, sfHermite, sfQuadratic,
75 sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom);
76 { Type of custom sampling function}
77 TFilterFunction = function(Value: Single): Single;
78 const
79 { Default resampling filter used for bicubic resizing.}
80 DefaultCubicFilter = sfCatmullRom;
81 var
82 { Built-in filter functions.}
83 SamplingFilterFunctions: array[TSamplingFilter] of TFilterFunction;
84 { Default radii of built-in filter functions.}
85 SamplingFilterRadii: array[TSamplingFilter] of Single;
86
87 { Stretches rectangle in source image to rectangle in destination image
88 with resampling. One of built-in resampling filters defined by
89 Filter is used. Set WrapEdges to True for seamlessly tileable images.
90 SrcImage and DstImage must be in the same data format.
91 Works for all data formats except special and indexed formats.}
92 procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
93 SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
94 DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean = False); overload;
95 { Stretches rectangle in source image to rectangle in destination image
96 with resampling. You can use custom sampling function and filter radius.
97 Set WrapEdges to True for seamlessly tileable images. SrcImage and DstImage
98 must be in the same data format.
99 Works for all data formats except special and indexed formats.}
100 procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
101 SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
102 DstHeight: LongInt; Filter: TFilterFunction; Radius: Single;
103 WrapEdges: Boolean = False); overload;
104 { Helper for functions that create mipmap levels. BiggerLevel is
105 valid image and SmallerLevel is empty zeroed image. SmallerLevel is created
106 with Width and Height dimensions and it is filled with pixels of BiggerLevel
107 using resampling filter specified by ImagingMipMapFilter option.
108 Uses StretchNearest and StretchResample internally so the same image data format
109 limitations apply.}
110 procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt;
111 var SmallerLevel: TImageData);
112
113
114 { Various helper & support functions }
115
116 { Copies Src pixel to Dest pixel. It is faster than System.Move procedure.}
117 procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
118 { Compares Src pixel and Dest pixel. It is faster than SysUtils.CompareMem function.}
119 function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
120 { Translates pixel color in SrcFormat to DstFormat.}
121 procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat,
122 DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32);
123 { Clamps floating point pixel channel values to [0.0, 1.0] range.}
124 procedure ClampFloatPixel(var PixF: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
125 { Helper function that converts pixel in any format to 32bit ARGB pixel.
126 For common formats it's faster than calling GetPixel32 etc.}
127 procedure ConvertToPixel32(SrcPix: PByte; DestPix: PColor32Rec;
128 const SrcInfo: TImageFormatInfo; SrcPalette: PPalette32 = nil); {$IFDEF USE_INLINE}inline;{$ENDIF}
129
130 { Adds padding bytes at the ends of scanlines. Bpp is the number of bytes per
131 pixel of source and WidthBytes is the number of bytes per scanlines of dest.}
132 procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
133 Bpp, WidthBytes: LongInt);
134 { Removes padding from image with scanlines that have aligned sizes. Bpp is
135 the number of bytes per pixel of dest and WidthBytes is the number of bytes
136 per scanlines of source.}
137 procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
138 Bpp, WidthBytes: LongInt);
139
140 { Converts 1bit image data to 8bit. Used mostly by file loaders for formats
141 supporting 1bit images. Scaling of pixel values to 8bits is optional
142 (indexed formats don't need this).}
143 procedure Convert1To8(DataIn, DataOut: PByte; Width, Height,
144 WidthBytes: LongInt; ScaleTo8Bits: Boolean);
145 { Converts 2bit image data to 8bit. Used mostly by file loaders for formats
146 supporting 2bit images. Scaling of pixel values to 8bits is optional
147 (indexed formats don't need this).}
148 procedure Convert2To8(DataIn, DataOut: PByte; Width, Height,
149 WidthBytes: LongInt; ScaleTo8Bits: Boolean);
150 { Converts 4bit image data to 8bit. Used mostly by file loaders for formats
151 supporting 4bit images. Scaling of pixel values to 8bits is optional
152 (indexed formats don't need this).}
153 procedure Convert4To8(DataIn, DataOut: PByte; Width, Height,
154 WidthBytes: LongInt; ScaleTo8Bits: Boolean);
155
156 { Helper function for image file loaders. Some 15 bit images (targas, bitmaps)
157 may contain 1 bit alpha but there is no indication of it. This function checks
158 all 16 bit(should be X1R5G5B5 or A1R5G5B5 format) pixels and some of them have
159 alpha bit set it returns True, otherwise False.}
160 function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean;
161 { Helper function for image file loaders. This function checks is similar
162 to Has16BitImageAlpha but works with A8R8G8B8/X8R8G8B8 format.}
163 function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean;
164 { Checks if there is any relevant alpha data (any entry has alpha <> 255)
165 in the given palette.}
166 function PaletteHasAlpha(Palette: PPalette32; PaletteEntries: Integer): Boolean;
167
168 { Provides indexed access to each line of pixels. Does not work with special
169 format images.}
170 function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
171 LineWidth, Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
172 { Returns True if Format is valid image data format identifier.}
173 function IsImageFormatValid(Format: TImageFormat): Boolean;
174
175 { Converts 16bit half floating point value to 32bit Single.}
176 function HalfToFloat(Half: THalfFloat): Single;
177 { Converts 32bit Single to 16bit half floating point.}
178 function FloatToHalf(Float: Single): THalfFloat;
179
180 { Converts half float color value to single-precision floating point color.}
181 function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
182 { Converts single-precision floating point color to half float color.}
183 function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
184
185 { Makes image PalEntries x 1 big where each pixel has color of one pal entry.}
186 procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData);
187
188 type
189 TPointRec = record
190 Pos: LongInt;
191 Weight: Single;
192 end;
193 TCluster = array of TPointRec;
194 TMappingTable = array of TCluster;
195
196 { Helper function for resampling.}
197 function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
198 Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
199 { Helper function for resampling.}
200 procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt);
201
202
203 { Pixel readers/writers for different image formats }
204
205 { Returns pixel of image in any ARGB format. Channel values are scaled to 16 bits.}
206 procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
207 var Pix: TColor64Rec);
208 { Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.}
209 procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
210 const Pix: TColor64Rec);
211
212 { Returns pixel of image in any grayscale format. Gray value is scaled to 64 bits
213 and alpha to 16 bits.}
214 procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
215 var Gray: TColor64Rec; var Alpha: Word);
216 { Sets pixel of image in any grayscale format. Gray value must be scaled to 64 bits
217 and alpha to 16 bits.}
218 procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
219 const Gray: TColor64Rec; Alpha: Word);
220
221 { Returns pixel of image in any floating point format. Channel values are
222 in range <0.0, 1.0>.}
223 procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
224 var Pix: TColorFPRec);
225 { Sets pixel of image in any floating point format. Channel values must be
226 in range <0.0, 1.0>.}
227 procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
228 const Pix: TColorFPRec);
229
230 { Returns pixel of image in any indexed format. Returned value is index to
231 the palette.}
232 procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
233 var Index: LongWord);
234 { Sets pixel of image in any indexed format. Index is index to the palette.}
235 procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
236 Index: LongWord);
237
238
239 { Pixel readers/writers for 32bit and FP colors}
240
241 { Function for getting pixel colors. Native pixel is read from Image and
242 then translated to 32 bit ARGB.}
243 function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo;
244 Palette: PPalette32): TColor32Rec;
245 { Procedure for setting pixel colors. Input 32 bit ARGB color is translated to
246 native format and then written to Image.}
247 procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo;
248 Palette: PPalette32; const Color: TColor32Rec);
249 { Function for getting pixel colors. Native pixel is read from Image and
250 then translated to FP ARGB.}
251 function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo;
252 Palette: PPalette32): TColorFPRec;
253 { Procedure for setting pixel colors. Input FP ARGB color is translated to
254 native format and then written to Image.}
255 procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo;
256 Palette: PPalette32; const Color: TColorFPRec);
257
258
259 { Image format conversion functions }
260
261 { Converts any ARGB format to any ARGB format.}
262 procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
263 DstInfo: PImageFormatInfo);
264 { Converts any ARGB format to any grayscale format.}
265 procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
266 DstInfo: PImageFormatInfo);
267 { Converts any ARGB format to any floating point format.}
268 procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
269 DstInfo: PImageFormatInfo);
270 { Converts any ARGB format to any indexed format.}
271 procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
272 DstInfo: PImageFormatInfo; DstPal: PPalette32);
273
274 { Converts any grayscale format to any grayscale format.}
275 procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
276 DstInfo: PImageFormatInfo);
277 { Converts any grayscale format to any ARGB format.}
278 procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
279 DstInfo: PImageFormatInfo);
280 { Converts any grayscale format to any floating point format.}
281 procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
282 DstInfo: PImageFormatInfo);
283 { Converts any grayscale format to any indexed format.}
284 procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
285 DstInfo: PImageFormatInfo; DstPal: PPalette32);
286
287 { Converts any floating point format to any floating point format.}
288 procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
289 DstInfo: PImageFormatInfo);
290 { Converts any floating point format to any ARGB format.}
291 procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
292 DstInfo: PImageFormatInfo);
293 { Converts any floating point format to any grayscale format.}
294 procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
295 DstInfo: PImageFormatInfo);
296 { Converts any floating point format to any indexed format.}
297 procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
298 DstInfo: PImageFormatInfo; DstPal: PPalette32);
299
300 { Converts any indexed format to any indexed format.}
301 procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
302 DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32);
303 { Converts any indexed format to any ARGB format.}
304 procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
305 DstInfo: PImageFormatInfo; SrcPal: PPalette32);
306 { Converts any indexed format to any grayscale format.}
307 procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
308 DstInfo: PImageFormatInfo; SrcPal: PPalette32);
309 { Converts any indexed format to any floating point format.}
310 procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
311 DstInfo: PImageFormatInfo; SrcPal: PPalette32);
312
313
314 { Color constructor functions }
315
316 { Constructs TColor24Rec color.}
317 function Color24(R, G, B: Byte): TColor24Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
318 { Constructs TColor32Rec color.}
319 function Color32(A, R, G, B: Byte): TColor32Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
320 { Constructs TColor48Rec color.}
321 function Color48(R, G, B: Word): TColor48Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
322 { Constructs TColor64Rec color.}
323 function Color64(A, R, G, B: Word): TColor64Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
324 { Constructs TColorFPRec color.}
325 function ColorFP(A, R, G, B: Single): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
326 { Constructs TColorHFRec color.}
327 function ColorHF(A, R, G, B: THalfFloat): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
328
329
330 { Special formats conversion functions }
331
332 { Converts image to/from/between special image formats (dxtc, ...).}
333 procedure ConvertSpecial(var Image: TImageData; SrcInfo,
334 DstInfo: PImageFormatInfo);
335
336
337 { Inits all image format information. Called internally on startup.}
338 procedure InitImageFormats(var Infos: TImageFormatInfoArray);
339
340 const
341 // Grayscale conversion channel weights
342 GrayConv: TColorFPRec = (B: 0.114; G: 0.587; R: 0.299; A: 0.0);
343
344 // Contants for converting integer colors to floating point
345 OneDiv8Bit: Single = 1.0 / 255.0;
346 OneDiv16Bit: Single = 1.0 / 65535.0;
347
348 implementation
349
350 { TImageFormatInfo member functions }
351
352 { Returns size in bytes of image in given standard format where
353 Size = Width * Height * Bpp.}
354 function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
355 { Checks if Width and Height are valid for given standard format.}
356 procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;
357 { Returns size in bytes of image in given DXT format.}
358 function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
359 { Checks if Width and Height are valid for given DXT format. If they are
360 not valid, they are changed to pass the check.}
361 procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;
362 { Returns size in bytes of image in BTC format.}
363 function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
364 { Returns size in bytes of image in binary format (1bit image).}
365 function GetBinaryPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
366
367 function GetBCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
368 procedure CheckBCDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;
369
370
371 { Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }
372
373 function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward;
374 procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward;
375 function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
376 procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
377
378 function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward;
379 procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward;
380 function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
381 procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
382
383 function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
384 procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
385
386 var
387 PFR3G3B2: TPixelFormatInfo;
388 PFX5R1G1B1: TPixelFormatInfo;
389 PFR5G6B5: TPixelFormatInfo;
390 PFA1R5G5B5: TPixelFormatInfo;
391 PFA4R4G4B4: TPixelFormatInfo;
392 PFX1R5G5B5: TPixelFormatInfo;
393 PFX4R4G4B4: TPixelFormatInfo;
394 FInfos: PImageFormatInfoArray;
395
396 var
397 // Free Pascal generates hundreds of warnings here
398 {$WARNINGS OFF}
399
400 // indexed formats
401 Index8Info: TImageFormatInfo = (
402 Format: ifIndex8;
403 Name: 'Index8';
404 BytesPerPixel: 1;
405 ChannelCount: 1;
406 PaletteEntries: 256;
407 HasAlphaChannel: True;
408 IsIndexed: True;
409 GetPixelsSize: GetStdPixelsSize;
410 CheckDimensions: CheckStdDimensions;
411 GetPixel32: GetPixel32Generic;
412 GetPixelFP: GetPixelFPGeneric;
413 SetPixel32: SetPixel32Generic;
414 SetPixelFP: SetPixelFPGeneric);
415
416 // grayscale formats
417 Gray8Info: TImageFormatInfo = (
418 Format: ifGray8;
419 Name: 'Gray8';
420 BytesPerPixel: 1;
421 ChannelCount: 1;
422 HasGrayChannel: True;
423 GetPixelsSize: GetStdPixelsSize;
424 CheckDimensions: CheckStdDimensions;
425 GetPixel32: GetPixel32Channel8Bit;
426 GetPixelFP: GetPixelFPChannel8Bit;
427 SetPixel32: SetPixel32Channel8Bit;
428 SetPixelFP: SetPixelFPChannel8Bit);
429
430 A8Gray8Info: TImageFormatInfo = (
431 Format: ifA8Gray8;
432 Name: 'A8Gray8';
433 BytesPerPixel: 2;
434 ChannelCount: 2;
435 HasGrayChannel: True;
436 HasAlphaChannel: True;
437 GetPixelsSize: GetStdPixelsSize;
438 CheckDimensions: CheckStdDimensions;
439 GetPixel32: GetPixel32Channel8Bit;
440 GetPixelFP: GetPixelFPChannel8Bit;
441 SetPixel32: SetPixel32Channel8Bit;
442 SetPixelFP: SetPixelFPChannel8Bit);
443
444 Gray16Info: TImageFormatInfo = (
445 Format: ifGray16;
446 Name: 'Gray16';
447 BytesPerPixel: 2;
448 ChannelCount: 1;
449 HasGrayChannel: True;
450 GetPixelsSize: GetStdPixelsSize;
451 CheckDimensions: CheckStdDimensions;
452 GetPixel32: GetPixel32Generic;
453 GetPixelFP: GetPixelFPGeneric;
454 SetPixel32: SetPixel32Generic;
455 SetPixelFP: SetPixelFPGeneric);
456
457 Gray32Info: TImageFormatInfo = (
458 Format: ifGray32;
459 Name: 'Gray32';
460 BytesPerPixel: 4;
461 ChannelCount: 1;
462 HasGrayChannel: True;
463 GetPixelsSize: GetStdPixelsSize;
464 CheckDimensions: CheckStdDimensions;
465 GetPixel32: GetPixel32Generic;
466 GetPixelFP: GetPixelFPGeneric;
467 SetPixel32: SetPixel32Generic;
468 SetPixelFP: SetPixelFPGeneric);
469
470 Gray64Info: TImageFormatInfo = (
471 Format: ifGray64;
472 Name: 'Gray64';
473 BytesPerPixel: 8;
474 ChannelCount: 1;
475 HasGrayChannel: True;
476 GetPixelsSize: GetStdPixelsSize;
477 CheckDimensions: CheckStdDimensions;
478 GetPixel32: GetPixel32Generic;
479 GetPixelFP: GetPixelFPGeneric;
480 SetPixel32: SetPixel32Generic;
481 SetPixelFP: SetPixelFPGeneric);
482
483 A16Gray16Info: TImageFormatInfo = (
484 Format: ifA16Gray16;
485 Name: 'A16Gray16';
486 BytesPerPixel: 4;
487 ChannelCount: 2;
488 HasGrayChannel: True;
489 HasAlphaChannel: True;
490 GetPixelsSize: GetStdPixelsSize;
491 CheckDimensions: CheckStdDimensions;
492 GetPixel32: GetPixel32Generic;
493 GetPixelFP: GetPixelFPGeneric;
494 SetPixel32: SetPixel32Generic;
495 SetPixelFP: SetPixelFPGeneric);
496
497 // ARGB formats
498 X5R1G1B1Info: TImageFormatInfo = (
499 Format: ifX5R1G1B1;
500 Name: 'X5R1G1B1';
501 BytesPerPixel: 1;
502 ChannelCount: 3;
503 UsePixelFormat: True;
504 PixelFormat: @PFX5R1G1B1;
505 GetPixelsSize: GetStdPixelsSize;
506 CheckDimensions: CheckStdDimensions;
507 GetPixel32: GetPixel32Generic;
508 GetPixelFP: GetPixelFPGeneric;
509 SetPixel32: SetPixel32Generic;
510 SetPixelFP: SetPixelFPGeneric);
511
512 R3G3B2Info: TImageFormatInfo = (
513 Format: ifR3G3B2;
514 Name: 'R3G3B2';
515 BytesPerPixel: 1;
516 ChannelCount: 3;
517 UsePixelFormat: True;
518 PixelFormat: @PFR3G3B2;
519 GetPixelsSize: GetStdPixelsSize;
520 CheckDimensions: CheckStdDimensions;
521 GetPixel32: GetPixel32Generic;
522 GetPixelFP: GetPixelFPGeneric;
523 SetPixel32: SetPixel32Generic;
524 SetPixelFP: SetPixelFPGeneric);
525
526 R5G6B5Info: TImageFormatInfo = (
527 Format: ifR5G6B5;
528 Name: 'R5G6B5';
529 BytesPerPixel: 2;
530 ChannelCount: 3;
531 UsePixelFormat: True;
532 PixelFormat: @PFR5G6B5;
533 GetPixelsSize: GetStdPixelsSize;
534 CheckDimensions: CheckStdDimensions;
535 GetPixel32: GetPixel32Generic;
536 GetPixelFP: GetPixelFPGeneric;
537 SetPixel32: SetPixel32Generic;
538 SetPixelFP: SetPixelFPGeneric);
539
540 A1R5G5B5Info: TImageFormatInfo = (
541 Format: ifA1R5G5B5;
542 Name: 'A1R5G5B5';
543 BytesPerPixel: 2;
544 ChannelCount: 4;
545 HasAlphaChannel: True;
546 UsePixelFormat: True;
547 PixelFormat: @PFA1R5G5B5;
548 GetPixelsSize: GetStdPixelsSize;
549 CheckDimensions: CheckStdDimensions;
550 GetPixel32: GetPixel32Generic;
551 GetPixelFP: GetPixelFPGeneric;
552 SetPixel32: SetPixel32Generic;
553 SetPixelFP: SetPixelFPGeneric);
554
555 A4R4G4B4Info: TImageFormatInfo = (
556 Format: ifA4R4G4B4;
557 Name: 'A4R4G4B4';
558 BytesPerPixel: 2;
559 ChannelCount: 4;
560 HasAlphaChannel: True;
561 UsePixelFormat: True;
562 PixelFormat: @PFA4R4G4B4;
563 GetPixelsSize: GetStdPixelsSize;
564 CheckDimensions: CheckStdDimensions;
565 GetPixel32: GetPixel32Generic;
566 GetPixelFP: GetPixelFPGeneric;
567 SetPixel32: SetPixel32Generic;
568 SetPixelFP: SetPixelFPGeneric);
569
570 X1R5G5B5Info: TImageFormatInfo = (
571 Format: ifX1R5G5B5;
572 Name: 'X1R5G5B5';
573 BytesPerPixel: 2;
574 ChannelCount: 3;
575 UsePixelFormat: True;
576 PixelFormat: @PFX1R5G5B5;
577 GetPixelsSize: GetStdPixelsSize;
578 CheckDimensions: CheckStdDimensions;
579 GetPixel32: GetPixel32Generic;
580 GetPixelFP: GetPixelFPGeneric;
581 SetPixel32: SetPixel32Generic;
582 SetPixelFP: SetPixelFPGeneric);
583
584 X4R4G4B4Info: TImageFormatInfo = (
585 Format: ifX4R4G4B4;
586 Name: 'X4R4G4B4';
587 BytesPerPixel: 2;
588 ChannelCount: 3;
589 UsePixelFormat: True;
590 PixelFormat: @PFX4R4G4B4;
591 GetPixelsSize: GetStdPixelsSize;
592 CheckDimensions: CheckStdDimensions;
593 GetPixel32: GetPixel32Generic;
594 GetPixelFP: GetPixelFPGeneric;
595 SetPixel32: SetPixel32Generic;
596 SetPixelFP: SetPixelFPGeneric);
597
598 R8G8B8Info: TImageFormatInfo = (
599 Format: ifR8G8B8;
600 Name: 'R8G8B8';
601 BytesPerPixel: 3;
602 ChannelCount: 3;
603 GetPixelsSize: GetStdPixelsSize;
604 CheckDimensions: CheckStdDimensions;
605 GetPixel32: GetPixel32Channel8Bit;
606 GetPixelFP: GetPixelFPChannel8Bit;
607 SetPixel32: SetPixel32Channel8Bit;
608 SetPixelFP: SetPixelFPChannel8Bit);
609
610 A8R8G8B8Info: TImageFormatInfo = (
611 Format: ifA8R8G8B8;
612 Name: 'A8R8G8B8';
613 BytesPerPixel: 4;
614 ChannelCount: 4;
615 HasAlphaChannel: True;
616 GetPixelsSize: GetStdPixelsSize;
617 CheckDimensions: CheckStdDimensions;
618 GetPixel32: GetPixel32ifA8R8G8B8;
619 GetPixelFP: GetPixelFPifA8R8G8B8;
620 SetPixel32: SetPixel32ifA8R8G8B8;
621 SetPixelFP: SetPixelFPifA8R8G8B8);
622
623 X8R8G8B8Info: TImageFormatInfo = (
624 Format: ifX8R8G8B8;
625 Name: 'X8R8G8B8';
626 BytesPerPixel: 4;
627 ChannelCount: 3;
628 GetPixelsSize: GetStdPixelsSize;
629 CheckDimensions: CheckStdDimensions;
630 GetPixel32: GetPixel32Channel8Bit;
631 GetPixelFP: GetPixelFPChannel8Bit;
632 SetPixel32: SetPixel32Channel8Bit;
633 SetPixelFP: SetPixelFPChannel8Bit);
634
635 R16G16B16Info: TImageFormatInfo = (
636 Format: ifR16G16B16;
637 Name: 'R16G16B16';
638 BytesPerPixel: 6;
639 ChannelCount: 3;
640 RBSwapFormat: ifB16G16R16;
641 GetPixelsSize: GetStdPixelsSize;
642 CheckDimensions: CheckStdDimensions;
643 GetPixel32: GetPixel32Generic;
644 GetPixelFP: GetPixelFPGeneric;
645 SetPixel32: SetPixel32Generic;
646 SetPixelFP: SetPixelFPGeneric);
647
648 A16R16G16B16Info: TImageFormatInfo = (
649 Format: ifA16R16G16B16;
650 Name: 'A16R16G16B16';
651 BytesPerPixel: 8;
652 ChannelCount: 4;
653 HasAlphaChannel: True;
654 RBSwapFormat: ifA16B16G16R16;
655 GetPixelsSize: GetStdPixelsSize;
656 CheckDimensions: CheckStdDimensions;
657 GetPixel32: GetPixel32Generic;
658 GetPixelFP: GetPixelFPGeneric;
659 SetPixel32: SetPixel32Generic;
660 SetPixelFP: SetPixelFPGeneric);
661
662 B16G16R16Info: TImageFormatInfo = (
663 Format: ifB16G16R16;
664 Name: 'B16G16R16';
665 BytesPerPixel: 6;
666 ChannelCount: 3;
667 IsRBSwapped: True;
668 RBSwapFormat: ifR16G16B16;
669 GetPixelsSize: GetStdPixelsSize;
670 CheckDimensions: CheckStdDimensions;
671 GetPixel32: GetPixel32Generic;
672 GetPixelFP: GetPixelFPGeneric;
673 SetPixel32: SetPixel32Generic;
674 SetPixelFP: SetPixelFPGeneric);
675
676 A16B16G16R16Info: TImageFormatInfo = (
677 Format: ifA16B16G16R16;
678 Name: 'A16B16G16R16';
679 BytesPerPixel: 8;
680 ChannelCount: 4;
681 HasAlphaChannel: True;
682 IsRBSwapped: True;
683 RBSwapFormat: ifA16R16G16B16;
684 GetPixelsSize: GetStdPixelsSize;
685 CheckDimensions: CheckStdDimensions;
686 GetPixel32: GetPixel32Generic;
687 GetPixelFP: GetPixelFPGeneric;
688 SetPixel32: SetPixel32Generic;
689 SetPixelFP: SetPixelFPGeneric);
690
691 // floating point formats
692 R32FInfo: TImageFormatInfo = (
693 Format: ifR32F;
694 Name: 'R32F';
695 BytesPerPixel: 4;
696 ChannelCount: 1;
697 IsFloatingPoint: True;
698 GetPixelsSize: GetStdPixelsSize;
699 CheckDimensions: CheckStdDimensions;
700 GetPixel32: GetPixel32Generic;
701 GetPixelFP: GetPixelFPFloat32;
702 SetPixel32: SetPixel32Generic;
703 SetPixelFP: SetPixelFPFloat32);
704
705 A32R32G32B32FInfo: TImageFormatInfo = (
706 Format: ifA32R32G32B32F;
707 Name: 'A32R32G32B32F';
708 BytesPerPixel: 16;
709 ChannelCount: 4;
710 HasAlphaChannel: True;
711 IsFloatingPoint: True;
712 RBSwapFormat: ifA32B32G32R32F;
713 GetPixelsSize: GetStdPixelsSize;
714 CheckDimensions: CheckStdDimensions;
715 GetPixel32: GetPixel32Generic;
716 GetPixelFP: GetPixelFPFloat32;
717 SetPixel32: SetPixel32Generic;
718 SetPixelFP: SetPixelFPFloat32);
719
720 A32B32G32R32FInfo: TImageFormatInfo = (
721 Format: ifA32B32G32R32F;
722 Name: 'A32B32G32R32F';
723 BytesPerPixel: 16;
724 ChannelCount: 4;
725 HasAlphaChannel: True;
726 IsFloatingPoint: True;
727 IsRBSwapped: True;
728 RBSwapFormat: ifA32R32G32B32F;
729 GetPixelsSize: GetStdPixelsSize;
730 CheckDimensions: CheckStdDimensions;
731 GetPixel32: GetPixel32Generic;
732 GetPixelFP: GetPixelFPFloat32;
733 SetPixel32: SetPixel32Generic;
734 SetPixelFP: SetPixelFPFloat32);
735
736 R16FInfo: TImageFormatInfo = (
737 Format: ifR16F;
738 Name: 'R16F';
739 BytesPerPixel: 2;
740 ChannelCount: 1;
741 IsFloatingPoint: True;
742 GetPixelsSize: GetStdPixelsSize;
743 CheckDimensions: CheckStdDimensions;
744 GetPixel32: GetPixel32Generic;
745 GetPixelFP: GetPixelFPGeneric;
746 SetPixel32: SetPixel32Generic;
747 SetPixelFP: SetPixelFPGeneric);
748
749 A16R16G16B16FInfo: TImageFormatInfo = (
750 Format: ifA16R16G16B16F;
751 Name: 'A16R16G16B16F';
752 BytesPerPixel: 8;
753 ChannelCount: 4;
754 HasAlphaChannel: True;
755 IsFloatingPoint: True;
756 RBSwapFormat: ifA16B16G16R16F;
757 GetPixelsSize: GetStdPixelsSize;
758 CheckDimensions: CheckStdDimensions;
759 GetPixel32: GetPixel32Generic;
760 GetPixelFP: GetPixelFPGeneric;
761 SetPixel32: SetPixel32Generic;
762 SetPixelFP: SetPixelFPGeneric);
763
764 A16B16G16R16FInfo: TImageFormatInfo = (
765 Format: ifA16B16G16R16F;
766 Name: 'A16B16G16R16F';
767 BytesPerPixel: 8;
768 ChannelCount: 4;
769 HasAlphaChannel: True;
770 IsFloatingPoint: True;
771 IsRBSwapped: True;
772 RBSwapFormat: ifA16R16G16B16F;
773 GetPixelsSize: GetStdPixelsSize;
774 CheckDimensions: CheckStdDimensions;
775 GetPixel32: GetPixel32Generic;
776 GetPixelFP: GetPixelFPGeneric;
777 SetPixel32: SetPixel32Generic;
778 SetPixelFP: SetPixelFPGeneric);
779
780 R32G32B32FInfo: TImageFormatInfo = (
781 Format: ifR32G32B32F;
782 Name: 'R32G32B32F';
783 BytesPerPixel: 12;
784 ChannelCount: 3;
785 IsFloatingPoint: True;
786 RBSwapFormat: ifB32G32R32F;
787 GetPixelsSize: GetStdPixelsSize;
788 CheckDimensions: CheckStdDimensions;
789 GetPixel32: GetPixel32Generic;
790 GetPixelFP: GetPixelFPFloat32;
791 SetPixel32: SetPixel32Generic;
792 SetPixelFP: SetPixelFPFloat32);
793
794 B32G32R32FInfo: TImageFormatInfo = (
795 Format: ifB32G32R32F;
796 Name: 'B32G32R32F';
797 BytesPerPixel: 12;
798 ChannelCount: 3;
799 IsFloatingPoint: True;
800 IsRBSwapped: True;
801 RBSwapFormat: ifR32G32B32F;
802 GetPixelsSize: GetStdPixelsSize;
803 CheckDimensions: CheckStdDimensions;
804 GetPixel32: GetPixel32Generic;
805 GetPixelFP: GetPixelFPFloat32;
806 SetPixel32: SetPixel32Generic;
807 SetPixelFP: SetPixelFPFloat32);
808
809 // special formats
810 DXT1Info: TImageFormatInfo = (
811 Format: ifDXT1;
812 Name: 'DXT1';
813 ChannelCount: 4;
814 HasAlphaChannel: True;
815 IsSpecial: True;
816 GetPixelsSize: GetDXTPixelsSize;
817 CheckDimensions: CheckDXTDimensions;
818 SpecialNearestFormat: ifA8R8G8B8);
819
820 DXT3Info: TImageFormatInfo = (
821 Format: ifDXT3;
822 Name: 'DXT3';
823 ChannelCount: 4;
824 HasAlphaChannel: True;
825 IsSpecial: True;
826 GetPixelsSize: GetDXTPixelsSize;
827 CheckDimensions: CheckDXTDimensions;
828 SpecialNearestFormat: ifA8R8G8B8);
829
830 DXT5Info: TImageFormatInfo = (
831 Format: ifDXT5;
832 Name: 'DXT5';
833 ChannelCount: 4;
834 HasAlphaChannel: True;
835 IsSpecial: True;
836 GetPixelsSize: GetDXTPixelsSize;
837 CheckDimensions: CheckDXTDimensions;
838 SpecialNearestFormat: ifA8R8G8B8);
839
840 BTCInfo: TImageFormatInfo = (
841 Format: ifBTC;
842 Name: 'BTC';
843 ChannelCount: 1;
844 HasAlphaChannel: False;
845 IsSpecial: True;
846 GetPixelsSize: GetBTCPixelsSize;
847 CheckDimensions: CheckDXTDimensions;
848 SpecialNearestFormat: ifGray8);
849
850 ATI1NInfo: TImageFormatInfo = (
851 Format: ifATI1N;
852 Name: 'ATI1N';
853 ChannelCount: 1;
854 HasAlphaChannel: False;
855 IsSpecial: True;
856 GetPixelsSize: GetDXTPixelsSize;
857 CheckDimensions: CheckDXTDimensions;
858 SpecialNearestFormat: ifGray8);
859
860 ATI2NInfo: TImageFormatInfo = (
861 Format: ifATI2N;
862 Name: 'ATI2N';
863 ChannelCount: 2;
864 HasAlphaChannel: False;
865 IsSpecial: True;
866 GetPixelsSize: GetDXTPixelsSize;
867 CheckDimensions: CheckDXTDimensions;
868 SpecialNearestFormat: ifA8R8G8B8);
869
870 BinaryInfo: TImageFormatInfo = (
871 Format: ifBinary;
872 Name: 'Binary';
873 ChannelCount: 1;
874 HasAlphaChannel: False;
875 IsSpecial: True;
876 GetPixelsSize: GetBinaryPixelsSize;
877 CheckDimensions: CheckStdDimensions;
878 SpecialNearestFormat: ifGray8);
879
880 {ETC1Info: TImageFormatInfo = (
881 Format: ifETC1;
882 Name: 'ETC1';
883 ChannelCount: 3;
884 HasAlphaChannel: False;
885 IsSpecial: True;
886 IsPasstrough: True;
887 GetPixelsSize: GetBCPixelsSize;
888 CheckDimensions: CheckBCDimensions;
889 SpecialNearestFormat: ifR8G8B8);
890
891 ETC2RGBInfo: TImageFormatInfo = (
892 Format: ifETC2RGB;
893 Name: 'ETC2RGB';
894 ChannelCount: 3;
895 HasAlphaChannel: False;
896 IsSpecial: True;
897 IsPasstrough: True;
898 GetPixelsSize: GetBCPixelsSize;
899 CheckDimensions: CheckBCDimensions;
900 SpecialNearestFormat: ifR8G8B8);
901
902 ETC2RGBAInfo: TImageFormatInfo = (
903 Format: ifETC2RGBA;
904 Name: 'ETC2RGBA';
905 ChannelCount: 4;
906 HasAlphaChannel: True;
907 IsSpecial: True;
908 IsPasstrough: True;
909 GetPixelsSize: GetBCPixelsSize;
910 CheckDimensions: CheckBCDimensions;
911 SpecialNearestFormat: ifA8R8G8B8);
912
913 ETC2PAInfo: TImageFormatInfo = (
914 Format: ifETC2PA;
915 Name: 'ETC2PA';
916 ChannelCount: 4;
917 HasAlphaChannel: True;
918 IsSpecial: True;
919 IsPasstrough: True;
920 GetPixelsSize: GetBCPixelsSize;
921 CheckDimensions: CheckBCDimensions;
922 SpecialNearestFormat: ifA8R8G8B8);
923
924 DXBC6Info: TImageFormatInfo = (
925 Format: ifDXBC6;
926 Name: 'DXBC6';
927 ChannelCount: 4;
928 HasAlphaChannel: True;
929 IsSpecial: True;
930 IsPasstrough: True;
931 GetPixelsSize: GetBCPixelsSize;
932 CheckDimensions: CheckBCDimensions;
933 SpecialNearestFormat: ifA8R8G8B8);
934
935 DXBC7Info: TImageFormatInfo = (
936 Format: ifDXBC6;
937 Name: 'DXBC7';
938 ChannelCount: 4;
939 HasAlphaChannel: True;
940 IsSpecial: True;
941 IsPasstrough: True;
942 GetPixelsSize: GetBCPixelsSize;
943 CheckDimensions: CheckBCDimensions;
944 SpecialNearestFormat: ifA8R8G8B8); }
945
946 {PVRTCInfo: TImageFormatInfo = (
947 Format: ifPVRTC;
948 Name: 'PVRTC';
949 ChannelCount: 4;
950 HasAlphaChannel: True;
951 IsSpecial: True;
952 IsPasstrough: True;
953 GetPixelsSize: GetBCPixelsSize;
954 CheckDimensions: CheckBCDimensions;
955 SpecialNearestFormat: ifA8R8G8B8);}
956
957 {$WARNINGS ON}
958
959 function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward;
960
961 procedure InitImageFormats(var Infos: TImageFormatInfoArray);
962 begin
963 FInfos := @Infos;
964
965 Infos[ifDefault] := @A8R8G8B8Info;
966 // indexed formats
967 Infos[ifIndex8] := @Index8Info;
968 // grayscale formats
969 Infos[ifGray8] := @Gray8Info;
970 Infos[ifA8Gray8] := @A8Gray8Info;
971 Infos[ifGray16] := @Gray16Info;
972 Infos[ifGray32] := @Gray32Info;
973 Infos[ifGray64] := @Gray64Info;
974 Infos[ifA16Gray16] := @A16Gray16Info;
975 // ARGB formats
976 Infos[ifX5R1G1B1] := @X5R1G1B1Info;
977 Infos[ifR3G3B2] := @R3G3B2Info;
978 Infos[ifR5G6B5] := @R5G6B5Info;
979 Infos[ifA1R5G5B5] := @A1R5G5B5Info;
980 Infos[ifA4R4G4B4] := @A4R4G4B4Info;
981 Infos[ifX1R5G5B5] := @X1R5G5B5Info;
982 Infos[ifX4R4G4B4] := @X4R4G4B4Info;
983 Infos[ifR8G8B8] := @R8G8B8Info;
984 Infos[ifA8R8G8B8] := @A8R8G8B8Info;
985 Infos[ifX8R8G8B8] := @X8R8G8B8Info;
986 Infos[ifR16G16B16] := @R16G16B16Info;
987 Infos[ifA16R16G16B16] := @A16R16G16B16Info;
988 Infos[ifB16G16R16] := @B16G16R16Info;
989 Infos[ifA16B16G16R16] := @A16B16G16R16Info;
990 // floating point formats
991 Infos[ifR32F] := @R32FInfo;
992 Infos[ifA32R32G32B32F] := @A32R32G32B32FInfo;
993 Infos[ifA32B32G32R32F] := @A32B32G32R32FInfo;
994 Infos[ifR16F] := @R16FInfo;
995 Infos[ifA16R16G16B16F] := @A16R16G16B16FInfo;
996 Infos[ifA16B16G16R16F] := @A16B16G16R16FInfo;
997 Infos[ifR32G32B32F] := @R32G32B32FInfo;
998 Infos[ifB32G32R32F] := @B32G32R32FInfo;
999 // special formats
1000 Infos[ifDXT1] := @DXT1Info;
1001 Infos[ifDXT3] := @DXT3Info;
1002 Infos[ifDXT5] := @DXT5Info;
1003 Infos[ifBTC] := @BTCInfo;
1004 Infos[ifATI1N] := @ATI1NInfo;
1005 Infos[ifATI2N] := @ATI2NInfo;
1006 Infos[ifBinary] := @BinaryInfo;
1007
1008 PFR3G3B2 := PixelFormat(0, 3, 3, 2);
1009 PFX5R1G1B1 := PixelFormat(0, 1, 1, 1);
1010 PFR5G6B5 := PixelFormat(0, 5, 6, 5);
1011 PFA1R5G5B5 := PixelFormat(1, 5, 5, 5);
1012 PFA4R4G4B4 := PixelFormat(4, 4, 4, 4);
1013 PFX1R5G5B5 := PixelFormat(0, 5, 5, 5);
1014 PFX4R4G4B4 := PixelFormat(0, 4, 4, 4);
1015 end;
1016
1017
1018 { Internal unit helper functions }
1019
1020 function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo;
1021 begin
1022 Result.ABitMask := ((1 shl ABitCount) - 1) shl (RBitCount + GBitCount +
1023 BBitCount);
1024 Result.RBitMask := ((1 shl RBitCount) - 1) shl (GBitCount + BBitCount);
1025 Result.GBitMask := ((1 shl GBitCount) - 1) shl (BBitCount);
1026 Result.BBitMask := (1 shl BBitCount) - 1;
1027 Result.ABitCount := ABitCount;
1028 Result.RBitCount := RBitCount;
1029 Result.GBitCount := GBitCount;
1030 Result.BBitCount := BBitCount;
1031 Result.AShift := RBitCount + GBitCount + BBitCount;
1032 Result.RShift := GBitCount + BBitCount;
1033 Result.GShift := BBitCount;
1034 Result.BShift := 0;
1035 Result.ARecDiv := Max(1, Pow2Int(Result.ABitCount) - 1);
1036 Result.RRecDiv := Max(1, Pow2Int(Result.RBitCount) - 1);
1037 Result.GRecDiv := Max(1, Pow2Int(Result.GBitCount) - 1);
1038 Result.BRecDiv := Max(1, Pow2Int(Result.BBitCount) - 1);
1039 end;
1040
1041 function PixelFormatMask(ABitMask, RBitMask, GBitMask, BBitMask: LongWord): TPixelFormatInfo;
1042
1043 function GetBitCount(B: LongWord): LongWord;
1044 var
1045 I: LongWord;
1046 begin
1047 I := 0;
1048 while (I < 31) and (((1 shl I) and B) = 0) do
1049 Inc(I);
1050 Result := 0;
1051 while ((1 shl I) and B) <> 0 do
1052 begin
1053 Inc(I);
1054 Inc(Result);
1055 end;
1056 end;
1057
1058 begin
1059 Result := PixelFormat(GetBitCount(ABitMask), GetBitCount(RBitMask),
1060 GetBitCount(GBitMask), GetBitCount(BBitMask));
1061 end;
1062
1063 function PFSetARGB(const PF: TPixelFormatInfo; A, R, G, B: Byte): TColor32;
1064 {$IFDEF USE_INLINE}inline;{$ENDIF}
1065 begin
1066 with PF do
1067 Result :=
1068 (A shl ABitCount shr 8 shl AShift) or
1069 (R shl RBitCount shr 8 shl RShift) or
1070 (G shl GBitCount shr 8 shl GShift) or
1071 (B shl BBitCount shr 8 shl BShift);
1072 end;
1073
1074 procedure PFGetARGB(const PF: TPixelFormatInfo; Color: LongWord;
1075 var A, R, G, B: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF}
1076 begin
1077 with PF do
1078 begin
1079 A := (Color and ABitMask shr AShift) * 255 div ARecDiv;
1080 R := (Color and RBitMask shr RShift) * 255 div RRecDiv;
1081 G := (Color and GBitMask shr GShift) * 255 div GRecDiv;
1082 B := (Color and BBitMask shl BShift) * 255 div BRecDiv;
1083 end;
1084 end;
1085
1086 function PFSetColor(const PF: TPixelFormatInfo; ARGB: TColor32): LongWord;
1087 {$IFDEF USE_INLINE}inline;{$ENDIF}
1088 begin
1089 with PF do
1090 Result :=
1091 (Byte(ARGB shr 24) shl ABitCount shr 8 shl AShift) or
1092 (Byte(ARGB shr 16) shl RBitCount shr 8 shl RShift) or
1093 (Byte(ARGB shr 8) shl GBitCount shr 8 shl GShift) or
1094 (Byte(ARGB) shl BBitCount shr 8 shl BShift);
1095 end;
1096
1097 function PFGetColor(const PF: TPixelFormatInfo; Color: LongWord): TColor32;
1098 {$IFDEF USE_INLINE}inline;{$ENDIF}
1099 begin
1100 //with PF, TColor32Rec(Result) do
1101 begin
1102 TColor32Rec(Result).A := (Color and PF.ABitMask shr PF.AShift) * 255 div PF.ARecDiv;
1103 TColor32Rec(Result).R := (Color and PF.RBitMask shr PF.RShift) * 255 div PF.RRecDiv;
1104 TColor32Rec(Result).G := (Color and PF.GBitMask shr PF.GShift) * 255 div PF.GRecDiv;
1105 TColor32Rec(Result).B := (Color and PF.BBitMask shl PF.BShift) * 255 div PF.BRecDiv;
1106 end;
1107 end;
1108
1109
1110 { Color constructor functions }
1111
1112
1113 function Color24(R, G, B: Byte): TColor24Rec;
1114 begin
1115 Result.R := R;
1116 Result.G := G;
1117 Result.B := B;
1118 end;
1119
1120 function Color32(A, R, G, B: Byte): TColor32Rec;
1121 begin
1122 Result.A := A;
1123 Result.R := R;
1124 Result.G := G;
1125 Result.B := B;
1126 end;
1127
1128 function Color48(R, G, B: Word): TColor48Rec;
1129 begin
1130 Result.R := R;
1131 Result.G := G;
1132 Result.B := B;
1133 end;
1134
1135 function Color64(A, R, G, B: Word): TColor64Rec;
1136 begin
1137 Result.A := A;
1138 Result.R := R;
1139 Result.G := G;
1140 Result.B := B;
1141 end;
1142
1143 function ColorFP(A, R, G, B: Single): TColorFPRec;
1144 begin
1145 Result.A := A;
1146 Result.R := R;
1147 Result.G := G;
1148 Result.B := B;
1149 end;
1150
1151 function ColorHF(A, R, G, B: THalfFloat): TColorHFRec;
1152 begin
1153 Result.A := A;
1154 Result.R := R;
1155 Result.G := G;
1156 Result.B := B;
1157 end;
1158
1159
1160 { Additional image manipulation functions (usually used internally by Imaging unit) }
1161
1162 const
1163 MaxPossibleColors = 4096;
1164 HashSize = 32768;
1165 AlphaWeight = 1024;
1166 RedWeight = 612;
1167 GreenWeight = 1202;
1168 BlueWeight = 234;
1169
1170 type
1171 PColorBin = ^TColorBin;
1172 TColorBin = record
1173 Color: TColor32Rec;
1174 Number: LongInt;
1175 Next: PColorBin;
1176 end;
1177
1178 THashTable = array[0..HashSize - 1] of PColorBin;
1179
1180 TColorBox = record
1181 AMin, AMax,
1182 RMin, RMax,
1183 GMin, GMax,
1184 BMin, BMax: LongInt;
1185 Total: LongInt;
1186 Represented: TColor32Rec;
1187 List: PColorBin;
1188 end;
1189
1190 var
1191 Table: THashTable;
1192 Box: array[0..MaxPossibleColors - 1] of TColorBox;
1193 Boxes: LongInt;
1194 BoxesCreated: Boolean = False;
1195
1196 procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
1197 DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte;
1198 DstPal: PPalette32; Actions: TReduceColorsActions);
1199
1200 procedure CreateHistogram (Src: PByte; SrcInfo: PImageFormatInfo;
1201 ChannelMask: Byte);
1202 var
1203 A, R, G, B: Byte;
1204 I, Addr: LongInt;
1205 PC: PColorBin;
1206 Col: TColor32Rec;
1207 begin
1208 for I := 0 to NumPixels - 1 do
1209 begin
1210 Col := GetPixel32Generic(Src, SrcInfo, nil);
1211 A := Col.A and ChannelMask;
1212 R := Col.R and ChannelMask;
1213 G := Col.G and ChannelMask;
1214 B := Col.B and ChannelMask;
1215
1216 Addr := (A + 11 * B + 59 * R + 119 * G) mod HashSize;
1217 PC := Table[Addr];
1218
1219 while (PC <> nil) and ((PC.Color.R <> R) or (PC.Color.G <> G) or
1220 (PC.Color.B <> B) or (PC.Color.A <> A)) do
1221 PC := PC.Next;
1222
1223 if PC = nil then
1224 begin
1225 New(PC);
1226 PC.Color.R := R;
1227 PC.Color.G := G;
1228 PC.Color.B := B;
1229 PC.Color.A := A;
1230 PC.Number := 1;
1231 PC.Next := Table[Addr];
1232 Table[Addr] := PC;
1233 end
1234 else
1235 Inc(PC^.Number);
1236 Inc(Src, SrcInfo.BytesPerPixel);
1237 end;
1238 end;
1239
1240 procedure InitBox (var Box : TColorBox);
1241 begin
1242 Box.AMin := 256;
1243 Box.RMin := 256;
1244 Box.GMin := 256;
1245 Box.BMin := 256;
1246 Box.AMax := -1;
1247 Box.RMax := -1;
1248 Box.GMax := -1;
1249 Box.BMax := -1;
1250 Box.Total := 0;
1251 Box.List := nil;
1252 end;
1253
1254 procedure ChangeBox (var Box: TColorBox; const C: TColorBin);
1255 begin
1256 with C.Color do
1257 begin
1258 if A < Box.AMin then Box.AMin := A;
1259 if A > Box.AMax then Box.AMax := A;
1260 if B < Box.BMin then Box.BMin := B;
1261 if B > Box.BMax then Box.BMax := B;
1262 if G < Box.GMin then Box.GMin := G;
1263 if G > Box.GMax then Box.GMax := G;
1264 if R < Box.RMin then Box.RMin := R;
1265 if R > Box.RMax then Box.RMax := R;
1266 end;
1267 Inc(Box.Total, C.Number);
1268 end;
1269
1270 procedure MakeColormap;
1271 var
1272 I, J: LongInt;
1273 CP, Pom: PColorBin;
1274 Cut, LargestIdx, Largest, Size, S: LongInt;
1275 CutA, CutR, CutG, CutB: Boolean;
1276 SumA, SumR, SumG, SumB: LongInt;
1277 Temp: TColorBox;
1278 begin
1279 I := 0;
1280 Boxes := 1;
1281 LargestIdx := 0;
1282 while (I < HashSize) and (Table[I] = nil) do
1283 Inc(i);
1284 if I < HashSize then
1285 begin
1286 // put all colors into Box[0]
1287 InitBox(Box[0]);
1288 repeat
1289 CP := Table[I];
1290 while CP.Next <> nil do
1291 begin
1292 ChangeBox(Box[0], CP^);
1293 CP := CP.Next;
1294 end;
1295 ChangeBox(Box[0], CP^);
1296 CP.Next := Box[0].List;
1297 Box[0].List := Table[I];
1298 Table[I] := nil;
1299 repeat
1300 Inc(I)
1301 until (I = HashSize) or (Table[I] <> nil);
1302 until I = HashSize;
1303 // now all colors are in Box[0]
1304 repeat
1305 // cut one color box
1306 Largest := 0;
1307 for I := 0 to Boxes - 1 do
1308 with Box[I] do
1309 begin
1310 Size := (AMax - AMin) * AlphaWeight;
1311 S := (RMax - RMin) * RedWeight;
1312 if S > Size then
1313 Size := S;
1314 S := (GMax - GMin) * GreenWeight;
1315 if S > Size then
1316 Size := S;
1317 S := (BMax - BMin) * BlueWeight;
1318 if S > Size then
1319 Size := S;
1320 if Size > Largest then
1321 begin
1322 Largest := Size;
1323 LargestIdx := I;
1324 end;
1325 end;
1326 if Largest > 0 then
1327 begin
1328 // cutting Box[LargestIdx] into Box[LargestIdx] and Box[Boxes]
1329 CutR := False;
1330 CutG := False;
1331 CutB := False;
1332 CutA := False;
1333 with Box[LargestIdx] do
1334 begin
1335 if (AMax - AMin) * AlphaWeight = Largest then
1336 begin
1337 Cut := (AMax + AMin) shr 1;
1338 CutA := True;
1339 end
1340 else
1341 if (RMax - RMin) * RedWeight = Largest then
1342 begin
1343 Cut := (RMax + RMin) shr 1;
1344 CutR := True;
1345 end
1346 else
1347 if (GMax - GMin) * GreenWeight = Largest then
1348 begin
1349 Cut := (GMax + GMin) shr 1;
1350 CutG := True;
1351 end
1352 else
1353 begin
1354 Cut := (BMax + BMin) shr 1;
1355 CutB := True;
1356 end;
1357 CP := List;
1358 end;
1359 InitBox(Box[LargestIdx]);
1360 InitBox(Box[Boxes]);
1361 repeat
1362 // distribute one color
1363 Pom := CP.Next;
1364 with CP.Color do
1365 begin
1366 if (CutA and (A <= Cut)) or (CutR and (R <= Cut)) or
1367 (CutG and (G <= Cut)) or (CutB and (B <= Cut)) then
1368 I := LargestIdx
1369 else
1370 I := Boxes;
1371 end;
1372 CP.Next := Box[i].List;
1373 Box[i].List := CP;
1374 ChangeBox(Box[i], CP^);
1375 CP := Pom;
1376 until CP = nil;
1377 Inc(Boxes);
1378 end;
1379 until (Boxes = MaxColors) or (Largest = 0);
1380 // compute box representation
1381 for I := 0 to Boxes - 1 do
1382 begin
1383 SumR := 0;
1384 SumG := 0;
1385 SumB := 0;
1386 SumA := 0;
1387 repeat
1388 CP := Box[I].List;
1389 Inc(SumR, CP.Color.R * CP.Number);
1390 Inc(SumG, CP.Color.G * CP.Number);
1391 Inc(SumB, CP.Color.B * CP.Number);
1392 Inc(SumA, CP.Color.A * CP.Number);
1393 Box[I].List := CP.Next;
1394 Dispose(CP);
1395 until Box[I].List = nil;
1396 with Box[I] do
1397 begin
1398 Represented.A := SumA div Total;
1399 Represented.R := SumR div Total;
1400 Represented.G := SumG div Total;
1401 Represented.B := SumB div Total;
1402 AMin := AMin and ChannelMask;
1403 RMin := RMin and ChannelMask;
1404 GMin := GMin and ChannelMask;
1405 BMin := BMin and ChannelMask;
1406 AMax := (AMax and ChannelMask) + (not ChannelMask);
1407 RMax := (RMax and ChannelMask) + (not ChannelMask);
1408 GMax := (GMax and ChannelMask) + (not ChannelMask);
1409 BMax := (BMax and ChannelMask) + (not ChannelMask);
1410 end;
1411 end;
1412 // sort color boxes
1413 for I := 0 to Boxes - 2 do
1414 begin
1415 Largest := 0;
1416 for J := I to Boxes - 1 do
1417 if Box[J].Total > Largest then
1418 begin
1419 Largest := Box[J].Total;
1420 LargestIdx := J;
1421 end;
1422 if LargestIdx <> I then
1423 begin
1424 Temp := Box[I];
1425 Box[I] := Box[LargestIdx];
1426 Box[LargestIdx] := Temp;
1427 end;
1428 end;
1429 end;
1430 end;
1431
1432 procedure FillOutputPalette;
1433 var
1434 I: LongInt;
1435 begin
1436 FillChar(DstPal^, SizeOf(TColor32Rec) * MaxColors, $FF);
1437 for I := 0 to MaxColors - 1 do
1438 begin
1439 if I < Boxes then
1440 with Box[I].Represented do
1441 begin
1442 DstPal[I].A := A;
1443 DstPal[I].R := R;
1444 DstPal[I].G := G;
1445 DstPal[I].B := B;
1446 end
1447 else
1448 DstPal[I].Color := $FF000000;
1449 end;
1450 end;
1451
1452 function MapColor(const Col: TColor32Rec) : LongInt;
1453 var
1454 I: LongInt;
1455 begin
1456 I := 0;
1457 with Col do
1458 while (I < Boxes) and ((Box[I].AMin > A) or (Box[I].AMax < A) or
1459 (Box[I].RMin > R) or (Box[I].RMax < R) or (Box[I].GMin > G) or
1460 (Box[I].GMax < G) or (Box[I].BMin > B) or (Box[I].BMax < B)) do
1461 Inc(I);
1462 if I = Boxes then
1463 MapColor := 0
1464 else
1465 MapColor := I;
1466 end;
1467
1468 procedure MapImage(Src, Dst: PByte; SrcInfo, DstInfo: PImageFormatInfo);
1469 var
1470 I: LongInt;
1471 Col: TColor32Rec;
1472 begin
1473 for I := 0 to NumPixels - 1 do
1474 begin
1475 Col := GetPixel32Generic(Src, SrcInfo, nil);
1476 IndexSetDstPixel(Dst, DstInfo, MapColor(Col));
1477 Inc(Src, SrcInfo.BytesPerPixel);
1478 Inc(Dst, DstInfo.BytesPerPixel);
1479 end;
1480 end;
1481
1482 begin
1483 MaxColors := ClampInt(MaxColors, 2, MaxPossibleColors);
1484
1485 if (raUpdateHistogram in Actions) or (raMapImage in Actions) then
1486 begin
1487 Assert(not SrcInfo.IsSpecial);
1488 Assert(not SrcInfo.IsIndexed);
1489 end;
1490
1491 if raCreateHistogram in Actions then
1492 FillChar(Table, SizeOf(Table), 0);
1493
1494 if raUpdateHistogram in Actions then
1495 CreateHistogram(Src, SrcInfo, ChannelMask);
1496
1497 if raMakeColorMap in Actions then
1498 begin
1499 MakeColorMap;
1500 FillOutputPalette;
1501 end;
1502
1503 if raMapImage in Actions then
1504 MapImage(Src, Dst, SrcInfo, DstInfo);
1505 end;
1506
1507 procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
1508 SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
1509 DstHeight: LongInt);
1510 var
1511 Info: TImageFormatInfo;
1512 ScaleX, ScaleY, X, Y, Xp, Yp: LongInt;
1513 DstPixel, SrcLine: PByte;
1514 begin
1515 GetImageFormatInfo(SrcImage.Format, Info);
1516 Assert(SrcImage.Format = DstImage.Format);
1517 Assert(not Info.IsSpecial);
1518 // Use integers instead of floats for source image pixel coords
1519 // Xp and Yp coords must be shifted right to get read source image coords
1520 ScaleX := (SrcWidth shl 16) div DstWidth;
1521 ScaleY := (SrcHeight shl 16) div DstHeight;
1522 Yp := 0;
1523 for Y := 0 to DstHeight - 1 do
1524 begin
1525 Xp := 0;
1526 SrcLine := @PByteArray(SrcImage.Bits)[((SrcY + Yp shr 16) * SrcImage.Width + SrcX) * Info.BytesPerPixel];
1527 DstPixel := @PByteArray(DstImage.Bits)[((DstY + Y) * DstImage.Width + DstX) * Info.BytesPerPixel];
1528 for X := 0 to DstWidth - 1 do
1529 begin
1530 case Info.BytesPerPixel of
1531 1: PByte(DstPixel)^ := PByteArray(SrcLine)[Xp shr 16];
1532 2: PWord(DstPixel)^ := PWordArray(SrcLine)[Xp shr 16];
1533 3: PColor24Rec(DstPixel)^ := PPalette24(SrcLine)[Xp shr 16];
1534 4: PColor32(DstPixel)^ := PLongWordArray(SrcLine)[Xp shr 16];
1535 6: PColor48Rec(DstPixel)^ := PColor48RecArray(SrcLine)[Xp shr 16];
1536 8: PColor64(DstPixel)^ := PInt64Array(SrcLine)[Xp shr 16];
1537 16: PColorFPRec(DstPixel)^ := PColorFPRecArray(SrcLine)[Xp shr 16];
1538 end;
1539 Inc(DstPixel, Info.BytesPerPixel);
1540 Inc(Xp, ScaleX);
1541 end;
1542 Inc(Yp, ScaleY);
1543 end;
1544 end;
1545
1546 { Filter function for nearest filtering. Also known as box filter.}
1547 function FilterNearest(Value: Single): Single;
1548 begin
1549 if (Value > -0.5) and (Value <= 0.5) then
1550 Result := 1
1551 else
1552 Result := 0;
1553 end;
1554
1555 { Filter function for linear filtering. Also known as triangle or Bartlett filter.}
1556 function FilterLinear(Value: Single): Single;
1557 begin
1558 if Value < 0.0 then
1559 Value := -Value;
1560 if Value < 1.0 then
1561 Result := 1.0 - Value
1562 else
1563 Result := 0.0;
1564 end;
1565
1566 { Cosine filter.}
1567 function FilterCosine(Value: Single): Single;
1568 begin
1569 Result := 0;
1570 if Abs(Value) < 1 then
1571 Result := (Cos(Value * Pi) + 1) / 2;
1572 end;
1573
1574 { f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1 }
1575 function FilterHermite(Value: Single): Single;
1576 begin
1577 if Value < 0.0 then
1578 Value := -Value;
1579 if Value < 1 then
1580 Result := (2 * Value - 3) * Sqr(Value) + 1
1581 else
1582 Result := 0;
1583 end;
1584
1585 { Quadratic filter. Also known as Bell.}
1586 function FilterQuadratic(Value: Single): Single;
1587 begin
1588 if Value < 0.0 then
1589 Value := -Value;
1590 if Value < 0.5 then
1591 Result := 0.75 - Sqr(Value)
1592 else
1593 if Value < 1.5 then
1594 begin
1595 Value := Value - 1.5;
1596 Result := 0.5 * Sqr(Value);
1597 end
1598 else
1599 Result := 0.0;
1600 end;
1601
1602 { Gaussian filter.}
1603 function FilterGaussian(Value: Single): Single;
1604 begin
1605 Result := Exp(-2.0 * Sqr(Value)) * Sqrt(2.0 / Pi);
1606 end;
1607
1608 { 4th order (cubic) b-spline filter.}
1609 function FilterSpline(Value: Single): Single;
1610 var
1611 Temp: Single;
1612 begin
1613 if Value < 0.0 then
1614 Value := -Value;
1615 if Value < 1.0 then
1616 begin
1617 Temp := Sqr(Value);
1618 Result := 0.5 * Temp * Value - Temp + 2.0 / 3.0;
1619 end
1620 else
1621 if Value < 2.0 then
1622 begin
1623 Value := 2.0 - Value;
1624 Result := Sqr(Value) * Value / 6.0;
1625 end
1626 else
1627 Result := 0.0;
1628 end;
1629
1630 { Lanczos-windowed sinc filter.}
1631 function FilterLanczos(Value: Single): Single;
1632
1633 function SinC(Value: Single): Single;
1634 begin
1635 if Value <> 0.0 then
1636 begin
1637 Value := Value * Pi;
1638 Result := Sin(Value) / Value;
1639 end
1640 else
1641 Result := 1.0;
1642 end;
1643
1644 begin
1645 if Value < 0.0 then
1646 Value := -Value;
1647 if Value < 3.0 then
1648 Result := SinC(Value) * SinC(Value / 3.0)
1649 else
1650 Result := 0.0;
1651 end;
1652
1653 { Micthell cubic filter.}
1654 function FilterMitchell(Value: Single): Single;
1655 const
1656 B = 1.0 / 3.0;
1657 C = 1.0 / 3.0;
1658 var
1659 Temp: Single;
1660 begin
1661 if Value < 0.0 then
1662 Value := -Value;
1663 Temp := Sqr(Value);
1664 if Value < 1.0 then
1665 begin
1666 Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp)) +
1667 ((-18.0 + 12.0 * B + 6.0 * C) * Temp) +
1668 (6.0 - 2.0 * B));
1669 Result := Value / 6.0;
1670 end
1671 else
1672 if Value < 2.0 then
1673 begin
1674 Value := (((-B - 6.0 * C) * (Value * Temp)) +
1675 ((6.0 * B + 30.0 * C) * Temp) +
1676 ((-12.0 * B - 48.0 * C) * Value) +
1677 (8.0 * B + 24.0 * C));
1678 Result := Value / 6.0;
1679 end
1680 else
1681 Result := 0.0;
1682 end;
1683
1684 { CatmullRom spline filter.}
1685 function FilterCatmullRom(Value: Single): Single;
1686 begin
1687 if Value < 0.0 then
1688 Value := -Value;
1689 if Value < 1.0 then
1690 Result := 0.5 * (2.0 + Sqr(Value) * (-5.0 + 3.0 * Value))
1691 else
1692 if Value < 2.0 then
1693 Result := 0.5 * (4.0 + Value * (-8.0 + Value * (5.0 - Value)))
1694 else
1695 Result := 0.0;
1696 end;
1697
1698 procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
1699 SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
1700 DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean);
1701 begin
1702 // Calls the other function with filter function and radius defined by Filter
1703 StretchResample(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY,
1704 DstWidth, DstHeight, SamplingFilterFunctions[Filter], SamplingFilterRadii[Filter],
1705 WrapEdges);
1706 end;
1707
1708 var
1709 FullEdge: Boolean = True;
1710
1711 { The following resampling code is modified and extended code from Graphics32
1712 library by Alex A. Denisov.}
1713 function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
1714 Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
1715 var
1716 I, J, K, N: LongInt;
1717 Left, Right, SrcWidth, DstWidth: LongInt;
1718 Weight, Scale, Center, Count: Single;
1719 begin
1720 Result := nil;
1721 K := 0;
1722 SrcWidth := SrcHigh - SrcLow;
1723 DstWidth := DstHigh - DstLow;
1724
1725 // Check some special cases
1726 if SrcWidth = 1 then
1727 begin
1728 SetLength(Result, DstWidth);
1729 for I := 0 to DstWidth - 1 do
1730 begin
1731 SetLength(Result[I], 1);
1732 Result[I][0].Pos := 0;
1733 Result[I][0].Weight := 1.0;
1734 end;
1735 Exit;
1736 end
1737 else
1738 if (SrcWidth = 0) or (DstWidth = 0) then
1739 Exit;
1740
1741 if FullEdge then
1742 Scale := DstWidth / SrcWidth
1743 else
1744 Scale := (DstWidth - 1) / (SrcWidth - 1);
1745
1746 SetLength(Result, DstWidth);
1747
1748 // Pre-calculate filter contributions for a row or column
1749 if Scale = 0.0 then
1750 begin
1751 Assert(Length(Result) = 1);
1752 SetLength(Result[0], 1);
1753 Result[0][0].Pos := (SrcLow + SrcHigh) div 2;
1754 Result[0][0].Weight := 1.0;
1755 end
1756 else if Scale < 1.0 then
1757 begin
1758 // Sub-sampling - scales from bigger to smaller
1759 Radius := Radius / Scale;
1760 for I := 0 to DstWidth - 1 do
1761 begin
1762 if FullEdge then
1763 Center := SrcLow - 0.5 + (I + 0.5) / Scale
1764 else
1765 Center := SrcLow + I / Scale;
1766 Left := Floor(Center - Radius);
1767 Right := Ceil(Center + Radius);
1768 Count := -1.0;
1769 for J := Left to Right do
1770 begin
1771 Weight := Filter((Center - J) * Scale) * Scale;
1772 if Weight <> 0.0 then
1773 begin
1774 Count := Count + Weight;
1775 K := Length(Result[I]);
1776 SetLength(Result[I], K + 1);
1777 Result[I][K].Pos := ClampInt(J, SrcLow, SrcHigh - 1);
1778 Result[I][K].Weight := Weight;
1779 end;
1780 end;
1781 if Length(Result[I]) = 0 then
1782 begin
1783 SetLength(Result[I], 1);
1784 Result[I][0].Pos := Floor(Center);
1785 Result[I][0].Weight := 1.0;
1786 end
1787 else if Count <> 0.0 then
1788 Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
1789 end;
1790 end
1791 else // if Scale > 1.0 then
1792 begin
1793 // Super-sampling - scales from smaller to bigger
1794 Scale := 1.0 / Scale;
1795 for I := 0 to DstWidth - 1 do
1796 begin
1797 if FullEdge then
1798 Center := SrcLow - 0.5 + (I + 0.5) * Scale
1799 else
1800 Center := SrcLow + I * Scale;
1801 Left := Floor(Center - Radius);
1802 Right := Ceil(Center + Radius);
1803 Count := -1.0;
1804 for J := Left to Right do
1805 begin
1806 Weight := Filter(Center - J);
1807 if Weight <> 0.0 then
1808 begin
1809 Count := Count + Weight;
1810 K := Length(Result[I]);
1811 SetLength(Result[I], K + 1);
1812
1813 if WrapEdges then
1814 begin
1815 if J < 0 then
1816 N := SrcImageWidth + J
1817 else if J >= SrcImageWidth then
1818 N := J - SrcImageWidth
1819 else
1820 N := ClampInt(J, SrcLow, SrcHigh - 1);
1821 end
1822 else
1823 N := ClampInt(J, SrcLow, SrcHigh - 1);
1824
1825 Result[I][K].Pos := N;
1826 Result[I][K].Weight := Weight;
1827 end;
1828 end;
1829 if Count <> 0.0 then
1830 Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
1831 end;
1832 end;
1833 end;
1834
1835 procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt);
1836 var
1837 I, J: LongInt;
1838 begin
1839 if Length(Map) > 0 then
1840 begin
1841 MinPos := Map[0][0].Pos;
1842 MaxPos := MinPos;
1843 for I := 0 to Length(Map) - 1 do
1844 for J := 0 to Length(Map[I]) - 1 do
1845 begin
1846 if MinPos > Map[I][J].Pos then
1847 MinPos := Map[I][J].Pos;
1848 if MaxPos < Map[I][J].Pos then
1849 MaxPos := Map[I][J].Pos;
1850 end;
1851 end;
1852 end;
1853
1854 procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
1855 SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
1856 DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
1857 const
1858 Channel8BitMax: Single = 255.0;
1859 var
1860 MapX, MapY: TMappingTable;
1861 I, J, X, Y: LongInt;
1862 XMinimum, XMaximum: LongInt;
1863 LineBufferFP: array of TColorFPRec;
1864 ClusterX, ClusterY: TCluster;
1865 Weight, AccumA, AccumR, AccumG, AccumB: Single;
1866 DstLine: PByte;
1867 SrcFloat: TColorFPRec;
1868 Info: TImageFormatInfo;
1869 BytesPerChannel: LongInt;
1870 begin
1871 GetImageFormatInfo(SrcImage.Format, Info);
1872 Assert(SrcImage.Format = DstImage.Format);
1873 Assert(not Info.IsSpecial and not Info.IsIndexed);
1874 BytesPerChannel := Info.BytesPerPixel div Info.ChannelCount;
1875
1876 // Create horizontal and vertical mapping tables
1877 MapX := BuildMappingTable(DstX, DstX + DstWidth, SrcX, SrcX + SrcWidth,
1878 SrcImage.Width, Filter, Radius, WrapEdges);
1879 MapY := BuildMappingTable(DstY, DstY + DstHeight, SrcY, SrcY + SrcHeight,
1880 SrcImage.Height, Filter, Radius, WrapEdges);
1881
1882 if (MapX = nil) or (MapY = nil) then
1883 Exit;
1884
1885 ClusterX := nil;
1886 ClusterY := nil;
1887
1888 try
1889 // Find min and max X coords of pixels that will contribute to target image
1890 FindExtremes(MapX, XMinimum, XMaximum);
1891
1892 SetLength(LineBufferFP, XMaximum - XMinimum + 1);
1893 // Following code works for the rest of data formats
1894 for J := 0 to DstHeight - 1 do
1895 begin
1896 // First for each pixel in the current line sample vertically
1897 // and store results in LineBuffer. Then sample horizontally
1898 // using values in LineBuffer.
1899 ClusterY := MapY[J];
1900 for X := XMinimum to XMaximum do
1901 begin
1902 // Clear accumulators
1903 AccumA := 0;
1904 AccumR := 0;
1905 AccumG := 0;
1906 AccumB := 0;
1907 // For each pixel in line compute weighted sum of pixels
1908 // in source column that will contribute to this pixel
1909 for Y := 0 to Length(ClusterY) - 1 do
1910 begin
1911 // Accumulate this pixel's weighted value
1912 Weight := ClusterY[Y].Weight;
1913 SrcFloat := Info.GetPixelFP(@PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel], @Info, nil);
1914 AccumB := AccumB + SrcFloat.B * Weight;
1915 AccumG := AccumG + SrcFloat.G * Weight;
1916 AccumR := AccumR + SrcFloat.R * Weight;
1917 AccumA := AccumA + SrcFloat.A * Weight;
1918 end;
1919 // Store accumulated value for this pixel in buffer
1920 with LineBufferFP[X - XMinimum] do
1921 begin
1922 A := AccumA;
1923 R := AccumR;
1924 G := AccumG;
1925 B := AccumB;
1926 end;
1927 end;
1928
1929 DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX) * Info.BytesPerPixel];
1930 // Now compute final colors for targte pixels in the current row
1931 // by sampling horizontally
1932 for I := 0 to DstWidth - 1 do
1933 begin
1934 ClusterX := MapX[I];
1935 // Clear accumulator
1936 AccumA := 0;
1937 AccumR := 0;
1938 AccumG := 0;
1939 AccumB := 0;
1940 // Compute weighted sum of values (which are already
1941 // computed weighted sums of pixels in source columns stored in LineBuffer)
1942 // that will contribute to the current target pixel
1943 for X := 0 to Length(ClusterX) - 1 do
1944 begin
1945 Weight := ClusterX[X].Weight;
1946 with LineBufferFP[ClusterX[X].Pos - XMinimum] do
1947 begin
1948 AccumB := AccumB + B * Weight;
1949 AccumG := AccumG + G * Weight;
1950 AccumR := AccumR + R * Weight;
1951 AccumA := AccumA + A * Weight;
1952 end;
1953 end;
1954
1955 // Now compute final color to be written to dest image
1956 SrcFloat.A := AccumA;
1957 SrcFloat.R := AccumR;
1958 SrcFloat.G := AccumG;
1959 SrcFloat.B := AccumB;
1960
1961 Info.SetPixelFP(DstLine, @Info, nil, SrcFloat);
1962 Inc(DstLine, Info.BytesPerPixel);
1963 end;
1964 end;
1965
1966 finally
1967 MapX := nil;
1968 MapY := nil;
1969 end;
1970 end;
1971
1972 procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt;
1973 var SmallerLevel: TImageData);
1974 var
1975 Filter: TSamplingFilter;
1976 Info: TImageFormatInfo;
1977 CompatibleCopy: TImageData;
1978 begin
1979 Assert(TestImage(BiggerLevel));
1980 Filter := TSamplingFilter(GetOption(ImagingMipMapFilter));
1981
1982 // If we have special format image we must create copy to allow pixel access
1983 GetImageFormatInfo(BiggerLevel.Format, Info);
1984 if Info.IsSpecial then
1985 begin
1986 InitImage(CompatibleCopy);
1987 CloneImage(BiggerLevel, CompatibleCopy);
1988 ConvertImage(CompatibleCopy, ifDefault);
1989 end
1990 else
1991 CompatibleCopy := BiggerLevel;
1992
1993 // Create new smaller image
1994 NewImage(Width, Height, CompatibleCopy.Format, SmallerLevel);
1995 GetImageFormatInfo(CompatibleCopy.Format, Info);
1996 // If input is indexed we must copy its palette
1997 if Info.IsIndexed then
1998 CopyPalette(CompatibleCopy.Palette, SmallerLevel.Palette, 0, 0, Info.PaletteEntries);
1999
2000 if (Filter = sfNearest) or Info.IsIndexed then
2001 begin
2002 StretchNearest(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height,
2003 SmallerLevel, 0, 0, Width, Height);
2004 end
2005 else
2006 begin
2007 StretchResample(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height,
2008 SmallerLevel, 0, 0, Width, Height, Filter);
2009 end;
2010
2011 // Free copy and convert result to special format if necessary
2012 if CompatibleCopy.Format <> BiggerLevel.Format then
2013 begin
2014 ConvertImage(SmallerLevel, BiggerLevel.Format);
2015 FreeImage(CompatibleCopy);
2016 end;
2017 end;
2018
2019
2020 { Various format support functions }
2021
2022 procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt);
2023 begin
2024 case BytesPerPixel of
2025 1: PByte(Dest)^ := PByte(Src)^;
2026 2: PWord(Dest)^ := PWord(Src)^;
2027 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
2028 4: PLongWord(Dest)^ := PLongWord(Src)^;
2029 6: PColor48Rec(Dest)^ := PColor48Rec(Src)^;
2030 8: PInt64(Dest)^ := PInt64(Src)^;
2031 12: PColor96FPRec(Dest)^ := PColor96FPRec(Src)^;
2032 16: PColorFPRec(Dest)^ := PColorFPRec(Src)^;
2033 end;
2034 end;
2035
2036 function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean;
2037 begin
2038 case BytesPerPixel of
2039 1: Result := PByte(PixelA)^ = PByte(PixelB)^;
2040 2: Result := PWord(PixelA)^ = PWord(PixelB)^;
2041 3: Result := (PWord(PixelA)^ = PWord(PixelB)^) and (PColor24Rec(PixelA).R = PColor24Rec(PixelB).R);
2042 4: Result := PLongWord(PixelA)^ = PLongWord(PixelB)^;
2043 6: Result := (PLongWord(PixelA)^ = PLongWord(PixelB)^) and (PColor48Rec(PixelA).R = PColor48Rec(PixelB).R);
2044 8: Result := PInt64(PixelA)^ = PInt64(PixelB)^;
2045 12: Result := (PFloatHelper(PixelA).Data = PFloatHelper(PixelB).Data) and
2046 (PFloatHelper(PixelA).Data32 = PFloatHelper(PixelB).Data32);
2047 16: Result := (PFloatHelper(PixelA).Data = PFloatHelper(PixelB).Data) and
2048 (PFloatHelper(PixelA).Data64 = PFloatHelper(PixelB).Data64);
2049 else
2050 Result := False;
2051 end;
2052 end;
2053
2054 procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat,
2055 DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32);
2056 var
2057 SrcInfo, DstInfo: PImageFormatInfo;
2058 PixFP: TColorFPRec;
2059 begin
2060 SrcInfo := FInfos[SrcFormat];
2061 DstInfo := FInfos[DstFormat];
2062
2063 PixFP := GetPixelFPGeneric(SrcPixel, SrcInfo, SrcPalette);
2064 SetPixelFPGeneric(DstPixel, DstInfo, DstPalette, PixFP);
2065 end;
2066
2067 procedure ClampFloatPixel(var PixF: TColorFPRec);
2068 begin
2069 if PixF.A > 1.0 then
2070 PixF.A := 1.0;
2071 if PixF.R > 1.0 then
2072 PixF.R := 1.0;
2073 if PixF.G > 1.0 then
2074 PixF.G := 1.0;
2075 if PixF.B > 1.0 then
2076 PixF.B := 1.0;
2077
2078 if PixF.A < 0.0 then
2079 PixF.A := 0.0;
2080 if PixF.R < 0.0 then
2081 PixF.R := 0.0;
2082 if PixF.G < 0.0 then
2083 PixF.G := 0.0;
2084 if PixF.B < 0.0 then
2085 PixF.B := 0.0;
2086 end;
2087
2088 procedure ConvertToPixel32(SrcPix: PByte; DestPix: PColor32Rec;
2089 const SrcInfo: TImageFormatInfo; SrcPalette: PPalette32);
2090 begin
2091 case SrcInfo.Format of
2092 ifIndex8:
2093 begin
2094 DestPix^ := SrcPalette[SrcPix^];
2095 end;
2096 ifGray8:
2097 begin
2098 DestPix.R := SrcPix^;
2099 DestPix.G := SrcPix^;
2100 DestPix.B := SrcPix^;
2101 DestPix.A := 255;
2102 end;
2103 ifA8Gray8:
2104 begin
2105 DestPix.R := SrcPix^;
2106 DestPix.G := SrcPix^;
2107 DestPix.B := SrcPix^;
2108 DestPix.A := PWordRec(SrcPix).High;
2109 end;
2110 ifGray16:
2111 begin
2112 DestPix.R := PWord(SrcPix)^ shr 8;
2113 DestPix.G := DestPix.R;
2114 DestPix.B := DestPix.R;
2115 DestPix.A := 255;
2116 end;
2117 ifR8G8B8:
2118 begin
2119 DestPix.Color24Rec := PColor24Rec(SrcPix)^;
2120 DestPix.A := 255;
2121 end;
2122 ifA8R8G8B8:
2123 begin
2124 DestPix^ := PColor32Rec(SrcPix)^;
2125 end;
2126 ifR16G16B16:
2127 begin
2128 DestPix.R := PColor48Rec(SrcPix).R shr 8;
2129 DestPix.G := PColor48Rec(SrcPix).G shr 8;
2130 DestPix.B := PColor48Rec(SrcPix).B shr 8;
2131 DestPix.A := 255;
2132 end;
2133 ifA16R16G16B16:
2134 begin
2135 DestPix.R := PColor64Rec(SrcPix).R shr 8;
2136 DestPix.G := PColor64Rec(SrcPix).G shr 8;
2137 DestPix.B := PColor64Rec(SrcPix).B shr 8;
2138 DestPix.A := PColor64Rec(SrcPix).A shr 8;
2139 end;
2140 else
2141 DestPix^ := SrcInfo.GetPixel32(SrcPix, @SrcInfo, SrcPalette);
2142 end;
2143 end;
2144
2145 procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
2146 Bpp, WidthBytes: LongInt);
2147 var
2148 I, W: LongInt;
2149 begin
2150 W := Width * Bpp;
2151 for I := 0 to Height - 1 do
2152 Move(PByteArray(DataIn)[I * W], PByteArray(DataOut)[I * WidthBytes], W);
2153 end;
2154
2155 procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
2156 Bpp, WidthBytes: LongInt);
2157 var
2158 I, W: LongInt;
2159 begin
2160 W := Width * Bpp;
2161 for I := 0 to Height - 1 do
2162 Move(PByteArray(DataIn)[I * WidthBytes], PByteArray(DataOut)[I * W], W);
2163 end;
2164
2165 procedure Convert1To8(DataIn, DataOut: PByte; Width, Height,
2166 WidthBytes: LongInt; ScaleTo8Bits: Boolean);
2167 const
2168 Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
2169 Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0);
2170 Scaling: Byte = 255;
2171 var
2172 X, Y: LongInt;
2173 InArray: PByteArray absolute DataIn;
2174 begin
2175 for Y := 0 to Height - 1 do
2176 for X := 0 to Width - 1 do
2177 begin
2178 DataOut^ := (InArray[Y * WidthBytes + X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
2179 if ScaleTo8Bits then
2180 DataOut^ := DataOut^ * Scaling;
2181 Inc(DataOut);
2182 end;
2183 end;
2184
2185 procedure Convert2To8(DataIn, DataOut: PByte; Width, Height,
2186 WidthBytes: LongInt; ScaleTo8Bits: Boolean);
2187 const
2188 Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03);
2189 Shift2: array[0..3] of Byte = (6, 4, 2, 0);
2190 Scaling: Byte = 85;
2191 var
2192 X, Y: LongInt;
2193 InArray: PByteArray absolute DataIn;
2194 begin
2195 for Y := 0 to Height - 1 do
2196 for X := 0 to Width - 1 do
2197 begin
2198 DataOut^ := (InArray[Y * WidthBytes + X shr 2] and Mask2[X and 3]) shr Shift2[X and 3];
2199 if ScaleTo8Bits then
2200 DataOut^ := DataOut^ * Scaling;
2201 Inc(DataOut);
2202 end;
2203 end;
2204
2205 procedure Convert4To8(DataIn, DataOut: PByte; Width, Height,
2206 WidthBytes: LongInt; ScaleTo8Bits: Boolean);
2207 const
2208 Mask4: array[0..1] of Byte = ($F0, $0F);
2209 Shift4: array[0..1] of Byte = (4, 0);
2210 Scaling: Byte = 17;
2211 var
2212 X, Y: LongInt;
2213 InArray: PByteArray absolute DataIn;
2214 begin
2215 for Y := 0 to Height - 1 do
2216 for X := 0 to Width - 1 do
2217 begin
2218 DataOut^ := (InArray[Y * WidthBytes + X shr 1] and Mask4[X and 1]) shr Shift4[X and 1];
2219 if ScaleTo8Bits then
2220 DataOut^ := DataOut^ * Scaling;
2221 Inc(DataOut);
2222 end;
2223 end;
2224
2225 function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean;
2226 var
2227 I: LongInt;
2228 begin
2229 Result := False;
2230 for I := 0 to NumPixels - 1 do
2231 begin
2232 if Data^ >= 1 shl 15 then
2233 begin
2234 Result := True;
2235 Exit;
2236 end;
2237 Inc(Data);
2238 end;
2239 end;
2240
2241 function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean;
2242 var
2243 I: LongInt;
2244 begin
2245 Result := False;
2246 for I := 0 to NumPixels - 1 do
2247 begin
2248 if Data^ >= 1 shl 24 then
2249 begin
2250 Result := True;
2251 Exit;
2252 end;
2253 Inc(Data);
2254 end;
2255 end;
2256
2257 function PaletteHasAlpha(Palette: PPalette32; PaletteEntries: Integer): Boolean;
2258 var
2259 I: Integer;
2260 begin
2261 for I := 0 to PaletteEntries - 1 do
2262 begin
2263 if Palette[I].A <> 255 then
2264 begin
2265 Result := True;
2266 Exit;
2267 end;
2268 end;
2269 Result := False;
2270 end;
2271
2272 function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
2273 LineWidth, Index: LongInt): Pointer;
2274 var
2275 LineBytes: LongInt;
2276 begin
2277 Assert(not FormatInfo.IsSpecial);
2278 LineBytes := FormatInfo.GetPixelsSize(FormatInfo.Format, LineWidth, 1);
2279 Result := @PByteArray(ImageBits)[Index * LineBytes];
2280 end;
2281
2282 function IsImageFormatValid(Format: TImageFormat): Boolean;
2283 begin
2284 Result := FInfos[Format] <> nil;
2285 end;
2286
2287 const
2288 HalfMin: Single = 5.96046448e-08; // Smallest positive half
2289 HalfMinNorm: Single = 6.10351562e-05; // Smallest positive normalized half
2290 HalfMax: Single = 65504.0; // Largest positive half
2291 HalfEpsilon: Single = 0.00097656; // Smallest positive e for which half (1.0 + e) != half (1.0)
2292 HalfNaN: THalfFloat = 65535;
2293 HalfPosInf: THalfFloat = 31744;
2294 HalfNegInf: THalfFloat = 64512;
2295
2296
2297 {
2298 Half/Float conversions inspired by half class from OpenEXR library.
2299
2300 Float (Pascal Single type) is an IEEE 754 single-precision
2301 floating point number.
2302
2303 Bit layout of Single:
2304
2305 31 (msb)
2306 |
2307 | 30 23
2308 | | |
2309 | | | 22 0 (lsb)
2310 | | | | |
2311 X XXXXXXXX XXXXXXXXXXXXXXXXXXXXXXX
2312 s e m
2313
2314 Bit layout of half:
2315
2316 15 (msb)
2317 |
2318 | 14 10
2319 | | |
2320 | | | 9 0 (lsb)
2321 | | | | |
2322 X XXXXX XXXXXXXXXX
2323 s e m
2324
2325 S is the sign-bit, e is the exponent and m is the significand (mantissa).
2326 }
2327
2328 function HalfToFloat(Half: THalfFloat): Single;
2329 var
2330 Dst, Sign, Mantissa: LongWord;
2331 Exp: LongInt;
2332 begin
2333 // Extract sign, exponent, and mantissa from half number
2334 Sign := Half shr 15;
2335 Exp := (Half and $7C00) shr 10;
2336 Mantissa := Half and 1023;
2337
2338 if (Exp > 0) and (Exp < 31) then
2339 begin
2340 // Common normalized number
2341 Exp := Exp + (127 - 15);
2342 Mantissa := Mantissa shl 13;
2343 Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
2344 // Result := Power(-1, Sign) * Power(2, Exp - 15) * (1 + Mantissa / 1024);
2345 end
2346 else if (Exp = 0) and (Mantissa = 0) then
2347 begin
2348 // Zero - preserve sign
2349 Dst := Sign shl 31;
2350 end
2351 else if (Exp = 0) and (Mantissa <> 0) then
2352 begin
2353 // Denormalized number - renormalize it
2354 while (Mantissa and $00000400) = 0 do
2355 begin
2356 Mantissa := Mantissa shl 1;
2357 Dec(Exp);
2358 end;
2359 Inc(Exp);
2360 Mantissa := Mantissa and not $00000400;
2361 // Now assemble normalized number
2362 Exp := Exp + (127 - 15);
2363 Mantissa := Mantissa shl 13;
2364 Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
2365 // Result := Power(-1, Sign) * Power(2, -14) * (Mantissa / 1024);
2366 end
2367 else if (Exp = 31) and (Mantissa = 0) then
2368 begin
2369 // +/- infinity
2370 Dst := (Sign shl 31) or $7F800000;
2371 end
2372 else //if (Exp = 31) and (Mantisa <> 0) then
2373 begin
2374 // Not a number - preserve sign and mantissa
2375 Dst := (Sign shl 31) or $7F800000 or (Mantissa shl 13);
2376 end;
2377
2378 // Reinterpret LongWord as Single
2379 Result := PSingle(@Dst)^;
2380 end;
2381
2382 function FloatToHalf(Float: Single): THalfFloat;
2383 var
2384 Src: LongWord;
2385 Sign, Exp, Mantissa: LongInt;
2386 begin
2387 Src := PLongWord(@Float)^;
2388 // Extract sign, exponent, and mantissa from Single number
2389 Sign := Src shr 31;
2390 Exp := LongInt((Src and $7F800000) shr 23) - 127 + 15;
2391 Mantissa := Src and $007FFFFF;
2392
2393 if (Exp > 0) and (Exp < 30) then
2394 begin
2395 // Simple case - round the significand and combine it with the sign and exponent
2396 Result := (Sign shl 15) or (Exp shl 10) or ((Mantissa + $00001000) shr 13);
2397 end
2398 else if Src = 0 then
2399 begin
2400 // Input float is zero - return zero
2401 Result := 0;
2402 end
2403 else
2404 begin
2405 // Difficult case - lengthy conversion
2406 if Exp <= 0 then
2407 begin
2408 if Exp < -10 then
2409 begin
2410 // Input float's value is less than HalfMin, return zero
2411 Result := 0;
2412 end
2413 else
2414 begin
2415 // Float is a normalized Single whose magnitude is less than HalfNormMin.
2416 // We convert it to denormalized half.
2417 Mantissa := (Mantissa or $00800000) shr (1 - Exp);
2418 // Round to nearest
2419 if (Mantissa and $00001000) > 0 then
2420 Mantissa := Mantissa + $00002000;
2421 // Assemble Sign and Mantissa (Exp is zero to get denormalized number)
2422 Result := (Sign shl 15) or (Mantissa shr 13);
2423 end;
2424 end
2425 else if Exp = 255 - 127 + 15 then
2426 begin
2427 if Mantissa = 0 then
2428 begin
2429 // Input float is infinity, create infinity half with original sign
2430 Result := (Sign shl 15) or $7C00;
2431 end
2432 else
2433 begin
2434 // Input float is NaN, create half NaN with original sign and mantissa
2435 Result := (Sign shl 15) or $7C00 or (Mantissa shr 13);
2436 end;
2437 end
2438 else
2439 begin
2440 // Exp is > 0 so input float is normalized Single
2441
2442 // Round to nearest
2443 if (Mantissa and $00001000) > 0 then
2444 begin
2445 Mantissa := Mantissa + $00002000;
2446 if (Mantissa and $00800000) > 0 then
2447 begin
2448 Mantissa := 0;
2449 Exp := Exp + 1;
2450 end;
2451 end;
2452
2453 if Exp > 30 then
2454 begin
2455 // Exponent overflow - return infinity half
2456 Result := (Sign shl 15) or $7C00;
2457 end
2458 else
2459 // Assemble normalized half
2460 Result := (Sign shl 15) or (Exp shl 10) or (Mantissa shr 13);
2461 end;
2462 end;
2463 end;
2464
2465 function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec;
2466 begin
2467 Result.A := HalfToFloat(ColorHF.A);
2468 Result.R := HalfToFloat(ColorHF.R);
2469 Result.G := HalfToFloat(ColorHF.G);
2470 Result.B := HalfToFloat(ColorHF.B);
2471 end;
2472
2473 function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec;
2474 begin
2475 Result.A := FloatToHalf(ColorFP.A);
2476 Result.R := FloatToHalf(ColorFP.R);
2477 Result.G := FloatToHalf(ColorFP.G);
2478 Result.B := FloatToHalf(ColorFP.B);
2479 end;
2480
2481 procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData);
2482 var
2483 I: Integer;
2484 Pix: PColor32;
2485 begin
2486 InitImage(PalImage);
2487 NewImage(Entries, 1, ifA8R8G8B8, PalImage);
2488 Pix := PalImage.Bits;
2489 for I := 0 to Entries - 1 do
2490 begin
2491 Pix^ := Pal[I].Color;
2492 Inc(Pix);
2493 end;
2494 end;
2495
2496
2497 { Pixel readers/writers for different image formats }
2498
2499 procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
2500 var Pix: TColor64Rec);
2501 var
2502 A, R, G, B: Byte;
2503 begin
2504 A := 0;
2505 R := 0;
2506 G := 0;
2507 B := 0;
2508 FillChar(Pix, SizeOf(Pix), 0);
2509 // returns 64 bit color value with 16 bits for each channel
2510 case SrcInfo.BytesPerPixel of
2511 1:
2512 begin
2513 PFGetARGB(SrcInfo.PixelFormat^, Src^, A, R, G, B);
2514 Pix.A := A shl 8;
2515 Pix.R := R shl 8;
2516 Pix.G := G shl 8;
2517 Pix.B := B shl 8;
2518 end;
2519 2:
2520 begin
2521 PFGetARGB(SrcInfo.PixelFormat^, PWord(Src)^, A, R, G, B);
2522 Pix.A := A shl 8;
2523 Pix.R := R shl 8;
2524 Pix.G := G shl 8;
2525 Pix.B := B shl 8;
2526 end;
2527 3:
2528 with Pix do
2529 begin
2530 R := MulDiv(PColor24Rec(Src).R, 65535, 255);
2531 G := MulDiv(PColor24Rec(Src).G, 65535, 255);
2532 B := MulDiv(PColor24Rec(Src).B, 65535, 255);
2533 end;
2534 4:
2535 with Pix do
2536 begin
2537 A := MulDiv(PColor32Rec(Src).A, 65535, 255);
2538 R := MulDiv(PColor32Rec(Src).R, 65535, 255);
2539 G := MulDiv(PColor32Rec(Src).G, 65535, 255);
2540 B := MulDiv(PColor32Rec(Src).B, 65535, 255);
2541 end;
2542 6:
2543 with Pix do
2544 begin
2545 R := PColor48Rec(Src).R;
2546 G := PColor48Rec(Src).G;
2547 B := PColor48Rec(Src).B;
2548 end;
2549 8: Pix.Color := PColor64(Src)^;
2550 end;
2551 // if src has no alpha, we set it to max (otherwise we would have to
2552 // test if dest has alpha or not in each ChannelToXXX function)
2553 if not SrcInfo.HasAlphaChannel then
2554 Pix.A := 65535;
2555
2556 if SrcInfo.IsRBSwapped then
2557 SwapValues(Pix.R, Pix.B);
2558 end;
2559
2560 procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
2561 const Pix: TColor64Rec);
2562 var
2563 PixW: TColor64Rec;
2564 begin
2565 PixW := Pix;
2566 if DstInfo.IsRBSwapped then
2567 SwapValues(PixW.R, PixW.B);
2568 // Pix contains 64 bit color value with 16 bit for each channel
2569 case DstInfo.BytesPerPixel of
2570 1: Dst^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8,
2571 PixW.R shr 8, PixW.G shr 8, PixW.B shr 8);
2572 2: PWord(Dst)^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8,
2573 PixW.R shr 8, PixW.G shr 8, PixW.B shr 8);
2574 3:
2575 with PColor24Rec(Dst)^ do
2576 begin
2577 R := MulDiv(PixW.R, 255, 65535);
2578 G := MulDiv(PixW.G, 255, 65535);
2579 B := MulDiv(PixW.B, 255, 65535);
2580 end;
2581 4:
2582 with PColor32Rec(Dst)^ do
2583 begin
2584 A := MulDiv(PixW.A, 255, 65535);
2585 R := MulDiv(PixW.R, 255, 65535);
2586 G := MulDiv(PixW.G, 255, 65535);
2587 B := MulDiv(PixW.B, 255, 65535);
2588 end;
2589 6:
2590 with PColor48Rec(Dst)^ do
2591 begin
2592 R := PixW.R;
2593 G := PixW.G;
2594 B := PixW.B;
2595 end;
2596 8: PColor64(Dst)^ := PixW.Color;
2597 end;
2598 end;
2599
2600 procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
2601 var Gray: TColor64Rec; var Alpha: Word);
2602 begin
2603 FillChar(Gray, SizeOf(Gray), 0);
2604 // Source alpha is scaled to 16 bits and stored in Alpha,
2605 // grayscale value is scaled to 64 bits and stored in Gray
2606 case SrcInfo.BytesPerPixel of
2607 1: Gray.A := MulDiv(Src^, 65535, 255);
2608 2:
2609 if SrcInfo.HasAlphaChannel then
2610 with PWordRec(Src)^ do
2611 begin
2612 Alpha := MulDiv(High, 65535, 255);
2613 Gray.A := MulDiv(Low, 65535, 255);
2614 end
2615 else
2616 Gray.A := PWord(Src)^;
2617 4:
2618 if SrcInfo.HasAlphaChannel then
2619 with PLongWordRec(Src)^ do
2620 begin
2621 Alpha := High;
2622 Gray.A := Low;
2623 end
2624 else
2625 with PLongWordRec(Src)^ do
2626 begin
2627 Gray.A := High;
2628 Gray.R := Low;
2629 end;
2630 8: Gray.Color := PColor64(Src)^;
2631 end;
2632 // if src has no alpha, we set it to max (otherwise we would have to
2633 // test if dest has alpha or not in each GrayToXXX function)
2634 if not SrcInfo.HasAlphaChannel then
2635 Alpha := 65535;
2636 end;
2637
2638 procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
2639 const Gray: TColor64Rec; Alpha: Word);
2640 begin
2641 // Gray contains grayscale value scaled to 64 bits, Alpha contains
2642 // alpha value scaled to 16 bits
2643 case DstInfo.BytesPerPixel of
2644 1: Dst^ := MulDiv(Gray.A, 255, 65535);
2645 2:
2646 if DstInfo.HasAlphaChannel then
2647 with PWordRec(Dst)^ do
2648 begin
2649 High := MulDiv(Alpha, 255, 65535);
2650 Low := MulDiv(Gray.A, 255, 65535);
2651 end
2652 else
2653 PWord(Dst)^ := Gray.A;
2654 4:
2655 if DstInfo.HasAlphaChannel then
2656 with PLongWordRec(Dst)^ do
2657 begin
2658 High := Alpha;
2659 Low := Gray.A;
2660 end
2661 else
2662 with PLongWordRec(Dst)^ do
2663 begin
2664 High := Gray.A;
2665 Low := Gray.R;
2666 end;
2667 8: PColor64(Dst)^ := Gray.Color;
2668 end;
2669 end;
2670
2671 procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
2672 var Pix: TColorFPRec);
2673 var
2674 PixHF: TColorHFRec;
2675 begin
2676 Assert(SrcInfo.BytesPerPixel in [2, 4, 8, 12, 16]);
2677
2678 if SrcInfo.BytesPerPixel in [4, 12, 16] then
2679 begin
2680 // IEEE 754 single-precision channels
2681 FillChar(Pix, SizeOf(Pix), 0);
2682 case SrcInfo.BytesPerPixel of
2683 4: Pix.R := PSingle(Src)^;
2684 12: Pix.Color96Rec := PColor96FPRec(Src)^;
2685 16: Pix := PColorFPRec(Src)^;
2686 end;
2687 end
2688 else
2689 begin
2690 // Half float channels
2691 FillChar(PixHF, SizeOf(PixHF), 0);
2692 case SrcInfo.BytesPerPixel of
2693 2: PixHF.R := PHalfFloat(Src)^;
2694 8: PixHF := PColorHFRec(Src)^;
2695 end;
2696 Pix := ColorHalfToFloat(PixHF);
2697 end;
2698
2699 // If src has no alpha, we set it to max (otherwise we would have to
2700 // test if dest has alpha or not in each FloatToXXX function)
2701 if not SrcInfo.HasAlphaChannel then
2702 Pix.A := 1.0;
2703 if SrcInfo.IsRBSwapped then
2704 SwapValues(Pix.R, Pix.B);
2705 end;
2706
2707 procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
2708 const Pix: TColorFPRec);
2709 var
2710 PixW: TColorFPRec;
2711 PixHF: TColorHFRec;
2712 begin
2713 Assert(DstInfo.BytesPerPixel in [2, 4, 8, 12, 16]);
2714
2715 PixW := Pix;
2716 if DstInfo.IsRBSwapped then
2717 SwapValues(PixW.R, PixW.B);
2718
2719 if DstInfo.BytesPerPixel in [4, 12, 16] then
2720 begin
2721 case DstInfo.BytesPerPixel of
2722 4: PSingle(Dst)^ := PixW.R;
2723 12: PColor96FPRec(Dst)^:= PixW.Color96Rec;
2724 16: PColorFPRec(Dst)^ := PixW;
2725 end;
2726 end
2727 else
2728 begin
2729 PixHF := ColorFloatToHalf(PixW);
2730 case DstInfo.BytesPerPixel of
2731 2: PHalfFloat(Dst)^ := PixHF.R;
2732 8: PColorHFRec(Dst)^ := PixHF;
2733 end;
2734 end;
2735 end;
2736
2737 procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
2738 var Index: LongWord);
2739 begin
2740 case SrcInfo.BytesPerPixel of
2741 1: Index := Src^;
2742 end;
2743 end;
2744
2745 procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
2746 Index: LongWord);
2747 begin
2748 case DstInfo.BytesPerPixel of
2749 1: Dst^ := Byte(Index);
2750 2: PWord(Dst)^ := Word(Index);
2751 4: PLongWord(Dst)^ := Index;
2752 end;
2753 end;
2754
2755
2756 { Pixel readers/writers for 32bit and FP colors}
2757
2758 function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
2759 var
2760 Pix64: TColor64Rec;
2761 PixF: TColorFPRec;
2762 Alpha: Word;
2763 Index: LongWord;
2764 begin
2765 if Info.Format = ifA8R8G8B8 then
2766 begin
2767 Result := PColor32Rec(Bits)^
2768 end
2769 else if Info.Format = ifR8G8B8 then
2770 begin
2771 PColor24Rec(@Result)^ := PColor24Rec(Bits)^;
2772 Result.A := $FF;
2773 end
2774 else if Info.IsFloatingPoint then
2775 begin
2776 FloatGetSrcPixel(Bits, Info, PixF);
2777 Result.A := ClampToByte(Round(PixF.A * 255.0));
2778 Result.R := ClampToByte(Round(PixF.R * 255.0));
2779 Result.G := ClampToByte(Round(PixF.G * 255.0));
2780 Result.B := ClampToByte(Round(PixF.B * 255.0));
2781 end
2782 else if Info.HasGrayChannel then
2783 begin
2784 GrayGetSrcPixel(Bits, Info, Pix64, Alpha);
2785 Result.A := MulDiv(Alpha, 255, 65535);
2786 Result.R := MulDiv(Pix64.A, 255, 65535);
2787 Result.G := MulDiv(Pix64.A, 255, 65535);
2788 Result.B := MulDiv(Pix64.A, 255, 65535);
2789 end
2790 else if Info.IsIndexed then
2791 begin
2792 IndexGetSrcPixel(Bits, Info, Index);
2793 Result := Palette[Index];
2794 end
2795 else
2796 begin
2797 ChannelGetSrcPixel(Bits, Info, Pix64);
2798 Result.A := MulDiv(Pix64.A, 255, 65535);
2799 Result.R := MulDiv(Pix64.R, 255, 65535);
2800 Result.G := MulDiv(Pix64.G, 255, 65535);
2801 Result.B := MulDiv(Pix64.B, 255, 65535);
2802 end;
2803 end;
2804
2805 procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
2806 var
2807 Pix64: TColor64Rec;
2808 PixF: TColorFPRec;
2809 Alpha: Word;
2810 Index: LongWord;
2811 begin
2812 if Info.Format = ifA8R8G8B8 then
2813 begin
2814 PColor32Rec(Bits)^ := Color
2815 end
2816 else if Info.Format = ifR8G8B8 then
2817 begin
2818 PColor24Rec(Bits)^ := Color.Color24Rec;
2819 end
2820 else if Info.IsFloatingPoint then
2821 begin
2822 PixF.A := Color.A * OneDiv8Bit;
2823 PixF.R := Color.R * OneDiv8Bit;
2824 PixF.G := Color.G * OneDiv8Bit;
2825 PixF.B := Color.B * OneDiv8Bit;
2826 FloatSetDstPixel(Bits, Info, PixF);
2827 end
2828 else if Info.HasGrayChannel then
2829 begin
2830 Alpha := MulDiv(Color.A, 65535, 255);
2831 Pix64.Color := 0;
2832 Pix64.A := MulDiv(Round(GrayConv.R * Color.R + GrayConv.G * Color.G +
2833 GrayConv.B * Color.B), 65535, 255);
2834 GraySetDstPixel(Bits, Info, Pix64, Alpha);
2835 end
2836 else if Info.IsIndexed then
2837 begin
2838 Index := FindColor(Palette, Info.PaletteEntries, Color.Color);
2839 IndexSetDstPixel(Bits, Info, Index);
2840 end
2841 else
2842 begin
2843 Pix64.A := MulDiv(Color.A, 65535, 255);
2844 Pix64.R := MulDiv(Color.R, 65535, 255);
2845 Pix64.G := MulDiv(Color.G, 65535, 255);
2846 Pix64.B := MulDiv(Color.B, 65535, 255);
2847 ChannelSetDstPixel(Bits, Info, Pix64);
2848 end;
2849 end;
2850
2851 function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
2852 var
2853 Pix32: TColor32Rec;
2854 Pix64: TColor64Rec;
2855 Alpha: Word;
2856 Index: LongWord;
2857 begin
2858 if Info.IsFloatingPoint then
2859 begin
2860 FloatGetSrcPixel(Bits, Info, Result);
2861 end
2862 else if Info.HasGrayChannel then
2863 begin
2864 GrayGetSrcPixel(Bits, Info, Pix64, Alpha);
2865 Result.A := Alpha * OneDiv16Bit;
2866 Result.R := Pix64.A * OneDiv16Bit;
2867 Result.G := Pix64.A * OneDiv16Bit;
2868 Result.B := Pix64.A * OneDiv16Bit;
2869 end
2870 else if Info.IsIndexed then
2871 begin
2872 IndexGetSrcPixel(Bits, Info, Index);
2873 Pix32 := Palette[Index];
2874 Result.A := Pix32.A * OneDiv8Bit;
2875 Result.R := Pix32.R * OneDiv8Bit;
2876 Result.G := Pix32.G * OneDiv8Bit;
2877 Result.B := Pix32.B * OneDiv8Bit;
2878 end
2879 else
2880 begin
2881 ChannelGetSrcPixel(Bits, Info, Pix64);
2882 Result.A := Pix64.A * OneDiv16Bit;
2883 Result.R := Pix64.R * OneDiv16Bit;
2884 Result.G := Pix64.G * OneDiv16Bit;
2885 Result.B := Pix64.B * OneDiv16Bit;
2886 end;
2887 end;
2888
2889 procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
2890 var
2891 Pix32: TColor32Rec;
2892 Pix64: TColor64Rec;
2893 Alpha: Word;
2894 Index: LongWord;
2895 begin
2896 if Info.IsFloatingPoint then
2897 begin
2898 FloatSetDstPixel(Bits, Info, Color);
2899 end
2900 else if Info.HasGrayChannel then
2901 begin
2902 Alpha := ClampToWord(Round(Color.A * 65535.0));
2903 Pix64.Color := 0;
2904 Pix64.A := ClampToWord(Round((GrayConv.R * Color.R + GrayConv.G * Color.G +
2905 GrayConv.B * Color.B) * 65535.0));
2906 GraySetDstPixel(Bits, Info, Pix64, Alpha);
2907 end
2908 else if Info.IsIndexed then
2909 begin
2910 Pix32.A := ClampToByte(Round(Color.A * 255.0));
2911 Pix32.R := ClampToByte(Round(Color.R * 255.0));
2912 Pix32.G := ClampToByte(Round(Color.G * 255.0));
2913 Pix32.B := ClampToByte(Round(Color.B * 255.0));
2914 Index := FindColor(Palette, Info.PaletteEntries, Pix32.Color);
2915 IndexSetDstPixel(Bits, Info, Index);
2916 end
2917 else
2918 begin
2919 Pix64.A := ClampToWord(Round(Color.A * 65535.0));
2920 Pix64.R := ClampToWord(Round(Color.R * 65535.0));
2921 Pix64.G := ClampToWord(Round(Color.G * 65535.0));
2922 Pix64.B := ClampToWord(Round(Color.B * 65535.0));
2923 ChannelSetDstPixel(Bits, Info, Pix64);
2924 end;
2925 end;
2926
2927
2928 { Image format conversion functions }
2929
2930 procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
2931 DstInfo: PImageFormatInfo);
2932 var
2933 I: LongInt;
2934 Pix64: TColor64Rec;
2935 begin
2936 // two most common conversions (RGB->ARGB and ARGB->RGB for 24/32 bit
2937 // images) are made separately from general ARGB conversion to
2938 // make them faster
2939 if (SrcInfo.BytesPerPixel = 3) and (DstInfo.BytesPerPixel = 4) then
2940 for I := 0 to NumPixels - 1 do
2941 begin
2942 PColor24Rec(Dst)^ := PColor24Rec(Src)^;
2943 if DstInfo.HasAlphaChannel then
2944 PColor32Rec(Dst).A := 255;
2945 Inc(Src, SrcInfo.BytesPerPixel);
2946 Inc(Dst, DstInfo.BytesPerPixel);
2947 end
2948 else
2949 if (SrcInfo.BytesPerPixel = 4) and (DstInfo.BytesPerPixel = 3) then
2950 for I := 0 to NumPixels - 1 do
2951 begin
2952 PColor24Rec(Dst)^ := PColor24Rec(Src)^;
2953 Inc(Src, SrcInfo.BytesPerPixel);
2954 Inc(Dst, DstInfo.BytesPerPixel);
2955 end
2956 else
2957 for I := 0 to NumPixels - 1 do
2958 begin
2959 // general ARGB conversion
2960 ChannelGetSrcPixel(Src, SrcInfo, Pix64);
2961 ChannelSetDstPixel(Dst, DstInfo, Pix64);
2962 Inc(Src, SrcInfo.BytesPerPixel);
2963 Inc(Dst, DstInfo.BytesPerPixel);
2964 end;
2965 end;
2966
2967 procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
2968 DstInfo: PImageFormatInfo);
2969 var
2970 I: LongInt;
2971 Pix64: TColor64Rec;
2972 Alpha: Word;
2973 begin
2974 // two most common conversions (R8G8B8->Gray8 nad A8R8G8B8->Gray8)
2975 // are made separately from general conversions to make them faster
2976 if (SrcInfo.BytesPerPixel in [3, 4]) and (DstInfo.Format = ifGray8) then
2977 for I := 0 to NumPixels - 1 do
2978 begin
2979 Dst^ := Round(GrayConv.R * PColor24Rec(Src).R + GrayConv.G * PColor24Rec(Src).G +
2980 GrayConv.B * PColor24Rec(Src).B);
2981 Inc(Src, SrcInfo.BytesPerPixel);
2982 Inc(Dst, DstInfo.BytesPerPixel);
2983 end
2984 else
2985 for I := 0 to NumPixels - 1 do
2986 begin
2987 ChannelGetSrcPixel(Src, SrcInfo, Pix64);
2988
2989 // alpha is saved from source pixel to Alpha,
2990 // Gray value is computed and set to highest word of Pix64 so
2991 // Pix64.Color contains grayscale value scaled to 64 bits
2992 Alpha := Pix64.A;
2993 with GrayConv do
2994 Pix64.A := Round(R * Pix64.R + G * Pix64.G + B * Pix64.B);
2995
2996 GraySetDstPixel(Dst, DstInfo, Pix64, Alpha);
2997 Inc(Src, SrcInfo.BytesPerPixel);
2998 Inc(Dst, DstInfo.BytesPerPixel);
2999 end;
3000 end;
3001
3002 procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3003 DstInfo: PImageFormatInfo);
3004 var
3005 I: LongInt;
3006 Pix64: TColor64Rec;
3007 PixF: TColorFPRec;
3008 begin
3009 for I := 0 to NumPixels - 1 do
3010 begin
3011 ChannelGetSrcPixel(Src, SrcInfo, Pix64);
3012
3013 // floating point channel values are scaled to 1.0
3014 PixF.A := Pix64.A * OneDiv16Bit;
3015 PixF.R := Pix64.R * OneDiv16Bit;
3016 PixF.G := Pix64.G * OneDiv16Bit;
3017 PixF.B := Pix64.B * OneDiv16Bit;
3018
3019 FloatSetDstPixel(Dst, DstInfo, PixF);
3020 Inc(Src, SrcInfo.BytesPerPixel);
3021 Inc(Dst, DstInfo.BytesPerPixel);
3022 end;
3023 end;
3024
3025 procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3026 DstInfo: PImageFormatInfo; DstPal: PPalette32);
3027 begin
3028 ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries,
3029 GetOption(ImagingColorReductionMask), DstPal);
3030 end;
3031
3032 procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3033 DstInfo: PImageFormatInfo);
3034 var
3035 I: LongInt;
3036 Gray: TColor64Rec;
3037 Alpha: Word;
3038 begin
3039 // two most common conversions (Gray8->Gray16 nad Gray16->Gray8)
3040 // are made separately from general conversions to make them faster
3041 if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifGray16) then
3042 begin
3043 for I := 0 to NumPixels - 1 do
3044 PWordArray(Dst)[I] := PByteArray(Src)[I] shl 8;
3045 end
3046 else
3047 begin
3048 if (DstInfo.Format = ifGray8) and (SrcInfo.Format = ifGray16) then
3049 begin
3050 for I := 0 to NumPixels - 1 do
3051 PByteArray(Dst)[I] := PWordArray(Src)[I] shr 8;
3052 end
3053 else
3054 for I := 0 to NumPixels - 1 do
3055 begin
3056 // general grayscale conversion
3057 GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
3058 GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
3059 Inc(Src, SrcInfo.BytesPerPixel);
3060 Inc(Dst, DstInfo.BytesPerPixel);
3061 end;
3062 end;
3063 end;
3064
3065 procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3066 DstInfo: PImageFormatInfo);
3067 var
3068 I: LongInt;
3069 Pix64: TColor64Rec;
3070 Alpha: Word;
3071 begin
3072 // two most common conversions (Gray8->R8G8B8 nad Gray8->A8R8G8B8)
3073 // are made separately from general conversions to make them faster
3074 if (DstInfo.BytesPerPixel in [3, 4]) and (SrcInfo.Format = ifGray8) then
3075 for I := 0 to NumPixels - 1 do
3076 begin
3077 PColor24Rec(Dst).R := Src^;
3078 PColor24Rec(Dst).G := Src^;
3079 PColor24Rec(Dst).B := Src^;
3080 if DstInfo.HasAlphaChannel then
3081 PColor32Rec(Dst).A := $FF;
3082 Inc(Src, SrcInfo.BytesPerPixel);
3083 Inc(Dst, DstInfo.BytesPerPixel);
3084 end
3085 else
3086 for I := 0 to NumPixels - 1 do
3087 begin
3088 GrayGetSrcPixel(Src, SrcInfo, Pix64, Alpha);
3089
3090 // most significant word of grayscale value is used for
3091 // each channel and alpha channel is set to Alpha
3092 Pix64.R := Pix64.A;
3093 Pix64.G := Pix64.A;
3094 Pix64.B := Pix64.A;
3095 Pix64.A := Alpha;
3096
3097 ChannelSetDstPixel(Dst, DstInfo, Pix64);
3098 Inc(Src, SrcInfo.BytesPerPixel);
3099 Inc(Dst, DstInfo.BytesPerPixel);
3100 end;
3101 end;
3102
3103 procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3104 DstInfo: PImageFormatInfo);
3105 var
3106 I: LongInt;
3107 Gray: TColor64Rec;
3108 PixF: TColorFPRec;
3109 Alpha: Word;
3110 begin
3111 for I := 0 to NumPixels - 1 do
3112 begin
3113 GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
3114 // most significant word of grayscale value is used for
3115 // each channel and alpha channel is set to Alpha
3116 // then all is scaled to 0..1
3117 PixF.R := Gray.A * OneDiv16Bit;
3118 PixF.G := Gray.A * OneDiv16Bit;
3119 PixF.B := Gray.A * OneDiv16Bit;
3120 PixF.A := Alpha * OneDiv16Bit;
3121
3122 FloatSetDstPixel(Dst, DstInfo, PixF);
3123 Inc(Src, SrcInfo.BytesPerPixel);
3124 Inc(Dst, DstInfo.BytesPerPixel);
3125 end;
3126 end;
3127
3128 procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3129 DstInfo: PImageFormatInfo; DstPal: PPalette32);
3130 var
3131 I: LongInt;
3132 Idx: LongWord;
3133 Gray: TColor64Rec;
3134 Alpha, Shift: Word;
3135 begin
3136 FillGrayscalePalette(DstPal, DstInfo.PaletteEntries);
3137 Shift := Log2Int(DstInfo.PaletteEntries);
3138 // most common conversion (Gray8->Index8)
3139 // is made separately from general conversions to make it faster
3140 if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifIndex8) then
3141 for I := 0 to NumPixels - 1 do
3142 begin
3143 Dst^ := Src^;
3144 Inc(Src, SrcInfo.BytesPerPixel);
3145 Inc(Dst, DstInfo.BytesPerPixel);
3146 end
3147 else
3148 for I := 0 to NumPixels - 1 do
3149 begin
3150 // gray value is read from src and index to precomputed
3151 // grayscale palette is computed and written to dst
3152 // (we assume here that there will be no more than 65536 palette
3153 // entries in dst format, gray value is shifted so the highest
3154 // gray value match the highest possible index in palette)
3155 GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
3156 Idx := Gray.A shr (16 - Shift);
3157 IndexSetDstPixel(Dst, DstInfo, Idx);
3158 Inc(Src, SrcInfo.BytesPerPixel);
3159 Inc(Dst, DstInfo.BytesPerPixel);
3160 end;
3161 end;
3162
3163 procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3164 DstInfo: PImageFormatInfo);
3165 var
3166 I: LongInt;
3167 PixF: TColorFPRec;
3168 begin
3169 for I := 0 to NumPixels - 1 do
3170 begin
3171 // general floating point conversion
3172 FloatGetSrcPixel(Src, SrcInfo, PixF);
3173 FloatSetDstPixel(Dst, DstInfo, PixF);
3174 Inc(Src, SrcInfo.BytesPerPixel);
3175 Inc(Dst, DstInfo.BytesPerPixel);
3176 end;
3177 end;
3178
3179 procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3180 DstInfo: PImageFormatInfo);
3181 var
3182 I: LongInt;
3183 Pix64: TColor64Rec;
3184 PixF: TColorFPRec;
3185 begin
3186 for I := 0 to NumPixels - 1 do
3187 begin
3188 FloatGetSrcPixel(Src, SrcInfo, PixF);
3189 ClampFloatPixel(PixF);
3190
3191 // floating point channel values are scaled to 1.0
3192 Pix64.A := ClampToWord(Round(PixF.A * 65535));
3193 Pix64.R := ClampToWord(Round(PixF.R * 65535));
3194 Pix64.G := ClampToWord(Round(PixF.G * 65535));
3195 Pix64.B := ClampToWord(Round(PixF.B * 65535));
3196
3197 ChannelSetDstPixel(Dst, DstInfo, Pix64);
3198 Inc(Src, SrcInfo.BytesPerPixel);
3199 Inc(Dst, DstInfo.BytesPerPixel);
3200 end;
3201 end;
3202
3203 procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3204 DstInfo: PImageFormatInfo);
3205 var
3206 I: LongInt;
3207 PixF: TColorFPRec;
3208 Gray: TColor64Rec;
3209 Alpha: Word;
3210 begin
3211 for I := 0 to NumPixels - 1 do
3212 begin
3213 FloatGetSrcPixel(Src, SrcInfo, PixF);
3214 ClampFloatPixel(PixF);
3215
3216 // alpha is saved from source pixel to Alpha,
3217 // Gray value is computed and set to highest word of Pix64 so
3218 // Pix64.Color contains grayscale value scaled to 64 bits
3219 Alpha := ClampToWord(Round(PixF.A * 65535.0));
3220 Gray.A := ClampToWord(Round((GrayConv.R * PixF.R + GrayConv.G * PixF.G +
3221 GrayConv.B * PixF.B) * 65535.0));
3222
3223 GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
3224 Inc(Src, SrcInfo.BytesPerPixel);
3225 Inc(Dst, DstInfo.BytesPerPixel);
3226 end;
3227 end;
3228
3229 procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3230 DstInfo: PImageFormatInfo; DstPal: PPalette32);
3231 begin
3232 ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries,
3233 GetOption(ImagingColorReductionMask), DstPal);
3234 end;
3235
3236 procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3237 DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32);
3238 var
3239 I: LongInt;
3240 begin
3241 // there is only one indexed format now, so it is just a copy
3242 for I := 0 to NumPixels - 1 do
3243 begin
3244 Dst^ := Src^;
3245 Inc(Src, SrcInfo.BytesPerPixel);
3246 Inc(Dst, DstInfo.BytesPerPixel);
3247 end;
3248 for I := 0 to SrcInfo.PaletteEntries - 1 do
3249 DstPal[I] := SrcPal[I];
3250 end;
3251
3252 procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3253 DstInfo: PImageFormatInfo; SrcPal: PPalette32);
3254 var
3255 I: LongInt;
3256 Pix64: TColor64Rec;
3257 Idx: LongWord;
3258 begin
3259 // two most common conversions (Index8->R8G8B8 nad Index8->A8R8G8B8)
3260 // are made separately from general conversions to make them faster
3261 if (SrcInfo.Format = ifIndex8) and (DstInfo.Format in [ifR8G8B8, ifA8R8G8B8]) then
3262 for I := 0 to NumPixels - 1 do
3263 begin
3264 with PColor24Rec(Dst)^ do
3265 begin
3266 R := SrcPal[Src^].R;
3267 G := SrcPal[Src^].G;
3268 B := SrcPal[Src^].B;
3269 end;
3270 if DstInfo.Format = ifA8R8G8B8 then
3271 PColor32Rec(Dst).A := SrcPal[Src^].A;
3272 Inc(Src, SrcInfo.BytesPerPixel);
3273 Inc(Dst, DstInfo.BytesPerPixel);
3274 end
3275 else
3276 for I := 0 to NumPixels - 1 do
3277 begin
3278 // index to palette is read from source and color
3279 // is retrieved from palette entry. Color is then
3280 // scaled to 16bits and written to dest
3281 IndexGetSrcPixel(Src, SrcInfo, Idx);
3282 with Pix64 do
3283 begin
3284 A := SrcPal[Idx].A shl 8;
3285 R := SrcPal[Idx].R shl 8;
3286 G := SrcPal[Idx].G shl 8;
3287 B := SrcPal[Idx].B shl 8;
3288 end;
3289 ChannelSetDstPixel(Dst, DstInfo, Pix64);
3290 Inc(Src, SrcInfo.BytesPerPixel);
3291 Inc(Dst, DstInfo.BytesPerPixel);
3292 end;
3293 end;
3294
3295 procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3296 DstInfo: PImageFormatInfo; SrcPal: PPalette32);
3297 var
3298 I: LongInt;
3299 Gray: TColor64Rec;
3300 Alpha: Word;
3301 Idx: LongWord;
3302 begin
3303 // most common conversion (Index8->Gray8)
3304 // is made separately from general conversions to make it faster
3305 if (SrcInfo.Format = ifIndex8) and (DstInfo.Format = ifGray8) then
3306 begin
3307 for I := 0 to NumPixels - 1 do
3308 begin
3309 Dst^ := Round(GrayConv.R * SrcPal[Src^].R + GrayConv.G * SrcPal[Src^].G +
3310 GrayConv.B * SrcPal[Src^].B);
3311 Inc(Src, SrcInfo.BytesPerPixel);
3312 Inc(Dst, DstInfo.BytesPerPixel);
3313 end
3314 end
3315 else
3316 for I := 0 to NumPixels - 1 do
3317 begin
3318 // index to palette is read from source and color
3319 // is retrieved from palette entry. Color is then
3320 // transformed to grayscale and assigned to the highest
3321 // byte of Gray value
3322 IndexGetSrcPixel(Src, SrcInfo, Idx);
3323 Alpha := SrcPal[Idx].A shl 8;
3324 Gray.A := MulDiv(Round(GrayConv.R * SrcPal[Idx].R + GrayConv.G * SrcPal[Idx].G +
3325 GrayConv.B * SrcPal[Idx].B), 65535, 255);
3326 GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
3327 Inc(Src, SrcInfo.BytesPerPixel);
3328 Inc(Dst, DstInfo.BytesPerPixel);
3329 end;
3330 end;
3331
3332 procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
3333 DstInfo: PImageFormatInfo; SrcPal: PPalette32);
3334 var
3335 I: LongInt;
3336 Idx: LongWord;
3337 PixF: TColorFPRec;
3338 begin
3339 for I := 0 to NumPixels - 1 do
3340 begin
3341 // index to palette is read from source and color
3342 // is retrieved from palette entry. Color is then
3343 // scaled to 0..1 and written to dest
3344 IndexGetSrcPixel(Src, SrcInfo, Idx);
3345 with PixF do
3346 begin
3347 A := SrcPal[Idx].A * OneDiv8Bit;
3348 R := SrcPal[Idx].R * OneDiv8Bit;
3349 G := SrcPal[Idx].G * OneDiv8Bit;
3350 B := SrcPal[Idx].B * OneDiv8Bit;
3351 end;
3352 FloatSetDstPixel(Dst, DstInfo, PixF);
3353 Inc(Src, SrcInfo.BytesPerPixel);
3354 Inc(Dst, DstInfo.BytesPerPixel);
3355 end;
3356 end;
3357
3358
3359 { Special formats conversion functions }
3360
3361 type
3362 // DXT RGB color block
3363 TDXTColorBlock = packed record
3364 Color0, Color1: Word;
3365 Mask: LongWord;
3366 end;
3367 PDXTColorBlock = ^TDXTColorBlock;
3368
3369 // DXT explicit alpha for a block
3370 TDXTAlphaBlockExp = packed record
3371 Alphas: array[0..3] of Word;
3372 end;
3373 PDXTAlphaBlockExp = ^TDXTAlphaBlockExp;
3374
3375 // DXT interpolated alpha for a block
3376 TDXTAlphaBlockInt = packed record
3377 Alphas: array[0..7] of Byte;
3378 end;
3379 PDXTAlphaBlockInt = ^TDXTAlphaBlockInt;
3380
3381 TPixelInfo = record
3382 Color: Word;
3383 Alpha: Byte;
3384 Orig: TColor32Rec;
3385 end;
3386
3387 TPixelBlock = array[0..15] of TPixelInfo;
3388
3389 function DecodeCol(Color: Word): TColor32Rec;
3390 {$IFDEF USE_INLINE} inline; {$ENDIF}
3391 begin
3392 Result.A := $FF;
3393 { Result.R := ((Color and $F800) shr 11) shl 3;
3394 Result.G := ((Color and $07E0) shr 5) shl 2;
3395 Result.B := (Color and $001F) shl 3;}
3396 // this color expansion is slower but gives better results
3397 Result.R := (Color shr 11) * 255 div 31;
3398 Result.G := ((Color shr 5) and $3F) * 255 div 63;
3399 Result.B := (Color and $1F) * 255 div 31;
3400 end;
3401
3402 procedure DecodeDXT1(SrcBits, DestBits: PByte; Width, Height: LongInt);
3403 var
3404 Sel, X, Y, I, J, K: LongInt;
3405 Block: TDXTColorBlock;
3406 Colors: array[0..3] of TColor32Rec;
3407 begin
3408 for Y := 0 to Height div 4 - 1 do
3409 for X := 0 to Width div 4 - 1 do
3410 begin
3411 Block := PDXTColorBlock(SrcBits)^;
3412 Inc(SrcBits, SizeOf(Block));
3413 // we read and decode endpoint colors
3414 Colors[0] := DecodeCol(Block.Color0);
3415 Colors[1] := DecodeCol(Block.Color1);
3416 // and interpolate between them
3417 if Block.Color0 > Block.Color1 then
3418 begin
3419 // interpolation for block without alpha
3420 Colors[2].A := $FF;
3421 Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
3422 Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
3423 Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
3424 Colors[3].A := $FF;
3425 Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
3426 Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
3427 Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
3428 end
3429 else
3430 begin
3431 // interpolation for block with alpha
3432 Colors[2].A := $FF;
3433 Colors[2].R := (Colors[0].R + Colors[1].R) shr 1;
3434 Colors[2].G := (Colors[0].G + Colors[1].G) shr 1;
3435 Colors[2].B := (Colors[0].B + Colors[1].B) shr 1;
3436 Colors[3].A := 0;
3437 Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
3438 Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
3439 Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
3440 end;
3441
3442 // we distribute the dxt block colors across the 4x4 block of the
3443 // destination image accroding to the dxt block mask
3444 K := 0;
3445 for J := 0 to 3 do
3446 for I := 0 to 3 do
3447 begin
3448 Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
3449 if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then
3450 PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] :=
3451 Colors[Sel];
3452 Inc(K);
3453 end;
3454 end;
3455 end;
3456
3457 procedure DecodeDXT3(SrcBits, DestBits: PByte; Width, Height: LongInt);
3458 var
3459 Sel, X, Y, I, J, K: LongInt;
3460 Block: TDXTColorBlock;
3461 AlphaBlock: TDXTAlphaBlockExp;
3462 Colors: array[0..3] of TColor32Rec;
3463 AWord: Word;
3464 begin
3465 for Y := 0 to Height div 4 - 1 do
3466 for X := 0 to Width div 4 - 1 do
3467 begin
3468 AlphaBlock := PDXTAlphaBlockExp(SrcBits)^;
3469 Inc(SrcBits, SizeOf(AlphaBlock));
3470 Block := PDXTColorBlock(SrcBits)^;
3471 Inc(SrcBits, SizeOf(Block));
3472 // we read and decode endpoint colors
3473 Colors[0] := DecodeCol(Block.Color0);
3474 Colors[1] := DecodeCol(Block.Color1);
3475 // and interpolate between them
3476 Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
3477 Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
3478 Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
3479 Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
3480 Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
3481 Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
3482
3483 // we distribute the dxt block colors and alphas
3484 // across the 4x4 block of the destination image
3485 // accroding to the dxt block mask and alpha block
3486 K := 0;
3487 for J := 0 to 3 do
3488 begin
3489 AWord := AlphaBlock.Alphas[J];
3490 for I := 0 to 3 do
3491 begin
3492 Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
3493 if (X shl 2 + I < Width) and (Y shl 2 + J < Height) then
3494 begin
3495 Colors[Sel].A := AWord and $0F;
3496 Colors[Sel].A := Colors[Sel].A or (Colors[Sel].A shl 4);
3497 PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] :=
3498 Colors[Sel];
3499 end;
3500 Inc(K);
3501 AWord := AWord shr 4;
3502 end;
3503 end;
3504 end;
3505 end;
3506
3507 procedure GetInterpolatedAlphas(var AlphaBlock: TDXTAlphaBlockInt);
3508 begin
3509 with AlphaBlock do
3510 if Alphas[0] > Alphas[1] then
3511 begin
3512 // Interpolation of six alphas
3513 Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7;
3514 Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7;
3515 Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7;
3516 Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7;
3517 Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7;
3518 Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7;
3519 end
3520 else
3521 begin
3522 // Interpolation of four alphas, two alphas are set directly
3523 Alphas[2] := (4 * Alphas[0] + 1 * Alphas[1] + 2) div 5;
3524 Alphas[3] := (3 * Alphas[0] + 2 * Alphas[1] + 2) div 5;
3525 Alphas[4] := (2 * Alphas[0] + 3 * Alphas[1] + 2) div 5;
3526 Alphas[5] := (1 * Alphas[0] + 4 * Alphas[1] + 2) div 5;
3527 Alphas[6] := 0;
3528 Alphas[7] := $FF;
3529 end;
3530 end;
3531
3532 procedure DecodeDXT5(SrcBits, DestBits: PByte; Width, Height: LongInt);
3533 var
3534 Sel, X, Y, I, J, K: LongInt;
3535 Block: TDXTColorBlock;
3536 AlphaBlock: TDXTAlphaBlockInt;
3537 Colors: array[0..3] of TColor32Rec;
3538 AMask: array[0..1] of LongWord;
3539 begin
3540 for Y := 0 to Height div 4 - 1 do
3541 for X := 0 to Width div 4 - 1 do
3542 begin
3543 AlphaBlock := PDXTAlphaBlockInt(SrcBits)^;
3544 Inc(SrcBits, SizeOf(AlphaBlock));
3545 Block := PDXTColorBlock(SrcBits)^;
3546 Inc(SrcBits, SizeOf(Block));
3547 // we read and decode endpoint colors
3548 Colors[0] := DecodeCol(Block.Color0);
3549 Colors[1] := DecodeCol(Block.Color1);
3550 // and interpolate between them
3551 Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
3552 Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
3553 Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
3554 Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
3555 Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
3556 Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
3557 // 6 bit alpha mask is copied into two long words for
3558 // easier usage
3559 AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF;
3560 AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF;
3561 // alpha interpolation between two endpoint alphas
3562 GetInterpolatedAlphas(AlphaBlock);
3563
3564 // we distribute the dxt block colors and alphas
3565 // across the 4x4 block of the destination image
3566 // accroding to the dxt block mask and alpha block mask
3567 K := 0;
3568 for J := 0 to 3 do
3569 for I := 0 to 3 do
3570 begin
3571 Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
3572 if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then
3573 begin
3574 Colors[Sel].A := AlphaBlock.Alphas[AMask[J shr 1] and 7];
3575 PPalette32(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] :=
3576 Colors[Sel];
3577 end;
3578 Inc(K);
3579 AMask[J shr 1] := AMask[J shr 1] shr 3;
3580 end;
3581 end;
3582 end;
3583
3584 procedure GetBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
3585 Width, Height: LongInt);
3586 var
3587 X, Y, I: LongInt;
3588 Src: PColor32Rec;
3589 begin
3590 I := 0;
3591 // 4x4 pixel block is filled with information about every
3592 // pixel in the block: alpha, original color, 565 color
3593 for Y := 0 to 3 do
3594 for X := 0 to 3 do
3595 begin
3596 Src := @PPalette32(SrcBits)[(YPos shl 2 + Y) * Width + XPos shl 2 + X];
3597 Block[I].Color := ((Src.R shr 3) shl 11) or ((Src.G shr 2) shl 5) or
3598 (Src.B shr 3);
3599 Block[I].Alpha := Src.A;
3600 Block[I].Orig := Src^;
3601 Inc(I);
3602 end;
3603 end;
3604
3605 function ColorDistance(const C1, C2: TColor32Rec): LongInt;
3606 {$IFDEF USE_INLINE} inline;{$ENDIF}
3607 begin
3608 Result := (C1.R - C2.R) * (C1.R - C2.R) +
3609 (C1.G - C2.G) * (C1.G - C2.G) + (C1.B - C2.B) * (C1.B - C2.B);
3610 end;
3611
3612 procedure GetEndpoints(const Block: TPixelBlock; var Ep0, Ep1: Word);
3613 var
3614 I, J, Farthest, Dist: LongInt;
3615 Colors: array[0..15] of TColor32Rec;
3616 begin
3617 // we choose two colors from the pixel block which has the
3618 // largest distance between them
3619 for I := 0 to 15 do
3620 Colors[I] := Block[I].Orig;
3621 Farthest := -1;
3622 for I := 0 to 15 do
3623 for J := I + 1 to 15 do
3624 begin
3625 Dist := ColorDistance(Colors[I], Colors[J]);
3626 if Dist > Farthest then
3627 begin
3628 Farthest := Dist;
3629 Ep0 := Block[I].Color;
3630 Ep1 := Block[J].Color;
3631 end;
3632 end;
3633 end;
3634
3635 procedure GetAlphaEndpoints(const Block: TPixelBlock; var Min, Max: Byte);
3636 var
3637 I: LongInt;
3638 begin
3639 Min := 255;
3640 Max := 0;
3641 // we choose the lowest and the highest alpha values
3642 for I := 0 to 15 do
3643 begin
3644 if Block[I].Alpha < Min then
3645 Min := Block[I].Alpha;
3646 if Block[I].Alpha > Max then
3647 Max := Block[I].Alpha;
3648 end;
3649 end;
3650
3651 procedure FixEndpoints(var Ep0, Ep1: Word; HasAlpha: Boolean);
3652 var
3653 Temp: Word;
3654 begin
3655 // if dxt block has alpha information, Ep0 must be smaller
3656 // than Ep1, if the block has no alpha Ep1 must be smaller
3657 if HasAlpha then
3658 begin
3659 if Ep0 > Ep1 then
3660 begin
3661 Temp := Ep0;
3662 Ep0 := Ep1;
3663 Ep1 := Temp;
3664 end;
3665 end
3666 else
3667 if Ep0 < Ep1 then
3668 begin
3669 Temp := Ep0;
3670 Ep0 := Ep1;
3671 Ep1 := Temp;
3672 end;
3673 end;
3674
3675 function GetColorMask(Ep0, Ep1: Word; NumCols: LongInt;
3676 const Block: TPixelBlock): LongWord;
3677 var
3678 I, J, Closest, Dist: LongInt;
3679 Colors: array[0..3] of TColor32Rec;
3680 Mask: array[0..15] of Byte;
3681 begin
3682 FillChar(Mask, sizeof(Mask), 0);
3683 // we decode endpoint colors
3684 Colors[0] := DecodeCol(Ep0);
3685 Colors[1] := DecodeCol(Ep1);
3686 // and interpolate colors between (3 for DXT1 with alpha, 4 for the others)
3687 if NumCols = 3 then
3688 begin
3689 Colors[2].R := (Colors[0].R + Colors[1].R) shr 1;
3690 Colors[2].G := (Colors[0].G + Colors[1].G) shr 1;
3691 Colors[2].B := (Colors[0].B + Colors[1].B) shr 1;
3692 Colors[3].R := (Colors[0].R + Colors[1].R) shr 1;
3693 Colors[3].G := (Colors[0].G + Colors[1].G) shr 1;
3694 Colors[3].B := (Colors[0].B + Colors[1].B) shr 1;
3695 end
3696 else
3697 begin
3698 Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
3699 Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
3700 Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
3701 Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
3702 Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
3703 Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
3704 end;
3705
3706 for I := 0 to 15 do
3707 begin
3708 // this is only for DXT1 with alpha
3709 if (Block[I].Alpha < 128) and (NumCols = 3) then
3710 begin
3711 Mask[I] := 3;
3712 Continue;
3713 end;
3714 // for each of the 16 input pixels the nearest color in the
3715 // 4 dxt colors is found
3716 Closest := MaxInt;
3717 for J := 0 to NumCols - 1 do
3718 begin
3719 Dist := ColorDistance(Block[I].Orig, Colors[J]);
3720 if Dist < Closest then
3721 begin
3722 Closest := Dist;
3723 Mask[I] := J;
3724 end;
3725 end;
3726 end;
3727
3728 Result := 0;
3729 for I := 0 to 15 do
3730 Result := Result or (Mask[I] shl (I shl 1));
3731 end;
3732
3733 procedure GetAlphaMask(Ep0, Ep1: Byte; var Block: TPixelBlock; Mask: PByteArray);
3734 var
3735 Alphas: array[0..7] of Byte;
3736 M: array[0..15] of Byte;
3737 I, J, Closest, Dist: LongInt;
3738 begin
3739 FillChar(M, sizeof(M), 0);
3740 Alphas[0] := Ep0;
3741 Alphas[1] := Ep1;
3742 // interpolation between two given alpha endpoints
3743 // (I use 6 interpolated values mode)
3744 Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7;
3745 Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7;
3746 Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7;
3747 Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7;
3748 Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7;
3749 Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7;
3750
3751 // the closest interpolated values for each of the input alpha
3752 // is found
3753 for I := 0 to 15 do
3754 begin
3755 Closest := MaxInt;
3756 for J := 0 to 7 do
3757 begin
3758 Dist := Abs(Alphas[J] - Block[I].Alpha);
3759 if Dist < Closest then
3760 begin
3761 Closest := Dist;
3762 M[I] := J;
3763 end;
3764 end;
3765 end;
3766
3767 Mask[0] := M[0] or (M[1] shl 3) or ((M[2] and 3) shl 6);
3768 Mask[1] := ((M[2] and 4) shr 2) or (M[3] shl 1) or (M[4] shl 4) or
3769 ((M[5] and 1) shl 7);
3770 Mask[2] := ((M[5] and 6) shr 1) or (M[6] shl 2) or (M[7] shl 5);
3771 Mask[3] := M[8] or (M[9] shl 3) or ((M[10] and 3) shl 6);
3772 Mask[4] := ((M[10] and 4) shr 2) or (M[11] shl 1) or (M[12] shl 4) or
3773 ((M[13] and 1) shl 7);
3774 Mask[5] := ((M[13] and 6) shr 1) or (M[14] shl 2) or (M[15] shl 5);
3775 end;
3776
3777
3778 procedure EncodeDXT1(SrcBits: PByte; DestBits: PByte; Width, Height: LongInt);
3779 var
3780 X, Y, I: LongInt;
3781 HasAlpha: Boolean;
3782 Block: TDXTColorBlock;
3783 Pixels: TPixelBlock;
3784 begin
3785 for Y := 0 to Height div 4 - 1 do
3786 for X := 0 to Width div 4 - 1 do
3787 begin
3788 GetBlock(Pixels, SrcBits, X, Y, Width, Height);
3789 HasAlpha := False;
3790 for I := 0 to 15 do
3791 if Pixels[I].Alpha < 128 then
3792 begin
3793 HasAlpha := True;
3794 Break;
3795 end;
3796 GetEndpoints(Pixels, Block.Color0, Block.Color1);
3797 FixEndpoints(Block.Color0, Block.Color1, HasAlpha);
3798 if HasAlpha then
3799 Block.Mask := GetColorMask(Block.Color0, Block.Color1, 3, Pixels)
3800 else
3801 Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
3802 PDXTColorBlock(DestBits)^ := Block;
3803 Inc(DestBits, SizeOf(Block));
3804 end;
3805 end;
3806
3807 procedure EncodeDXT3(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt);
3808 var
3809 X, Y, I: LongInt;
3810 Block: TDXTColorBlock;
3811 AlphaBlock: TDXTAlphaBlockExp;
3812 Pixels: TPixelBlock;
3813 begin
3814 for Y := 0 to Height div 4 - 1 do
3815 for X := 0 to Width div 4 - 1 do
3816 begin
3817 GetBlock(Pixels, SrcBits, X, Y, Width, Height);
3818 for I := 0 to 7 do
3819 PByteArray(@AlphaBlock.Alphas)[I] :=
3820 (Pixels[I shl 1].Alpha shr 4) or ((Pixels[I shl 1 + 1].Alpha shr 4) shl 4);
3821 GetEndpoints(Pixels, Block.Color0, Block.Color1);
3822 FixEndpoints(Block.Color0, Block.Color1, False);
3823 Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
3824 PDXTAlphaBlockExp(DestBits)^ := AlphaBlock;
3825 Inc(DestBits, SizeOf(AlphaBlock));
3826 PDXTColorBlock(DestBits)^ := Block;
3827 Inc(DestBits, SizeOf(Block));
3828 end;
3829 end;
3830
3831 procedure EncodeDXT5(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt);
3832 var
3833 X, Y: LongInt;
3834 Block: TDXTColorBlock;
3835 AlphaBlock: TDXTAlphaBlockInt;
3836 Pixels: TPixelBlock;
3837 begin
3838 for Y := 0 to Height div 4 - 1 do
3839 for X := 0 to Width div 4 - 1 do
3840 begin
3841 GetBlock(Pixels, SrcBits, X, Y, Width, Height);
3842 GetEndpoints(Pixels, Block.Color0, Block.Color1);
3843 FixEndpoints(Block.Color0, Block.Color1, False);
3844 Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
3845 GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
3846 GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
3847 PByteArray(@AlphaBlock.Alphas[2]));
3848 PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
3849 Inc(DestBits, SizeOf(AlphaBlock));
3850 PDXTColorBlock(DestBits)^ := Block;
3851 Inc(DestBits, SizeOf(Block));
3852 end;
3853 end;
3854
3855 type
3856 TBTCBlock = packed record
3857 MLower, MUpper: Byte;
3858 BitField: Word;
3859 end;
3860 PBTCBlock = ^TBTCBlock;
3861
3862 procedure EncodeBTC(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
3863 var
3864 X, Y, I, J: Integer;
3865 Block: TBTCBlock;
3866 M, MLower, MUpper, K: Integer;
3867 Pixels: array[0..15] of Byte;
3868 begin
3869 for Y := 0 to Height div 4 - 1 do
3870 for X := 0 to Width div 4 - 1 do
3871 begin
3872 M := 0;
3873 MLower := 0;
3874 MUpper := 0;
3875 FillChar(Block, SizeOf(Block), 0);
3876 K := 0;
3877
3878 // Store 4x4 pixels and compute average, lower, and upper intensity levels
3879 for I := 0 to 3 do
3880 for J := 0 to 3 do
3881 begin
3882 Pixels[K] := PByteArray(SrcBits)[(Y shl 2 + I) * Width + X shl 2 + J];
3883 Inc(M, Pixels[K]);
3884 Inc(K);
3885 end;
3886
3887 M := M div 16;
3888 K := 0;
3889
3890 // Now compute upper and lower levels, number of upper pixels,
3891 // and update bit field (1 when pixel is above avg. level M)
3892 for I := 0 to 15 do
3893 begin
3894 if Pixels[I] > M then
3895 begin
3896 Inc(MUpper, Pixels[I]);
3897 Inc(K);
3898 Block.BitField := Block.BitField or (1 shl I);
3899 end
3900 else
3901 Inc(MLower, Pixels[I]);
3902 end;
3903
3904 // Scale levels and save them to block
3905 if K > 0 then
3906 Block.MUpper := ClampToByte(MUpper div K)
3907 else
3908 Block.MUpper := 0;
3909 Block.MLower := ClampToByte(MLower div (16 - K));
3910
3911 // Finally save block to dest data
3912 PBTCBlock(DestBits)^ := Block;
3913 Inc(DestBits, SizeOf(Block));
3914 end;
3915 end;
3916
3917 procedure GetOneChannelBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
3918 Width, Height, BytesPP, ChannelIdx: Integer);
3919 var
3920 X, Y, I: Integer;
3921 Src: PByte;
3922 begin
3923 I := 0;
3924 // 4x4 pixel block is filled with information about every pixel in the block,
3925 // but only one channel value is stored in Alpha field
3926 for Y := 0 to 3 do
3927 for X := 0 to 3 do
3928 begin
3929 Src := @PByteArray(SrcBits)[(YPos * 4 + Y) * Width * BytesPP +
3930 (XPos * 4 + X) * BytesPP + ChannelIdx];
3931 Block[I].Alpha := Src^;
3932 Inc(I);
3933 end;
3934 end;
3935
3936 procedure EncodeATI1N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
3937 var
3938 X, Y: Integer;
3939 AlphaBlock: TDXTAlphaBlockInt;
3940 Pixels: TPixelBlock;
3941 begin
3942 for Y := 0 to Height div 4 - 1 do
3943 for X := 0 to Width div 4 - 1 do
3944 begin
3945 // Encode one channel
3946 GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 1, 0);
3947 GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
3948 GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
3949 PByteArray(@AlphaBlock.Alphas[2]));
3950 PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
3951 Inc(DestBits, SizeOf(AlphaBlock));
3952 end;
3953 end;
3954
3955 procedure EncodeATI2N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
3956 var
3957 X, Y: Integer;
3958 AlphaBlock: TDXTAlphaBlockInt;
3959 Pixels: TPixelBlock;
3960 begin
3961 for Y := 0 to Height div 4 - 1 do
3962 for X := 0 to Width div 4 - 1 do
3963 begin
3964 // Encode Red/X channel
3965 GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelRed);
3966 GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
3967 GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
3968 PByteArray(@AlphaBlock.Alphas[2]));
3969 PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
3970 Inc(DestBits, SizeOf(AlphaBlock));
3971 // Encode Green/Y channel
3972 GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelGreen);
3973 GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
3974 GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
3975 PByteArray(@AlphaBlock.Alphas[2]));
3976 PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
3977 Inc(DestBits, SizeOf(AlphaBlock));
3978 end;
3979 end;
3980
3981 procedure EncodeBinary(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
3982 var
3983 Src: PByte absolute SrcBits;
3984 Bitmap: PByteArray absolute DestBits;
3985 X, Y, WidthBytes: Integer;
3986 PixelTresholded, Treshold: Byte;
3987 begin
3988 Treshold := ClampToByte(GetOption(ImagingBinaryTreshold));
3989 WidthBytes := (Width + 7) div 8;
3990
3991 for Y := 0 to Height - 1 do
3992 for X := 0 to Width - 1 do
3993 begin
3994 if Src^ > Treshold then
3995 PixelTresholded := 255
3996 else
3997 PixelTresholded := 0;
3998
3999 Bitmap[Y * WidthBytes + X div 8] := Bitmap[Y * WidthBytes + X div 8] or // OR current value of byte with following:
4000 (PixelTresholded and 1) // To make 1 from 255, 0 remains 0
4001 shl (7 - (X mod 8)); // Put current bit to proper place in byte
4002
4003 Inc(Src);
4004 end;
4005 end;
4006
4007 procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: Integer);
4008 var
4009 X, Y, I, J, K: Integer;
4010 Block: TBTCBlock;
4011 Dest: PByte;
4012 begin
4013 for Y := 0 to Height div 4 - 1 do
4014 for X := 0 to Width div 4 - 1 do
4015 begin
4016 Block := PBTCBlock(SrcBits)^;
4017 Inc(SrcBits, SizeOf(Block));
4018 K := 0;
4019
4020 // Just write MUpper when there is '1' in bit field and MLower
4021 // when there is '0'
4022 for I := 0 to 3 do
4023 for J := 0 to 3 do
4024 begin
4025 Dest := @PByteArray(DestBits)[(Y shl 2 + I) * Width + X shl 2 + J];
4026 if Block.BitField and (1 shl K) <> 0 then
4027 Dest^ := Block.MUpper
4028 else
4029 Dest^ := Block.MLower;
4030 Inc(K);
4031 end;
4032 end;
4033 end;
4034
4035 procedure DecodeATI1N(SrcBits, DestBits: PByte; Width, Height: Integer);
4036 var
4037 X, Y, I, J: Integer;
4038 AlphaBlock: TDXTAlphaBlockInt;
4039 AMask: array[0..1] of LongWord;
4040 begin
4041 for Y := 0 to Height div 4 - 1 do
4042 for X := 0 to Width div 4 - 1 do
4043 begin
4044 AlphaBlock := PDXTAlphaBlockInt(SrcBits)^;
4045 Inc(SrcBits, SizeOf(AlphaBlock));
4046 // 6 bit alpha mask is copied into two long words for
4047 // easier usage
4048 AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF;
4049 AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF;
4050 // alpha interpolation between two endpoint alphas
4051 GetInterpolatedAlphas(AlphaBlock);
4052
4053 // we distribute the dxt block alphas
4054 // across the 4x4 block of the destination image
4055 for J := 0 to 3 do
4056 for I := 0 to 3 do
4057 begin
4058 PByteArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] :=
4059 AlphaBlock.Alphas[AMask[J shr 1] and 7];
4060 AMask[J shr 1] := AMask[J shr 1] shr 3;
4061 end;
4062 end;
4063 end;
4064
4065 procedure DecodeATI2N(SrcBits, DestBits: PByte; Width, Height: Integer);
4066 var
4067 X, Y, I, J: Integer;
4068 Color: TColor32Rec;
4069 AlphaBlock1, AlphaBlock2: TDXTAlphaBlockInt;
4070 AMask1: array[0..1] of LongWord;
4071 AMask2: array[0..1] of LongWord;
4072 begin
4073 for Y := 0 to Height div 4 - 1 do
4074 for X := 0 to Width div 4 - 1 do
4075 begin
4076 // Read the first alpha block and get masks
4077 AlphaBlock1 := PDXTAlphaBlockInt(SrcBits)^;
4078 Inc(SrcBits, SizeOf(AlphaBlock1));
4079 AMask1[0] := PLongWord(@AlphaBlock1.Alphas[2])^ and $00FFFFFF;
4080 AMask1[1] := PLongWord(@AlphaBlock1.Alphas[5])^ and $00FFFFFF;
4081 // Read the secind alpha block and get masks
4082 AlphaBlock2 := PDXTAlphaBlockInt(SrcBits)^;
4083 Inc(SrcBits, SizeOf(AlphaBlock2));
4084 AMask2[0] := PLongWord(@AlphaBlock2.Alphas[2])^ and $00FFFFFF;
4085 AMask2[1] := PLongWord(@AlphaBlock2.Alphas[5])^ and $00FFFFFF;
4086 // alpha interpolation between two endpoint alphas
4087 GetInterpolatedAlphas(AlphaBlock1);
4088 GetInterpolatedAlphas(AlphaBlock2);
4089
4090 Color.A := $FF;
4091 Color.B := 0;
4092
4093 // Distribute alpha block values across 4x4 pixel block,
4094 // first alpha block represents Red channel, second is Green.
4095 for J := 0 to 3 do
4096 for I := 0 to 3 do
4097 begin
4098 Color.R := AlphaBlock1.Alphas[AMask1[J shr 1] and 7];
4099 Color.G := AlphaBlock2.Alphas[AMask2[J shr 1] and 7];
4100 PColor32RecArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := Color;
4101 AMask1[J shr 1] := AMask1[J shr 1] shr 3;
4102 AMask2[J shr 1] := AMask2[J shr 1] shr 3;
4103 end;
4104 end;
4105 end;
4106
4107 procedure DecodeBinary(SrcBits, DestBits: PByte; Width, Height: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
4108 begin
4109 Convert1To8(SrcBits, DestBits, Width, Height, (Width + 7) div 8, True);
4110 end;
4111
4112 procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer;
4113 SpecialFormat: TImageFormat);
4114 begin
4115 case SpecialFormat of
4116 ifDXT1: DecodeDXT1(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
4117 ifDXT3: DecodeDXT3(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
4118 ifDXT5: DecodeDXT5(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
4119 ifBTC: DecodeBTC (SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
4120 ifATI1N: DecodeATI1N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
4121 ifATI2N: DecodeATI2N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
4122 ifBinary: DecodeBinary(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
4123 end;
4124 end;
4125
4126 procedure UnSpecialToSpecial(SrcBits: Pointer; const DestImage: TImageData;
4127 SpecialFormat: TImageFormat);
4128 begin
4129 case SpecialFormat of
4130 ifDXT1: EncodeDXT1(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
4131 ifDXT3: EncodeDXT3(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
4132 ifDXT5: EncodeDXT5(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
4133 ifBTC: EncodeBTC (SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
4134 ifATI1N: EncodeATI1N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
4135 ifATI2N: EncodeATI2N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
4136 ifBinary: EncodeBinary(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
4137 end;
4138 end;
4139
4140 procedure ConvertSpecial(var Image: TImageData;
4141 SrcInfo, DstInfo: PImageFormatInfo);
4142 var
4143 WorkImage: TImageData;
4144
4145 procedure CheckSize(var Img: TImageData; Info: PImageFormatInfo);
4146 var
4147 Width, Height: Integer;
4148 begin
4149 Width := Img.Width;
4150 Height := Img.Height;
4151 DstInfo.CheckDimensions(Info.Format, Width, Height);
4152 ResizeImage(Img, Width, Height, rfNearest);
4153 end;
4154
4155 begin
4156 if SrcInfo.IsSpecial and DstInfo.IsSpecial then
4157 begin
4158 // Convert source to nearest 'normal' format
4159 InitImage(WorkImage);
4160 NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
4161 SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
4162 FreeImage(Image);
4163 // Make sure output of SpecialToUnSpecial is the same as input of
4164 // UnSpecialToSpecial
4165 if SrcInfo.SpecialNearestFormat <> DstInfo.SpecialNearestFormat then
4166 ConvertImage(WorkImage, DstInfo.SpecialNearestFormat);
4167 // Convert work image to dest special format
4168 CheckSize(WorkImage, DstInfo);
4169 NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image);
4170 UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format);
4171 FreeImage(WorkImage);
4172 end
4173 else if SrcInfo.IsSpecial and not DstInfo.IsSpecial then
4174 begin
4175 // Convert source to nearest 'normal' format
4176 InitImage(WorkImage);
4177 NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
4178 SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
4179 FreeImage(Image);
4180 // Now convert to dest format
4181 ConvertImage(WorkImage, DstInfo.Format);
4182 Image := WorkImage;
4183 end
4184 else if not SrcInfo.IsSpecial and DstInfo.IsSpecial then
4185 begin
4186 // Convert source to nearest format
4187 WorkImage := Image;
4188 ConvertImage(WorkImage, DstInfo.SpecialNearestFormat);
4189 // Now convert from nearest to dest
4190 CheckSize(WorkImage, DstInfo);
4191 InitImage(Image);
4192 NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image);
4193 UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format);
4194 FreeImage(WorkImage);
4195 end;
4196 end;
4197
4198 function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
4199 begin
4200 if FInfos[Format] <> nil then
4201 Result := Width * Height * FInfos[Format].BytesPerPixel
4202 else
4203 Result := 0;
4204 end;
4205
4206 procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt);
4207 begin
4208 end;
4209
4210 function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
4211 begin
4212 // DXT can be used only for images with dimensions that are
4213 // multiples of four
4214 CheckDXTDimensions(Format, Width, Height);
4215 Result := Width * Height;
4216 if Format in [ifDXT1, ifATI1N] then
4217 Result := Result div 2;
4218 end;
4219
4220 procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt);
4221 begin
4222 // DXT image dimensions must be multiples of four
4223 Width := (Width + 3) and not 3; // div 4 * 4;
4224 Height := (Height + 3) and not 3; // div 4 * 4;
4225 end;
4226
4227 function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
4228 begin
4229 // BTC can be used only for images with dimensions that are
4230 // multiples of four
4231 CheckDXTDimensions(Format, Width, Height);
4232 Result := Width * Height div 4; // 2bits/pixel
4233 end;
4234
4235 function GetBCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
4236 begin
4237 Result := 0;
4238 raise ENotImplemented.Create();
4239 end;
4240
4241 procedure CheckBCDimensions(Format: TImageFormat; var Width, Height: LongInt);
4242 begin
4243 raise ENotImplemented.Create();
4244 end;
4245
4246 function GetBinaryPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
4247 begin
4248 // Binary images are aligned on BYTE boundary
4249 Result := ((Width + 7) div 8) * Height; // 1bit/pixel
4250 end;
4251
4252 { Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }
4253
4254 function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
4255 begin
4256 Result.Color := PLongWord(Bits)^;
4257 end;
4258
4259 procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
4260 begin
4261 PLongWord(Bits)^ := Color.Color;
4262 end;
4263
4264 function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
4265 begin
4266 Result.A := PColor32Rec(Bits).A * OneDiv8Bit;
4267 Result.R := PColor32Rec(Bits).R * OneDiv8Bit;
4268 Result.G := PColor32Rec(Bits).G * OneDiv8Bit;
4269 Result.B := PColor32Rec(Bits).B * OneDiv8Bit;
4270 end;
4271
4272 procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
4273 begin
4274 PColor32Rec(Bits).A := ClampToByte(Round(Color.A * 255.0));
4275 PColor32Rec(Bits).R := ClampToByte(Round(Color.R * 255.0));
4276 PColor32Rec(Bits).G := ClampToByte(Round(Color.G * 255.0));
4277 PColor32Rec(Bits).B := ClampToByte(Round(Color.B * 255.0));
4278 end;
4279
4280 function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
4281 begin
4282 Result.A := 0;
4283 Result.R := 0;
4284 Result.G := 0;
4285 Result.B := 0;
4286 case Info.Format of
4287 ifR8G8B8, ifX8R8G8B8:
4288 begin
4289 Result.A := $FF;
4290 PColor24Rec(@Result)^ := PColor24Rec(Bits)^;
4291 end;
4292 ifGray8, ifA8Gray8:
4293 begin
4294 if Info.HasAlphaChannel then
4295 Result.A := PWordRec(Bits).High
4296 else
4297 Result.A := $FF;
4298 Result.R := PWordRec(Bits).Low;
4299 Result.G := PWordRec(Bits).Low;
4300 Result.B := PWordRec(Bits).Low;
4301 end;
4302 end;
4303 end;
4304
4305 procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
4306 begin
4307 case Info.Format of
4308 ifR8G8B8, ifX8R8G8B8:
4309 begin
4310 PColor24Rec(Bits)^ := PColor24Rec(@Color)^;
4311 end;
4312 ifGray8, ifA8Gray8:
4313 begin
4314 if Info.HasAlphaChannel then
4315 PWordRec(Bits).High := Color.A;
4316 PWordRec(Bits).Low := Round(GrayConv.R * Color.R + GrayConv.G * Color.G +
4317 GrayConv.B * Color.B);
4318 end;
4319 end;
4320 end;
4321
4322 function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
4323 begin
4324 Result.A := 0;
4325 Result.R := 0;
4326 Result.G := 0;
4327 Result.B := 0;
4328 case Info.Format of
4329 ifR8G8B8, ifX8R8G8B8:
4330 begin
4331 Result.A := 1.0;
4332 Result.R := PColor24Rec(Bits).R * OneDiv8Bit;
4333 Result.G := PColor24Rec(Bits).G * OneDiv8Bit;
4334 Result.B := PColor24Rec(Bits).B * OneDiv8Bit;
4335 end;
4336 ifGray8, ifA8Gray8:
4337 begin
4338 if Info.HasAlphaChannel then
4339 Result.A := PWordRec(Bits).High * OneDiv8Bit
4340 else
4341 Result.A := 1.0;
4342 Result.R := PWordRec(Bits).Low * OneDiv8Bit;
4343 Result.G := PWordRec(Bits).Low * OneDiv8Bit;
4344 Result.B := PWordRec(Bits).Low * OneDiv8Bit;
4345 end;
4346 end;
4347 end;
4348
4349 procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
4350 begin
4351 case Info.Format of
4352 ifR8G8B8, ifX8R8G8B8:
4353 begin
4354 PColor24Rec(Bits).R := ClampToByte(Round(Color.R * 255.0));
4355 PColor24Rec(Bits).G := ClampToByte(Round(Color.G * 255.0));
4356 PColor24Rec(Bits).B := ClampToByte(Round(Color.B * 255.0));
4357 end;
4358 ifGray8, ifA8Gray8:
4359 begin
4360 if Info.HasAlphaChannel then
4361 PWordRec(Bits).High := ClampToByte(Round(Color.A * 255.0));
4362 PWordRec(Bits).Low := ClampToByte(Round((GrayConv.R * Color.R + GrayConv.G * Color.G +
4363 GrayConv.B * Color.B) * 255.0));
4364 end;
4365 end;
4366 end;
4367
4368 function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
4369 begin
4370 case Info.Format of
4371 ifA32R32G32B32F, ifA32B32G32R32F:
4372 begin
4373 Result := PColorFPRec(Bits)^;
4374 end;
4375 ifR32G32B32F, ifB32G32R32F:
4376 begin
4377 Result.A := 1.0;
4378 Result.Color96Rec := PColor96FPRec(Bits)^;
4379 end;
4380 ifR32F:
4381 begin
4382 Result.A := 1.0;
4383 Result.R := PSingle(Bits)^;
4384 Result.G := 0.0;
4385 Result.B := 0.0;
4386 end;
4387 end;
4388 if Info.IsRBSwapped then
4389 SwapValues(Result.R, Result.B);
4390 end;
4391
4392 procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
4393 begin
4394 case Info.Format of
4395 ifA32R32G32B32F, ifA32B32G32R32F:
4396 begin
4397 PColorFPRec(Bits)^ := Color;
4398 end;
4399 ifR32G32B32F, ifB32G32R32F:
4400 begin
4401 PColor96FPRec(Bits)^ := Color.Color96Rec;
4402 end;
4403 ifR32F:
4404 begin
4405 PSingle(Bits)^ := Color.R;
4406 end;
4407 end;
4408 if Info.IsRBSwapped then
4409 SwapValues(PColor96FPRec(Bits).R, PColor96FPRec(Bits).B);
4410 end;
4411
4412 initialization
4413 // Initialize default sampling filter function pointers and radii
4414 SamplingFilterFunctions[sfNearest] := FilterNearest;
4415 SamplingFilterFunctions[sfLinear] := FilterLinear;
4416 SamplingFilterFunctions[sfCosine] := FilterCosine;
4417 SamplingFilterFunctions[sfHermite] := FilterHermite;
4418 SamplingFilterFunctions[sfQuadratic] := FilterQuadratic;
4419 SamplingFilterFunctions[sfGaussian] := FilterGaussian;
4420 SamplingFilterFunctions[sfSpline] := FilterSpline;
4421 SamplingFilterFunctions[sfLanczos] := FilterLanczos;
4422 SamplingFilterFunctions[sfMitchell] := FilterMitchell;
4423 SamplingFilterFunctions[sfCatmullRom] := FilterCatmullRom;
4424 SamplingFilterRadii[sfNearest] := 1.0;
4425 SamplingFilterRadii[sfLinear] := 1.0;
4426 SamplingFilterRadii[sfCosine] := 1.0;
4427 SamplingFilterRadii[sfHermite] := 1.0;
4428 SamplingFilterRadii[sfQuadratic] := 1.5;
4429 SamplingFilterRadii[sfGaussian] := 1.25;
4430 SamplingFilterRadii[sfSpline] := 2.0;
4431 SamplingFilterRadii[sfLanczos] := 3.0;
4432 SamplingFilterRadii[sfMitchell] := 2.0;
4433 SamplingFilterRadii[sfCatmullRom] := 2.0;
4434
4435 {
4436 File Notes:
4437
4438 -- TODOS ----------------------------------------------------
4439 - nothing now
4440
4441 -- 0.77 Changes/Bug Fixes -------------------------------------
4442 - NOT YET: Added support for Passtrough image data formats.
4443 - Added ConvertToPixel32 helper function.
4444
4445 -- 0.26.5 Changes/Bug Fixes -----------------------------------
4446 - Removed optimized codepatch for few data formats from StretchResample
4447 function. It was quite buggy and not so much faster anyway.
4448 - Added PaletteHasAlpha function.
4449 - Added support functions for ifBinary data format.
4450 - Added optional pixel scaling to Convert1To8, Convert2To8,
4451 abd Convert4To8 functions.
4452
4453 -- 0.26.3 Changes/Bug Fixes -----------------------------------
4454 - Filtered resampling ~10% faster now.
4455 - Fixed DXT3 alpha encoding.
4456 - ifIndex8 format now has HasAlphaChannel=True.
4457
4458 -- 0.25.0 Changes/Bug Fixes -----------------------------------
4459 - Made some resampling stuff public so that it can be used in canvas class.
4460 - Added some color constructors.
4461 - Added VisualizePalette helper function.
4462 - Fixed ConvertSpecial, not very readable before and error when
4463 converting special->special.
4464
4465 -- 0.24.3 Changes/Bug Fixes -----------------------------------
4466 - Some refactorings a changes to DXT based formats.
4467 - Added ifATI1N and ifATI2N image data formats support structures and functions.
4468
4469 -- 0.23 Changes/Bug Fixes -----------------------------------
4470 - Added ifBTC image format support structures and functions.
4471
4472 -- 0.21 Changes/Bug Fixes -----------------------------------
4473 - FillMipMapLevel now works well with indexed and special formats too.
4474 - Moved Convert1To8 and Convert4To8 functions from ImagingBitmaps here
4475 and created new Convert2To8 function. They are now used by more than one
4476 file format loader.
4477
4478 -- 0.19 Changes/Bug Fixes -----------------------------------
4479 - StretchResample now uses pixel get/set functions stored in
4480 TImageFormatInfo so it is much faster for formats that override
4481 them with optimized ones
4482 - added pixel set/get functions optimized for various image formats
4483 (to be stored in TImageFormatInfo)
4484 - bug in ConvertSpecial caused problems when converting DXTC images
4485 to bitmaps in ImagingCoponents
4486 - bug in StretchRect caused that it didn't work with ifR32F and
4487 ifR16F formats
4488 - removed leftover code in FillMipMapLevel which disabled
4489 filtered resizing of images witch ChannelSize <> 8bits
4490 - added half float converting functions and support for half based
4491 image formats where needed
4492 - added TranslatePixel and IsImageFormatValid functions
4493 - fixed possible range overflows when converting from FP to integer images
4494 - added pixel set/get functions: GetPixel32Generic, GetPixelFPGeneric,
4495 SetPixel32Generic, SetPixelFPGeneric
4496 - fixed occasional range overflows in StretchResample
4497
4498 -- 0.17 Changes/Bug Fixes -----------------------------------
4499 - added StretchNearest, StretchResample and some sampling functions
4500 - added ChannelCount values to TImageFormatInfo constants
4501 - added resolution validity check to GetDXTPixelsSize
4502
4503 -- 0.15 Changes/Bug Fixes -----------------------------------
4504 - added RBSwapFormat values to some TImageFromatInfo definitions
4505 - fixed bug in ConvertSpecial (causing DXT images to convert only to 32bit)
4506 - added CopyPixel, ComparePixels helper functions
4507
4508 -- 0.13 Changes/Bug Fixes -----------------------------------
4509 - replaced pixel format conversions for colors not to be
4510 darkened when converting from low bit counts
4511 - ReduceColorsMedianCut was updated to support creating one
4512 optimal palette for more images and it is somewhat faster
4513 now too
4514 - there was ugly bug in DXTC dimensions checking
4515 }
4516
4517 end.
[MIRROR] a port of Doom 2D Forever to FPC/SDL
[15/08/2024 14:52:34]
DEADSOFTWARE 2012-2024