2 $Id: Imaging.pas 173 2009-09-04 17:05:52Z galfar $
3 Vampyre Imaging Library
5 http://imaginglib.sourceforge.net
7 The contents of this file are used with permission, subject to the Mozilla
8 Public License Version 1.1 (the "License"); you may not use this file except
9 in compliance with the License. You may obtain a copy of the License at
10 http://www.mozilla.org/MPL/MPL-1.1.html
12 Software distributed under the License is distributed on an "AS IS" basis,
13 WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
14 the specific language governing rights and limitations under the License.
16 Alternatively, the contents of this file may be used under the terms of the
17 GNU Lesser General Public License (the "LGPL License"), in which case the
18 provisions of the LGPL License are applicable instead of those above.
19 If you wish to allow use of your version of this file only under the terms
20 of the LGPL License and not to allow others to use your version of this file
21 under the MPL, indicate your decision by deleting the provisions above and
22 replace them with the notice and other provisions required by the LGPL
23 License. If you do not delete the provisions above, a recipient may use
24 your version of this file under either the MPL or the LGPL License.
26 For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
29 { This unit is heart of Imaging library. It contains basic functions for
30 manipulating image data as well as various image file format support.}
33 {$I ImagingOptions.inc}
38 ImagingTypes
, SysUtils
, Classes
;
41 { Default Imaging excepton class.}
42 EImagingError
= class(Exception
);
44 { Dynamic array of TImageData records.}
45 TDynImageDataArray
= array of TImageData
;
48 { ------------------------------------------------------------------------
49 Low Level Interface Functions
50 ------------------------------------------------------------------------}
54 { Initializes image (all is set to zeroes). Call this for each image
55 before using it (before calling every other function) to be sure there
56 are no random-filled bytes (which would cause errors later).}
57 procedure InitImage(var Image
: TImageData
);
58 { Creates empty image of given dimensions and format. Image is filled with
59 transparent black color (A=0, R=0, G=0, B=0).}
60 function NewImage(Width
, Height
: LongInt; Format
: TImageFormat
;
61 var Image
: TImageData
): Boolean;
62 { Returns True if given TImageData record is valid.}
63 function TestImage(const Image
: TImageData
): Boolean;
64 { Frees given image data. Ater this call image is in the same state
65 as after calling InitImage. If image is not valid (dost not pass TestImage
66 test) it is only zeroed by calling InitImage.}
67 procedure FreeImage(var Image
: TImageData
);
68 { Call FreeImage() on all images in given dynamic array and sets its
70 procedure FreeImagesInArray(var Images
: TDynImageDataArray
);
71 { Returns True if all TImageData records in given array are valid. Returns False
72 if at least one is invalid or if array is empty.}
73 function TestImagesInArray(const Images
: TDynImageDataArray
): Boolean;
74 { Checks given file for every supported image file format and if
75 the file is in one of them returns its string identifier
76 (which can be used in LoadFromStream/LoadFromMem type functions).
77 If file is not in any of the supported formats empty string is returned.}
78 function DetermineFileFormat(const FileName
: string): string;
79 { Checks given stream for every supported image file format and if
80 the stream is in one of them returns its string identifier
81 (which can be used in LoadFromStream/LoadFromMem type functions).
82 If stream is not in any of the supported formats empty string is returned.}
83 function DetermineStreamFormat(Stream
: TStream
): string;
84 { Checks given memory for every supported image file format and if
85 the memory is in one of them returns its string identifier
86 (which can be used in LoadFromStream/LoadFromMem type functions).
87 If memory is not in any of the supported formats empty string is returned.}
88 function DetermineMemoryFormat(Data
: Pointer; Size
: LongInt): string;
89 { Checks that an apropriate file format is supported purely from inspecting
90 the given file name's extension (not contents of the file itself).
91 The file need not exist.}
92 function IsFileFormatSupported(const FileName
: string): Boolean;
93 { Enumerates all registered image file formats. Descriptive name,
94 default extension, masks (like '*.jpg,*.jfif') and some capabilities
95 of each format are returned. To enumerate all formats start with Index at 0 and
96 call EnumFileFormats with given Index in loop until it returns False (Index is
97 automatically increased by 1 in function's body on successful call).}
98 function EnumFileFormats(var Index
: LongInt; var Name
, DefaultExt
, Masks
: string;
99 var CanSaveImages
, IsMultiImageFormat
: Boolean): Boolean;
101 { Loading Functions }
103 { Loads single image from given file.}
104 function LoadImageFromFile(const FileName
: string; var Image
: TImageData
): Boolean;
105 { Loads single image from given stream. If function fails stream position
107 function LoadImageFromStream(Stream
: TStream
; var Image
: TImageData
): Boolean;
108 { Loads single image from given memory location.}
109 function LoadImageFromMemory(Data
: Pointer; Size
: LongInt; var Image
: TImageData
): Boolean;
110 { Loads multiple images from given file.}
111 function LoadMultiImageFromFile(const FileName
: string;
112 var Images
: TDynImageDataArray
): Boolean;
113 { Loads multiple images from given stream. If function fails stream position
115 function LoadMultiImageFromStream(Stream
: TStream
;
116 var Images
: TDynImageDataArray
): Boolean;
117 { Loads multiple images from given memory location.}
118 function LoadMultiImageFromMemory(Data
: Pointer; Size
: LongInt;
119 var Images
: TDynImageDataArray
): Boolean;
123 { Saves single image to given file.}
124 function SaveImageToFile(const FileName
: string; const Image
: TImageData
): Boolean;
125 { Saves single image to given stream. If function fails stream position
126 is not changed. Ext identifies desired image file format (jpg, png, dds, ...).}
127 function SaveImageToStream(const Ext
: string; Stream
: TStream
;
128 const Image
: TImageData
): Boolean;
129 { Saves single image to given memory location. Memory must be allocated and its
130 size is passed in Size parameter in which number of written bytes is returned.
131 Ext identifies desired image file format (jpg, png, dds, ...).}
132 function SaveImageToMemory(const Ext
: string; Data
: Pointer; var Size
: LongInt;
133 const Image
: TImageData
): Boolean;
134 { Saves multiple images to given file. If format supports
135 only single level images and there are multiple images to be saved,
136 they are saved as sequence of files img000.jpg, img001.jpg ....).}
137 function SaveMultiImageToFile(const FileName
: string;
138 const Images
: TDynImageDataArray
): Boolean;
139 { Saves multiple images to given stream. If format supports
140 only single level images and there are multiple images to be saved,
141 they are saved one after another to the stream. If function fails stream
142 position is not changed. Ext identifies desired image file format (jpg, png, dds, ...).}
143 function SaveMultiImageToStream(const Ext
: string; Stream
: TStream
;
144 const Images
: TDynImageDataArray
): Boolean;
145 { Saves multiple images to given memory location. If format supports
146 only single level images and there are multiple images to be saved,
147 they are saved one after another to the memory. Memory must be allocated and
148 its size is passed in Size parameter in which number of written bytes is returned.
149 Ext identifies desired image file format (jpg, png, dds, ...).}
150 function SaveMultiImageToMemory(const Ext
: string; Data
: Pointer;
151 var Size
: LongInt; const Images
: TDynImageDataArray
): Boolean;
153 { Manipulation Functions }
155 { Creates identical copy of image data. Clone should be initialized
156 by InitImage or it should be vaild image which will be freed by CloneImage.}
157 function CloneImage(const Image
: TImageData
; var Clone
: TImageData
): Boolean;
158 { Converts image to the given format.}
159 function ConvertImage(var Image
: TImageData
; DestFormat
: TImageFormat
): Boolean;
160 { Flips given image. Reverses the image along its horizontal axis \97 the top
161 becomes the bottom and vice versa.}
162 function FlipImage(var Image
: TImageData
): Boolean;
163 { Mirrors given image. Reverses the image along its vertical axis \97 the left
164 side becomes the right and vice versa.}
165 function MirrorImage(var Image
: TImageData
): Boolean;
166 { Resizes given image to new dimensions. Nearest, bilinear, or bicubic filtering
167 can be used. Input Image must already be created - use NewImage to create new images.}
168 function ResizeImage(var Image
: TImageData
; NewWidth
, NewHeight
: LongInt;
169 Filter
: TResizeFilter
): Boolean;
170 { Swaps SrcChannel and DstChannel color or alpha channels of image.
171 Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
173 function SwapChannels(var Image
: TImageData
; SrcChannel
, DstChannel
: LongInt): Boolean;
174 { Reduces the number of colors of the Image. Currently MaxColors must be in
175 range <2, 4096>. Color reduction works also for alpha channel. Note that for
176 large images and big number of colors it can be very slow.
177 Output format of the image is the same as input format.}
178 function ReduceColors(var Image
: TImageData
; MaxColors
: LongInt): Boolean;
179 { Generates mipmaps for image. Levels is the number of desired mipmaps levels
180 with zero (or some invalid number) meaning all possible levels.}
181 function GenerateMipMaps(const Image
: TImageData
; Levels
: LongInt;
182 var MipMaps
: TDynImageDataArray
): Boolean;
183 { Maps image to existing palette producing image in ifIndex8 format.
184 Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes.
185 As resulting image is in 8bit indexed format Entries must be lower or
187 function MapImageToPalette(var Image
: TImageData
; Pal
: PPalette32
;
188 Entries
: LongInt): Boolean;
189 { Splits image into XChunks x YChunks subimages. Default size of each chunk is
190 ChunkWidth x ChunkHeight. If PreserveSize si True chunks at the edges of
191 the image are also ChunkWidth x ChunkHeight sized and empty space is filled
192 with Fill pixels. After calling this function XChunks contains number of
193 chunks along x axis and YChunks along y axis. To access chunk [X, Y] use this
194 index: Chunks[Y * XChunks + X].}
195 function SplitImage(var Image
: TImageData
; var Chunks
: TDynImageDataArray
;
196 ChunkWidth
, ChunkHeight
: LongInt; var XChunks
, YChunks
: LongInt;
197 PreserveSize
: Boolean; Fill
: Pointer): Boolean;
198 { Creates palette with MaxColors based on the colors of images in Images array.
199 Use it when you want to convert several images to indexed format using
200 single palette for all of them. If ConvertImages is True images in array
201 are converted to indexed format using resulting palette. if it is False
202 images are left intact and only resulting palatte is returned in Pal.
203 Pal must be allocated to have at least MaxColors entries.}
204 function MakePaletteForImages(var Images
: TDynImageDataArray
; Pal
: PPalette32
;
205 MaxColors
: LongInt; ConvertImages
: Boolean): Boolean;
206 { Rotates image by Angle degrees counterclockwise. All angles are allowed.}
207 function RotateImage(var Image
: TImageData
; Angle
: Single): Boolean;
209 { Drawing/Pixel functions }
211 { Copies rectangular part of SrcImage to DstImage. No blending is performed -
212 alpha is simply copied to destination image. Operates also with
213 negative X and Y coordinates.
214 Note that copying is fastest for images in the same data format
215 (and slowest for images in special formats).}
216 function CopyRect(const SrcImage
: TImageData
; SrcX
, SrcY
, Width
, Height
: LongInt;
217 var DstImage
: TImageData
; DstX
, DstY
: LongInt): Boolean;
218 { Fills given rectangle of image with given pixel fill data. Fill should point
219 to the pixel in the same format as the given image is in.}
220 function FillRect(var Image
: TImageData
; X
, Y
, Width
, Height
: LongInt; FillColor
: Pointer): Boolean;
221 { Replaces pixels with OldPixel in the given rectangle by NewPixel.
222 OldPixel and NewPixel should point to the pixels in the same format
223 as the given image is in.}
224 function ReplaceColor(var Image
: TImageData
; X
, Y
, Width
, Height
: LongInt;
225 OldColor
, NewColor
: Pointer): Boolean;
226 { Stretches the contents of the source rectangle to the destination rectangle
227 with optional resampling. No blending is performed - alpha is
228 simply copied/resampled to destination image. Note that stretching is
229 fastest for images in the same data format (and slowest for
230 images in special formats).}
231 function StretchRect(const SrcImage
: TImageData
; SrcX
, SrcY
, SrcWidth
,
232 SrcHeight
: LongInt; var DstImage
: TImageData
; DstX
, DstY
, DstWidth
,
233 DstHeight
: LongInt; Filter
: TResizeFilter
): Boolean;
234 { Copies pixel of Image at [X, Y] to memory pointed at by Pixel. Doesn't
235 work with special formats.}
236 procedure GetPixelDirect(const Image
: TImageData
; X
, Y
: LongInt; Pixel
: Pointer);
237 { Copies pixel from memory pointed at by Pixel to Image at position [X, Y].
238 Doesn't work with special formats.}
239 procedure SetPixelDirect(const Image
: TImageData
; X
, Y
: LongInt; Pixel
: Pointer);
240 { Function for getting pixel colors. Native pixel is read from Image and
241 then translated to 32 bit ARGB. Works for all image formats (except special)
242 so it is not very fast.}
243 function GetPixel32(const Image
: TImageData
; X
, Y
: LongInt): TColor32Rec
;
244 { Procedure for setting pixel colors. Input 32 bit ARGB color is translated to
245 native format and then written to Image. Works for all image formats (except special)
246 so it is not very fast.}
247 procedure SetPixel32(const Image
: TImageData
; X
, Y
: LongInt; const Color
: TColor32Rec
);
248 { Function for getting pixel colors. Native pixel is read from Image and
249 then translated to FP ARGB. Works for all image formats (except special)
250 so it is not very fast.}
251 function GetPixelFP(const Image
: TImageData
; X
, Y
: LongInt): TColorFPRec
;
252 { Procedure for setting pixel colors. Input FP ARGB color is translated to
253 native format and then written to Image. Works for all image formats (except special)
254 so it is not very fast.}
255 procedure SetPixelFP(const Image
: TImageData
; X
, Y
: LongInt; const Color
: TColorFPRec
);
257 { Palette Functions }
259 { Allocates new palette with Entries ARGB color entries.}
260 procedure NewPalette(Entries
: LongInt; var Pal
: PPalette32
);
261 { Frees given palette.}
262 procedure FreePalette(var Pal
: PPalette32
);
263 { Copies Count palette entries from SrcPal starting at index SrcIdx to
264 DstPal at index DstPal.}
265 procedure CopyPalette(SrcPal
, DstPal
: PPalette32
; SrcIdx
, DstIdx
, Count
: LongInt);
266 { Returns index of color in palette or index of nearest color if exact match
267 is not found. Pal must have at least Entries color entries.}
268 function FindColor(Pal
: PPalette32
; Entries
: LongInt; Color
: TColor32
): LongInt;
269 { Creates grayscale palette where each color channel has the same value.
270 Pal must have at least Entries color entries.}
271 procedure FillGrayscalePalette(Pal
: PPalette32
; Entries
: LongInt);
272 { Creates palette with given bitcount for each channel.
273 2^(RBits + GBits + BBits) should be equl to Entries. Examples:
274 (3, 3, 2) will create palette with all possible colors of R3G3B2 format
275 and (8, 0, 0) will create palette with 256 shades of red.
276 Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes.}
277 procedure FillCustomPalette(Pal
: PPalette32
; Entries
: LongInt; RBits
, GBits
,
278 BBits
: Byte; Alpha
: Byte = $FF);
279 { Swaps SrcChannel and DstChannel color or alpha channels of palette.
280 Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
281 identify channels. Pal must be allocated to at least
282 Entries * SizeOf(TColor32Rec) bytes.}
283 procedure SwapChannelsOfPalette(Pal
: PPalette32
; Entries
, SrcChannel
,
284 DstChannel
: LongInt);
286 { Options Functions }
288 { Sets value of integer option specified by OptionId parameter.
289 Option Ids are constans starting ImagingXXX.}
290 function SetOption(OptionId
, Value
: LongInt): Boolean;
291 { Returns value of integer option specified by OptionId parameter. If OptionId is
292 invalid, InvalidOption is returned. Option Ids are constans
293 starting ImagingXXX.}
294 function GetOption(OptionId
: LongInt): LongInt;
295 { Pushes current values of all options on the stack. Returns True
296 if successfull (max stack depth is 8 now). }
297 function PushOptions
: Boolean;
298 { Pops back values of all options from the top of the stack. Returns True
299 if successfull (max stack depth is 8 now). }
300 function PopOptions
: Boolean;
302 { Image Format Functions }
304 { Returns short information about given image format.}
305 function GetImageFormatInfo(Format
: TImageFormat
; out Info
: TImageFormatInfo
): Boolean;
306 { Returns size in bytes of Width x Height area of pixels. Works for all formats.}
307 function GetPixelsSize(Format
: TImageFormat
; Width
, Height
: LongInt): LongInt;
311 { User can set his own file IO functions used when loading from/saving to
312 files by this function.}
313 procedure SetUserFileIO(OpenReadProc
: TOpenReadProc
; OpenWriteProc
:
314 TOpenWriteProc
; CloseProc
: TCloseProc
; EofProc
: TEofProc
; SeekProc
:
315 TSeekProc
; TellProc
: TTellProc
; ReadProc
: TReadProc
; WriteProc
: TWriteProc
);
316 { Sets file IO functions to Imaging default.}
317 procedure ResetFileIO
;
320 { ------------------------------------------------------------------------
322 ------------------------------------------------------------------------}
325 { Set of TImageFormat enum.}
326 TImageFormats
= set of TImageFormat
;
328 { Record containg set of IO functions internaly used by image loaders/savers.}
329 TIOFunctions
= record
330 OpenRead
: TOpenReadProc
;
331 OpenWrite
: TOpenWriteProc
;
339 PIOFunctions
= ^TIOFunctions
;
341 { Base class for various image file format loaders/savers which
342 descend from this class. If you want to add support for new image file
343 format the best way is probably to look at TImageFileFormat descendants'
344 implementations that are already part of Imaging.}
346 TImageFileFormat
= class(TObject
)
348 FExtensions
: TStringList
;
350 { Does various checks and actions before LoadData method is called.}
351 function PrepareLoad(Handle
: TImagingHandle
; var Images
: TDynImageDataArray
;
352 OnlyFirstFrame
: Boolean): Boolean;
353 { Processes some actions according to result of LoadData.}
354 function PostLoadCheck(var Images
: TDynImageDataArray
; LoadResult
: Boolean): Boolean;
355 { Helper function to be called in SaveData methods of descendants (ensures proper
356 index and sets FFirstIdx and FLastIdx for multi-images).}
357 function PrepareSave(Handle
: TImagingHandle
; const Images
: TDynImageDataArray
;
358 var Index
: LongInt): Boolean;
363 FIsMultiImageFormat
: Boolean;
364 FSupportedFormats
: TImageFormats
;
365 FFirstIdx
, FLastIdx
: LongInt;
366 { Defines filename masks for this image file format. AMasks should be
367 in format '*.ext1,*.ext2,umajo.*'.}
368 procedure AddMasks(const AMasks
: string);
369 function GetFormatInfo(Format
: TImageFormat
): TImageFormatInfo
;
370 { Returns set of TImageData formats that can be saved in this file format
371 without need for conversion.}
372 function GetSupportedFormats
: TImageFormats
; virtual;
373 { Method which must be overrided in descendants if they' are be capable
374 of loading images. Images are already freed and length is set to zero
375 whenever this method gets called. Also Handle is assured to be valid
376 and contains data that passed TestFormat method's check.}
377 function LoadData(Handle
: TImagingHandle
; var Images
: TDynImageDataArray
;
378 OnlyFirstFrame
: Boolean): Boolean; virtual;
379 { Method which must be overrided in descendants if they are be capable
380 of saving images. Images are checked to have length >0 and
381 that they contain valid images. For single-image file formats
382 Index contain valid index to Images array (to image which should be saved).
383 Multi-image formats should use FFirstIdx and FLastIdx fields to
384 to get all images that are to be saved.}
385 function SaveData(Handle
: TImagingHandle
; const Images
: TDynImageDataArray
;
386 Index
: LongInt): Boolean; virtual;
387 { This method is called internaly by MakeCompatible when input image
388 is in format not supported by this file format. Image is clone of
389 MakeCompatible's input and Info is its extended format info.}
390 procedure ConvertToSupported(var Image
: TImageData
;
391 const Info
: TImageFormatInfo
); virtual;
392 { Returns True if given image is supported for saving by this file format.
393 Most file formats don't need to override this method. It checks
394 (in this base class) if Image's format is in SupportedFromats set.
395 But you may override it if you want further checks
396 (proper widht and height for example).}
397 function IsSupported(const Image
: TImageData
): Boolean; virtual;
399 constructor Create
; virtual;
400 destructor Destroy
; override;
402 { Loads images from file source.}
403 function LoadFromFile(const FileName
: string; var Images
: TDynImageDataArray
;
404 OnlyFirstLevel
: Boolean = False): Boolean;
405 { Loads images from stream source.}
406 function LoadFromStream(Stream
: TStream
; var Images
: TDynImageDataArray
;
407 OnlyFirstLevel
: Boolean = False): Boolean;
408 { Loads images from memory source.}
409 function LoadFromMemory(Data
: Pointer; Size
: LongInt;
410 var Images
: TDynImageDataArray
; OnlyFirstLevel
: Boolean = False): Boolean;
412 { Saves images to file. If format supports only single level images and
413 there are multiple images to be saved, they are saved as sequence of
414 independent images (for example SaveToFile saves sequence of
415 files img000.jpg, img001.jpg ....).}
416 function SaveToFile(const FileName
: string; const Images
: TDynImageDataArray
;
417 OnlyFirstLevel
: Boolean = False): Boolean;
418 { Saves images to stream. If format supports only single level images and
419 there are multiple images to be saved, they are saved as sequence of
421 function SaveToStream(Stream
: TStream
; const Images
: TDynImageDataArray
;
422 OnlyFirstLevel
: Boolean = False): Boolean;
423 { Saves images to memory. If format supports only single level images and
424 there are multiple images to be saved, they are saved as sequence of
425 independent images. Data must be already allocated and their size passed
426 as Size parameter, number of written bytes is then returned in the same
428 function SaveToMemory(Data
: Pointer; var Size
: LongInt;
429 const Images
: TDynImageDataArray
; OnlyFirstLevel
: Boolean = False): Boolean;
431 { Makes Image compatible with this file format (that means it is in one
432 of data formats in Supported formats set). If input is already
433 in supported format then Compatible just use value from input
434 (Compatible := Image) so must not free it after you are done with it
435 (image bits pointer points to input image's bits).
436 If input is not in supported format then it is cloned to Compatible
437 and concerted to one of supported formats (which one dependeds on
438 this file format). If image is cloned MustBeFreed is set to True
439 to indicated that you must free Compatible after you are done with it.}
440 function MakeCompatible(const Image
: TImageData
; var Compatible
: TImageData
;
441 out MustBeFreed
: Boolean): Boolean;
442 { Returns True if data located in source identified by Handle
443 represent valid image in current format.}
444 function TestFormat(Handle
: TImagingHandle
): Boolean; virtual;
445 { Resturns True if the given FileName matches filter for this file format.
446 For most formats it just checks filename extensions.
447 It uses filename masks in from Masks property so it can recognize
448 filenames like this 'umajoXXXumajo.j0j' if one of themasks is
450 function TestFileName(const FileName
: string): Boolean;
451 { Descendants use this method to check if their options (registered with
452 constant Ids for SetOption/GetOption interface or accessible as properties
453 of descendants) have valid values and make necessary changes.}
454 procedure CheckOptionsValidity
; virtual;
456 { Description of this format.}
457 property Name
: string read FName
;
458 { Indicates whether images in this format can be loaded.}
459 property CanLoad
: Boolean read FCanLoad
;
460 { Indicates whether images in this format can be saved.}
461 property CanSave
: Boolean read FCanSave
;
462 { Indicates whether images in this format can contain multiple image levels.}
463 property IsMultiImageFormat
: Boolean read FIsMultiImageFormat
;
464 { List of filename extensions for this format.}
465 property Extensions
: TStringList read FExtensions
;
466 { List of filename mask that are used to associate filenames
467 with TImageFileFormat descendants. Typical mask looks like
468 '*.bmp' or 'texture.*' (supports file formats which use filename instead
469 of extension to identify image files).}
470 property Masks
: TStringList read FMasks
;
471 { Set of TImageFormats supported by saving functions of this format. Images
472 can be saved only in one those formats.}
473 property SupportedFormats
: TImageFormats read GetSupportedFormats
;
477 { Class reference for TImageFileFormat class}
478 TImageFileFormatClass
= class of TImageFileFormat
;
480 { Returns symbolic name of given format.}
481 function GetFormatName(Format
: TImageFormat
): string;
482 { Returns string with information about given Image.}
483 function ImageToStr(const Image
: TImageData
): string;
484 { Returns Imaging version string in format 'Major.Minor.Patch'.}
485 function GetVersionStr
: string;
486 { If Condition is True then TruePart is retured, otherwise FalsePart is returned.}
487 function IffFormat(Condition
: Boolean; const TruePart
, FalsePart
: TImageFormat
): TImageFormat
;
488 { Registers new image loader/saver so it can be used by LoadFrom/SaveTo
490 procedure RegisterImageFileFormat(AClass
: TImageFileFormatClass
);
491 { Registers new option so it can be used by SetOption and GetOption functions.
492 Returns True if registration was succesful - that is Id is valid and is
493 not already taken by another option.}
494 function RegisterOption(OptionId
: LongInt; Variable
: PLongInt): Boolean;
495 { Returns image format loader/saver according to given extension
496 or nil if not found.}
497 function FindImageFileFormatByExt(const Ext
: string): TImageFileFormat
;
498 { Returns image format loader/saver according to given filename
499 or nil if not found.}
500 function FindImageFileFormatByName(const FileName
: string): TImageFileFormat
;
501 { Returns image format loader/saver based on its class
502 or nil if not found or not registered.}
503 function FindImageFileFormatByClass(AClass
: TImageFileFormatClass
): TImageFileFormat
;
504 { Returns number of registered image file format loaders/saver.}
505 function GetFileFormatCount
: LongInt;
506 { Returns image file format loader/saver at given index. Index must be
507 in range [0..GetFileFormatCount - 1] otherwise nil is returned.}
508 function GetFileFormatAtIndex(Index
: LongInt): TImageFileFormat
;
509 { Returns filter string for usage with open and save picture dialogs
510 which contains all registered image file formats.
511 Set OpenFileFilter to True if you want filter for open dialog
512 and to False if you want save dialog filter (formats that cannot save to files
514 For open dialog filter for all known graphic files
515 (like All(*.jpg;*.png;....) is added too at the first index.}
516 function GetImageFileFormatsFilter(OpenFileFilter
: Boolean): string;
517 { Returns file extension (without dot) of image format selected
518 by given filter index. Used filter string is defined by GetImageFileFormatsFilter
519 function. This function can be used with save dialogs (with filters created
520 by GetImageFileFormatsFilter) to get the extension of file format selected
521 in dialog quickly. Index is in range 1..N (as FilterIndex property
522 of TOpenDialog/TSaveDialog)}
523 function GetFilterIndexExtension(Index
: LongInt; OpenFileFilter
: Boolean): string;
524 { Returns filter index of image file format of file specified by FileName. Used filter
525 string is defined by GetImageFileFormatsFilter function.
526 Returned index is in range 1..N (as FilterIndex property of TOpenDialog/TSaveDialog)}
527 function GetFileNameFilterIndex(const FileName
: string; OpenFileFilter
: Boolean): LongInt;
528 { Returns current IO functions.}
529 function GetIO
: TIOFunctions
;
530 { Raises EImagingError with given message.}
531 procedure RaiseImaging(const Msg
: string; const Args
: array of const);
536 {$IFNDEF DONT_LINK_BITMAP}
539 {$IFNDEF DONT_LINK_JPEG}
542 {$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
543 ImagingNetworkGraphics
,
545 {$IFNDEF DONT_LINK_GIF}
548 {$IFNDEF DONT_LINK_DDS}
551 {$IFNDEF DONT_LINK_TARGA}
554 {$IFNDEF DONT_LINK_PNM}
557 {$IFNDEF DONT_LINK_EXTRAS}
560 ImagingFormats
, ImagingUtility
, ImagingIO
;
563 SImagingTitle
= 'Vampyre Imaging Library';
564 SExceptMsg
= 'Exception Message';
565 SAllFilter
= 'All Images';
566 SUnknownFormat
= 'Unknown and unsupported format';
567 SErrorFreeImage
= 'Error while freeing image. %s';
568 SErrorCloneImage
= 'Error while cloning image. %s';
569 SErrorFlipImage
= 'Error while flipping image. %s';
570 SErrorMirrorImage
= 'Error while mirroring image. %s';
571 SErrorResizeImage
= 'Error while resizing image. %s';
572 SErrorSwapImage
= 'Error while swapping channels of image. %s';
573 SFileFormatCanNotLoad
= 'Image Format "%s" does not support loading images.';
574 SFileFormatCanNotSave
= 'Image Format "%s" does not support saving images.';
575 SErrorNewImage
= 'Error while creating image data with params: Width=%d ' +
576 'Height=%d Format=%s.';
577 SErrorConvertImage
= 'Error while converting image to format "%s". %s';
578 SImageInfo
= 'Image @%p info: Width = %dpx, Height = %dpx, ' +
579 'Format = %s, Size = %.0n %s, Bits @%p, Palette @%p.';
580 SImageInfoInvalid
= 'Access violation encountered when getting info on ' +
581 'image at address %p.';
582 SFileNotValid
= 'File "%s" is not valid image in "%s" format.';
583 SStreamNotValid
= 'Stream %p does not contain valid image in "%s" format.';
584 SMemoryNotValid
= 'Memory %p (%d Bytes) does not contain valid image ' +
586 SErrorLoadingFile
= 'Error while loading images from file "%s" (file format: %s).';
587 SErrorLoadingStream
= 'Error while loading images from stream %p (file format: %s).';
588 SErrorLoadingMemory
= 'Error while loading images from memory %p (%d Bytes) (file format: %s).';
589 SErrorSavingFile
= 'Error while saving images to file "%s" (file format: %s).';
590 SErrorSavingStream
= 'Error while saving images to stream %p (file format: %s).';
591 SErrorSavingMemory
= 'Error while saving images to memory %p (%d Bytes) (file format: %s).';
592 SErrorFindColor
= 'Error while finding color in palette @%p with %d entries.';
593 SErrorGrayscalePalette
= 'Error while filling grayscale palette @%p with %d entries.';
594 SErrorCustomPalette
= 'Error while filling custom palette @%p with %d entries.';
595 SErrorSwapPalette
= 'Error while swapping channels of palette @%p with %d entries.';
596 SErrorReduceColors
= 'Error while reducing number of colors of image to %d. %s';
597 SErrorGenerateMipMaps
= 'Error while generating %d mipmap levels for image %s';
598 SImagesNotValid
= 'One or more images are not valid.';
599 SErrorCopyRect
= 'Error while copying rect from image %s to image %s.';
600 SErrorMapImage
= 'Error while mapping image %s to palette.';
601 SErrorFillRect
= 'Error while filling rectangle X:%d Y:%d W:%d H:%d in image %s';
602 SErrorSplitImage
= 'Error while splitting image %s to %dx%d sized chunks.';
603 SErrorMakePaletteForImages
= 'Error while making %d color palette for %d images.';
604 SErrorNewPalette
= 'Error while creating new palette with %d entries';
605 SErrorFreePalette
= 'Error while freeing palette @%p';
606 SErrorCopyPalette
= 'Error while copying %d entries from palette @%p to @%p';
607 SErrorReplaceColor
= 'Error while replacing colors in rectangle X:%d Y:%d W:%d H:%d of image %s';
608 SErrorRotateImage
= 'Error while rotating image %s by %.2n degrees';
609 SErrorStretchRect
= 'Error while stretching rect from image %s to image %s.';
610 SErrorEmptyStream
= 'Input stream has no data. Check Position property.';
613 // initial size of array with options information
614 InitialOptions
= 256;
615 // max depth of the option stack
616 OptionStackDepth
= 8;
617 // do not change the default format now, its too late
618 DefaultImageFormat
: TImageFormat
= ifA8R8G8B8
;
621 TOptionArray
= array of PLongInt;
622 TOptionValueArray
= array of LongInt;
624 TOptionStack
= class(TObject
)
626 FStack
: array[0..OptionStackDepth
- 1] of TOptionValueArray
;
630 destructor Destroy
; override;
631 function Push
: Boolean;
632 function Pop
: Boolean;
636 // currently set IO functions
638 // list with all registered TImageFileFormat classes
639 ImageFileFormats
: TList
= nil;
640 // array with registered options (pointers to their values)
641 Options
: TOptionArray
= nil;
642 // array containing addional infomation about every image format
643 ImageFormatInfos
: TImageFormatInfoArray
;
644 // stack used by PushOptions/PopOtions functions
645 OptionStack
: TOptionStack
= nil;
647 // variable for ImagingColorReduction option
648 ColorReductionMask
: LongInt = $FF;
649 // variable for ImagingLoadOverrideFormat option
650 LoadOverrideFormat
: TImageFormat
= ifUnknown
;
651 // variable for ImagingSaveOverrideFormat option
652 SaveOverrideFormat
: TImageFormat
= ifUnknown
;
653 // variable for ImagingSaveOverrideFormat option
654 MipMapFilter
: TSamplingFilter
= sfLinear
;
657 { Internal unit functions }
659 { Modifies option value to be in the allowed range. Works only
660 for options registered in this unit.}
661 function CheckOptionValue(OptionId
, Value
: LongInt): LongInt; forward;
662 { Sets IO functions to file IO.}
663 procedure SetFileIO
; forward;
664 { Sets IO functions to stream IO.}
665 procedure SetStreamIO
; forward;
666 { Sets IO functions to memory IO.}
667 procedure SetMemoryIO
; forward;
668 { Inits image format infos array.}
669 procedure InitImageFormats
; forward;
670 { Freew image format infos array.}
671 procedure FreeImageFileFormats
; forward;
672 { Creates options array and stack.}
673 procedure InitOptions
; forward;
674 { Frees options array and stack.}
675 procedure FreeOptions
; forward;
678 { Those inline functions are copied here from ImagingFormats
679 because Delphi 9/10 cannot inline them if they are declared in
680 circularly dependent units.}
682 procedure CopyPixel(Src
, Dest
: Pointer; BytesPerPixel
: LongInt); inline;
684 case BytesPerPixel
of
685 1: PByte(Dest
)^ := PByte(Src
)^;
686 2: PWord(Dest
)^ := PWord(Src
)^;
687 3: PColor24Rec(Dest
)^ := PColor24Rec(Src
)^;
688 4: PLongWord(Dest
)^ := PLongWord(Src
)^;
689 6: PColor48Rec(Dest
)^ := PColor48Rec(Src
)^;
690 8: PInt64(Dest
)^ := PInt64(Src
)^;
691 16: PColorFPRec(Dest
)^ := PColorFPRec(Src
)^;
695 function ComparePixels(PixelA
, PixelB
: Pointer; BytesPerPixel
: LongInt): Boolean; inline;
697 case BytesPerPixel
of
698 1: Result
:= PByte(PixelA
)^ = PByte(PixelB
)^;
699 2: Result
:= PWord(PixelA
)^ = PWord(PixelB
)^;
700 3: Result
:= (PWord(PixelA
)^ = PWord(PixelB
)^) and
701 (PColor24Rec(PixelA
).R
= PColor24Rec(PixelB
).R
);
702 4: Result
:= PLongWord(PixelA
)^ = PLongWord(PixelB
)^;
703 6: Result
:= (PLongWord(PixelA
)^ = PLongWord(PixelB
)^) and
704 (PColor48Rec(PixelA
).R
= PColor48Rec(PixelB
).R
);
705 8: Result
:= PInt64(PixelA
)^ = PInt64(PixelB
)^;
706 16: Result
:= (PFloatHelper(PixelA
).Data2
= PFloatHelper(PixelB
).Data2
) and
707 (PFloatHelper(PixelA
).Data1
= PFloatHelper(PixelB
).Data1
);
714 { ------------------------------------------------------------------------
715 Low Level Interface Functions
716 ------------------------------------------------------------------------}
718 { General Functions }
720 procedure InitImage(var Image
: TImageData
);
722 FillChar(Image
, SizeOf(Image
), 0);
725 function NewImage(Width
, Height
: LongInt; Format
: TImageFormat
; var Image
:
726 TImageData
): Boolean;
728 FInfo
: PImageFormatInfo
;
730 Assert((Width
> 0) and (Height
>0));
731 Assert(IsImageFormatValid(Format
));
735 Image
.Width
:= Width
;
736 Image
.Height
:= Height
;
737 // Select default data format if selected
738 if (Format
= ifDefault
) then
739 Image
.Format
:= DefaultImageFormat
741 Image
.Format
:= Format
;
742 // Get extended format info
743 FInfo
:= ImageFormatInfos
[Image
.Format
];
749 // Check image dimensions and calculate its size in bytes
750 FInfo
.CheckDimensions(FInfo
.Format
, Image
.Width
, Image
.Height
);
751 Image
.Size
:= FInfo
.GetPixelsSize(FInfo
.Format
, Image
.Width
, Image
.Height
);
752 if Image
.Size
= 0 then
757 // Image bits are allocated and set to zeroes
758 GetMem(Image
.Bits
, Image
.Size
);
759 FillChar(Image
.Bits
^, Image
.Size
, 0);
760 // Palette is allocated and set to zeroes
761 if FInfo
.PaletteEntries
> 0 then
763 GetMem(Image
.Palette
, FInfo
.PaletteEntries
* SizeOf(TColor32Rec
));
764 FillChar(Image
.Palette
^, FInfo
.PaletteEntries
* SizeOf(TColor32Rec
), 0);
766 Result
:= TestImage(Image
);
768 RaiseImaging(SErrorNewImage
, [Width
, Height
, GetFormatName(Format
)]);
772 function TestImage(const Image
: TImageData
): Boolean;
775 Result
:= (LongInt(Image
.Format
) >= LongInt(Low(TImageFormat
))) and
776 (LongInt(Image
.Format
) <= LongInt(High(TImageFormat
))) and
777 (ImageFormatInfos
[Image
.Format
] <> nil) and
778 (Assigned(ImageFormatInfos
[Image
.Format
].GetPixelsSize
) and
779 (ImageFormatInfos
[Image
.Format
].GetPixelsSize(Image
.Format
,
780 Image
.Width
, Image
.Height
) = Image
.Size
));
782 // Possible int overflows or other errors
787 procedure FreeImage(var Image
: TImageData
);
790 if TestImage(Image
) then
792 FreeMemNil(Image
.Bits
);
793 FreeMemNil(Image
.Palette
);
797 RaiseImaging(SErrorFreeImage
, [ImageToStr(Image
)]);
801 procedure FreeImagesInArray(var Images
: TDynImageDataArray
);
805 if Length(Images
) > 0 then
807 for I
:= 0 to Length(Images
) - 1 do
808 FreeImage(Images
[I
]);
809 SetLength(Images
, 0);
813 function TestImagesInArray(const Images
: TDynImageDataArray
): Boolean;
817 if Length(Images
) > 0 then
820 for I
:= 0 to Length(Images
) - 1 do
822 Result
:= Result
and TestImage(Images
[I
]);
831 function DetermineFileFormat(const FileName
: string): string;
834 Fmt
: TImageFileFormat
;
835 Handle
: TImagingHandle
;
837 Assert(FileName
<> '');
841 Handle
:= IO
.OpenRead(PChar(FileName
));
843 // First file format according to FileName and test if the data in
844 // file is really in that format
845 for I
:= 0 to ImageFileFormats
.Count
- 1 do
847 Fmt
:= TImageFileFormat(ImageFileFormats
[I
]);
848 if Fmt
.TestFileName(FileName
) and Fmt
.TestFormat(Handle
) then
850 Result
:= Fmt
.Extensions
[0];
854 // No file format was found with filename search so try data-based search
855 for I
:= 0 to ImageFileFormats
.Count
- 1 do
857 Fmt
:= TImageFileFormat(ImageFileFormats
[I
]);
858 if Fmt
.TestFormat(Handle
) then
860 Result
:= Fmt
.Extensions
[0];
872 function DetermineStreamFormat(Stream
: TStream
): string;
875 Fmt
: TImageFileFormat
;
876 Handle
: TImagingHandle
;
878 Assert(Stream
<> nil);
882 Handle
:= IO
.OpenRead(Pointer(Stream
));
884 for I
:= 0 to ImageFileFormats
.Count
- 1 do
886 Fmt
:= TImageFileFormat(ImageFileFormats
[I
]);
887 if Fmt
.TestFormat(Handle
) then
889 Result
:= Fmt
.Extensions
[0];
901 function DetermineMemoryFormat(Data
: Pointer; Size
: LongInt): string;
904 Fmt
: TImageFileFormat
;
905 Handle
: TImagingHandle
;
908 Assert((Data
<> nil) and (Size
> 0));
915 Handle
:= IO
.OpenRead(@IORec
);
917 for I
:= 0 to ImageFileFormats
.Count
- 1 do
919 Fmt
:= TImageFileFormat(ImageFileFormats
[I
]);
920 if Fmt
.TestFormat(Handle
) then
922 Result
:= Fmt
.Extensions
[0];
934 function IsFileFormatSupported(const FileName
: string): Boolean;
936 Result
:= FindImageFileFormatByName(FileName
) <> nil;
939 function EnumFileFormats(var Index
: LongInt; var Name
, DefaultExt
, Masks
: string;
940 var CanSaveImages
, IsMultiImageFormat
: Boolean): Boolean;
942 FileFmt
: TImageFileFormat
;
944 FileFmt
:= GetFileFormatAtIndex(Index
);
945 Result
:= FileFmt
<> nil;
948 Name
:= FileFmt
.Name
;
949 DefaultExt
:= FileFmt
.Extensions
[0];
950 Masks
:= FileFmt
.Masks
.DelimitedText
;
951 CanSaveImages
:= FileFmt
.CanSave
;
952 IsMultiImageFormat
:= FileFmt
.IsMultiImageFormat
;
960 CanSaveImages
:= False;
961 IsMultiImageFormat
:= False;
965 { Loading Functions }
967 function LoadImageFromFile(const FileName
: string; var Image
: TImageData
):
970 Format
: TImageFileFormat
;
971 IArray
: TDynImageDataArray
;
974 Assert(FileName
<> '');
976 Format
:= FindImageFileFormatByExt(DetermineFileFormat(FileName
));
977 if Format
<> nil then
980 Result
:= Format
.LoadFromFile(FileName
, IArray
, True);
981 if Result
and (Length(IArray
) > 0) then
984 for I
:= 1 to Length(IArray
) - 1 do
985 FreeImage(IArray
[I
]);
992 function LoadImageFromStream(Stream
: TStream
; var Image
: TImageData
): Boolean;
994 Format
: TImageFileFormat
;
995 IArray
: TDynImageDataArray
;
998 Assert(Stream
<> nil);
999 if Stream
.Size
- Stream
.Position
= 0 then
1000 RaiseImaging(SErrorEmptyStream
, []);
1002 Format
:= FindImageFileFormatByExt(DetermineStreamFormat(Stream
));
1003 if Format
<> nil then
1006 Result
:= Format
.LoadFromStream(Stream
, IArray
, True);
1007 if Result
and (Length(IArray
) > 0) then
1010 for I
:= 1 to Length(IArray
) - 1 do
1011 FreeImage(IArray
[I
]);
1018 function LoadImageFromMemory(Data
: Pointer; Size
: LongInt; var Image
: TImageData
): Boolean;
1020 Format
: TImageFileFormat
;
1021 IArray
: TDynImageDataArray
;
1024 Assert((Data
<> nil) and (Size
> 0));
1026 Format
:= FindImageFileFormatByExt(DetermineMemoryFormat(Data
, Size
));
1027 if Format
<> nil then
1030 Result
:= Format
.LoadFromMemory(Data
, Size
, IArray
, True);
1031 if Result
and (Length(IArray
) > 0) then
1034 for I
:= 1 to Length(IArray
) - 1 do
1035 FreeImage(IArray
[I
]);
1042 function LoadMultiImageFromFile(const FileName
: string; var Images
:
1043 TDynImageDataArray
): Boolean;
1045 Format
: TImageFileFormat
;
1047 Assert(FileName
<> '');
1049 Format
:= FindImageFileFormatByExt(DetermineFileFormat(FileName
));
1050 if Format
<> nil then
1052 FreeImagesInArray(Images
);
1053 Result
:= Format
.LoadFromFile(FileName
, Images
);
1057 function LoadMultiImageFromStream(Stream
: TStream
; var Images
: TDynImageDataArray
): Boolean;
1059 Format
: TImageFileFormat
;
1061 Assert(Stream
<> nil);
1062 if Stream
.Size
- Stream
.Position
= 0 then
1063 RaiseImaging(SErrorEmptyStream
, []);
1065 Format
:= FindImageFileFormatByExt(DetermineStreamFormat(Stream
));
1066 if Format
<> nil then
1068 FreeImagesInArray(Images
);
1069 Result
:= Format
.LoadFromStream(Stream
, Images
);
1073 function LoadMultiImageFromMemory(Data
: Pointer; Size
: LongInt;
1074 var Images
: TDynImageDataArray
): Boolean;
1076 Format
: TImageFileFormat
;
1078 Assert((Data
<> nil) and (Size
> 0));
1080 Format
:= FindImageFileFormatByExt(DetermineMemoryFormat(Data
, Size
));
1081 if Format
<> nil then
1083 FreeImagesInArray(Images
);
1084 Result
:= Format
.LoadFromMemory(Data
, Size
, Images
);
1088 { Saving Functions }
1090 function SaveImageToFile(const FileName
: string; const Image
: TImageData
): Boolean;
1092 Format
: TImageFileFormat
;
1093 IArray
: TDynImageDataArray
;
1095 Assert(FileName
<> '');
1097 Format
:= FindImageFileFormatByName(FileName
);
1098 if Format
<> nil then
1100 SetLength(IArray
, 1);
1102 Result
:= Format
.SaveToFile(FileName
, IArray
, True);
1106 function SaveImageToStream(const Ext
: string; Stream
: TStream
;
1107 const Image
: TImageData
): Boolean;
1109 Format
: TImageFileFormat
;
1110 IArray
: TDynImageDataArray
;
1112 Assert((Ext
<> '') and (Stream
<> nil));
1114 Format
:= FindImageFileFormatByExt(Ext
);
1115 if Format
<> nil then
1117 SetLength(IArray
, 1);
1119 Result
:= Format
.SaveToStream(Stream
, IArray
, True);
1123 function SaveImageToMemory(const Ext
: string; Data
: Pointer; var Size
: LongInt;
1124 const Image
: TImageData
): Boolean;
1126 Format
: TImageFileFormat
;
1127 IArray
: TDynImageDataArray
;
1129 Assert((Ext
<> '') and (Data
<> nil) and (Size
> 0));
1131 Format
:= FindImageFileFormatByExt(Ext
);
1132 if Format
<> nil then
1134 SetLength(IArray
, 1);
1136 Result
:= Format
.SaveToMemory(Data
, Size
, IArray
, True);
1140 function SaveMultiImageToFile(const FileName
: string;
1141 const Images
: TDynImageDataArray
): Boolean;
1143 Format
: TImageFileFormat
;
1145 Assert(FileName
<> '');
1147 Format
:= FindImageFileFormatByName(FileName
);
1148 if Format
<> nil then
1149 Result
:= Format
.SaveToFile(FileName
, Images
);
1152 function SaveMultiImageToStream(const Ext
: string; Stream
: TStream
;
1153 const Images
: TDynImageDataArray
): Boolean;
1155 Format
: TImageFileFormat
;
1157 Assert((Ext
<> '') and (Stream
<> nil));
1159 Format
:= FindImageFileFormatByExt(Ext
);
1160 if Format
<> nil then
1161 Result
:= Format
.SaveToStream(Stream
, Images
);
1164 function SaveMultiImageToMemory(const Ext
: string; Data
: Pointer;
1165 var Size
: LongInt; const Images
: TDynImageDataArray
): Boolean;
1167 Format
: TImageFileFormat
;
1169 Assert((Ext
<> '') and (Data
<> nil) and (Size
> 0));
1171 Format
:= FindImageFileFormatByExt(Ext
);
1172 if Format
<> nil then
1173 Result
:= Format
.SaveToMemory(Data
, Size
, Images
);
1176 { Manipulation Functions }
1178 function CloneImage(const Image
: TImageData
; var Clone
: TImageData
): Boolean;
1180 Info
: PImageFormatInfo
;
1183 if TestImage(Image
) then
1185 if TestImage(Clone
) and (Image
.Bits
<> Clone
.Bits
) then
1190 Info
:= ImageFormatInfos
[Image
.Format
];
1191 Clone
.Width
:= Image
.Width
;
1192 Clone
.Height
:= Image
.Height
;
1193 Clone
.Format
:= Image
.Format
;
1194 Clone
.Size
:= Image
.Size
;
1196 if Info
.PaletteEntries
> 0 then
1198 GetMem(Clone
.Palette
, Info
.PaletteEntries
* SizeOf(TColor32Rec
));
1199 Move(Image
.Palette
^, Clone
.Palette
^, Info
.PaletteEntries
*
1200 SizeOf(TColor32Rec
));
1203 GetMem(Clone
.Bits
, Clone
.Size
);
1204 Move(Image
.Bits
^, Clone
.Bits
^, Clone
.Size
);
1207 RaiseImaging(SErrorCloneImage
, [ImageToStr(Image
)]);
1211 function ConvertImage(var Image
: TImageData
; DestFormat
: TImageFormat
): Boolean;
1215 NewSize
, NumPixels
: LongInt;
1216 SrcInfo
, DstInfo
: PImageFormatInfo
;
1218 Assert(IsImageFormatValid(DestFormat
));
1220 if TestImage(Image
) then
1223 // If default format is set we use DefaultImageFormat
1224 if DestFormat
= ifDefault
then
1225 DestFormat
:= DefaultImageFormat
;
1226 SrcInfo
:= ImageFormatInfos
[Format
];
1227 DstInfo
:= ImageFormatInfos
[DestFormat
];
1228 if SrcInfo
= DstInfo
then
1230 // There is nothing to convert - src is alredy in dest format
1234 // Exit Src or Dest format is invalid
1235 if (SrcInfo
= nil) or (DstInfo
= nil) then Exit
;
1236 // If dest format is just src with swapped channels we call
1237 // SwapChannels instead
1238 if (SrcInfo
.RBSwapFormat
= DestFormat
) and
1239 (DstInfo
.RBSwapFormat
= SrcInfo
.Format
) then
1241 Result
:= SwapChannels(Image
, ChannelRed
, ChannelBlue
);
1242 Image
.Format
:= SrcInfo
.RBSwapFormat
;
1246 if (not SrcInfo
.IsSpecial
) and (not DstInfo
.IsSpecial
) then
1248 NumPixels
:= Width
* Height
;
1249 NewSize
:= NumPixels
* DstInfo
.BytesPerPixel
;
1250 GetMem(NewData
, NewSize
);
1251 FillChar(NewData
^, NewSize
, 0);
1252 GetMem(NewPal
, DstInfo
.PaletteEntries
* SizeOf(TColor32Rec
));
1253 FillChar(NewPal
^, DstInfo
.PaletteEntries
* SizeOf(TColor32Rec
), 0);
1255 if SrcInfo
.IsIndexed
then
1257 // Source: indexed format
1258 if DstInfo
.IsIndexed
then
1259 IndexToIndex(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
, Palette
, NewPal
)
1260 else if DstInfo
.HasGrayChannel
then
1261 IndexToGray(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
, Palette
)
1262 else if DstInfo
.IsFloatingPoint
then
1263 IndexToFloat(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
, Palette
)
1265 IndexToChannel(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
, Palette
);
1267 else if SrcInfo
.HasGrayChannel
then
1269 // Source: grayscale format
1270 if DstInfo
.IsIndexed
then
1271 GrayToIndex(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
, NewPal
)
1272 else if DstInfo
.HasGrayChannel
then
1273 GrayToGray(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
)
1274 else if DstInfo
.IsFloatingPoint
then
1275 GrayToFloat(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
)
1277 GrayToChannel(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
);
1279 else if SrcInfo
.IsFloatingPoint
then
1281 // Source: floating point format
1282 if DstInfo
.IsIndexed
then
1283 FloatToIndex(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
, NewPal
)
1284 else if DstInfo
.HasGrayChannel
then
1285 FloatToGray(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
)
1286 else if DstInfo
.IsFloatingPoint
then
1287 FloatToFloat(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
)
1289 FloatToChannel(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
);
1293 // Source: standard multi channel image
1294 if DstInfo
.IsIndexed
then
1295 ChannelToIndex(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
, NewPal
)
1296 else if DstInfo
.HasGrayChannel
then
1297 ChannelToGray(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
)
1298 else if DstInfo
.IsFloatingPoint
then
1299 ChannelToFloat(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
)
1301 ChannelToChannel(NumPixels
, Bits
, NewData
, SrcInfo
, DstInfo
);
1305 FreeMemNil(Palette
);
1306 Format
:= DestFormat
;
1312 ConvertSpecial(Image
, SrcInfo
, DstInfo
);
1314 Assert(SrcInfo
.Format
<> Image
.Format
);
1318 RaiseImaging(SErrorConvertImage
, [GetFormatName(DestFormat
), ImageToStr(Image
)]);
1322 function FlipImage(var Image
: TImageData
): Boolean;
1324 P1
, P2
, Buff
: Pointer;
1325 WidthBytes
, I
: LongInt;
1326 OldFmt
: TImageFormat
;
1329 OldFmt
:= Image
.Format
;
1330 if TestImage(Image
) then
1333 if ImageFormatInfos
[OldFmt
].IsSpecial
then
1334 ConvertImage(Image
, ifDefault
);
1336 WidthBytes
:= Width
* ImageFormatInfos
[Format
].BytesPerPixel
;
1337 GetMem(Buff
, WidthBytes
);
1339 // Swap all scanlines of image
1340 for I
:= 0 to Height
div 2 - 1 do
1342 P1
:= @PByteArray(Bits
)[I
* WidthBytes
];
1343 P2
:= @PByteArray(Bits
)[(Height
- I
- 1) * WidthBytes
];
1344 Move(P1
^, Buff
^, WidthBytes
);
1345 Move(P2
^, P1
^, WidthBytes
);
1346 Move(Buff
^, P2
^, WidthBytes
);
1352 if OldFmt
<> Format
then
1353 ConvertImage(Image
, OldFmt
);
1357 RaiseImaging(SErrorFlipImage
, [ImageToStr(Image
)]);
1361 function MirrorImage(var Image
: TImageData
): Boolean;
1365 Bpp
, Y
, X
, WidthDiv2
, WidthBytes
, XLeft
, XRight
: LongInt;
1366 OldFmt
: TImageFormat
;
1369 OldFmt
:= Image
.Format
;
1370 if TestImage(Image
) then
1373 if ImageFormatInfos
[OldFmt
].IsSpecial
then
1374 ConvertImage(Image
, ifDefault
);
1376 Bpp
:= ImageFormatInfos
[Format
].BytesPerPixel
;
1377 WidthDiv2
:= Width
div 2;
1378 WidthBytes
:= Width
* Bpp
;
1379 // Mirror all pixels on each scanline of image
1380 for Y
:= 0 to Height
- 1 do
1382 Scanline
:= @PByteArray(Bits
)[Y
* WidthBytes
];
1384 XRight
:= (Width
- 1) * Bpp
;
1385 for X
:= 0 to WidthDiv2
- 1 do
1387 CopyPixel(@PByteArray(Scanline
)[XLeft
], @Buff
, Bpp
);
1388 CopyPixel(@PByteArray(Scanline
)[XRight
],
1389 @PByteArray(Scanline
)[XLeft
], Bpp
);
1390 CopyPixel(@Buff
, @PByteArray(Scanline
)[XRight
], Bpp
);
1396 if OldFmt
<> Format
then
1397 ConvertImage(Image
, OldFmt
);
1401 RaiseImaging(SErrorMirrorImage
, [ImageToStr(Image
)]);
1405 function ResizeImage(var Image
: TImageData
; NewWidth
, NewHeight
: LongInt;
1406 Filter
: TResizeFilter
): Boolean;
1408 WorkImage
: TImageData
;
1410 Assert((NewWidth
> 0) and (NewHeight
> 0));
1412 if TestImage(Image
) and ((Image
.Width
<> NewWidth
) or (Image
.Height
<> NewHeight
)) then
1414 InitImage(WorkImage
);
1415 // Create new image with desired dimensions
1416 NewImage(NewWidth
, NewHeight
, Image
.Format
, WorkImage
);
1417 // Stretch pixels from old image to new one
1418 StretchRect(Image
, 0, 0, Image
.Width
, Image
.Height
,
1419 WorkImage
, 0, 0, WorkImage
.Width
, WorkImage
.Height
, Filter
);
1420 // Free old image and assign new image to it
1421 FreeMemNil(Image
.Bits
);
1422 if Image
.Palette
<> nil then
1424 FreeMem(WorkImage
.Palette
);
1425 WorkImage
.Palette
:= Image
.Palette
;
1430 RaiseImaging(SErrorResizeImage
, [ImageToStr(Image
)]);
1434 function SwapChannels(var Image
: TImageData
; SrcChannel
, DstChannel
: LongInt): Boolean;
1436 I
, NumPixels
: LongInt;
1437 Info
: PImageFormatInfo
;
1444 Assert((SrcChannel
in [0..3]) and (DstChannel
in [0..3]));
1446 if TestImage(Image
) and (SrcChannel
<> DstChannel
) then
1449 NumPixels
:= Width
* Height
;
1450 Info
:= ImageFormatInfos
[Format
];
1453 if (Info
.Format
= ifR8G8B8
) or ((Info
.Format
= ifA8R8G8B8
) and
1454 (SrcChannel
<> ChannelAlpha
) and (DstChannel
<> ChannelAlpha
)) then
1456 // Swap channels of most common formats R8G8B8 and A8R8G8B8 (no alpha)
1457 for I
:= 0 to NumPixels
- 1 do
1458 with PColor24Rec(Data
)^ do
1460 Swap
:= Channels
[SrcChannel
];
1461 Channels
[SrcChannel
] := Channels
[DstChannel
];
1462 Channels
[DstChannel
] := Swap
;
1463 Inc(Data
, Info
.BytesPerPixel
);
1466 else if Info
.IsIndexed
then
1468 // Swap palette channels of indexed images
1469 SwapChannelsOfPalette(Palette
, Info
.PaletteEntries
, SrcChannel
, DstChannel
)
1471 else if Info
.IsFloatingPoint
then
1473 // Swap channels of floating point images
1474 for I
:= 0 to NumPixels
- 1 do
1476 FloatGetSrcPixel(Data
, Info
, PixF
);
1479 SwapF
:= Channels
[SrcChannel
];
1480 Channels
[SrcChannel
] := Channels
[DstChannel
];
1481 Channels
[DstChannel
] := SwapF
;
1483 FloatSetDstPixel(Data
, Info
, PixF
);
1484 Inc(Data
, Info
.BytesPerPixel
);
1487 else if Info
.IsSpecial
then
1489 // Swap channels of special format images
1490 ConvertImage(Image
, ifDefault
);
1491 SwapChannels(Image
, SrcChannel
, DstChannel
);
1492 ConvertImage(Image
, Info
.Format
);
1494 else if Info
.HasGrayChannel
and Info
.HasAlphaChannel
and
1495 ((SrcChannel
= ChannelAlpha
) or (DstChannel
= ChannelAlpha
)) then
1497 for I
:= 0 to NumPixels
- 1 do
1499 // If we have grayscale image with alpha and alpha is channel
1500 // to be swapped, we swap it. No other alternative for gray images,
1501 // just alpha and something
1502 GrayGetSrcPixel(Data
, Info
, Pix64
, Alpha
);
1506 GraySetDstPixel(Data
, Info
, Pix64
, Alpha
);
1507 Inc(Data
, Info
.BytesPerPixel
);
1512 // Then do general swap on other channel image formats
1513 for I
:= 0 to NumPixels
- 1 do
1515 ChannelGetSrcPixel(Data
, Info
, Pix64
);
1518 Swap
:= Channels
[SrcChannel
];
1519 Channels
[SrcChannel
] := Channels
[DstChannel
];
1520 Channels
[DstChannel
] := Swap
;
1522 ChannelSetDstPixel(Data
, Info
, Pix64
);
1523 Inc(Data
, Info
.BytesPerPixel
);
1529 RaiseImaging(SErrorSwapImage
, [ImageToStr(Image
)]);
1533 function ReduceColors(var Image
: TImageData
; MaxColors
: LongInt): Boolean;
1535 TmpInfo
: TImageFormatInfo
;
1537 I
, NumPixels
: LongInt;
1540 OldFmt
: TImageFormat
;
1543 if TestImage(Image
) then
1546 // First create temp image info and allocate output bits and palette
1547 MaxColors
:= ClampInt(MaxColors
, 2, High(Word));
1549 FillChar(TmpInfo
, SizeOf(TmpInfo
), 0);
1550 TmpInfo
.PaletteEntries
:= MaxColors
;
1551 TmpInfo
.BytesPerPixel
:= 2;
1552 NumPixels
:= Width
* Height
;
1553 GetMem(Data
, NumPixels
* TmpInfo
.BytesPerPixel
);
1554 GetMem(Pal
, MaxColors
* SizeOf(TColor32Rec
));
1555 ConvertImage(Image
, ifA8R8G8B8
);
1556 // We use median cut algorithm to create reduced palette and to
1557 // fill Data with indices to this palette
1558 ReduceColorsMedianCut(NumPixels
, Bits
, PByte(Data
),
1559 ImageFormatInfos
[Format
], @TmpInfo
, MaxColors
, ColorReductionMask
, Pal
);
1562 // Then we write reduced colors to the input image
1563 for I
:= 0 to NumPixels
- 1 do
1565 Col
.Color
:= Pal
[Index
^].Color
;
1571 // And convert it to its original format
1572 ConvertImage(Image
, OldFmt
);
1575 RaiseImaging(SErrorReduceColors
, [MaxColors
, ImageToStr(Image
)]);
1579 function GenerateMipMaps(const Image
: TImageData
; Levels
: LongInt;
1580 var MipMaps
: TDynImageDataArray
): Boolean;
1582 Width
, Height
, I
, Count
: LongInt;
1583 Info
: TImageFormatInfo
;
1584 CompatibleCopy
: TImageData
;
1587 if TestImage(Image
) then
1589 Width
:= Image
.Width
;
1590 Height
:= Image
.Height
;
1591 // We compute number of possible mipmap levels and if
1592 // the given levels are invalid or zero we use this value
1593 Count
:= GetNumMipMapLevels(Width
, Height
);
1594 if (Levels
<= 0) or (Levels
> Count
) then
1597 // If we have special format image we create copy to allow pixel access.
1598 // This is also done in FillMipMapLevel which is called for each level
1599 // but then the main big image would be converted to compatible
1601 GetImageFormatInfo(Image
.Format
, Info
);
1602 if Info
.IsSpecial
then
1604 InitImage(CompatibleCopy
);
1605 CloneImage(Image
, CompatibleCopy
);
1606 ConvertImage(CompatibleCopy
, ifDefault
);
1609 CompatibleCopy
:= Image
;
1611 FreeImagesInArray(MipMaps
);
1612 SetLength(MipMaps
, Levels
);
1613 CloneImage(Image
, MipMaps
[0]);
1615 for I
:= 1 to Levels
- 1 do
1617 Width
:= Width
shr 1;
1618 Height
:= Height
shr 1;
1619 if Width
< 1 then Width
:= 1;
1620 if Height
< 1 then Height
:= 1;
1621 FillMipMapLevel(CompatibleCopy
, Width
, Height
, MipMaps
[I
]);
1624 if CompatibleCopy
.Format
<> MipMaps
[0].Format
then
1626 // Must convert smaller levels to proper format
1627 for I
:= 1 to High(MipMaps
) do
1628 ConvertImage(MipMaps
[I
], MipMaps
[0].Format
);
1629 FreeImage(CompatibleCopy
);
1634 RaiseImaging(SErrorGenerateMipMaps
, [Levels
, ImageToStr(Image
)]);
1638 function MapImageToPalette(var Image
: TImageData
; Pal
: PPalette32
;
1639 Entries
: LongInt): Boolean;
1641 function FindNearestColor(Pal
: PPalette32
; Entries
: LongInt; Col
: TColor32Rec
): LongInt;
1643 I
, MinDif
, Dif
: LongInt;
1647 for I
:= 0 to Entries
- 1 do
1650 Dif
:= Abs(R
- Col
.R
);
1651 if Dif
> MinDif
then Continue
;
1652 Dif
:= Dif
+ Abs(G
- Col
.G
);
1653 if Dif
> MinDif
then Continue
;
1654 Dif
:= Dif
+ Abs(B
- Col
.B
);
1655 if Dif
> MinDif
then Continue
;
1656 Dif
:= Dif
+ Abs(A
- Col
.A
);
1657 if Dif
< MinDif
then
1666 I
, MaxEntries
: LongInt;
1668 PColor
: PColor32Rec
;
1669 CloneARGB
: TImageData
;
1670 Info
: PImageFormatInfo
;
1672 Assert((Entries
>= 2) and (Entries
<= 256));
1675 if TestImage(Image
) then
1677 // We create clone of source image in A8R8G8B8 and
1678 // then recreate source image in ifIndex8 format
1679 // with palette taken from Pal parameter
1680 InitImage(CloneARGB
);
1681 CloneImage(Image
, CloneARGB
);
1682 ConvertImage(CloneARGB
, ifA8R8G8B8
);
1684 NewImage(CloneARGB
.Width
, CloneARGB
.Height
, ifIndex8
, Image
);
1686 Info
:= ImageFormatInfos
[Image
.Format
];
1687 MaxEntries
:= Min(Info
.PaletteEntries
, Entries
);
1688 Move(Pal
^, Image
.Palette
^, MaxEntries
* SizeOf(TColor32Rec
));
1689 PIndex
:= Image
.Bits
;
1690 PColor
:= CloneARGB
.Bits
;
1692 // For every pixel of ARGB clone we find closest color in
1693 // given palette and assign its index to resulting image's pixel
1694 // procedure used here is very slow but simple and memory usage friendly
1695 // (contrary to other methods)
1696 for I
:= 0 to Image
.Width
* Image
.Height
- 1 do
1698 PIndex
^ := Byte(FindNearestColor(Image
.Palette
, MaxEntries
, PColor
^));
1703 FreeImage(CloneARGB
);
1706 RaiseImaging(SErrorMapImage
, [ImageToStr(Image
)]);
1710 function SplitImage(var Image
: TImageData
; var Chunks
: TDynImageDataArray
;
1711 ChunkWidth
, ChunkHeight
: LongInt; var XChunks
, YChunks
: LongInt;
1712 PreserveSize
: Boolean; Fill
: Pointer): Boolean;
1714 X
, Y
, XTrunc
, YTrunc
: LongInt;
1716 Info
: PImageFormatInfo
;
1717 OldFmt
: TImageFormat
;
1719 Assert((ChunkWidth
> 0) and (ChunkHeight
> 0));
1721 OldFmt
:= Image
.Format
;
1722 FreeImagesInArray(Chunks
);
1724 if TestImage(Image
) then
1726 Info
:= ImageFormatInfos
[Image
.Format
];
1727 if Info
.IsSpecial
then
1728 ConvertImage(Image
, ifDefault
);
1730 // We compute make sure that chunks are not larger than source image or negative
1731 ChunkWidth
:= ClampInt(ChunkWidth
, 0, Image
.Width
);
1732 ChunkHeight
:= ClampInt(ChunkHeight
, 0, Image
.Height
);
1733 // Number of chunks along X and Y axes is computed
1734 XChunks
:= Trunc(Ceil(Image
.Width
/ ChunkWidth
));
1735 YChunks
:= Trunc(Ceil(Image
.Height
/ ChunkHeight
));
1736 SetLength(Chunks
, XChunks
* YChunks
);
1738 // For every chunk we create new image and copy a portion of
1739 // the source image to it. If chunk is on the edge of the source image
1740 // we fill enpty space with Fill pixel data if PreserveSize is set or
1741 // make the chunk smaller if it is not set
1742 for Y
:= 0 to YChunks
- 1 do
1743 for X
:= 0 to XChunks
- 1 do
1745 // Determine if current chunk is on the edge of original image
1746 NotOnEdge
:= ((X
< XChunks
- 1) and (Y
< YChunks
- 1)) or
1747 ((Image
.Width
mod ChunkWidth
= 0) and (Image
.Height
mod ChunkHeight
= 0));
1749 if PreserveSize
or NotOnEdge
then
1751 // We should preserve chunk sizes or we are somewhere inside original image
1752 NewImage(ChunkWidth
, ChunkHeight
, Image
.Format
, Chunks
[Y
* XChunks
+ X
]);
1753 if (not NotOnEdge
) and (Fill
<> nil) then
1754 FillRect(Chunks
[Y
* XChunks
+ X
], 0, 0, ChunkWidth
, ChunkHeight
, Fill
);
1755 CopyRect(Image
, X
* ChunkWidth
, Y
* ChunkHeight
, ChunkWidth
, ChunkHeight
,
1756 Chunks
[Y
* XChunks
+ X
], 0, 0);
1760 // Create smaller edge chunk
1761 XTrunc
:= Image
.Width
- (Image
.Width
div ChunkWidth
) * ChunkWidth
;
1762 YTrunc
:= Image
.Height
- (Image
.Height
div ChunkHeight
) * ChunkHeight
;
1763 NewImage(XTrunc
, YTrunc
, Image
.Format
, Chunks
[Y
* XChunks
+ X
]);
1764 CopyRect(Image
, X
* ChunkWidth
, Y
* ChunkHeight
, XTrunc
, YTrunc
,
1765 Chunks
[Y
* XChunks
+ X
], 0, 0);
1768 // If source image is in indexed format we copy its palette to chunk
1769 if Info
.IsIndexed
then
1771 Move(Image
.Palette
^, Chunks
[Y
* XChunks
+ X
].Palette
^,
1772 Info
.PaletteEntries
* SizeOf(TColor32Rec
));
1776 if OldFmt
<> Image
.Format
then
1778 ConvertImage(Image
, OldFmt
);
1779 for X
:= 0 to Length(Chunks
) - 1 do
1780 ConvertImage(Chunks
[X
], OldFmt
);
1785 RaiseImaging(SErrorSplitImage
, [ImageToStr(Image
), ChunkWidth
, ChunkHeight
]);
1789 function MakePaletteForImages(var Images
: TDynImageDataArray
; Pal
: PPalette32
;
1790 MaxColors
: LongInt; ConvertImages
: Boolean): Boolean;
1793 SrcInfo
, DstInfo
: PImageFormatInfo
;
1794 Target
, TempImage
: TImageData
;
1795 DstFormat
: TImageFormat
;
1797 Assert((Pal
<> nil) and (MaxColors
> 0));
1799 InitImage(TempImage
);
1801 if TestImagesInArray(Images
) then
1803 // Null the color histogram
1804 ReduceColorsMedianCut(0, nil, nil, nil, nil, 0, 0, nil, [raCreateHistogram
]);
1805 for I
:= 0 to Length(Images
) - 1 do
1807 SrcInfo
:= ImageFormatInfos
[Images
[I
].Format
];
1808 if SrcInfo
.IsIndexed
or SrcInfo
.IsSpecial
then
1810 // create temp image in supported format for updating histogram
1811 CloneImage(Images
[I
], TempImage
);
1812 ConvertImage(TempImage
, ifA8R8G8B8
);
1813 SrcInfo
:= ImageFormatInfos
[TempImage
.Format
];
1816 TempImage
:= Images
[I
];
1818 // Update histogram with colors of each input image
1819 ReduceColorsMedianCut(TempImage
.Width
* TempImage
.Height
, TempImage
.Bits
,
1820 nil, SrcInfo
, nil, MaxColors
, ColorReductionMask
, nil, [raUpdateHistogram
]);
1822 if Images
[I
].Bits
<> TempImage
.Bits
then
1823 FreeImage(TempImage
);
1825 // Construct reduced color map from the histogram
1826 ReduceColorsMedianCut(0, nil, nil, nil, nil, MaxColors
, ColorReductionMask
,
1827 Pal
, [raMakeColorMap
]);
1829 if ConvertImages
then
1831 DstFormat
:= ifIndex8
;
1832 DstInfo
:= ImageFormatInfos
[DstFormat
];
1833 MaxColors
:= Min(DstInfo
.PaletteEntries
, MaxColors
);
1835 for I
:= 0 to Length(Images
) - 1 do
1837 SrcInfo
:= ImageFormatInfos
[Images
[I
].Format
];
1838 if SrcInfo
.IsIndexed
or SrcInfo
.IsSpecial
then
1840 // If source image is in format not supported by ReduceColorsMedianCut
1842 ConvertImage(Images
[I
], ifA8R8G8B8
);
1843 SrcInfo
:= ImageFormatInfos
[Images
[I
].Format
];
1847 NewImage(Images
[I
].Width
, Images
[I
].Height
, DstFormat
, Target
);
1848 // We map each input image to reduced palette and replace
1849 // image in array with mapped image
1850 ReduceColorsMedianCut(Images
[I
].Width
* Images
[I
].Height
, Images
[I
].Bits
,
1851 Target
.Bits
, SrcInfo
, DstInfo
, MaxColors
, 0, nil, [raMapImage
]);
1852 Move(Pal
^, Target
.Palette
^, MaxColors
* SizeOf(TColor32Rec
));
1854 FreeImage(Images
[I
]);
1855 Images
[I
] := Target
;
1860 RaiseImaging(SErrorMakePaletteForImages
, [MaxColors
, Length(Images
)]);
1864 function RotateImage(var Image
: TImageData
; Angle
: Single): Boolean;
1866 OldFmt
: TImageFormat
;
1868 procedure XShear(var Src
, Dst
: TImageData
; Row
, Offset
, Weight
, Bpp
: Integer);
1870 I
, J
, XPos
: Integer;
1871 PixSrc
, PixLeft
, PixOldLeft
: TColor32Rec
;
1872 LineDst
: PByteArray
;
1875 SrcPtr
:= @PByteArray(Src
.Bits
)[Row
* Src
.Width
* Bpp
];
1876 LineDst
:= @PByteArray(Dst
.Bits
)[Row
* Dst
.Width
* Bpp
];
1877 PixOldLeft
.Color
:= 0;
1879 for I
:= 0 to Src
.Width
- 1 do
1881 CopyPixel(SrcPtr
, @PixSrc
, Bpp
);
1882 for J
:= 0 to Bpp
- 1 do
1883 PixLeft
.Channels
[J
] := MulDiv(PixSrc
.Channels
[J
], Weight
, 256);
1886 if (XPos
>= 0) and (XPos
< Dst
.Width
) then
1888 for J
:= 0 to Bpp
- 1 do
1889 PixSrc
.Channels
[J
] := PixSrc
.Channels
[J
] - (PixLeft
.Channels
[J
] - PixOldLeft
.Channels
[J
]);
1890 CopyPixel(@PixSrc
, @LineDst
[XPos
* Bpp
], Bpp
);
1892 PixOldLeft
:= PixLeft
;
1893 Inc(PByte(SrcPtr
), Bpp
);
1896 XPos
:= Src
.Width
+ Offset
;
1897 if XPos
< Dst
.Width
then
1898 CopyPixel(@PixOldLeft
, @LineDst
[XPos
* Bpp
], Bpp
);
1901 procedure YShear(var Src
, Dst
: TImageData
; Col
, Offset
, Weight
, Bpp
: Integer);
1903 I
, J
, YPos
: Integer;
1904 PixSrc
, PixLeft
, PixOldLeft
: TColor32Rec
;
1907 SrcPtr
:= @PByteArray(Src
.Bits
)[Col
* Bpp
];
1908 PixOldLeft
.Color
:= 0;
1910 for I
:= 0 to Src
.Height
- 1 do
1912 CopyPixel(SrcPtr
, @PixSrc
, Bpp
);
1913 for J
:= 0 to Bpp
- 1 do
1914 PixLeft
.Channels
[J
] := MulDiv(PixSrc
.Channels
[J
], Weight
, 256);
1917 if (YPos
>= 0) and (YPos
< Dst
.Height
) then
1919 for J
:= 0 to Bpp
- 1 do
1920 PixSrc
.Channels
[J
] := PixSrc
.Channels
[J
] - (PixLeft
.Channels
[J
] - PixOldLeft
.Channels
[J
]);
1921 CopyPixel(@PixSrc
, @PByteArray(Dst
.Bits
)[(YPos
* Dst
.Width
+ Col
) * Bpp
], Bpp
);
1923 PixOldLeft
:= PixLeft
;
1924 Inc(SrcPtr
, Src
.Width
* Bpp
);
1927 YPos
:= Src
.Height
+ Offset
;
1928 if YPos
< Dst
.Height
then
1929 CopyPixel(@PixOldLeft
, @PByteArray(Dst
.Bits
)[(YPos
* Dst
.Width
+ Col
) * Bpp
], Bpp
);
1932 procedure Rotate45(var Image
: TImageData
; Angle
: Single);
1934 TempImage1
, TempImage2
: TImageData
;
1935 AngleRad
, AngleTan
, AngleSin
, AngleCos
, Shear
: Single;
1936 I
, DstWidth
, DstHeight
, SrcWidth
, SrcHeight
, Bpp
: Integer;
1937 SrcFmt
, TempFormat
: TImageFormat
;
1938 Info
: TImageFormatInfo
;
1940 AngleRad
:= Angle
* Pi
/ 180;
1941 AngleSin
:= Sin(AngleRad
);
1942 AngleCos
:= Cos(AngleRad
);
1943 AngleTan
:= Sin(AngleRad
/ 2) / Cos(AngleRad
/ 2);
1944 SrcWidth
:= Image
.Width
;
1945 SrcHeight
:= Image
.Height
;
1946 SrcFmt
:= Image
.Format
;
1948 if not (SrcFmt
in [ifR8G8B8
..ifX8R8G8B8
, ifGray8
..ifGray32
, ifA16Gray16
]) then
1949 ConvertImage(Image
, ifA8R8G8B8
);
1951 TempFormat
:= Image
.Format
;
1952 GetImageFormatInfo(TempFormat
, Info
);
1953 Bpp
:= Info
.BytesPerPixel
;
1955 // 1st shear (horizontal)
1956 DstWidth
:= Trunc(SrcWidth
+ SrcHeight
* Abs(AngleTan
) + 0.5);
1957 DstHeight
:= SrcHeight
;
1958 NewImage(DstWidth
, DstHeight
, TempFormat
, TempImage1
);
1960 for I
:= 0 to DstHeight
- 1 do
1962 if AngleTan
>= 0 then
1963 Shear
:= (I
+ 0.5) * AngleTan
1965 Shear
:= (I
- DstHeight
+ 0.5) * AngleTan
;
1966 XShear(Image
, TempImage1
, I
, Floor(Shear
), Trunc(255 * (Shear
- Floor(Shear
)) + 1), Bpp
);
1969 // 2nd shear (vertical)
1971 DstHeight
:= Trunc(SrcWidth
* Abs(AngleSin
) + SrcHeight
* AngleCos
+ 0.5) + 1;
1972 NewImage(DstWidth
, DstHeight
, TempFormat
, TempImage2
);
1974 if AngleSin
>= 0 then
1975 Shear
:= (SrcWidth
- 1) * AngleSin
1977 Shear
:= (SrcWidth
- DstWidth
) * -AngleSin
;
1979 for I
:= 0 to DstWidth
- 1 do
1981 YShear(TempImage1
, TempImage2
, I
, Floor(Shear
), Trunc(255 * (Shear
- Floor(Shear
)) + 1), Bpp
);
1982 Shear
:= Shear
- AngleSin
;
1985 // 3rd shear (horizontal)
1986 FreeImage(TempImage1
);
1987 DstWidth
:= Trunc(SrcHeight
* Abs(AngleSin
) + SrcWidth
* AngleCos
+ 0.5) + 1;
1988 NewImage(DstWidth
, DstHeight
, TempFormat
, Image
);
1990 if AngleSin
>= 0 then
1991 Shear
:= (SrcWidth
- 1) * AngleSin
* -AngleTan
1993 Shear
:= ((SrcWidth
- 1) * -AngleSin
+ (1 - DstHeight
)) * AngleTan
;
1995 for I
:= 0 to DstHeight
- 1 do
1997 XShear(TempImage2
, Image
, I
, Floor(Shear
), Trunc(255 * (Shear
- Floor(Shear
)) + 1), Bpp
);
1998 Shear
:= Shear
+ AngleTan
;
2001 FreeImage(TempImage2
);
2002 if Image
.Format
<> SrcFmt
then
2003 ConvertImage(Image
, SrcFmt
);
2006 procedure RotateMul90(var Image
: TImageData
; Angle
: Integer);
2008 RotImage
: TImageData
;
2009 X
, Y
, BytesPerPixel
: Integer;
2012 InitImage(RotImage
);
2013 BytesPerPixel
:= ImageFormatInfos
[Image
.Format
].BytesPerPixel
;
2015 if ((Angle
= 90) or (Angle
= 270)) and (Image
.Width
<> Image
.Height
) then
2016 NewImage(Image
.Height
, Image
.Width
, Image
.Format
, RotImage
)
2018 NewImage(Image
.Width
, Image
.Height
, Image
.Format
, RotImage
);
2020 RotPix
:= RotImage
.Bits
;
2024 for Y
:= 0 to RotImage
.Height
- 1 do
2026 Pix
:= @PByteArray(Image
.Bits
)[(Image
.Width
- Y
- 1) * BytesPerPixel
];
2027 for X
:= 0 to RotImage
.Width
- 1 do
2029 CopyPixel(Pix
, RotPix
, BytesPerPixel
);
2030 Inc(RotPix
, BytesPerPixel
);
2031 Inc(Pix
, Image
.Width
* BytesPerPixel
);
2037 Pix
:= @PByteArray(Image
.Bits
)[((Image
.Height
- 1) * Image
.Width
+
2038 (Image
.Width
- 1)) * BytesPerPixel
];
2039 for Y
:= 0 to RotImage
.Height
- 1 do
2040 for X
:= 0 to RotImage
.Width
- 1 do
2042 CopyPixel(Pix
, RotPix
, BytesPerPixel
);
2043 Inc(RotPix
, BytesPerPixel
);
2044 Dec(Pix
, BytesPerPixel
);
2049 for Y
:= 0 to RotImage
.Height
- 1 do
2051 Pix
:= @PByteArray(Image
.Bits
)[((Image
.Height
- 1) * Image
.Width
+ Y
) * BytesPerPixel
];
2052 for X
:= 0 to RotImage
.Width
- 1 do
2054 CopyPixel(Pix
, RotPix
, BytesPerPixel
);
2055 Inc(RotPix
, BytesPerPixel
);
2056 Dec(Pix
, Image
.Width
* BytesPerPixel
);
2062 FreeMemNil(Image
.Bits
);
2063 RotImage
.Palette
:= Image
.Palette
;
2070 if TestImage(Image
) then
2072 while Angle
>= 360 do
2073 Angle
:= Angle
- 360;
2075 Angle
:= Angle
+ 360;
2077 if (Angle
= 0) or (Abs(Angle
) = 360) then
2083 OldFmt
:= Image
.Format
;
2084 if ImageFormatInfos
[Image
.Format
].IsSpecial
then
2085 ConvertImage(Image
, ifDefault
);
2087 if (Angle
> 45) and (Angle
<= 135) then
2089 RotateMul90(Image
, 90);
2090 Angle
:= Angle
- 90;
2092 else if (Angle
> 135) and (Angle
<= 225) then
2094 RotateMul90(Image
, 180);
2095 Angle
:= Angle
- 180;
2097 else if (Angle
> 225) and (Angle
<= 315) then
2099 RotateMul90(Image
, 270);
2100 Angle
:= Angle
- 270;
2104 Rotate45(Image
, Angle
);
2106 if OldFmt
<> Image
.Format
then
2107 ConvertImage(Image
, OldFmt
);
2111 RaiseImaging(SErrorRotateImage
, [ImageToStr(Image
), Angle
]);
2115 { Drawing/Pixel functions }
2117 function CopyRect(const SrcImage
: TImageData
; SrcX
, SrcY
, Width
, Height
: LongInt;
2118 var DstImage
: TImageData
; DstX
, DstY
: LongInt): Boolean;
2120 Info
: PImageFormatInfo
;
2121 I
, SrcWidthBytes
, DstWidthBytes
, MoveBytes
: LongInt;
2122 SrcPointer
, DstPointer
: PByte;
2123 WorkImage
: TImageData
;
2124 OldFormat
: TImageFormat
;
2127 OldFormat
:= ifUnknown
;
2128 if TestImage(SrcImage
) and TestImage(DstImage
) then
2130 // Make sure we are still copying image to image, not invalid pointer to protected memory
2131 ClipCopyBounds(SrcX
, SrcY
, Width
, Height
, DstX
, DstY
, SrcImage
.Width
, SrcImage
.Height
,
2132 Rect(0, 0, DstImage
.Width
, DstImage
.Height
));
2134 if (Width
> 0) and (Height
> 0) then
2136 Info
:= ImageFormatInfos
[DstImage
.Format
];
2137 if Info
.IsSpecial
then
2139 // If dest image is in special format we convert it to default
2140 OldFormat
:= Info
.Format
;
2141 ConvertImage(DstImage
, ifDefault
);
2142 Info
:= ImageFormatInfos
[DstImage
.Format
];
2144 if SrcImage
.Format
<> DstImage
.Format
then
2146 // If images are in different format source is converted to dest's format
2147 InitImage(WorkImage
);
2148 CloneImage(SrcImage
, WorkImage
);
2149 ConvertImage(WorkImage
, DstImage
.Format
);
2152 WorkImage
:= SrcImage
;
2154 MoveBytes
:= Width
* Info
.BytesPerPixel
;
2155 DstWidthBytes
:= DstImage
.Width
* Info
.BytesPerPixel
;
2156 DstPointer
:= @PByteArray(DstImage
.Bits
)[DstY
* DstWidthBytes
+
2157 DstX
* Info
.BytesPerPixel
];
2158 SrcWidthBytes
:= WorkImage
.Width
* Info
.BytesPerPixel
;
2159 SrcPointer
:= @PByteArray(WorkImage
.Bits
)[SrcY
* SrcWidthBytes
+
2160 SrcX
* Info
.BytesPerPixel
];
2162 for I
:= 0 to Height
- 1 do
2164 Move(SrcPointer
^, DstPointer
^, MoveBytes
);
2165 Inc(SrcPointer
, SrcWidthBytes
);
2166 Inc(DstPointer
, DstWidthBytes
);
2168 // If dest image was in special format we convert it back
2169 if OldFormat
<> ifUnknown
then
2170 ConvertImage(DstImage
, OldFormat
);
2171 // Working image must be freed if it is not the same as source image
2172 if WorkImage
.Bits
<> SrcImage
.Bits
then
2173 FreeImage(WorkImage
);
2178 RaiseImaging(SErrorCopyRect
, [ImageToStr(SrcImage
), ImageToStr(DstImage
)]);
2182 function FillRect(var Image
: TImageData
; X
, Y
, Width
, Height
: LongInt;
2183 FillColor
: Pointer): Boolean;
2185 Info
: PImageFormatInfo
;
2186 I
, J
, ImageWidthBytes
, RectWidthBytes
, Bpp
: Longint;
2187 LinePointer
, PixPointer
: PByte;
2188 OldFmt
: TImageFormat
;
2191 if TestImage(Image
) then
2193 ClipRectBounds(X
, Y
, Width
, Height
, Rect(0, 0, Image
.Width
, Image
.Height
));
2195 if (Width
> 0) and (Height
> 0) then
2197 OldFmt
:= Image
.Format
;
2198 if ImageFormatInfos
[OldFmt
].IsSpecial
then
2199 ConvertImage(Image
, ifDefault
);
2201 Info
:= ImageFormatInfos
[Image
.Format
];
2202 Bpp
:= Info
.BytesPerPixel
;
2203 ImageWidthBytes
:= Image
.Width
* Bpp
;
2204 RectWidthBytes
:= Width
* Bpp
;
2205 LinePointer
:= @PByteArray(Image
.Bits
)[Y
* ImageWidthBytes
+ X
* Bpp
];
2207 for I
:= 0 to Height
- 1 do
2210 1: FillMemoryByte(LinePointer
, RectWidthBytes
, PByte(FillColor
)^);
2211 2: FillMemoryWord(LinePointer
, RectWidthBytes
, PWord(FillColor
)^);
2212 4: FillMemoryLongWord(LinePointer
, RectWidthBytes
, PLongWord(FillColor
)^);
2214 PixPointer
:= LinePointer
;
2215 for J
:= 0 to Width
- 1 do
2217 CopyPixel(FillColor
, PixPointer
, Bpp
);
2218 Inc(PixPointer
, Bpp
);
2221 Inc(LinePointer
, ImageWidthBytes
);
2224 if OldFmt
<> Image
.Format
then
2225 ConvertImage(Image
, OldFmt
);
2230 RaiseImaging(SErrorFillRect
, [X
, Y
, Width
, Height
, ImageToStr(Image
)]);
2234 function ReplaceColor(var Image
: TImageData
; X
, Y
, Width
, Height
: LongInt;
2235 OldColor
, NewColor
: Pointer): Boolean;
2237 Info
: PImageFormatInfo
;
2238 I
, J
, WidthBytes
, Bpp
: Longint;
2239 LinePointer
, PixPointer
: PByte;
2240 OldFmt
: TImageFormat
;
2242 Assert((OldColor
<> nil) and (NewColor
<> nil));
2244 if TestImage(Image
) then
2246 ClipRectBounds(X
, Y
, Width
, Height
, Rect(0, 0, Image
.Width
, Image
.Height
));
2248 if (Width
> 0) and (Height
> 0) then
2250 OldFmt
:= Image
.Format
;
2251 if ImageFormatInfos
[OldFmt
].IsSpecial
then
2252 ConvertImage(Image
, ifDefault
);
2254 Info
:= ImageFormatInfos
[Image
.Format
];
2255 Bpp
:= Info
.BytesPerPixel
;
2256 WidthBytes
:= Image
.Width
* Bpp
;
2257 LinePointer
:= @PByteArray(Image
.Bits
)[Y
* WidthBytes
+ X
* Bpp
];
2259 for I
:= 0 to Height
- 1 do
2261 PixPointer
:= LinePointer
;
2262 for J
:= 0 to Width
- 1 do
2264 if ComparePixels(PixPointer
, OldColor
, Bpp
) then
2265 CopyPixel(NewColor
, PixPointer
, Bpp
);
2266 Inc(PixPointer
, Bpp
);
2268 Inc(LinePointer
, WidthBytes
);
2271 if OldFmt
<> Image
.Format
then
2272 ConvertImage(Image
, OldFmt
);
2277 RaiseImaging(SErrorReplaceColor
, [X
, Y
, Width
, Height
, ImageToStr(Image
)]);
2281 function StretchRect(const SrcImage
: TImageData
; SrcX
, SrcY
, SrcWidth
,
2282 SrcHeight
: LongInt; var DstImage
: TImageData
; DstX
, DstY
, DstWidth
,
2283 DstHeight
: LongInt; Filter
: TResizeFilter
): Boolean;
2285 Info
: PImageFormatInfo
;
2286 WorkImage
: TImageData
;
2287 OldFormat
: TImageFormat
;
2290 OldFormat
:= ifUnknown
;
2291 if TestImage(SrcImage
) and TestImage(DstImage
) then
2293 // Make sure we are still copying image to image, not invalid pointer to protected memory
2294 ClipStretchBounds(SrcX
, SrcY
, SrcWidth
, SrcHeight
, DstX
, DstY
, DstWidth
, DstHeight
,
2295 SrcImage
.Width
, SrcImage
.Height
, Rect(0, 0, DstImage
.Width
, DstImage
.Height
));
2297 if (SrcWidth
= DstWidth
) and (SrcHeight
= DstHeight
) then
2299 // If source and dest rectangles have the same size call CopyRect
2300 Result
:= CopyRect(SrcImage
, SrcX
, SrcY
, SrcWidth
, SrcHeight
, DstImage
, DstX
, DstY
);
2302 else if (SrcWidth
> 0) and (SrcHeight
> 0) and (DstWidth
> 0) and (DstHeight
> 0) then
2304 // If source and dest rectangles don't have the same size we do stretch
2305 Info
:= ImageFormatInfos
[DstImage
.Format
];
2307 if Info
.IsSpecial
then
2309 // If dest image is in special format we convert it to default
2310 OldFormat
:= Info
.Format
;
2311 ConvertImage(DstImage
, ifDefault
);
2312 Info
:= ImageFormatInfos
[DstImage
.Format
];
2315 if SrcImage
.Format
<> DstImage
.Format
then
2317 // If images are in different format source is converted to dest's format
2318 InitImage(WorkImage
);
2319 CloneImage(SrcImage
, WorkImage
);
2320 ConvertImage(WorkImage
, DstImage
.Format
);
2323 WorkImage
:= SrcImage
;
2325 // Only pixel resize is supported for indexed images
2326 if Info
.IsIndexed
then
2327 Filter
:= rfNearest
;
2330 rfNearest
: StretchNearest(WorkImage
, SrcX
, SrcY
, SrcWidth
, SrcHeight
,
2331 DstImage
, DstX
, DstY
, DstWidth
, DstHeight
);
2332 rfBilinear
: StretchResample(WorkImage
, SrcX
, SrcY
, SrcWidth
, SrcHeight
,
2333 DstImage
, DstX
, DstY
, DstWidth
, DstHeight
, sfLinear
);
2334 rfBicubic
: StretchResample(WorkImage
, SrcX
, SrcY
, SrcWidth
, SrcHeight
,
2335 DstImage
, DstX
, DstY
, DstWidth
, DstHeight
, sfCatmullRom
);
2338 // If dest image was in special format we convert it back
2339 if OldFormat
<> ifUnknown
then
2340 ConvertImage(DstImage
, OldFormat
);
2341 // Working image must be freed if it is not the same as source image
2342 if WorkImage
.Bits
<> SrcImage
.Bits
then
2343 FreeImage(WorkImage
);
2348 RaiseImaging(SErrorStretchRect
, [ImageToStr(SrcImage
), ImageToStr(DstImage
)]);
2352 procedure GetPixelDirect(const Image
: TImageData
; X
, Y
: LongInt; Pixel
: Pointer);
2354 BytesPerPixel
: LongInt;
2356 Assert(Pixel
<> nil);
2357 BytesPerPixel
:= ImageFormatInfos
[Image
.Format
].BytesPerPixel
;
2358 CopyPixel(@PByteArray(Image
.Bits
)[(Y
* Image
.Width
+ X
) * BytesPerPixel
],
2359 Pixel
, BytesPerPixel
);
2362 procedure SetPixelDirect(const Image
: TImageData
; X
, Y
: LongInt; Pixel
: Pointer);
2364 BytesPerPixel
: LongInt;
2366 Assert(Pixel
<> nil);
2367 BytesPerPixel
:= ImageFormatInfos
[Image
.Format
].BytesPerPixel
;
2368 CopyPixel(Pixel
, @PByteArray(Image
.Bits
)[(Y
* Image
.Width
+ X
) * BytesPerPixel
],
2372 function GetPixel32(const Image
: TImageData
; X
, Y
: LongInt): TColor32Rec
;
2374 Info
: PImageFormatInfo
;
2377 Info
:= ImageFormatInfos
[Image
.Format
];
2378 Data
:= @PByteArray(Image
.Bits
)[(Y
* Image
.Width
+ X
) * Info
.BytesPerPixel
];
2379 Result
:= GetPixel32Generic(Data
, Info
, Image
.Palette
);
2382 procedure SetPixel32(const Image
: TImageData
; X
, Y
: LongInt; const Color
: TColor32Rec
);
2384 Info
: PImageFormatInfo
;
2387 Info
:= ImageFormatInfos
[Image
.Format
];
2388 Data
:= @PByteArray(Image
.Bits
)[(Y
* Image
.Width
+ X
) * Info
.BytesPerPixel
];
2389 SetPixel32Generic(Data
, Info
, Image
.Palette
, Color
);
2392 function GetPixelFP(const Image
: TImageData
; X
, Y
: LongInt): TColorFPRec
;
2394 Info
: PImageFormatInfo
;
2397 Info
:= ImageFormatInfos
[Image
.Format
];
2398 Data
:= @PByteArray(Image
.Bits
)[(Y
* Image
.Width
+ X
) * Info
.BytesPerPixel
];
2399 Result
:= GetPixelFPGeneric(Data
, Info
, Image
.Palette
);
2402 procedure SetPixelFP(const Image
: TImageData
; X
, Y
: LongInt; const Color
: TColorFPRec
);
2404 Info
: PImageFormatInfo
;
2407 Info
:= ImageFormatInfos
[Image
.Format
];
2408 Data
:= @PByteArray(Image
.Bits
)[(Y
* Image
.Width
+ X
) * Info
.BytesPerPixel
];
2409 SetPixelFPGeneric(Data
, Info
, Image
.Palette
, Color
);
2412 { Palette Functions }
2414 procedure NewPalette(Entries
: LongInt; var Pal
: PPalette32
);
2416 Assert((Entries
> 2) and (Entries
<= 65535));
2418 GetMem(Pal
, Entries
* SizeOf(TColor32Rec
));
2419 FillChar(Pal
^, Entries
* SizeOf(TColor32Rec
), $FF);
2421 RaiseImaging(SErrorNewPalette
, [Entries
]);
2425 procedure FreePalette(var Pal
: PPalette32
);
2430 RaiseImaging(SErrorFreePalette
, [Pal
]);
2434 procedure CopyPalette(SrcPal
, DstPal
: PPalette32
; SrcIdx
, DstIdx
, Count
: LongInt);
2436 Assert((SrcPal
<> nil) and (DstPal
<> nil));
2437 Assert((SrcIdx
>= 0) and (DstIdx
>= 0) and (Count
>= 0));
2439 Move(SrcPal
[SrcIdx
], DstPal
[DstIdx
], Count
* SizeOf(TColor32Rec
));
2441 RaiseImaging(SErrorCopyPalette
, [Count
, SrcPal
, DstPal
]);
2445 function FindColor(Pal
: PPalette32
; Entries
: LongInt; Color
: TColor32
):
2449 I
, MinDif
, Dif
: LongInt;
2455 // First try to find exact match
2456 for I
:= 0 to Entries
- 1 do
2459 if (A
= Col
.A
) and (R
= Col
.R
) and
2460 (G
= Col
.G
) and (B
= Col
.B
) then
2467 // If exact match was not found, find nearest color
2469 for I
:= 0 to Entries
- 1 do
2472 Dif
:= Abs(R
- Col
.R
);
2473 if Dif
> MinDif
then Continue
;
2474 Dif
:= Dif
+ Abs(G
- Col
.G
);
2475 if Dif
> MinDif
then Continue
;
2476 Dif
:= Dif
+ Abs(B
- Col
.B
);
2477 if Dif
> MinDif
then Continue
;
2478 Dif
:= Dif
+ Abs(A
- Col
.A
);
2479 if Dif
< MinDif
then
2486 RaiseImaging(SErrorFindColor
, [Pal
, Entries
]);
2490 procedure FillGrayscalePalette(Pal
: PPalette32
; Entries
: LongInt);
2496 for I
:= 0 to Entries
- 1 do
2505 RaiseImaging(SErrorGrayscalePalette
, [Pal
, Entries
]);
2509 procedure FillCustomPalette(Pal
: PPalette32
; Entries
: LongInt; RBits
, GBits
,
2510 BBits
: Byte; Alpha
: Byte = $FF);
2512 I
, TotalBits
, MaxEntries
: LongInt;
2515 TotalBits
:= RBits
+ GBits
+ BBits
;
2516 MaxEntries
:= Min(Pow2Int(TotalBits
), Entries
);
2517 FillChar(Pal
^, Entries
* SizeOf(TColor32Rec
), 0);
2519 for I
:= 0 to MaxEntries
- 1 do
2524 R
:= ((I
shr Max(0, GBits
+ BBits
- 1)) and (1 shl RBits
- 1)) * 255 div (1 shl RBits
- 1);
2526 G
:= ((I
shr Max(0, BBits
- 1)) and (1 shl GBits
- 1)) * 255 div (1 shl GBits
- 1);
2528 B
:= ((I
shr 0) and (1 shl BBits
- 1)) * 255 div (1 shl BBits
- 1);
2531 RaiseImaging(SErrorCustomPalette
, [Pal
, Entries
]);
2535 procedure SwapChannelsOfPalette(Pal
: PPalette32
; Entries
, SrcChannel
,
2536 DstChannel
: LongInt);
2542 Assert((SrcChannel
in [0..3]) and (DstChannel
in [0..3]));
2544 for I
:= 0 to Entries
- 1 do
2547 Swap
:= Channels
[SrcChannel
];
2548 Channels
[SrcChannel
] := Channels
[DstChannel
];
2549 Channels
[DstChannel
] := Swap
;
2552 RaiseImaging(SErrorSwapPalette
, [Pal
, Entries
]);
2556 { Options Functions }
2558 function SetOption(OptionId
, Value
: LongInt): Boolean;
2561 if (OptionId
>= 0) and (OptionId
< Length(Options
)) and
2562 (Options
[OptionID
] <> nil) then
2564 Options
[OptionID
]^ := CheckOptionValue(OptionId
, Value
);
2569 function GetOption(OptionId
: LongInt): LongInt;
2571 Result
:= InvalidOption
;
2572 if (OptionId
>= 0) and (OptionId
< Length(Options
)) and
2573 (Options
[OptionID
] <> nil) then
2575 Result
:= Options
[OptionID
]^;
2579 function PushOptions
: Boolean;
2581 Result
:= OptionStack
.Push
;
2584 function PopOptions
: Boolean;
2586 Result
:= OptionStack
.Pop
;
2589 { Image Format Functions }
2591 function GetImageFormatInfo(Format
: TImageFormat
; out Info
: TImageFormatInfo
): Boolean;
2593 FillChar(Info
, SizeOf(Info
), 0);
2594 if ImageFormatInfos
[Format
] <> nil then
2596 Info
:= ImageFormatInfos
[Format
]^;
2603 function GetPixelsSize(Format
: TImageFormat
; Width
, Height
: LongInt): LongInt;
2605 if ImageFormatInfos
[Format
] <> nil then
2606 Result
:= ImageFormatInfos
[Format
].GetPixelsSize(Format
, Width
, Height
)
2613 procedure SetUserFileIO(OpenReadProc
: TOpenReadProc
; OpenWriteProc
:
2615 CloseProc
: TCloseProc
; EofProc
: TEofProc
; SeekProc
: TSeekProc
; TellProc
:
2616 TTellProc
; ReadProc
: TReadProc
; WriteProc
: TWriteProc
);
2618 FileIO
.OpenRead
:= OpenReadProc
;
2619 FileIO
.OpenWrite
:= OpenWriteProc
;
2620 FileIO
.Close
:= CloseProc
;
2621 FileIO
.Eof
:= EofProc
;
2622 FileIO
.Seek
:= SeekProc
;
2623 FileIO
.Tell
:= TellProc
;
2624 FileIO
.Read
:= ReadProc
;
2625 FileIO
.Write
:= WriteProc
;
2628 procedure ResetFileIO
;
2630 FileIO
:= OriginalFileIO
;
2634 { ------------------------------------------------------------------------
2636 ------------------------------------------------------------------------}
2638 function GetFormatName(Format
: TImageFormat
): string;
2640 if ImageFormatInfos
[Format
] <> nil then
2641 Result
:= ImageFormatInfos
[Format
].Name
2643 Result
:= SUnknownFormat
;
2646 function ImageToStr(const Image
: TImageData
): string;
2650 if TestImage(Image
) then
2654 if ImgSize
> 8192 then
2655 ImgSize
:= ImgSize
div 1024;
2656 Result
:= SysUtils
.Format(SImageInfo
, [@Image
, Width
, Height
,
2657 GetFormatName(Format
), ImgSize
+ 0.0, Iff(ImgSize
= Size
, 'B', 'KiB'), Bits
,
2661 Result
:= SysUtils
.Format(SImageInfoInvalid
, [@Image
]);
2664 function GetVersionStr
: string;
2666 Result
:= Format('%.1d.%.2d.%.1d', [ImagingVersionMajor
,
2667 ImagingVersionMinor
, ImagingVersionPatch
]);
2670 function IffFormat(Condition
: Boolean; const TruePart
, FalsePart
: TImageFormat
): TImageFormat
;
2675 Result
:= FalsePart
;
2678 procedure RegisterImageFileFormat(AClass
: TImageFileFormatClass
);
2680 Assert(AClass
<> nil);
2681 if ImageFileFormats
= nil then
2682 ImageFileFormats
:= TList
.Create
;
2683 if ImageFileFormats
<> nil then
2684 ImageFileFormats
.Add(AClass
.Create
);
2687 function RegisterOption(OptionId
: LongInt; Variable
: PLongInt): Boolean;
2690 if Options
= nil then
2693 Assert(Variable
<> nil);
2695 if OptionId
>= Length(Options
) then
2696 SetLength(Options
, OptionId
+ InitialOptions
);
2697 if (OptionId
>= 0) and (OptionId
< Length(Options
)) {and (Options[OptionId] = nil) - must be able to override existing } then
2699 Options
[OptionId
] := Variable
;
2704 function FindImageFileFormatByExt(const Ext
: string): TImageFileFormat
;
2709 for I
:= ImageFileFormats
.Count
- 1 downto 0 do
2710 if TImageFileFormat(ImageFileFormats
[I
]).Extensions
.IndexOf(Ext
) >= 0 then
2712 Result
:= TImageFileFormat(ImageFileFormats
[I
]);
2717 function FindImageFileFormatByName(const FileName
: string): TImageFileFormat
;
2722 for I
:= ImageFileFormats
.Count
- 1 downto 0 do
2723 if TImageFileFormat(ImageFileFormats
[I
]).TestFileName(FileName
) then
2725 Result
:= TImageFileFormat(ImageFileFormats
[I
]);
2730 function FindImageFileFormatByClass(AClass
: TImageFileFormatClass
): TImageFileFormat
;
2735 for I
:= 0 to ImageFileFormats
.Count
- 1 do
2736 if TImageFileFormat(ImageFileFormats
[I
]) is AClass
then
2738 Result
:= TObject(ImageFileFormats
[I
]) as TImageFileFormat
;
2743 function GetFileFormatCount
: LongInt;
2745 Result
:= ImageFileFormats
.Count
;
2748 function GetFileFormatAtIndex(Index
: LongInt): TImageFileFormat
;
2750 if (Index
>= 0) and (Index
< ImageFileFormats
.Count
) then
2751 Result
:= TImageFileFormat(ImageFileFormats
[Index
])
2756 function GetImageFileFormatsFilter(OpenFileFilter
: Boolean): string;
2758 I
, J
, Count
: LongInt;
2759 Descriptions
: string;
2760 Filters
, CurFilter
: string;
2761 FileFormat
: TImageFileFormat
;
2767 for I
:= 0 to ImageFileFormats
.Count
- 1 do
2769 FileFormat
:= TObject(ImageFileFormats
[I
]) as TImageFileFormat
;
2771 // If we are creating filter for save dialog and this format cannot save
2772 // files the we skip it
2773 if not OpenFileFilter
and not FileFormat
.CanSave
then
2777 for J
:= 0 to FileFormat
.Masks
.Count
- 1 do
2779 CurFilter
:= CurFilter
+ FileFormat
.Masks
[J
];
2780 if J
< FileFormat
.Masks
.Count
- 1 then
2781 CurFilter
:= CurFilter
+ ';';
2784 FmtStr(Descriptions
, '%s%s (%s)|%2:s', [Descriptions
, FileFormat
.Name
, CurFilter
]);
2785 if Filters
<> '' then
2786 FmtStr(Filters
, '%s;%s', [Filters
, CurFilter
])
2788 Filters
:= CurFilter
;
2790 if I
< ImageFileFormats
.Count
- 1 then
2791 Descriptions
:= Descriptions
+ '|';
2796 if (Count
> 1) and OpenFileFilter
then
2797 FmtStr(Descriptions
, '%s (%s)|%1:s|%s', [SAllFilter
, Filters
, Descriptions
]);
2799 Result
:= Descriptions
;
2802 function GetFilterIndexExtension(Index
: LongInt; OpenFileFilter
: Boolean): string;
2805 FileFormat
: TImageFileFormat
;
2807 // -1 because filter indices are in 1..n range
2810 if OpenFileFilter
then
2816 if (Index
>= 0) and (Index
< ImageFileFormats
.Count
) then
2819 for I
:= 0 to ImageFileFormats
.Count
- 1 do
2821 FileFormat
:= TObject(ImageFileFormats
[I
]) as TImageFileFormat
;
2822 if not OpenFileFilter
and not FileFormat
.CanSave
then
2824 if Index
= Count
then
2826 if FileFormat
.Extensions
.Count
> 0 then
2827 Result
:= FileFormat
.Extensions
[0];
2835 function GetFileNameFilterIndex(const FileName
: string; OpenFileFilter
: Boolean): LongInt;
2838 FileFormat
: TImageFileFormat
;
2841 for I
:= 0 to ImageFileFormats
.Count
- 1 do
2843 FileFormat
:= TObject(ImageFileFormats
[I
]) as TImageFileFormat
;
2844 if not OpenFileFilter
and not FileFormat
.CanSave
then
2846 if FileFormat
.TestFileName(FileName
) then
2848 // +1 because filter indices are in 1..n range
2850 if OpenFileFilter
then
2859 function GetIO
: TIOFunctions
;
2864 procedure RaiseImaging(const Msg
: string; const Args
: array of const);
2869 if GetExceptObject
<> nil then
2870 WholeMsg
:= WholeMsg
+ ' ' + SExceptMsg
+ ': ' +
2871 GetExceptObject
.Message;
2872 raise EImagingError
.CreateFmt(WholeMsg
, Args
);
2875 { Internal unit functions }
2877 function CheckOptionValue(OptionId
, Value
: LongInt): LongInt;
2880 ImagingColorReductionMask
:
2881 Result
:= ClampInt(Value
, 0, $FF);
2882 ImagingLoadOverrideFormat
, ImagingSaveOverrideFormat
:
2883 Result
:= Iff(ImagingFormats
.IsImageFormatValid(TImageFormat(Value
)),
2884 Value
, LongInt(ifUnknown
));
2885 ImagingMipMapFilter
: Result
:= ClampInt(Value
, Ord(Low(TSamplingFilter
)),
2886 Ord(High(TSamplingFilter
)));
2892 procedure SetFileIO
;
2897 procedure SetStreamIO
;
2902 procedure SetMemoryIO
;
2907 procedure InitImageFormats
;
2909 ImagingFormats
.InitImageFormats(ImageFormatInfos
);
2912 procedure FreeImageFileFormats
;
2916 if ImageFileFormats
<> nil then
2917 for I
:= 0 to ImageFileFormats
.Count
- 1 do
2918 TImageFileFormat(ImageFileFormats
[I
]).Free
;
2919 FreeAndNil(ImageFileFormats
);
2922 procedure InitOptions
;
2924 SetLength(Options
, InitialOptions
);
2925 OptionStack
:= TOptionStack
.Create
;
2928 procedure FreeOptions
;
2930 SetLength(Options
, 0);
2931 FreeAndNil(OptionStack
);
2935 TImageFileFormat class implementation
2938 constructor TImageFileFormat
.Create
;
2941 FName
:= SUnknownFormat
;
2942 FExtensions
:= TStringList
.Create
;
2943 FMasks
:= TStringList
.Create
;
2946 destructor TImageFileFormat
.Destroy
;
2953 function TImageFileFormat
.PrepareLoad(Handle
: TImagingHandle
;
2954 var Images
: TDynImageDataArray
; OnlyFirstFrame
: Boolean): Boolean;
2956 FreeImagesInArray(Images
);
2957 SetLength(Images
, 0);
2958 Result
:= Handle
<> nil;
2961 function TImageFileFormat
.PostLoadCheck(var Images
: TDynImageDataArray
;
2962 LoadResult
: Boolean): Boolean;
2966 if not LoadResult
then
2968 FreeImagesInArray(Images
);
2969 SetLength(Images
, 0);
2974 Result
:= (Length(Images
) > 0) and TestImagesInArray(Images
);
2978 // Convert to overriden format if it is set
2979 if LoadOverrideFormat
<> ifUnknown
then
2980 for I
:= Low(Images
) to High(Images
) do
2981 ConvertImage(Images
[I
], LoadOverrideFormat
);
2986 function TImageFileFormat
.PrepareSave(Handle
: TImagingHandle
;
2987 const Images
: TDynImageDataArray
; var Index
: Integer): Boolean;
2991 CheckOptionsValidity
;
2995 Len
:= Length(Images
);
2998 // If there are no images to be saved exit
2999 if Len
= 0 then Exit
;
3001 // Check index of image to be saved (-1 as index means save all images)
3002 if FIsMultiImageFormat
then
3004 if (Index
>= Len
) then
3011 FLastIdx
:= Len
- 1;
3019 for I
:= FFirstIdx
to FLastIdx
- 1 do
3020 if not TestImage(Images
[I
]) then
3025 if (Index
>= Len
) or (Index
< 0) then
3027 if not TestImage(Images
[Index
]) then
3035 procedure TImageFileFormat
.AddMasks(const AMasks
: string);
3041 FMasks
.CommaText
:= AMasks
;
3042 FMasks
.Delimiter
:= ';';
3044 for I
:= 0 to FMasks
.Count
- 1 do
3046 FMasks
[I
] := Trim(FMasks
[I
]);
3047 Ext
:= GetFileExt(FMasks
[I
]);
3048 if (Ext
<> '') and (Ext
<> '*') then
3049 FExtensions
.Add(Ext
);
3053 function TImageFileFormat
.GetFormatInfo(Format
: TImageFormat
): TImageFormatInfo
;
3055 Result
:= ImageFormatInfos
[Format
]^;
3058 function TImageFileFormat
.GetSupportedFormats
: TImageFormats
;
3060 Result
:= FSupportedFormats
;
3063 function TImageFileFormat
.LoadData(Handle
: TImagingHandle
;
3064 var Images
: TDynImageDataArray
; OnlyFirstFrame
: Boolean): Boolean;
3067 RaiseImaging(SFileFormatCanNotLoad
, [FName
]);
3070 function TImageFileFormat
.SaveData(Handle
: TImagingHandle
;
3071 const Images
: TDynImageDataArray
; Index
: LongInt): Boolean;
3074 RaiseImaging(SFileFormatCanNotSave
, [FName
]);
3077 procedure TImageFileFormat
.ConvertToSupported(var Image
: TImageData
;
3078 const Info
: TImageFormatInfo
);
3082 function TImageFileFormat
.IsSupported(const Image
: TImageData
): Boolean;
3084 Result
:= Image
.Format
in GetSupportedFormats
;
3087 function TImageFileFormat
.LoadFromFile(const FileName
: string;
3088 var Images
: TDynImageDataArray
; OnlyFirstLevel
: Boolean): Boolean;
3090 Handle
: TImagingHandle
;
3095 // Set IO ops to file ops and open given file
3097 Handle
:= IO
.OpenRead(PChar(FileName
));
3099 // Test if file contains valid image and if so then load it
3100 if TestFormat(Handle
) then
3102 Result
:= PrepareLoad(Handle
, Images
, OnlyFirstLevel
) and
3103 LoadData(Handle
, Images
, OnlyFirstlevel
);
3104 Result
:= Result
and PostLoadCheck(Images
, Result
);
3107 RaiseImaging(SFileNotValid
, [FileName
, Name
]);
3112 RaiseImaging(SErrorLoadingFile
, [FileName
, FExtensions
[0]]);
3116 function TImageFileFormat
.LoadFromStream(Stream
: TStream
;
3117 var Images
: TDynImageDataArray
; OnlyFirstLevel
: Boolean): Boolean;
3119 Handle
: TImagingHandle
;
3123 OldPosition
:= Stream
.Position
;
3126 // Set IO ops to stream ops and "open" given memory
3128 Handle
:= IO
.OpenRead(Pointer(Stream
));
3130 // Test if stream contains valid image and if so then load it
3131 if TestFormat(Handle
) then
3133 Result
:= PrepareLoad(Handle
, Images
, OnlyFirstLevel
) and
3134 LoadData(Handle
, Images
, OnlyFirstlevel
);
3135 Result
:= Result
and PostLoadCheck(Images
, Result
);
3138 RaiseImaging(SStreamNotValid
, [@Stream
, Name
]);
3143 Stream
.Position
:= OldPosition
;
3144 RaiseImaging(SErrorLoadingStream
, [@Stream
, FExtensions
[0]]);
3148 function TImageFileFormat
.LoadFromMemory(Data
: Pointer; Size
: LongInt; var
3149 Images
: TDynImageDataArray
; OnlyFirstLevel
: Boolean): Boolean;
3151 Handle
: TImagingHandle
;
3152 IORec
: TMemoryIORec
;
3157 // Set IO ops to memory ops and "open" given memory
3159 IORec
:= PrepareMemIO(Data
, Size
);
3160 Handle
:= IO
.OpenRead(@IORec
);
3162 // Test if memory contains valid image and if so then load it
3163 if TestFormat(Handle
) then
3165 Result
:= PrepareLoad(Handle
, Images
, OnlyFirstLevel
) and
3166 LoadData(Handle
, Images
, OnlyFirstlevel
);
3167 Result
:= Result
and PostLoadCheck(Images
, Result
);
3170 RaiseImaging(SMemoryNotValid
, [Data
, Size
, Name
]);
3175 RaiseImaging(SErrorLoadingMemory
, [Data
, Size
, FExtensions
[0]]);
3179 function TImageFileFormat
.SaveToFile(const FileName
: string;
3180 const Images
: TDynImageDataArray
; OnlyFirstLevel
: Boolean): Boolean;
3182 Handle
: TImagingHandle
;
3183 Len
, Index
, I
: LongInt;
3187 if FCanSave
and TestImagesInArray(Images
) then
3190 Len
:= Length(Images
);
3191 if FIsMultiImageFormat
or
3192 (not FIsMultiImageFormat
and (OnlyFirstLevel
or (Len
= 1))) then
3194 Handle
:= IO
.OpenWrite(PChar(FileName
));
3196 if OnlyFirstLevel
then
3200 // Write multi image to one file
3201 Result
:= PrepareSave(Handle
, Images
, Index
) and SaveData(Handle
, Images
, Index
);
3208 // Write multi image to file sequence
3209 Ext
:= ExtractFileExt(FileName
);
3210 FName
:= ChangeFileExt(FileName
, '');
3212 for I
:= 0 to Len
- 1 do
3214 Handle
:= IO
.OpenWrite(PChar(Format(FName
+ '%.3d' + Ext
, [I
])));
3217 Result
:= Result
and PrepareSave(Handle
, Images
, Index
) and
3218 SaveData(Handle
, Images
, Index
);
3227 RaiseImaging(SErrorSavingFile
, [FileName
, FExtensions
[0]]);
3231 function TImageFileFormat
.SaveToStream(Stream
: TStream
;
3232 const Images
: TDynImageDataArray
; OnlyFirstLevel
: Boolean): Boolean;
3234 Handle
: TImagingHandle
;
3235 Len
, Index
, I
: LongInt;
3239 OldPosition
:= Stream
.Position
;
3240 if FCanSave
and TestImagesInArray(Images
) then
3243 Handle
:= IO
.OpenWrite(PChar(Stream
));
3245 if FIsMultiImageFormat
or OnlyFirstLevel
then
3247 if OnlyFirstLevel
then
3251 // Write multi image in one run
3252 Result
:= PrepareSave(Handle
, Images
, Index
) and SaveData(Handle
, Images
, Index
);
3256 // Write multi image to sequence
3258 Len
:= Length(Images
);
3259 for I
:= 0 to Len
- 1 do
3262 Result
:= Result
and PrepareSave(Handle
, Images
, Index
) and
3263 SaveData(Handle
, Images
, Index
);
3272 Stream
.Position
:= OldPosition
;
3273 RaiseImaging(SErrorSavingStream
, [@Stream
, FExtensions
[0]]);
3277 function TImageFileFormat
.SaveToMemory(Data
: Pointer; var Size
: LongInt;
3278 const Images
: TDynImageDataArray
; OnlyFirstLevel
: Boolean): Boolean;
3280 Handle
: TImagingHandle
;
3281 Len
, Index
, I
: LongInt;
3282 IORec
: TMemoryIORec
;
3285 if FCanSave
and TestImagesInArray(Images
) then
3288 IORec
:= PrepareMemIO(Data
, Size
);
3289 Handle
:= IO
.OpenWrite(PChar(@IORec
));
3291 if FIsMultiImageFormat
or OnlyFirstLevel
then
3293 if OnlyFirstLevel
then
3297 // Write multi image in one run
3298 Result
:= PrepareSave(Handle
, Images
, Index
) and SaveData(Handle
, Images
, Index
);
3302 // Write multi image to sequence
3304 Len
:= Length(Images
);
3305 for I
:= 0 to Len
- 1 do
3308 Result
:= Result
and PrepareSave(Handle
, Images
, Index
) and
3309 SaveData(Handle
, Images
, Index
);
3314 Size
:= IORec
.Position
;
3319 RaiseImaging(SErrorSavingMemory
, [Data
, Size
, FExtensions
[0]]);
3323 function TImageFileFormat
.MakeCompatible(const Image
: TImageData
;
3324 var Compatible
: TImageData
; out MustBeFreed
: Boolean): Boolean;
3326 InitImage(Compatible
);
3328 if SaveOverrideFormat
<> ifUnknown
then
3330 // Save format override is active. Clone input and convert it to override format.
3331 CloneImage(Image
, Compatible
);
3332 ConvertImage(Compatible
, SaveOverrideFormat
);
3333 // Now check if override format is supported by file format. If it is not
3334 // then file format specific conversion (virtual method) is called.
3335 Result
:= IsSupported(Compatible
);
3338 ConvertToSupported(Compatible
, GetFormatInfo(Compatible
.Format
));
3339 Result
:= IsSupported(Compatible
);
3341 end // Add IsCompatible function! not only checking by Format
3342 else if IsSupported(Image
) then
3344 // No save format override and input is in format supported by this
3345 // file format. Just copy Image's fields to Compatible
3346 Compatible
:= Image
;
3351 // No override and input's format is not compatible with file format.
3352 // Clone it and the call file format specific conversion (virtual method).
3353 CloneImage(Image
, Compatible
);
3354 ConvertToSupported(Compatible
, GetFormatInfo(Compatible
.Format
));
3355 Result
:= IsSupported(Compatible
);
3357 // Tell the user that he must free Compatible after he's done with it
3359 MustBeFreed
:= Image
.Bits
<> Compatible
.Bits
;
3362 function TImageFileFormat
.TestFormat(Handle
: TImagingHandle
): Boolean;
3367 function TImageFileFormat
.TestFileName(const FileName
: string): Boolean;
3372 OnlyName
:= ExtractFileName(FileName
);
3373 // For each mask test if filename matches it
3374 for I
:= 0 to FMasks
.Count
- 1 do
3375 if MatchFileNameMask(OnlyName
, FMasks
[I
], False) then
3383 procedure TImageFileFormat
.CheckOptionsValidity
;
3387 { TOptionStack class implementation }
3389 constructor TOptionStack
.Create
;
3395 destructor TOptionStack
.Destroy
;
3399 for I
:= 0 to OptionStackDepth
- 1 do
3400 SetLength(FStack
[I
], 0);
3404 function TOptionStack
.Pop
: Boolean;
3409 if FPosition
>= 0 then
3411 SetLength(Options
, Length(FStack
[FPosition
]));
3412 for I
:= 0 to Length(FStack
[FPosition
]) - 1 do
3413 if Options
[I
] <> nil then
3414 Options
[I
]^ := FStack
[FPosition
, I
];
3420 function TOptionStack
.Push
: Boolean;
3425 if FPosition
< OptionStackDepth
- 1 then
3428 SetLength(FStack
[FPosition
], Length(Options
));
3429 for I
:= 0 to Length(Options
) - 1 do
3430 if Options
[I
] <> nil then
3431 FStack
[FPosition
, I
] := Options
[I
]^;
3438 {$IF CompilerVersion >= 18}
3439 System
.ReportMemoryLeaksOnShutdown
:= True;
3442 if ImageFileFormats
= nil then
3443 ImageFileFormats
:= TList
.Create
;
3445 RegisterOption(ImagingColorReductionMask
, @ColorReductionMask
);
3446 RegisterOption(ImagingLoadOverrideFormat
, @LoadOverrideFormat
);
3447 RegisterOption(ImagingSaveOverrideFormat
, @SaveOverrideFormat
);
3448 RegisterOption(ImagingMipMapFilter
, @MipMapFilter
);
3451 FreeImageFileFormats
;
3456 -- TODOS ----------------------------------------------------
3459 -- 0.26.3 Changes/Bug Fixes ---------------------------------
3460 - Extended RotateImage to allow arbitrary angle rotations.
3461 - Reversed the order file formats list is searched so
3462 if you register a new one it will be found sooner than
3464 - Fixed memory leak in ResizeImage ocurring when resizing
3467 -- 0.26.1 Changes/Bug Fixes ---------------------------------
3468 - Added position/size checks to LoadFromStream functions.
3469 - Changed conditional compilation in impl. uses section to reflect changes
3472 -- 0.24.3 Changes/Bug Fixes ---------------------------------
3473 - GenerateMipMaps now generates all smaller levels from
3474 original big image (better results when using more advanced filters).
3475 Also conversion to compatible image format is now done here not
3476 in FillMipMapLevel (that is called for every mipmap level).
3478 -- 0.23 Changes/Bug Fixes -----------------------------------
3479 - MakePaletteForImages now works correctly for indexed and special format images
3480 - Fixed bug in StretchRect: Image was not properly stretched if
3481 src and dst dimensions differed only in height.
3482 - ConvertImage now fills new image with zeroes to avoid random data in
3483 some conversions (RGB->XRGB)
3484 - Changed RegisterOption procedure to function
3485 - Changed bunch of palette functions from low level interface to procedure
3486 (there was no reason for them to be functions).
3487 - Changed FreeImage and FreeImagesInArray functions to procedures.
3488 - Added many assertions, come try-finally, other checks, and small code
3491 -- 0.21 Changes/Bug Fixes -----------------------------------
3492 - GenerateMipMaps threw failed assertion when input was indexed or special,
3494 - Added CheckOptionsValidity to TImageFileFormat and its decendants.
3495 - Unit ImagingExtras which registers file formats in Extras package
3496 is now automatically added to uses clause if LINK_EXTRAS symbol is
3497 defined in ImagingOptions.inc file.
3498 - Added EnumFileFormats function to low level interface.
3499 - Fixed bug in SwapChannels which could cause AV when swapping alpha
3500 channel of A8R8G8B8 images.
3501 - Converting loaded images to ImagingOverrideFormat is now done
3502 in PostLoadCheck method to avoid code duplicity.
3503 - Added GetFileFormatCount and GetFileFormatAtIndex functions
3504 - Bug in ConvertImage: if some format was converted to similar format
3505 only with swapped channels (R16G16B16<>B16G16R16) then channels were
3506 swapped correctly but new data format (swapped one) was not set.
3507 - Made TImageFileFormat.MakeCompatible public non-virtual method
3508 (and modified its function). Created new virtual
3509 ConvertToSupported which should be overriden by descendants.
3510 Main reason for doint this is to avoid duplicate code that was in all
3511 TImageFileFormat's descendants.
3512 - Changed TImageFileFormat.GetFormatInfo's result type to TImageFormatInfo.
3513 - Split overloaded FindImageFileFormat functions to
3514 FindImageFileFormatByClass and FindImageFileFormatByExt and created new
3515 FindImageFileFormatByName which operates on whole filenames.
3516 - Function GetExtensionFilterIndex renamed to GetFileNameFilterIndex
3517 (because it now works with filenames not extensions).
3518 - DetermineFileFormat now first searches by filename and if not found
3520 - Added TestFileName method to TImageFileFormat.
3521 - Updated GetImageFileFormatsFilter to uses Masks instead of Extensions
3522 property of TImageFileFormat. Also you can now request
3523 OpenDialog and SaveDialog type filters
3524 - Added Masks property and AddMasks method to TImageFileFormat.
3525 AddMasks replaces AddExtensions, it uses filename masks instead
3526 of sime filename extensions to identify supported files.
3527 - Changed TImageFileFormat.LoadData procedure to function and
3528 moved varios duplicate code from its descandats (check index,...)
3529 here to TImageFileFormat helper methods.
3530 - Changed TImageFileFormat.SaveData procedure to function and
3531 moved varios duplicate code from its descandats (check index,...)
3532 here to TImageFileFormat helper methods.
3533 - Removed RAISE_EXCEPTIONS define, exceptions are now raised everytime
3534 - Added MustBeFreed parameter to TImageFileFormat.MakeComptible method
3535 that indicates that compatible image returned by this method must be
3536 freed after its usage.
3538 -- 0.19 Changes/Bug Fixes -----------------------------------
3539 - fixed bug in NewImage: if given format was ifDefault it wasn't
3540 replaced with DefaultImageFormat constant which caused problems later
3542 - fixed bug in RotateImage which caused that rotated special format
3543 images were whole black
3544 - LoadImageFromXXX and LoadMultiImageFromXXX now use DetermineXXXFormat
3545 when choosing proper loader, this eliminated need for Ext parameter
3546 in stream and memory loading functions
3547 - added GetVersionStr function
3548 - fixed bug in ResizeImage which caued indexed images to lose their
3549 palette during process resulting in whole black image
3550 - Clipping in ...Rect functions now uses clipping procs from ImagingUtility,
3551 it also works better
3552 - FillRect optimization for 8, 16, and 32 bit formats
3553 - added pixel set/get functions to low level interface:
3554 GetPixelDirect, SetPixelDirect, GetPixel32, SetPixel32,
3555 GetPixelFP, SetPixelFP
3556 - removed GetPixelBytes low level intf function - redundant
3557 (same data can be obtained by GetImageFormatInfo)
3558 - made small changes in many parts of library to compile
3559 on AMD64 CPU (Linux with FPC)
3560 - changed InitImage to procedure (function was pointless)
3561 - Method TestFormat of TImageFileFormat class made public
3563 - added function IsFileFormatSupported to low level interface
3564 (contributed by Paul Michell)
3565 - fixed some missing format arguments from error strings
3566 which caused Format function to raise exception
3567 - removed forgotten debug code that disabled filtered resizing of images with
3568 channel bitcounts > 8
3570 -- 0.17 Changes/Bug Fixes -----------------------------------
3571 - changed order of parameters of CopyRect function
3572 - GenerateMipMaps now filters mipmap levels
3573 - ResizeImage functions was extended to allow bilinear and bicubic filtering
3574 - added StretchRect function to low level interface
3575 - added functions GetImageFileFormatsFilter, GetFilterIndexExtension,
3576 and GetExtensionFilterIndex
3578 -- 0.15 Changes/Bug Fixes -----------------------------------
3579 - added function RotateImage to low level interface
3580 - moved TImageFormatInfo record and types required by it to
3581 ImagingTypes unit, changed GetImageFormatInfo low level
3582 interface function to return TImageFormatInfo instead of short info
3583 - added checking of options values validity before they are used
3584 - fixed possible memory leak in CloneImage
3585 - added ReplaceColor function to low level interface
3586 - new function FindImageFileFormat by class added
3588 -- 0.13 Changes/Bug Fixes -----------------------------------
3589 - added DetermineFileFormat, DetermineStreamFormat, DetermineMemoryFormat,
3590 GetPixelsSize functions to low level interface
3591 - added NewPalette, CopyPalette, FreePalette functions
3592 to low level interface
3593 - added MapImageToPalette, FillRect, SplitImage, MakePaletteForImages
3594 functions to low level interface
3595 - fixed buggy FillCustomPalette function (possible div by zero and others)
3596 - added CopyRect function to low level interface
3597 - Member functions of TImageFormatInfo record implemented for all formats
3598 - before saving images TestImagesInArray is called now
3599 - added TestImagesInArray function to low level interface
3600 - added GenerateMipMaps function to low level interface
3601 - stream position in load/save from/to stream is now set to position before
3602 function was called if error occurs
3603 - when error occured during load/save from/to file file handle
3605 - CloneImage returned always False