{
  $Id: Imaging.pas,v 1.11 2005/06/22 13:53:20 galfar Exp $
  Vampyre Imaging Library
  by Marek Mauder (pentar@seznam.cz)
  http://imaginglib.sourceforge.net

  The contents of this file are used with permission, subject to the Mozilla
  Public License Version 1.1 (the "License"); you may not use this file except
  in compliance with the License. You may obtain a copy of the License at
  http://www.mozilla.org/MPL/MPL-1.1.html

  Software distributed under the License is distributed on an "AS IS" basis,
  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  the specific language governing rights and limitations under the License.

  Alternatively, the contents of this file may be used under the terms of the
  GNU Lesser General Public License (the  "LGPL License"), in which case the
  provisions of the LGPL License are applicable instead of those above.
  If you wish to allow use of your version of this file only under the terms
  of the LGPL License and not to allow others to use your version of this file
  under the MPL, indicate your decision by deleting  the provisions above and
  replace  them with the notice and other provisions required by the LGPL
  License.  If you do not delete the provisions above, a recipient may use
  your version of this file under either the MPL or the LGPL License.

  For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}

{ This unit is heart of Imaging library. It contains basic functions for
  manipulating image data as well as various image file format support.}
unit Imaging;

{$I ImagingOptions.inc}

interface

uses
  ImagingTypes, SysUtils, Classes;

type
  { Default Imaging excepton class.}
  EImagingError = class(Exception);

  PLongInt = ^LongInt;

  { Dynamic array of TImageData records.}
  TDynImageDataArray = array of TImageData;


{ ------------------------------------------------------------------------
                       Low Level Interface Functions
  ------------------------------------------------------------------------}

{ General Functions }

{ Initializes image (all is set to zeroes). Call this for each image
  before using it (before calling every other function) to be sure there
  are no random-filled bytes (which would cause errors later).}
function InitImage(var Image: TImageData): Boolean;
{ Creates empty image of given dimensions and format. Image is filled with
  transparent black color (A=0, R=0, G=0, B=0).}
function NewImage(Width, Height: LongInt; Format: TImageFormat;
  var Image: TImageData): Boolean;
{ Returns True if given TImageData record is valid.}
function TestImage(const Image: TImageData): Boolean;
{ Frees given image data. Ater this call image is in the same state
  as after calling InitImage.}
function FreeImage(var Image: TImageData): Boolean;
{ Call FreeImage() on all images in given dynamic
  array.}
function FreeImagesInArray(var Images: TDynImageDataArray): Boolean;
{ Returns True if all TImageData records in given array are valid.}
function TestImagesInArray(const Images: TDynImageDataArray): Boolean;
{ Checks given file for every supported image file format and if
  the file is in one of them returns its string identifier
  (which can be used in LoadFromStream/LoadFromMem type functions).
  If file is not in any of the supported formats empty string is returned.}
function DetermineFileFormat(const FileName: string): string;
{ Checks given stream for every supported image file format and if
  the stream is in one of them returns its string identifier
  (which can be used in LoadFromStream/LoadFromMem type functions).
  If stream is not in any of the supported formats empty string is returned.}
function DetermineStreamFormat(Stream: TStream): string;
{ Checks given memory for every supported image file format and if
  the memory is in one of them returns its string identifier
  (which can be used in LoadFromStream/LoadFromMem type functions).
  If memory is not in any of the supported formats empty string is returned.}
function DetermineMemoryFormat(Data: Pointer; Size: LongInt): string;


{ Loading Functions }

{ Loads single image from given file.}
function LoadImageFromFile(const FileName: string; var Image: TImageData): Boolean;
{ Loads single image from given stream. If function fails stream position
  is not changed.}
function LoadImageFromStream(const Ext: string; Stream: TStream;
  var Image: TImageData): Boolean;
{ Loads single image from given memory location.}
function LoadImageFromMemory(const Ext: string; Data: Pointer; Size: LongInt;
  var Image: TImageData): Boolean;
{ Loads multiple images from given file.}
function LoadMultiImageFromFile(const FileName: string;
  var Images: TDynImageDataArray): Boolean;
{ Loads multiple images from given stream. If function fails stream position
  is not changed.}
function LoadMultiImageFromStream(const Ext: string; Stream: TStream;
  var Images: TDynImageDataArray): Boolean;
{ Loads multiple images from given memory location.}
function LoadMultiImageFromMemory(const Ext: string; Data: Pointer;
  Size: LongInt; var Images: TDynImageDataArray): Boolean;

{ Saving Functions }

{ Saves single image to given file.}
function SaveImageToFile(const FileName: string; const Image: TImageData): Boolean;
{ Saves single image to given stream. If function fails stream position
  is not changed.}
function SaveImageToStream(const Ext: string; Stream: TStream;
  const Image: TImageData): Boolean;
{ Saves single image to given memory location. Memory must be allocated and its
  size is passed in Size parameter in which number of written bytes is returned.}
function SaveImageToMemory(const Ext: string; Data: Pointer; var Size: LongInt;
  const Image: TImageData): Boolean;
{ Saves multiple images to given file. If format supports
  only single level images and there are multiple images to be saved,
  they are saved as sequence of files img000.jpg, img001.jpg ....).}
function SaveMultiImageToFile(const FileName: string;
  const Images: TDynImageDataArray): Boolean;
{ Saves multiple images to given stream. If format supports
  only single level images and there are multiple images to be saved,
  they are saved one after another to the stream. If function fails stream
  position is not changed.}
function SaveMultiImageToStream(const Ext: string; Stream: TStream;
  const Images: TDynImageDataArray): Boolean;
{ Saves multiple images to given memory location. If format supports
  only single level images and there are multiple images to be saved,
  they are saved one after another to the memory. Memory must be allocated and
  its size is passed in Size parameter in which number of written bytes is returned.}
function SaveMultiImageToMemory(const Ext: string; Data: Pointer;
  var Size: LongInt; const Images: TDynImageDataArray): Boolean;

{ Manipulation Functions }

{ Creates identical copy of image data.}
function CloneImage(const Image: TImageData; var Clone: TImageData): Boolean;
{ Converts image to given format.}
function ConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean;
{ Flips given image. Reverses an image along its horizontal axis—the top
  becomes the bottom and vice versa.}
function FlipImage(var Image: TImageData): Boolean;
{ Mirrors given image. Reverses the image along its vertical axis—the left
  side becomes the right and vice versa.}
function MirrorImage(var Image: TImageData): Boolean;
{ Resizes given image with new dimensions. It is pixel
  resize - no filtering is done.}
function ResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt): Boolean;
{ Swaps SrcChannel and DstChannel color or alpha channels of image.
  Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
  identify channels.}
function SwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean;
{ Reduces the number of colors of the Image. Currently MaxColors must be in
  range <1, 4096>. Color reduction works also for alpha channel. Note that for
  large images and big number of colors it can be very slow.
  Output format of the image is the same as input format.}
function ReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean;
{ Generates mipmaps for image. Levels is the number of desired mipmaps levels
  with zero meaning all possible levels.}
function GenerateMipMaps(const Image: TImageData; Levels: LongInt;
  var MipMaps: TDynImageDataArray): Boolean;
{ Copies rectangular part of SrcImage to DstImage. Note that it is done fastest
  for images in the same data format (and slowest for images in special formats).
  Operates also with negative X and Y coordinates.}
function CopyRect(const SrcImage: TImageData; var DstImage: TImageData;
  SrcX, SrcY, Width, Height, DstX, DstY: LongInt): Boolean;
{ Maps image to existing palette producing image in ifIndex8 format.
  Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes.}
function MapImageToPalette(var Image: TImageData; Pal: PPalette32;
  Entries: LongInt): Boolean;
{ Fills given rectangle of image with given pixel fill data. Fill should point
  to the one pixel in the same format as the given image is in.}
function FillRect(var Image: TImageData; X, Y, Width, Height: LongInt; Fill: Pointer): Boolean;
{ Splits image into XChunks x YChunks subimages. Default size of each chunk is
  ChunkWidth x ChunkHeight. If PreserveSize si True chunks at the edges of
  the image are also ChunkWidth x ChunkHeight sized and empty space is filled
  with Fill pixels. After calling this function XChunks contains number of
  chunks along x axis and YChunks along y axis. To access chunk [X, Y] use this
  index: Chunks[Y * XChunks + X].}
function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray;
  ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
  PreserveSize: Boolean; Fill: Pointer): Boolean;
{ Creates palette with MaxColors based on the colors of images in Images array.
  Use it when you want to convert several images to indexed format using
  single palette for all of them. If ConvertImages is True images in array
  are converted to indexed format using resulting palette. if it is False
  images are left intact and only resulting palatte is returned in Pal.
  Pal must be allocated to at least MaxColors * SizeOf(TColor32Rec) bytes.}
function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32;
  MaxColors: LongInt; ConvertImages: Boolean): Boolean;

{ Palette Functions }

{ Allocates new palette with Entries ARGB color entries.}
function NewPalette(Entries: LongInt; var Pal: PPalette32): Boolean;
{ Frees given palette.}
function FreePalette(var Pal: PPalette32): Boolean;
{ Copies Count palette entries from SrcPal starting at index SrcIdx to
  DstPal at index DstPal.}
function CopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean;
{ Returns index of color in palette or index of nearest color if exact match
  is not found.
  Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes.}
function FindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt;
{ Creates grayscale palette where each color channel has the same value.
  Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes.}
function FillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean;
{ Creates palette with given bitcount for each channel.
  2^(RBits + GBits + BBits) should be equl to Entries. Examples:
  (3, 3, 2) will create palette with all possible colors of R3G3B2 format
  and (8, 0, 0) will create palette with 256 shades of red.
  Pal must be allocated to at least Entries * SizeOf(TColor32Rec) bytes.}
function FillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
  BBits: Byte; Alpha: Byte = $FF): Boolean;
{ Swaps SrcChannel and DstChannel color or alpha channels of palette.
  Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
  identify channels. Pal must be allocated to at least
  Entries * SizeOf(TColor32Rec) bytes.}
function SwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
  DstChannel: LongInt): Boolean;

{ Options Functions }

{ Sets value of integer option specified by OptionId parameter.
  Option Ids are constans starting ImagingXXX.}
function SetOption(OptionId, Value: LongInt): Boolean;
{ Returns value of integer option specified by OptionId parameter. If OptionId is
  invalid, InvalidOption is returned. Option Ids are constans
  starting ImagingXXX.}
function GetOption(OptionId: LongInt): LongInt;
{ Pushes current values of all options on the stack. Returns True
  if successfull (max stack depth is 8 now). }
function PushOptions: Boolean;
{ Pops back values of all options from the top of the stack. Returns True
  if successfull (max stack depth is 8 now). }
function PopOptions: Boolean;

{ Image Format Functions }

{ Returns number of bytes per one pixel for given format (may not
  work for formats with pixels not byte aligned like DXTC).}
function GetPixelBytes(Format: TImageFormat): LongInt;
{ Returns short information about given image format.}
function GetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatShortInfo): Boolean;
{ Returns size in bytes of Width x Height area of pixels. Works for all formats.}
function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;

{ IO Functions }

{ User can set his own file IO functions used when loading from/saving to
  files by this function.}
procedure SetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
  TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc:
  TSeekProc; TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc);
{ Sets file IO functions to Imaging default.}
procedure ResetFileIO;


{ ------------------------------------------------------------------------
                           Other Imaging Stuff
  ------------------------------------------------------------------------}

type
  { Set of TImageFormat enum.}
  TImageFormats = set of TImageFormat;

  TFormatGetPixelsSizeFunc = function(Format: TImageFormat; Width,
    Height: LongInt): LongInt;

  TFormatCheckDimensionsProc = procedure(Format: TImageFormat; var Width,
    Height: LongInt);

  { Pixel format information used in conversions to/from 16 and 8 bit ARGB
    image formats.}
  TPixelFormat = record
    ABitCount, RBitCount, GBitCount, BBitCount: Byte;
    ABitMask, RBitMask, GBitMask, BBitMask: LongWord;
    AShift, RShift, GShift, BShift: Byte;
    ARecDiv, RRecDiv, GRecDiv, BRecDiv: Byte;
  end;
  PPixelFormat = ^TPixelFormat;

  { Additional full information for each TImageFormat value.}
  TImageFormatInfo = record
    Format: TImageFormat;             // Format described by this record
    Name: array[0..15] of Char;       // Symbolic name of format
    BytesPerPixel: Byte;              // Number of Bytes per pixel
    PaletteEntries: LongInt;          // Number of palette entries
    HasGrayChannel: Boolean;          // True if image has grayscale channel
    HasAlphaChannel: Boolean;         // True if image has alpha channel
    IsFloatingPoint: Boolean;         // True if image has floating point pixels
    UsePixelFormat: Boolean;          // True if image uses pixel format
    IsRBSwapped: Boolean;             // True if Red and Blue channels are swapped
                                      // e.g. A16B16G16R16 has IsRBSwapped True
    IsIndexed: Boolean;               // True if image uses palette
    IsSpecial: Boolean;               // True if image is in special format
    PixelFormat: PPixelFormat;        // Pixel format structure
    GetPixelsSize: TFormatGetPixelsSizeFunc; // Returns size in bytes of
                                      // Width * Height pixels of image
    CheckDimensions: TFormatCheckDimensionsProc; // some formats have limited
                                      // values of Width and Height. This
                                      // procedure checks and changes dimensions
                                      // to be valid for given format.
  end;
  PImageFormatInfo = ^TImageFormatInfo;

  { Record containg set of IO functions internaly used by image loaders/savers.}
  TIOFunctions = record
    OpenRead: TOpenReadProc;
    OpenWrite: TOpenWriteProc;
    Close: TCloseProc;
    Eof: TEofProc;
    Seek: TSeekProc;
    Tell: TTellProc;
    Read: TReadProc;
    Write: TWriteProc;
  end;

  { Base class for various image file format loaders/savers which
    descend from this class.}
  TImageFileFormat = class(TObject)
  protected
    FExtensions: TStringList;
    FName: string;
    FCanLoad: Boolean;
    FCanSave: Boolean;
    FIsMultiImageFormat: Boolean;
    procedure AddExtensions(const AExtensions: string);
    function GetFormatInfo(Format: TImageFormat): PImageFormatInfo;
    function GetSupportedFormats: TImageFormats; virtual;
    { Method which must be overrided in descendants if they'll be capable
      of loading images.}
    procedure LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
      OnlyFirstFrame: Boolean); virtual;
    { Method which must be overrided in descendants if they'll be capable
      of saving images.}
    procedure SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
      Index: LongInt = MaxInt); virtual;
    { Creates clone of image compatible with format's saving function.
      It can convert image to another format, swap channels of image, ...
      Note that if input Image is already compatible it is returned in Comp,
      so before freeing Comp you must test if it is not original Image.}
    procedure MakeCompatible(const Image: TImageData; var Comp: TImageData); virtual;
    { Returns True if data located in source identified by Handle
      represent valid image in current format.}
    function TestFormat(Handle: TImagingHandle): Boolean; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    { Loads images from file source.}
    function LoadFromFile(const FileName: string; var Images: TDynImageDataArray;
      OnlyFirstLevel: Boolean = False): Boolean;
    { Loads images from stream source.}
    function LoadFromStream(Stream: TStream; var Images: TDynImageDataArray;
      OnlyFirstLevel: Boolean = False): Boolean;
    { Loads images from memory source.}
    function LoadFromMemory(Data: Pointer; Size: LongInt;
      var Images: TDynImageDataArray; OnlyFirstLevel: Boolean = False): Boolean;

    { Saves images to file. If format supports only single level images and
      there are multiple images to be saved, they are saved as sequence of
      independent images (for example SaveToFile saves sequence of
      files img000.jpg, img001.jpg ....).}
    function SaveToFile(const FileName: string; const Images: TDynImageDataArray;
      OnlyFirstLevel: Boolean = False): Boolean;
    { Saves images to stream. If format supports only single level images and
      there are multiple images to be saved, they are saved as sequence of
      independent images.}
    function SaveToStream(Stream: TStream; const Images: TDynImageDataArray;
      OnlyFirstLevel: Boolean = False): Boolean;
    { Saves images to memory. If format supports only single level images and
      there are multiple images to be saved, they are saved as sequence of
      independent images. Data must be already allocated and their size passed
      as Size parameter, number of written bytes is then returned in the same
      parameter.}
    function SaveToMemory(Data: Pointer; var Size: LongInt;
      const Images: TDynImageDataArray; OnlyFirstLevel: Boolean = False): Boolean;

    { List of file extensions for this format}
    property Extensions: TStringList read FExtensions;
    { Description of this format}
    property Name: string read FName;
    { Indicates whether images in this format can be loaded}
    property CanLoad: Boolean read FCanLoad;
    { Indicates whether images in this format can be saved}
    property CanSave: Boolean read FCanSave;
    { Indicates whether images in this format can contain multiple image levels}
    property IsMultiImageFormat: Boolean read FIsMultiImageFormat;
    { Set of TImageFormats supported by saving/loading functions of this format}
    property SupportedFormats: TImageFormats read GetSupportedFormats;
  end;

  { Class reference for TImageFileFormat class}
  TImageFileFormatClass = class of TImageFileFormat;

{ Returns symbolic name of given format.}
function GetFormatName(Format: TImageFormat): string;
{ Returns string with information about given Image.}
function ImageToStr(const Image: TImageData): string;
{ Registers new image loader/saver so it can be used by LoadFrom/SaveTo
  functions.}
procedure RegisterImageFileFormat(AClass: TImageFileFormatClass);
{ Registers new option so it can be used by Srt/GetOption funcyions.}
procedure RegisterOption(OptionId: LongInt; Variable: PLongInt);
{ Returns image format loader/saver asociated with given file
  extension or nil if not found.}
function FindImageFileFormat(const Ext: string): TImageFileFormat;
{ Returns current IO functions.}
function GetIO: TIOFunctions;
{ Raises EImagingError with given message.}
procedure RaiseImaging(const Msg: string; const Args: array of const);

implementation

uses
{$IFDEF LINK_JPEG}
  ImagingJpeg,
{$ENDIF}
{$IFDEF LINK_PNG}
  ImagingPng,
{$ENDIF}
{$IFDEF LINK_TARGA}
  ImagingTarga,
{$ENDIF}
{$IFDEF LINK_BITMAP}
  ImagingBitmap,
{$ENDIF}
{$IFDEF LINK_DDS}
  ImagingDds,
{$ENDIF}
  ImagingFormats, ImagingUtility, ImagingIO;

resourcestring
  sExceptMsg = 'Exception Message';
  sUnknownFormat = 'Unknown & Unsupported Format';
  sErrorFreeImage = 'Error while freeing image. %s';
  sErrorCloneImage = 'Error while cloning image. %s';
  sErrorFlipImage = 'Error while flipping image. %s';
  sErrorMirrorImage = 'Error while mirroring image. %s';
  sErrorResizeImage = 'Error while resizing image.  %s';
  sErrorSwapImage = 'Error while swapping channels of image. %s';
  sFileFormatCanNotLoad = 'Image Format "%s" does not support loading images.';
  sFileFormatCanNotSave = 'Image Format "%s" does not support saving images.';
  sErrorNewImage = 'Error while creating image data with params: Width=%d ' +
    'Height=% Format=%s.';
  sErrorConvertImage = 'Error while converting image to format "%s". %s';
  sImageInfo = 'Image @%p info: Width = %dpx, Height = %dpx, ' +
    'Format = %s, Size = %.0nKiB, Bits @%p, Palette @%p.';
  sImageInfoInvalid = 'Access violation encountered when getting info on ' +
    'image at address %p.';
  sFileNotValid = 'File "%s" is not valid image in "%s" format.';
  sStreamNotValid = 'Stream %p does not contain valid image in "%s" format.';
  sMemoryNotValid = 'Memory %p (%d Bytes) does not contain valid image ' +
    'in "%s" format.';
  sErrorLoadingFile = 'Error while loading images from file "%s".';
  sErrorLoadingStream = 'Error while loading images from stream %p.';
  sErrorLoadingMemory = 'Error while loading images from memory %p (%d Bytes).';
  sErrorSavingFile = 'Error while saving images to file "%s".';
  sErrorSavingStream = 'Error while saving images to stream %p.';
  sErrorSavingMemory = 'Error while saving images to memory %p (%d Bytes).';
  sErrorFindColor = 'Error while finding color in palette @%p with %d entries.';
  sErrorGrayscalePalette = 'Error while filling grayscale palette @%p with ' +
    '%d entries.';
  sErrorCustomPalette = 'Error while filling custom palette @%p with '+
    '%d entries.';
  sErrorSwapPalette = 'Error while swapping channels of palette @%p with ' +
    '%d entries.';
  sErrorReduceColors = 'Error while reducing number of colors of image to %d.' +
    ' %s';
  sErrorGenerateMipMaps = 'Error while generating %d mipmap levels for image %s';
  sImagesNotValid = 'One or more images are not valid.';
  sErrorCopyRect = 'Error while copying rect from image %s to image %s.';
  sErrorMapImage = 'Error while mapping image %s to palette.';
  sErrorFillRect = 'Error while filling rectangle X:% Y:%d W:%d H:%d in image %s';
  sErrorSplitImage = 'Error while splitting image %s to %dx%d sized chunks.';
  sErrorMakePaletteForImages = 'Error while making %d color palette for %d images.';
  sErrorNewPalette = 'Error while creating new palette with %d entries';
  sErrorFreePalette = 'Error while freeing palette @%p';
  sErrorCopyPalette = 'Error while copying %d entries from palette @%p to @%p';

const
  // initial size of array with options information
  InitialOptions = 256;
  // max depth of the option stack
  OptionStackDepth = 8;
  // do not change the default format now, its too late
  DefaultImageFormat: TImageFormat = ifA8R8G8B8;

type
  TOptionArray = array of PLongInt;
  TOptionValueArray = array of LongInt;

  TOptionStack = class(TObject)
  private
    FStack: array[0..OptionStackDepth - 1] of TOptionValueArray;
    FPosition: LongInt;
  public
    constructor Create;
    destructor Destroy; override;
    function Push: Boolean;
    function Pop: Boolean;
  end;

var
  // currently set IO functions
  IO: TIOFunctions;
  // list with all registered TImageFileFormat classes
  ImageFileFormats: TList = nil;
  // array with registered options (pointers to their values)
  Options: TOptionArray = nil;
  // array containing addional infomation about every image format
  ImageFormatInfos: TImageFormatInfoArray;
  // stack used by PushOptions/PopOtions functions
  OptionStack: TOptionStack = nil;
var
  // variable for ImagingColorReduction option
  ColorReductionMask: LongInt = $FF;


{ Internal unit functions }

{ Sets IO functions to file IO.}
procedure SetFileIO; forward;
{ Sets IO functions to stream IO.}
procedure SetStreamIO; forward;
{ Sets IO functions to memory IO.}
procedure SetMemoryIO; forward;
{ Inits image format infos array.}
procedure InitImageFormats; forward;
{ Freew image format infos array.}
procedure FreeImageFileFormats; forward;
{ Creates options array and stack.}
procedure InitOptions; forward;
{ Frees options array and stack.}
procedure FreeOptions; forward;

{ Low Interface Helpers }

procedure CopyPixel(Src, Dest: Pointer; Bpp: LongInt);
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
  case Bpp of
    1: PByte(Dest)^ := PByte(Src)^;
    2: PWord(Dest)^ := PWord(Src)^;
    3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
    4: PLongWord(Dest)^ := PLongWord(Src)^;
    6: PColor48Rec(Dest)^ := PColor48Rec(Src)^;
    8: PInt64(Dest)^ := PInt64(Src)^;
    16: PColorFRec(Dest)^ := PColorFRec(Src)^;
  end;
end;

{ Low Level Interface Functions }

function InitImage(var Image: TImageData): Boolean;
begin
  FillChar(Image, SizeOf(Image), 0);
  Result := True;
end;

function NewImage(Width, Height: LongInt; Format: TImageFormat; var Image:
  TImageData): Boolean;
var
  FInfo: PImageFormatInfo;
begin
  Result := False;
  if FreeImage(Image) then
  try
    Image.Width := Width;
    Image.Height := Height;
    // if desired format is not valid then default format is selected
    if ImageFormatInfos[Format] = nil then
      Image.Format := DefaultImageFormat
    else
      Image.Format := Format;
    FInfo := ImageFormatInfos[Image.Format];
    Image.Size := FInfo.GetPixelsSize(FInfo.Format, Image.Width, Image.Height);
    if FInfo.IsSpecial then
      FInfo.CheckDimensions(FInfo.Format, Image.Width, Image.Height);
    // image bits are allocated and set to zeroes
    GetMem(Image.Bits, Image.Size);
    FillChar(Image.Bits^, Image.Size, 0);
    GetMem(Image.Palette, FInfo.PaletteEntries * SizeOf(TColor32Rec));
    FillChar(Image.Palette^, FInfo.PaletteEntries * SizeOf(TColor32Rec), 0);
    Result := True;
  except
    InitImage(Image);
    Result := False;
    RaiseImaging(sErrorNewImage, [Width, Height, GetFormatName(Format)]);
  end;
end;

function TestImage(const Image: TImageData): Boolean;
begin
  with Image do
    Result := (ImageFormatInfos[Format] <> nil) and
      (Assigned(ImageFormatInfos[Format].GetPixelsSize) and
      (ImageFormatInfos[Format].GetPixelsSize(Format, Width, Height) = Size));
end;

function FreeImage(var Image: TImageData): Boolean;
begin
  try
    if TestImage(Image) then
    begin
      FreeMem(Image.Bits);
      FreeMem(Image.Palette);
    end;
    FillChar(Image, SizeOf(TImageData), 0);
    Result := True;
  except
    Result := False;
    RaiseImaging(sErrorFreeImage, [ImageToStr(Image)]);
  end;
end;

function FreeImagesInArray(var Images: TDynImageDataArray): Boolean;
var
  I: LongInt;
begin
  Result := True;
  for I := 0 to Length(Images) - 1 do
    Result := Result and FreeImage(Images[I]);
end;

function TestImagesInArray(const Images: TDynImageDataArray): Boolean;
var
  I: LongInt;
begin
  Result := True;
  for I := 0 to Length(Images) - 1 do
  begin
    Result := Result and TestImage(Images[I]);
    if not Result then Break;
  end;
end;

function DetermineFileFormat(const FileName: string): string;
var
  I: LongInt;
  Fmt: TImageFileFormat;
  Handle: TImagingHandle;
begin
  Result := '';
  SetFileIO;
  try
    Handle := IO.OpenRead(PChar(FileName));
    try
      for I := 0 to ImageFileFormats.Count - 1 do
      begin
        Fmt := TImageFileFormat(ImageFileFormats[I]);
        if Fmt.TestFormat(Handle) then
        begin
          Result := Fmt.Extensions[0];
          Exit;
        end;
      end;
    finally
      IO.Close(Handle);
    end;
  except
  end;
end;

function DetermineStreamFormat(Stream: TStream): string;
var
  I: LongInt;
  Fmt: TImageFileFormat;
  Handle: TImagingHandle;
begin
  Result := '';
  SetStreamIO;
  try
    Handle := IO.OpenRead(Pointer(Stream));
    for I := 0 to ImageFileFormats.Count - 1 do
    begin
      Fmt := TImageFileFormat(ImageFileFormats[I]);
      if Fmt.TestFormat(Handle) then
      begin
        Result := Fmt.Extensions[0];
        Exit;
      end;
    end;
    IO.Close(Handle);
  except
  end;
end;

function DetermineMemoryFormat(Data: Pointer; Size: LongInt): string;
var
  I: LongInt;
  Fmt: TImageFileFormat;
  Handle: TImagingHandle;
  IORec: TMemoryIORec;
begin
  Result := '';
  SetMemoryIO;
  IORec.Data := Data;
  IORec.Position := 0;
  IORec.Size := Size;
  try
    Handle := IO.OpenRead(@IORec);
    for I := 0 to ImageFileFormats.Count - 1 do
    begin
      Fmt := TImageFileFormat(ImageFileFormats[I]);
      if Fmt.TestFormat(Handle) then
      begin
        Result := Fmt.Extensions[0];
        Exit;
      end;
    end;
    IO.Close(Handle);
  except
  end;
end;

function LoadImageFromFile(const FileName: string; var Image: TImageData):
  Boolean;
var
  Ext: string;
  Format: TImageFileFormat;
  IArray: TDynImageDataArray;
  I: LongInt;
begin
  Result := False;
  Ext := GetFileExt(FileName);
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
  begin
    Result := Format.LoadFromFile(FileName, IArray, True);
    FreeImage(Image);
    Image := IArray[0];
    if Length(IArray) > 1 then
      for I := 1 to Length(IArray) - 1 do
        FreeImage(IArray[I]);
  end;
end;

function LoadImageFromStream(const Ext: string; Stream: TStream; var Image:
  TImageData): Boolean;
var
  Format: TImageFileFormat;
  IArray: TDynImageDataArray;
  I: LongInt;
begin
  Result := False;
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
  begin
    Result := Format.LoadFromStream(Stream, IArray, True);
    FreeImage(Image);
    Image := IArray[0];
    if Length(IArray) > 1 then
      for I := 1 to Length(IArray) - 1 do
        FreeImage(IArray[I]);
  end;
end;

function LoadImageFromMemory(const Ext: string; Data: Pointer; Size: LongInt;
  var Image: TImageData): Boolean;
var
  Format: TImageFileFormat;
  IArray: TDynImageDataArray;
  I: LongInt;
begin
  Result := False;
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
  begin
    Result := Format.LoadFromMemory(Data, Size, IArray, True);
    FreeImage(Image);
    Image := IArray[0];
    if Length(IArray) > 1 then
      for I := 1 to Length(IArray) - 1 do
        FreeImage(IArray[I]);
  end;
end;

function LoadMultiImageFromFile(const FileName: string; var Images:
  TDynImageDataArray): Boolean;
var
  Ext: string;
  Format: TImageFileFormat;
begin
  Result := False;
  Ext := GetFileExt(FileName);
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
  begin
    FreeImagesInArray(Images);
    Result := Format.LoadFromFile(FileName, Images);
  end;
end;

function LoadMultiImageFromStream(const Ext: string; Stream: TStream; var
  Images:
  TDynImageDataArray): Boolean;
var
  Format: TImageFileFormat;
begin
  Result := False;
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
  begin
    FreeImagesInArray(Images);
    Result := Format.LoadFromStream(Stream, Images);
  end;
end;

function LoadMultiImageFromMemory(const Ext: string; Data: Pointer; Size:
  LongInt; var Images: TDynImageDataArray): Boolean;
var
  Format: TImageFileFormat;
begin
  Result := False;
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
  begin
    FreeImagesInArray(Images);
    Result := Format.LoadFromMemory(Data, Size, Images);
  end;
end;

function SaveImageToFile(const FileName: string; const Image: TImageData): Boolean;
var
  Ext: string;
  Format: TImageFileFormat;
  IArray: TDynImageDataArray;
begin
  Result := False;
  Ext := GetFileExt(FileName);
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
  begin
    SetLength(IArray, 1);
    IArray[0] := Image;
    Result := Format.SaveToFile(FileName, IArray, True);
  end;
end;

function SaveImageToStream(const Ext: string; Stream: TStream;
  const Image: TImageData): Boolean;
var
  Format: TImageFileFormat;
  IArray: TDynImageDataArray;
begin
  Result := False;
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
  begin
    SetLength(IArray, 1);
    IArray[0] := Image;
    Result := Format.SaveToStream(Stream, IArray, True);
  end;
end;

function SaveImageToMemory(const Ext: string; Data: Pointer; var Size: LongInt;
  const Image: TImageData): Boolean;
var
  Format: TImageFileFormat;
  IArray: TDynImageDataArray;
begin
  Result := False;
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
  begin
    SetLength(IArray, 1);
    IArray[0] := Image;
    Result := Format.SaveToMemory(Data, Size, IArray, True);
  end;
end;

function SaveMultiImageToFile(const FileName: string;
  const Images: TDynImageDataArray): Boolean;
var
  Ext: string;
  Format: TImageFileFormat;
begin
  Result := False;
  Ext := GetFileExt(FileName);
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
    Result := Format.SaveToFile(FileName, Images);
end;

function SaveMultiImageToStream(const Ext: string; Stream: TStream;
  const Images: TDynImageDataArray): Boolean;
var
  Format: TImageFileFormat;
begin
  Result := False;
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
    Result := Format.SaveToStream(Stream, Images);
end;

function SaveMultiImageToMemory(const Ext: string; Data: Pointer;
  var Size: LongInt; const Images: TDynImageDataArray): Boolean;
var
  Format: TImageFileFormat;
begin
  Result := False;
  Format := FindImageFileFormat(Ext);
  if Format <> nil then
    Result := Format.SaveToMemory(Data, Size, Images);
end;

function CloneImage(const Image: TImageData; var Clone: TImageData): Boolean;
var
  Info: PImageFormatInfo;
begin
  Result := False;
  if TestImage(Image) then
    with Image do
    try
      if TestImage(Clone) and (Image.Bits <> Clone.Bits) and
        (Image.Palette <> Clone.Palette) then
        FreeImage(Clone)
      else
        InitImage(Clone);
      Info := ImageFormatInfos[Format];
      Clone.Width := Width;
      Clone.Height := Height;
      Clone.Format := Format;
      Clone.Size := Size;
      if Info.PaletteEntries > 0 then
      begin
        GetMem(Clone.Palette, Info.PaletteEntries * SizeOf(TColor32Rec));
        Move(Palette^, Clone.Palette^, Info.PaletteEntries *
          SizeOf(TColor32Rec));
      end;
      GetMem(Clone.Bits, Clone.Size);
      Move(Bits^, Clone.Bits^, Clone.Size);
      Result := True;
    except
      RaiseImaging(sErrorCloneImage, [ImageToStr(Image)]);
    end;
end;

function ConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean;
var
  NewData: Pointer;
  NewPal: PPalette32;
  NewSize, NumPixels: LongInt;
  SrcInfo, DstInfo: PImageFormatInfo;
begin
  Result := False;
  if TestImage(Image) then
  with Image do
  try
    if DestFormat in [ifDefault, ifUnknown] then
      DestFormat := DefaultImageFormat;
    SrcInfo := ImageFormatInfos[Format];
    DstInfo := ImageFormatInfos[DestFormat];
    if SrcInfo = DstInfo then
    begin
      Result := True;
      Exit;
    end;
    if (SrcInfo = nil) or (DstInfo = nil) then
      Exit;

    if (not SrcInfo.IsSpecial) and (not DstInfo.IsSpecial) then
    begin
      NumPixels := Width * Height;
      NewSize := NumPixels * DstInfo.BytesPerPixel;
      GetMem(NewData, NewSize);
      GetMem(NewPal, DstInfo.PaletteEntries * SizeOf(TColor32Rec));

      // Source: indexed format
      if SrcInfo.IsIndexed then
      begin
        if DstInfo.IsIndexed then
          IndexToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette,
            NewPal)
        else
          if DstInfo.HasGrayChannel then
            IndexToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette)
          else
            if DstInfo.IsFloatingPoint then
              IndexToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo, Palette)
            else
              IndexToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo,
                Palette)
      end
      else
        // Source: grayscale format
        if SrcInfo.HasGrayChannel then
        begin
          if DstInfo.IsIndexed then
            GrayToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal)
          else
            if DstInfo.HasGrayChannel then
              GrayToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo)
            else
              if DstInfo.IsFloatingPoint then
                GrayToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo)
              else
                GrayToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo);
        end
        else
          // Source: floating point format
          if SrcInfo.IsFloatingPoint then
          begin
            if DstInfo.IsIndexed then
              FloatToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal)
            else
              if DstInfo.HasGrayChannel then
                FloatToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo)
              else
                if DstInfo.IsFloatingPoint then
                  FloatToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo)
                else
                  FloatToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo);
          end
          else
            // Source: standard multi channel image
          begin
            if DstInfo.IsIndexed then
              ChannelToIndex(NumPixels, Bits, NewData, SrcInfo, DstInfo, NewPal)
            else
              if DstInfo.HasGrayChannel then
                ChannelToGray(NumPixels, Bits, NewData, SrcInfo, DstInfo)
              else
                if DstInfo.IsFloatingPoint then
                  ChannelToFloat(NumPixels, Bits, NewData, SrcInfo, DstInfo)
                else
                  ChannelToChannel(NumPixels, Bits, NewData, SrcInfo, DstInfo);
          end;

      FreeMem(Bits);
      FreeMem(Palette);
      Format := DestFormat;
      Bits := NewData;
      Size := NewSize;
      Palette := NewPal;
    end
    else
      ConvertSpecial(Image, SrcInfo, DstInfo);

    Result := True;
  except
    RaiseImaging(sErrorConvertImage, [GetFormatName(DestFormat),
      ImageToStr(Image)]);
  end;
end;

function FlipImage(var Image: TImageData): Boolean;
var
  P1, P2, Buff: Pointer;
  WidthBytes, I: LongInt;
  OldFmt: TImageFormat;
begin
  Result := False;
  OldFmt := Image.Format;
  if TestImage(Image) then
  with Image do
  try
    if ImageFormatInfos[OldFmt].IsSpecial then
      ConvertImage(Image, ifDefault);
    WidthBytes := Width * ImageFormatInfos[Format].BytesPerPixel;
    GetMem(Buff, WidthBytes);
    try
      // swap all scanlines of image
      for I := 0 to Height div 2 - 1 do
      begin
        P1 := @PByteArray(Bits)[I * WidthBytes];
        P2 := @PByteArray(Bits)[(Height - I - 1) * WidthBytes];
        Move(P1^, Buff^, WidthBytes);
        Move(P2^, P1^, WidthBytes);
        Move(Buff^, P2^, WidthBytes);
      end;
      Result := True;
    finally
      FreeMem(Buff);
    end;
    if OldFmt <> Format then
      ConvertImage(Image, OldFmt);
  except
    RaiseImaging(sErrorFlipImage, [ImageToStr(Image)]);
  end;
end;

function MirrorImage(var Image: TImageData): Boolean;
var
  Scanline: PByte;
  Buff: TColorFRec;
  Bpp, Y, X, WidthDiv2, WidthBytes, XLeft, XRight: LongInt;
  OldFmt: TImageFormat;

begin
  Result := False;
  OldFmt := Image.Format;
  if TestImage(Image) then
  with Image do
  try
    if ImageFormatInfos[OldFmt].IsSpecial then
      ConvertImage(Image, ifDefault);
    Bpp := ImageFormatInfos[Format].BytesPerPixel;
    WidthDiv2 := Width div 2;
    WidthBytes := Width * Bpp;
    // mirror all pixels on each scanline of image
    for Y := 0 to Height - 1 do
    begin
      Scanline := @PByteArray(Bits)[Y * WidthBytes];
      XLeft := 0;
      XRight := (Width - 1) * Bpp;
      for X := 0 to WidthDiv2 - 1 do
      begin
        CopyPixel(@PByteArray(Scanline)[XLeft], @Buff, Bpp);
        CopyPixel(@PByteArray(Scanline)[XRight],
          @PByteArray(Scanline)[XLeft], Bpp);
        CopyPixel(@Buff, @PByteArray(Scanline)[XRight], Bpp);
        Inc(XLeft, Bpp);
        Dec(XRight, Bpp);
      end;
    end;
    Result := True;
    if OldFmt <> Format then
      ConvertImage(Image, OldFmt);
  except
    RaiseImaging(sErrorMirrorImage, [ImageToStr(Image)]);
  end;
end;

function ResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt):
  Boolean;
var
  X, Y, Sx, Sy: LongInt;
  Xp, Yp, Bpp, Bpl: LongInt;
  Data, Line, NewPix: PByte;
  OldFmt: TImageFormat;
begin
  Result := False;
  if TestImage(Image) and (Image.Width <> NewWidth) or
    (Image.Height <> NewHeight) then
  with Image do
  try
    OldFmt := Format;
    if ImageFormatInfos[OldFmt].IsSpecial then
      ConvertImage(Image, ifDefault);
    Bpp := ImageFormatInfos[Format].BytesPerPixel;
    Bpl := Width * Bpp;
    GetMem(Data, NewWidth * NewHeight * Bpp);
    Sx := (Width shl 16) div NewWidth;
    Sy := (Height shl 16) div NewHeight;
    Yp := 0;
    NewPix := Data;
    for Y := 0 to NewHeight - 1 do
    begin
      Xp := 0;
      Line := @PByteArray(Bits)[(Yp shr 16) * Bpl];
      for X := 0 to NewWidth - 1 do
      begin
        case Bpp of
          1: PByte(NewPix)^ := PByteArray(Line)[Xp shr 16];
          2: PWord(NewPix)^ := PWordArray(Line)[Xp shr 16];
          3: PColor24Rec(NewPix)^ := PPalette24(Line)[Xp shr 16];
          4: PColor32(NewPix)^ := PLongWordArray(Line)[Xp shr 16];
          6: PColor48Rec(NewPix)^ := PColor48RecArray(Line)[Xp shr 16];
          8: PColor64(NewPix)^ := PInt64Array(Line)[Xp shr 16];
          16: PColorFRec(NewPix)^ := PColorFRecArray(Line)[Xp shr 16];
        end;
        Inc(NewPix, Bpp);
        Inc(Xp, Sx);
      end;
      Inc(Yp, Sy);
    end;
    Width := NewWidth;
    Height := NewHeight;
    Size := NewWidth * NewHeight * LongInt(Bpp);
    FreeMem(Bits);
    Bits := Data;
    if OldFmt <> Format then
      ConvertImage(Image, OldFmt);
    Result := True;
  except
    RaiseImaging(sErrorResizeImage, [ImageToStr(Image)]);
  end;
end;

function SwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean;
var
  I, NumPixels: LongInt;
  Info: PImageFormatInfo;
  Swap, Alpha: Word;
  Data: PByte;
  Pix64: TColor64Rec;
  PixF: TColorFRec;
  SwapF: Single;
begin
  Result := False;
  if TestImage(Image) then
  with Image do
  try
    NumPixels := Width * Height;
    Info := ImageFormatInfos[Format];
    Data := Bits;

    // first swap channels of most common formats
    if (Info.Format = ifA8R8G8B8) or ((Info.Format = ifR8G8B8) and
       (SrcChannel <> ChannelAlpha) and (DstChannel <> ChannelAlpha)) then
      for I := 0 to NumPixels - 1 do
        with PColor24Rec(Data)^ do
        begin
          Swap := Channels[SrcChannel];
          Channels[SrcChannel] := Channels[DstChannel];
          Channels[DstChannel] := Swap;
          Inc(Data, Info.BytesPerPixel);
        end
    else
      // swap palette channels of indexed images
      if Info.IsIndexed then
        SwapChannelsOfPalette(Palette, Info.PaletteEntries, SrcChannel,
          DstChannel)
      else
        // swap channels of floating point images
        if Info.IsFloatingPoint then
        begin
          for I := 0 to NumPixels - 1 do
          begin
            FloatGetSrcPixel(Data, Info, PixF);
            with PixF do
            begin
              SwapF := Channels[SrcChannel];
              Channels[SrcChannel] := Channels[DstChannel];
              Channels[DstChannel] := SwapF;
            end;
            FloatSetDstPixel(Data, Info, PixF);
            Inc(Data, Info.BytesPerPixel);
          end;
        end
        else
          // swap channels of special format images
          if Info.IsSpecial then
          begin
            ConvertImage(Image, ifDefault);
            SwapChannels(Image, SrcChannel, DstChannel);
            ConvertImage(Image, Info.Format);
          end
          else
            if Info.HasGrayChannel and Info.HasAlphaChannel and
              ((SrcChannel = ChannelAlpha) or (DstChannel = ChannelAlpha)) then
              begin
                for I := 0 to NumPixels - 1 do
                begin
                  // if we have grayscale image with alpha and alpha is channel
                  // to be swapped, we swap it
                  GrayGetSrcPixel(Data, Info, Pix64, Alpha);
                  Swap := Alpha;
                  Alpha := Pix64.A;
                  Pix64.A := Swap;
                  GraySetDstPixel(Data, Info, Pix64, Alpha);
                  Inc(Data, Info.BytesPerPixel);
                end;
              end
            else
              // then do general swap on other channel image formats
              for I := 0 to NumPixels - 1 do
              begin
                ChannelGetSrcPixel(Data, Info, Pix64);
                with Pix64 do
                begin
                  Swap := Channels[SrcChannel];
                  Channels[SrcChannel] := Channels[DstChannel];
                  Channels[DstChannel] := Swap;
                end;
                ChannelSetDstPixel(Data, Info, Pix64);
                Inc(Data, Info.BytesPerPixel);
              end;
    Result := True;
  except
    RaiseImaging(sErrorSwapImage, [ImageToStr(Image)]);
  end;
end;

function ReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean;
var
  TmpInfo: TImageFormatInfo;
  Data, Index: PWord;
  I, NumPixels: LongInt;
  Pal: PPalette32;
  Col:PColor32Rec;
  OldFmt: TImageFormat;
begin
  Result := False;
  if TestImage(Image) then
  with Image do
  try
    // first create temp image info and allocate output bits and palette
    MaxColors := Iff(MaxColors > $FFFF, $FFFF, MaxColors);
    OldFmt := Format;
    FillChar(TmpInfo, SizeOf(TmpInfo), 0);
    TmpInfo.PaletteEntries := MaxColors;
    TmpInfo.BytesPerPixel := 2;
    NumPixels := Width * Height;
    GetMem(Data, NumPixels * TmpInfo.BytesPerPixel);
    GetMem(Pal, MaxColors * SizeOf(TColor32Rec));
    ConvertImage(Image, ifA8R8G8B8);
    // we use median cut algorithm to create reduced palette and to
    // fill Data with indices to this palette
    ReduceColorsMedianCut(NumPixels, Bits, PByte(Data),
      ImageFormatInfos[Format], @TmpInfo, MaxColors,
      GetOption(ImagingColorReductionMask), Pal);
    Col := Bits;
    Index := Data;
    // then we write reduced colors to the input image
    for I := 0 to NumPixels - 1 do
    begin
      Col.Color := Pal[Index^].Color;
      Inc(Col);
      Inc(Index);
    end;
    FreeMem(Data);
    FreeMem(Pal);
    // and convert it to its original format
    ConvertImage(Image, OldFmt);
    Result := True;
  except
    RaiseImaging(sErrorReduceColors, [MaxColors, ImageToStr(Image)]);
  end;
end;

function GenerateMipMaps(const Image: TImageData; Levels: LongInt;
  var MipMaps: TDynImageDataArray): Boolean;
var
  Width, Height, I, Count: LongInt;

  function GetNumLevels(Width, Height: LongInt): LongInt;
  begin
    Result := 0;
    if (Width > 0) and (Height > 0) then
    begin
      Result := 1;
      while (Width <> 1) and (Height <> 1) do
      begin
        Width := Width shr 1;
        Height := Height shr 1;
        if Width < 1 then
          Width := 1;
        if Height < 1 then
          Height := 1;
        Inc(Result);
      end;
    end;
  end;

begin
  Result := False;
  if TestImage(Image) then
  try
    Width := Image.Width;
    Height := Image.Height;
    // we compute number of possible mipmap levels and if
    // the given levels are invalid or zero we use this value
    Count := GetNumLevels(Width, Height);
    if (Levels = 0) or (Levels > Count) then
      Levels := Count;

    FreeImagesInArray(MipMaps);
    SetLength(MipMaps, Levels);
    CloneImage(Image, MipMaps[0]);

    for I := 1 to Levels - 1 do
    begin
      Width := Width shr 1;
      Height := Height shr 1;
      if Width < 1 then
        Width := 1;
      if Height < 1 then
        Height := 1;
      CloneImage(MipMaps[I - 1], MipMaps[I]);
      ResizeImage(MipMaps[I], Width, Height);
    end;
    Result := True;
  except
    RaiseImaging(sErrorGenerateMipMaps, [Levels, ImageToStr(Image)]);
  end;
end;

function CopyRect(const SrcImage: TImageData; var DstImage: TImageData;
  SrcX, SrcY, Width, Height, DstX, DstY: LongInt): Boolean;
var
  Info: PImageFormatInfo;
  I, SrcWidthBytes, DstWidthBytes, MoveBytes: LongInt;
  SrcPointer, DstPointer: PByte;
  TmpImage: TImageData;
  OldFormat: TImageFormat;
begin
  Result := False;
  OldFormat := ifUnknown;
  if TestImage(SrcImage) and TestImage(DstImage) then
  try
    // make sure we are still in images' areas
    if DstX < 0 then
    begin
      Width := Width + DstX;
      if DstX < SrcX then
        SrcX := Abs(DstX) + SrcX;
      DstX := 0;
    end;
    if DstY < 0 then
    begin
      Height := Height + DstY;
      if DstY < SrcY then
        SrcY := Abs(DstY) + SrcY;
      DstY := 0;
    end;
    if SrcX < 0 then
    begin
      Width := Width + SrcX;
      SrcX := 0;
    end;
    if SrcY < 0 then
    begin
      Height := Height + SrcY;
      SrcY := 0;
    end;
    if SrcX + Width > SrcImage.Width then Width := SrcImage.Width - SrcX;
    if SrcY + Height > SrcImage.Height then Height := SrcImage.Height - SrcY;
    if DstX + Width > DstImage.Width then Width := DstImage.Width - DstX;
    if DstY + Height > DstImage.Height then Height := DstImage.Height - DstY;

    if (Width > 0) and (Height > 0) then
    begin
      Info := ImageFormatInfos[DstImage.Format];
      if Info.IsSpecial then
      begin
        // if dest image is in special format we convert it to default
        OldFormat := Info.Format;
        ConvertImage(DstImage, ifDefault);
        Info := ImageFormatInfos[DstImage.Format];
      end;
      MoveBytes := Width * Info.BytesPerPixel;
      DstWidthBytes := DstImage.Width * Info.BytesPerPixel;
      DstPointer := @PByteArray(DstImage.Bits)[DstY * DstWidthBytes +
        DstX * Info.BytesPerPixel];
      if SrcImage.Format = DstImage.Format then
      begin
        // if images are in the same format we only copy memory
        SrcWidthBytes := SrcImage.Width * Info.BytesPerPixel;
        SrcPointer := @PByteArray(SrcImage.Bits)[SrcY * SrcWidthBytes +
          SrcX * Info.BytesPerPixel];
        for I := 0 to Height - 1 do
        begin
          Move(SrcPointer^, DstPointer^, MoveBytes);
          Inc(SrcPointer, SrcWidthBytes);
          Inc(DstPointer, DstWidthBytes);
        end;
      end
      else
      begin
        // clone source image and convert it to dest's format
        InitImage(TmpImage);
        CloneImage(SrcImage, TmpImage);
        ConvertImage(TmpImage, Info.Format);
        // copy memory from clone to dest
        SrcWidthBytes := TmpImage.Width * Info.BytesPerPixel;;
        SrcPointer := @PByteArray(TmpImage.Bits)[SrcY * SrcWidthBytes +
          SrcX * Info.BytesPerPixel];
        for I := 0 to Height - 1 do
        begin
          Move(SrcPointer^, DstPointer^, MoveBytes);
          Inc(SrcPointer, SrcWidthBytes);
          Inc(DstPointer, DstWidthBytes);
        end;
        FreeImage(TmpImage);
      end;
      // if dest image was in special format we convert it back
      if OldFormat <> ifUnknown then
        ConvertImage(DstImage, OldFormat);
    end;
    Result := True;
  except
    RaiseImaging(sErrorCopyRect, [ImageToStr(SrcImage), ImageToStr(DstImage)]);
  end;
end;

function MapImageToPalette(var Image: TImageData; Pal: PPalette32;
  Entries: LongInt): Boolean;

  function FindNearestColor(Pal: PPalette32; Entries: LongInt; Col: TColor32Rec): LongInt;
  var
    I, MinDif, Dif: LongInt;
  begin
    Result := 0;
    MinDif := 1020;
    for I := 0 to Entries - 1 do
      with Pal[I] do
      begin
        Dif := Abs(R - Col.R);
        if Dif > MinDif then Continue;
        Dif := Dif + Abs(G - Col.G);
        if Dif > MinDif then Continue;
        Dif := Dif + Abs(B - Col.B);
        if Dif > MinDif then Continue;
        Dif := Dif + Abs(A - Col.A);
        if Dif < MinDif then
        begin
          MinDif := Dif;
          Result := I;
        end;
      end;
  end;

var
  I, MaxEntries: LongInt;
  PIndex: PByte;
  PColor: PColor32Rec;
  CloneARGB: TImageData;
  Info: PImageFormatInfo;
begin
  Result := False;
  if TestImage(Image) and (Entries <= 256) then
  try
    // we create clone of source image in A8R8G8B8 and
    // then recreate source image in ifIndex8 format
    // with palette taken from Pal parameter
    InitImage(CloneARGB);
    CloneImage(Image, CloneARGB);
    ConvertImage(CloneARGB, ifA8R8G8B8);
    FreeImage(Image);
    NewImage(CloneARGB.Width, CloneARGB.Height, ifIndex8, Image);

    Info := ImageFormatInfos[Image.Format];
    MaxEntries := Min(Info.PaletteEntries, Entries);
    Move(Pal^, Image.Palette^, MaxEntries * SizeOf(TColor32Rec));
    PIndex := Image.Bits;
    PColor := CloneARGB.Bits;

    // for every pixel of ARGB clone we find closest color in
    // given palette and assign its index to resulting image's pixel
    // procedure used here is very slow but simple and memory usage friendly
    // (contrary to other methods)
    for I := 0 to Image.Width * Image.Height - 1 do
    begin
      PIndex^ := FindNearestColor(Image.Palette, MaxEntries, PColor^);
      Inc(PIndex);
      Inc(PColor);
    end;

    FreeImage(CloneARGB);
    Result := True;
  except
    RaiseImaging(sErrorMapImage, [ImageToStr(Image)]);
  end;
end;

function FillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
  Fill: Pointer): Boolean;
var
  Info: PImageFormatInfo;
  I, J, WidthBytes, Bpp: Longint;
  LinePointer, PixPointer: PByte;
  OldFmt: TImageFormat;
begin
  OldFmt := Image.Format;
  Result := False;
  if TestImage(Image) then
  try
    if X < 0 then
    begin
      Width := Width + X;
      X := 0;
    end;
    if Y < 0 then
    begin
      Height := Height + Y;
      Y := 0;
    end;
    if X + Width > Image.Width then Width := Image.Width - X;
    if Y + Height > Image.Height then Height := Image.Height - Y;

    if (Width > 0) and (Height > 0) then
    begin
      if ImageFormatInfos[OldFmt].IsSpecial then
        ConvertImage(Image, ifDefault);
      Info := ImageFormatInfos[Image.Format];
      Bpp := Info.BytesPerPixel;
      WidthBytes := Image.Width * Bpp;
      LinePointer := @PByteArray(Image.Bits)[Y * WidthBytes + X * Bpp];
      for I := 0 to Height - 1 do
      begin
        PixPointer := LinePointer;
        for J := 0 to Width - 1 do
        begin
          CopyPixel(Fill, PixPointer, Bpp);
          Inc(PixPointer, Bpp);
        end;
        Inc(LinePointer, WidthBytes);
      end;
    end;

    if OldFmt <> Image.Format then
      ConvertImage(Image, OldFmt);
    Result := True;
  except
    RaiseImaging(sErrorFillRect, [X, Y, Width, Height, ImageToStr(Image)]);
  end;
end;

function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray;
  ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
  PreserveSize: Boolean; Fill: Pointer): Boolean;
var
  X, Y, XTrunc, YTrunc: LongInt;
  NotOnEdge: Boolean;
  Info: PImageFormatInfo;
  OldFmt: TImageFormat;
begin
  OldFmt := Image.Format;
  Result := False;
  if TestImage(Image) then
  try
    Info := ImageFormatInfos[Image.Format];
    if Info.IsSpecial then
      ConvertImage(Image, ifDefault);
    // we compute make sure that chunks are not larger than source image or negative
    ChunkWidth := ClampInt(ChunkWidth, 0, Image.Width);
    ChunkHeight := ClampInt(ChunkHeight, 0, Image.Height);
    // number of chunks along X and Y axes is computed
    XChunks := Trunc(Ceil(Image.Width / ChunkWidth));
    YChunks := Trunc(Ceil(Image.Height / ChunkHeight));

    FreeImagesInArray(Chunks);
    SetLength(Chunks, XChunks * YChunks);
    // for every chunk we create new image and copy a portion of
    // the source image to it. If chunk is on the edge of the source image
    // we fill enpty space with Fill pixel data if PreserveSize is set or
    // make the chunk smaller if it is not set
    for Y := 0 to YChunks - 1 do
      for X := 0 to XChunks - 1 do
      begin
        NotOnEdge := ((X < XChunks - 1) and (Y < YChunks - 1)) or
          ((Image.Width mod ChunkWidth = 0) and (Image.Height mod ChunkHeight = 0));

        if PreserveSize or NotOnEdge then
        begin
          NewImage(ChunkWidth, ChunkHeight, Image.Format, Chunks[Y * XChunks + X]);
          if (not NotOnEdge) and (Fill <> nil) then
            FillRect(Chunks[Y * XChunks + X], 0, 0, ChunkWidth, ChunkHeight, Fill);
          CopyRect(Image, Chunks[Y * XChunks + X], X * ChunkWidth, Y * ChunkHeight,
            ChunkWidth, ChunkHeight, 0, 0);
        end
        else
        begin
          XTrunc := Image.Width - (Image.Width div ChunkWidth) * ChunkWidth;
          YTrunc := Image.Height - (Image.Height div ChunkHeight) * ChunkHeight;
          NewImage(XTrunc, YTrunc, Image.Format, Chunks[Y * XChunks + X]);
          CopyRect(Image, Chunks[Y * XChunks + X], X * ChunkWidth, Y * ChunkHeight,
            XTrunc, YTrunc, 0, 0);
        end;
        // if source image is in indexed format we copy its palette to chunk
        if Info.IsIndexed then
          Move(Image.Palette^, Chunks[Y * XChunks + X].Palette^,
            Info.PaletteEntries * SizeOf(TColor32Rec));
      end;

    if OldFmt <> Image.Format then
    begin
      ConvertImage(Image, OldFmt);
      for X := 0 to Length(Chunks) - 1 do
        ConvertImage(Chunks[X], OldFmt);
    end;

    Result := True;
  except
    RaiseImaging(sErrorSplitImage, [ImageToStr(Image), ChunkWidth, ChunkHeight]);
  end;
end;

function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32;
  MaxColors: LongInt; ConvertImages: Boolean): Boolean;
var
  I: LongInt;
  SrcInfo, DstInfo: PImageFormatInfo;
  Target: TImageData;
  DstFormat: TImageFormat;
begin
  Result := False;
  if TestImagesInArray(Images) then
  try
    // we null the color histogram
    ReduceColorsMedianCut(0, nil, nil, nil, nil, 0, 0, nil, [raCreateHistogram]);
    for I := 0 to Length(Images) - 1 do
    begin
      SrcInfo := ImageFormatInfos[Images[I].Format];
      // update histogram with colors of each input image
      ReduceColorsMedianCut(Images[I].Width * Images[I].Height, Images[I].Bits,
        nil, SrcInfo, nil, MaxColors, GetOption(ImagingColorReductionMask),
        nil, [raUpdateHistogram]);
    end;
    // construct reduced color map from the histogram
    ReduceColorsMedianCut(0, nil, nil, nil, nil, MaxColors,
      GetOption(ImagingColorReductionMask), Pal, [raMakeColorMap]);

    if ConvertImages then
    begin
      DstFormat := ifIndex8;
      DstInfo := ImageFormatInfos[DstFormat];
      MaxColors := Min(DstInfo.PaletteEntries, MaxColors);
      for I := 0 to Length(Images) - 1 do
      begin
        SrcInfo := ImageFormatInfos[Images[I].Format];
        InitImage(Target);
        NewImage(Images[I].Width, Images[I].Height, DstFormat, Target);
        // we map each input image to reduced palette and replace
        // image in array with mapped image
        ReduceColorsMedianCut(Images[I].Width * Images[I].Height, Images[I].Bits,
          Target.Bits, SrcInfo, DstInfo, MaxColors, 0, nil, [raMapImage]);
        Move(Pal^, Target.Palette^, MaxColors * SizeOf(TColor32Rec));
        FreeImage(Images[I]);
        Images[I] := Target;
      end;
    end;
    Result := True;
  except
    RaiseImaging(sErrorMakePaletteForImages, [MaxColors, Length(Images)]);
  end;
end;

function NewPalette(Entries: LongInt; var Pal: PPalette32): Boolean;
begin
  Result := False;
  try
    GetMem(Pal, Entries * SizeOf(TColor32Rec));
    FillChar(Pal^, Entries * SizeOf(TColor32Rec), $FF);
    Result := True;
  except
    RaiseImaging(sErrorNewPalette, [Entries]);
  end;
end;

function FreePalette(var Pal: PPalette32): Boolean;
begin
  Result := False;
  try
    FreeMem(Pal);
    Pal := nil;
    Result := True;
  except
    RaiseImaging(sErrorFreePalette, [Pal]);
  end;
end;

function CopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean;
begin
  Result := False;
  try
    Move(SrcPal[SrcIdx], DstPal[DstIdx], Count * SizeOf(TColor32Rec));
    Result := True;
  except
    RaiseImaging(sErrorCopyPalette, [Count, SrcPal, DstPal]);
  end;
end;

function FindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32):
  LongInt;
var
  Col: TColor32Rec;
  I, MinDif, Dif: LongInt;
begin
  Result := 0;
  Col.Color := Color;
  if Pal <> nil then
  try
    // first try to find exact match
    for I := 0 to Entries - 1 do
      with Pal[I] do
      begin
        if (A = Col.A) and (R = Col.R) and
          (G = Col.G) and (B = Col.B) then
        begin
          Result := I;
          Exit;
        end;
      end;

    // if exact match was not found, find nearest color
    MinDif := 1020;
    for I := 0 to Entries - 1 do
      with Pal[I] do
      begin
        Dif := Abs(R - Col.R);
        if Dif > MinDif then Continue;
        Dif := Dif + Abs(G - Col.G);
        if Dif > MinDif then Continue;
        Dif := Dif + Abs(B - Col.B);
        if Dif > MinDif then Continue;
        Dif := Dif + Abs(A - Col.A);
        if Dif < MinDif then
        begin
          MinDif := Dif;
          Result := I;
        end;
      end;
  except
    RaiseImaging(sErrorFindColor, [Pal, Entries]);
  end;
end;

function FillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean;
var
  I: LongInt;
begin
  Result := False;
  if Pal <> nil then
  try
    for I := 0 to Entries - 1 do
      with Pal[I] do
      begin
        A := $FF;
        R := I;
        G := I;
        B := I;
      end;
      Result := True;
  except
     RaiseImaging(sErrorGrayscalePalette, [Pal, Entries]);
  end;
end;

function FillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
  BBits: Byte; Alpha: Byte = $FF): Boolean;
var
  I, TotalBits, MaxEntries: LongInt;
begin
  Result := False;
  TotalBits := RBits + GBits + BBits;
  MaxEntries := Min(Pow2Int(TotalBits), Entries);
  FillChar(Pal^, Entries * SizeOf(TColor32Rec), 0);  
  if Pal <> nil then
  try
    for I := 0 to MaxEntries - 1 do
      with Pal[I] do
      begin
        A := Alpha;
        if RBits > 0 then
          R := ((I shr Max(0, GBits + BBits - 1)) and (1 shl RBits - 1)) * 255 div (1 shl RBits - 1);
        if GBits > 0 then
          G := ((I shr Max(0, BBits - 1)) and (1 shl GBits - 1)) * 255 div (1 shl GBits - 1);
        if BBits > 0 then
          B := ((I shr 0) and (1 shl BBits - 1)) * 255 div (1 shl BBits - 1);
      end;
      Result := True;
  except
     RaiseImaging(sErrorCustomPalette, [Pal, Entries]);
  end;
end;

function SwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
  DstChannel: LongInt): Boolean;
var
  I: LongInt;
  Swap: Byte;
begin
  Result := False;
  if Pal <> nil then
  try
    for I := 0 to Entries - 1 do
      with Pal[I] do
      begin
        Swap := Channels[SrcChannel];
        Channels[SrcChannel] := Channels[DstChannel];
        Channels[DstChannel] := Swap;
      end;
      Result := True;
  except
     RaiseImaging(sErrorSwapPalette, [Pal, Entries]);
  end;
end;

function SetOption(OptionId, Value: LongInt): Boolean;
begin
  Result := False;
  if (OptionId >= 0) and (OptionId < Length(Options)) and
    (Options[OptionID] <> nil) then
  begin
    Options[OptionID]^ := Value;
    Result := True;
  end;
end;

function GetOption(OptionId: LongInt): LongInt;
begin
  Result := InvalidOption;
  if (OptionId >= 0) and (OptionId < Length(Options)) and
    (Options[OptionID] <> nil) then
    Result := Options[OptionID]^;
end;

function PushOptions: Boolean;
begin
  Result := OptionStack.Push;
end;

function PopOptions: Boolean;
begin
  Result := OptionStack.Pop;
end;

function GetPixelBytes(Format: TImageFormat): LongInt;
begin
  if ImageFormatInfos[Format] <> nil then
    Result := ImageFormatInfos[Format].BytesPerPixel
  else
    Result := 0;
end;

function GetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatShortInfo): Boolean;
begin
  FillChar(Info, SizeOf(Info), 0);
  if ImageFormatInfos[Format] <> nil then
  with ImageFormatInfos[Format]^ do
  begin
    Info.Format := Format;
    StrCopy(Info.Name, Name);
    Info.BytesPerPixel := BytesPerPixel;
    Info.PaletteEntries := PaletteEntries;
    Info.HasGrayChannel := HasGrayChannel;
    Info.HasAlphaChannel := HasAlphaChannel;
    Info.IsFloatingPoint := IsFloatingPoint;
    Info.UsePixelFormat := UsePixelFormat;
    Info.IsRBSwapped := IsRBSwapped;
    Info.IsIndexed := IsIndexed;
    Info.IsSpecial := IsSpecial;
    Result := True;
  end
  else
    Result := False;
end;

function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
begin
  if ImageFormatInfos[Format] <> nil then
    Result := ImageFormatInfos[Format].GetPixelsSize(Format, Width, Height)
  else
    Result := 0;
end;

procedure SetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
  TOpenWriteProc;
  CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc; TellProc:
  TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc);
begin
  FileIO.OpenRead := OpenReadProc;
  FileIO.OpenWrite := OpenWriteProc;
  FileIO.Close := CloseProc;
  FileIO.Eof := EofProc;
  FileIO.Seek := SeekProc;
  FileIO.Tell := TellProc;
  FileIO.Read := ReadProc;
  FileIO.Write := WriteProc;
end;

procedure ResetFileIO;
begin
  FileIO := OriginalFileIO;
end;


{ Other Imaging Functions }

function GetFormatName(Format: TImageFormat): string;
begin
  if ImageFormatInfos[Format] <> nil then
    Result := ImageFormatInfos[Format].Name
  else
    Result := sUnknownFormat;
end;

function ImageToStr(const Image: TImageData): string;
begin
  try
    with Image do
      Result := SysUtils.Format(sImageInfo, [@Image, Width, Height,
        GetFormatName(Format), (Size div 1024) + 0.0, Bits, Palette])
  except
    Result := SysUtils.Format(sImageInfoInvalid, [@Image]);
  end;
end;

procedure RegisterImageFileFormat(AClass: TImageFileFormatClass);
begin
  if ImageFileFormats = nil then
    ImageFileFormats := TList.Create;
  if ImageFileFormats <> nil then
    ImageFileFormats.Add(AClass.Create);
end;

procedure RegisterOption(OptionId: LongInt; Variable: PLongInt);
begin
  if Options = nil then
    InitOptions;
  if Options <> nil then
  begin
    if OptionId >= Length(Options) then
      SetLength(Options, OptionId + InitialOptions);
    if (OptionId >= 0) and (OptionId < Length(Options)) then
      Options[OptionId] := Variable;
  end;
end;

function FindImageFileFormat(const Ext: string): TImageFileFormat;
var
  I: LongInt;
begin
  Result := nil;
  for I := 0 to ImageFileFormats.Count - 1 do
    if TImageFileFormat(ImageFileFormats[I]).Extensions.IndexOf(Ext) >= 0 then
    begin
      Result := TImageFileFormat(ImageFileFormats[I]);
      Break;
    end;
end;

function GetIO: TIOFunctions;
begin
  Result := IO;
end;

procedure RaiseImaging(const Msg: string; const Args: array of const);
{$IFDEF RAISE_EXCEPTIONS}
var
  WholeMsg: string;
begin
  WholeMsg := Msg;
  if GetExceptObject <> nil then
    WholeMsg := WholeMsg + ' ' + sExceptMsg + ': ' +
      GetExceptObject.Message;
  raise EImagingError.CreateFmt(WholeMsg, Args);
end;
{$ELSE}
begin
end;
{$ENDIF}


{ Internal unit functions }

procedure SetFileIO;
begin
  IO := FileIO;
end;

procedure SetStreamIO;
begin
  IO := StreamIO;
end;

procedure SetMemoryIO;
begin
  IO := MemoryIO;
end;

procedure InitImageFormats;
begin
  ImagingFormats.InitImageFormats(ImageFormatInfos);
end;

procedure FreeImageFileFormats;
var
  I: LongInt;
begin
  if ImageFileFormats <> nil then
    for I := 0 to ImageFileFormats.Count - 1 do
      TImageFileFormat(ImageFileFormats[I]).Free;
  FreeAndNil(ImageFileFormats);
end;

procedure InitOptions;
begin
  SetLength(Options, InitialOptions);
  OptionStack := TOptionStack.Create;
end;

procedure FreeOptions;
begin
  SetLength(Options, 0);
  FreeAndNil(OptionStack);
end;


{ TImageFileFormat class implementation }

constructor TImageFileFormat.Create;
begin
  inherited Create;
  FName := sUnknownFormat;
  FExtensions := TStringList.Create;
end;

destructor TImageFileFormat.Destroy;
begin
  FExtensions.Free;
  inherited Destroy;
end;

procedure TImageFileFormat.AddExtensions(const AExtensions: string);
begin
  FExtensions.CommaText := AExtensions;
end;

function TImageFileFormat.GetFormatInfo(Format: TImageFormat): PImageFormatInfo;
begin
  Result := ImageFormatInfos[Format];
end;

function TImageFileFormat.GetSupportedFormats: TImageFormats;
begin
  Result := [];
end;

procedure TImageFileFormat.LoadData(Handle: TImagingHandle;
  var Images: TDynImageDataArray; OnlyFirstFrame: Boolean);
begin
  RaiseImaging(sFileFormatCanNotLoad, [FName]);
end;

function TImageFileFormat.LoadFromFile(const FileName: string;
  var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
  Handle: TImagingHandle;
begin
  Result := False;
  if FCanLoad then
  try
    SetFileIO;
    Handle := IO.OpenRead(PChar(FileName));
    try
      if TestFormat(Handle) then
      begin
        LoadData(Handle, Images, OnlyFirstlevel);
        Result := True;
      end
      else
        RaiseImaging(sFileNotValid, [FileName, Name]);
    finally
      IO.Close(Handle);
    end;
  except
    RaiseImaging(sErrorLoadingFile, [FileName]);
  end;
end;

function TImageFileFormat.LoadFromStream(Stream: TStream;
  var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
  Handle: TImagingHandle;
  OldPosition: Int64;
begin
  Result := False;
  OldPosition := Stream.Position;
  if FCanLoad then
  try
    SetStreamIO;
    Handle := IO.OpenRead(Pointer(Stream));
    if TestFormat(Handle) then
    begin
      LoadData(Handle, Images, OnlyFirstlevel);
      Result := True;
    end
    else
      RaiseImaging(sStreamNotValid, [@Stream, Name]);
    IO.Close(Handle);
  except
    Stream.Position := OldPosition;
    RaiseImaging(sErrorLoadingStream, [@Stream]);
  end;
end;

function TImageFileFormat.LoadFromMemory(Data: Pointer; Size: LongInt; var
  Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
  Handle: TImagingHandle;
  IORec: TMemoryIORec;
begin
  Result := False;
  if FCanLoad then
  try
    SetMemoryIO;
    IORec.Data := Data;
    IORec.Position := 0;
    IORec.Size := Size;
    Handle := IO.OpenRead(@IORec);
    if TestFormat(Handle) then
    begin
      LoadData(Handle, Images, OnlyFirstlevel);
      Result := True;
    end
    else
      RaiseImaging(sMemoryNotValid, [Data, Size, Name]);
    IO.Close(Handle);
  except
    RaiseImaging(sErrorLoadingMemory, [Data, Size]);
  end;
end;

procedure TImageFileFormat.MakeCompatible(const Image: TImageData;
  var Comp: TImageData);
begin
  Comp := Image;
end;

function TImageFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
begin
  Result := False;
end;

procedure TImageFileFormat.SaveData(Handle: TImagingHandle;
  const Images: TDynImageDataArray; Index: LongInt);
begin
  RaiseImaging(sFileFormatCanNotSave, [FName]);
end;

function TImageFileFormat.SaveToFile(const FileName: string;
  const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
  Handle: TImagingHandle;
  Len, I: LongInt;
  Ext, FName: string;
begin
  Result := False;
  if FCanSave and TestImagesInArray(Images) then
  try
    SetFileIO;
    Len := Length(Images);
    if ((not FIsMultiImageFormat) and (OnlyFirstLevel or (Len = 1))) or
      FIsMultiImageFormat then
    begin
      // write multi image to one file
      Handle := IO.OpenWrite(PChar(FileName));
      try
        if OnlyFirstLevel then
          SaveData(Handle, Images, 0)
        else
          SaveData(Handle, Images);
      finally
        IO.Close(Handle);
      end;
    end
    else
    begin
      // write multi image to file sequence
      Ext := ExtractFileExt(FileName);
      FName := ChangeFileExt(FileName, '');
      for I := 0 to Len - 1 do
      begin
        Handle := IO.OpenWrite(PChar(Format(FName + '%.3d' + Ext, [I])));
        try
          SaveData(Handle, Images, I);
        finally
          IO.Close(Handle);
        end;
      end;
    end;
    Result := True;
  except
    RaiseImaging(sErrorSavingFile, [FileName]);
  end;
end;

function TImageFileFormat.SaveToStream(Stream: TStream;
  const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
  Handle: TImagingHandle;
  Len, I: LongInt;
  OldPosition: Int64;
begin
  Result := False;
  OldPosition := Stream.Position;
  if FCanSave and TestImagesInArray(Images) then
  try
    SetStreamIO;
    Len := Length(Images);
    Handle := IO.OpenWrite(PChar(Stream));
    if ((not FIsMultiImageFormat) and (OnlyFirstLevel or (Len = 1))) or
      FIsMultiImageFormat then
    begin
      if OnlyFirstLevel then
        SaveData(Handle, Images, 0)
      else
        SaveData(Handle, Images);
    end
    else
      for I := 0 to Len - 1 do
        SaveData(Handle, Images, I);
    IO.Close(Handle);
    Result := True;
  except
    Stream.Position := OldPosition;
    RaiseImaging(sErrorSavingStream, [@Stream]);
  end;
end;

function TImageFileFormat.SaveToMemory(Data: Pointer; var Size: LongInt;
  const Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
  Handle: TImagingHandle;
  Len, I: LongInt;
  IORec: TMemoryIORec;
begin
  Result := False;
  if FCanSave and TestImagesInArray(Images) then
  try
    SetMemoryIO;
    IORec.Data := Data;
    IORec.Position := 0;
    IORec.Size := Size;
    IORec.Written := 0;
    Len := Length(Images);
    Handle := IO.OpenWrite(PChar(@IORec));
    if ((not FIsMultiImageFormat) and (OnlyFirstLevel or (Len = 1))) or
      FIsMultiImageFormat then
    begin
      if OnlyFirstLevel then
        SaveData(Handle, Images, 0)
      else
        SaveData(Handle, Images);
    end
    else
      for I := 0 to Len - 1 do
        SaveData(Handle, Images, I);
    IO.Close(Handle);
    Size := IORec.Written;
    Result := True;
  except
    RaiseImaging(sErrorSavingMemory, [Data, Size]);
  end;
end;


{ TOptionStack  class implementation }

constructor TOptionStack.Create;
begin
  inherited Create;
  FPosition := -1;
end;

destructor TOptionStack.Destroy;
var
  I: LongInt;
begin
  for I := 0 to OptionStackDepth - 1 do
    SetLength(FStack[I], 0);
  inherited Destroy;
end;

function TOptionStack.Pop: Boolean;
var
  I: LongInt;
begin
  Result := False;
  if FPosition >= 0  then
  begin
    SetLength(Options, Length(FStack[FPosition]));
    for I := 0 to Length(FStack[FPosition]) - 1 do
      if Options[I] <> nil then
        Options[I]^ := FStack[FPosition, I];
    Dec(FPosition);
    Result := True;
  end;
end;

function TOptionStack.Push: Boolean;
var
  I: LongInt;
begin
  Result := False;
  if FPosition < OptionStackDepth - 1 then
  begin
    Inc(FPosition);
    SetLength(FStack[FPosition], Length(Options));
    for I := 0 to Length(Options) - 1 do
      if Options[I] <> nil then
        FStack[FPosition, I] := Options[I]^;
    Result := True;
  end;
end;

initialization
  InitImageFormats;
  RegisterOption(ImagingColorReductionMask, @ColorReductionMask);
finalization
  FreeOptions;
  FreeImageFileFormats;

{
  File Notes:

  -- TODOS ----------------------------------------------------
    - add some color functions - create, convert, add, merge, ...
    - permanent: check all new functions for special format support,
      memory lejks, ...

  -- 0.13 Changes/Bug Fixes -----------------------------------
    - added DetermineFileFormat, DetermineStreamFormat, DetermineMemoryFormat,
      GetPixelsSize functions to low level interface
    - added NewPalette, CopyPalette, FreePalette functions
      to low level interface
    - added MapImageToPalette, FillRect, SplitImage, MakePaletteForImages
      functions to low level interface
    - fixed buggy FillCustomPalette function (possible div by zero and others)
    - added CopyRect function to low level interface
    - Member functions of TImageFormatInfo record implemented for all formats
    - before saving images TestImagesInArray is called now
    - added TestImagesInArray function to low level interface
    - added GenerateMipMaps function to low level interface
    - stream position in load/save from/to stream is now set to position before
      function was called if error occurs
    - when error occured during load/save from/to file file handle
      was not released
    - CloneImage returned always False

}
end.

