galfar.imaginglib/Source/ImagingFormats.pas

{
  $Id: ImagingFormats.pas,v 1.22 2006/10/26 13:29:28 galfar Exp $
  Vampyre Imaging Library
  by Marek Mauder ([email protected])
  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 manages information about all image data formats and contains
  low level format conversion, manipulation, and other related functions.}
unit ImagingFormats;

{$I ImagingOptions.inc}

interface

uses
  ImagingTypes, Imaging, ImagingUtility;

type
  TImageFormatInfoArray = array[TImageFormat] of PImageFormatInfo;
  PImageFormatInfoArray = ^TImageFormatInfoArray;


{ Additional image manipulation functions (usually used internally by Imaging unit) }

type
  { Color reduction operations.}
  TReduceColorsAction = (raCreateHistogram, raUpdateHistogram, raMakeColorMap,
    raMapImage);
  TReduceColorsActions = set of TReduceColorsAction;
const
  AllReduceColorsActions = [raCreateHistogram, raUpdateHistogram,
    raMakeColorMap, raMapImage];
{ Reduces the number of colors of source. Src is bits of source image
  (ARGB or floating point) and Dst is in some indexed format. MaxColors
  is the number of colors to which reduce and DstPal is palette to which
  the resulting colors are written and it must be allocated to at least
  MaxColors entries. ChannelMask is 'anded' with every pixel's channel value
  when creating color histogram. If $FF is used all 8bits of color channels
  are used which can be slow for large images with many colors so you can
  use  lower masks to speed it up.}
procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte;
  DstPal: PPalette32; Actions: TReduceColorsActions = AllReduceColorsActions);
{ Stretches rectangle in source image to rectangle in destination image
  using nearest neighbor filtering. It is fast but results look blocky
  because there is no interpolation used. SrcImage and DstImage must be
  in the same data format. Works for all data formats except special formats.}
procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
  SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
  DstHeight: LongInt);
type
  { Built-in sampling filters.}
  TSamplingFilter = (sfNearest, sfLinear, sfCosine, sfHermite, sfQuadratic,
    sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom);
  { Type of custom sampling function}
  TFilterFunction = function(Value: Single): Single;
{ Stretches rectangle in source image to rectangle in destination image
  with resampling. One of built-in resampling filters defined by
  Filter is used. Set WrapEdges to True for seamlessly tileable images.
  SrcImage and DstImage must be in the same data format.
  Works for all data formats except special and indexed formats.}
procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
  SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
  DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean = False); overload;
{ Stretches rectangle in source image to rectangle in destination image
  with resampling. You can use custom sampling function and filter radius.
  Set WrapEdges to True for seamlessly tileable images. SrcImage and DstImage
  must be in the same data format.
  Works for all data formats except special and indexed formats.}
procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
  SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
  DstHeight: LongInt; Filter: TFilterFunction; Radius: Single;
  WrapEdges: Boolean = False); overload;
{ Helper for functions that create mipmap levels. BiggerLevel is
  valid image and SmallerLevel is empty zeroed image. SmallerLevel is created
  with Width and Height dimensions and it is filled with pixels of BiggerLevel
  using resampling filter specified by ImagingMipMapFilter option.
  Uses StretchNearest and StretchResample internally so the same image data format
  limitations apply.}
procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt;
  var SmallerLevel: TImageData);


{ Various helper format support functions }

{ Copies Src pixel to Dest pixel. It is faster than System.Move procedure.}
procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Compares Src pixel and Dest pixel. It is faster than SysUtils.CompareMem function.}
function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Translates pixel color in SrcFormat to DstFormat.}
procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat,
  DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32);
{ Clamps floating point pixel channel values to [0.0, 1.0] range.}
procedure ClampFloatPixel(var PixF: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}

{ Adds padding bytes at the ends of scanlines. Bpp is the number of bytes per
  pixel of source and WidthBytes is the number of bytes per scanlines of dest.}
procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
  Bpp, WidthBytes: LongInt);
{ Removes padding from image with scanlines that have aligned sizes. Bpp is
  the number of bytes per pixel of dest and WidthBytes is the number of bytes
  per scanlines of source.}
procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
  Bpp, WidthBytes: LongInt);

{ Helper function for image file loaders. Some 15 bit images (targas, bitmaps)
  may contain 1 bit alpha but there is no indication of it. This function checks
  all 16 bit(shoul be X1R5G5B5 or A1R5G5B5 format) pixels and some of them have
  alpha bit set it returns True, otherwise False.}
function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean;
{ Provides indexed access to each line of pixels. Does not work with special
  format images.}
function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
  LineWidth, Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns True if Format is valid image data format identifier.}
function IsImageFormatValid(Format: TImageFormat): Boolean;

{ Converts 16bit half floating point value to 32bit Single.}
function HalfToFloat(Half: THalfFloat): Single;
{ Converts 32bit Single to 16bit half floating point.}
function FloatToHalf(Float: Single): THalfFloat;

{ Converts half float color value to single-precision floating point color.}
function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Converts single-precision floating point color to half float color.}
function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF}


{ Pixel readers/writers for different image formats }

{ Returns pixel of image in any ARGB format. Channel values are scaled to 16 bits.}
procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
  var Pix: TColor64Rec);
{ Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.}
procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
  const Pix: TColor64Rec); 

{ Returns pixel of image in any grayscale format. Gray value is scaled to 64 bits
  and alpha to 16 bits.}
procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
  var Gray: TColor64Rec; var Alpha: Word);
{ Sets pixel of image in any grayscale format. Gray value must be scaled to 64 bits
  and alpha to 16 bits.}
procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
  const Gray: TColor64Rec; Alpha: Word);

{ Returns pixel of image in any floating point format. Channel values are
  in range <0.0, 1.0>.}
procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
  var Pix: TColorFPRec);
{ Sets pixel of image in any floating point format. Channel values must be
  in range <0.0, 1.0>.}
procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
  const Pix: TColorFPRec);

{ Returns pixel of image in any indexed format. Returned value is index to
  the palette.}
procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
  var Index: LongWord);
{ Sets pixel of image in any indexed format. Index is index to the palette.}
procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
  Index: LongWord);


{ Pixel readers/writers for 32bit and FP colors}

{ Function for getting pixel colors. Native pixel is read from Image and
  then translated to 32 bit ARGB.}
function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo;
  Palette: PPalette32): TColor32Rec;
{ Procedure for setting pixel colors. Input 32 bit ARGB color is translated to
    native format and then written to Image.}
procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo;
  Palette: PPalette32; const Color: TColor32Rec);
{ Function for getting pixel colors. Native pixel is read from Image and
  then translated to FP ARGB.}
function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo;
  Palette: PPalette32): TColorFPRec;
{ Procedure for setting pixel colors. Input FP ARGB color is translated to
    native format and then written to Image.}
procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo;
  Palette: PPalette32; const Color: TColorFPRec);


{ Image format conversion functions }

{ Converts any ARGB format to any ARGB format.}
procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
{ Converts any ARGB format to any grayscale format.}
procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
{ Converts any ARGB format to any floating point format.}
procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
{ Converts any ARGB format to any indexed format.}
procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; DstPal: PPalette32);

{ Converts any grayscale format to any grayscale format.}
procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
{ Converts any grayscale format to any ARGB format.}
procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
{ Converts any grayscale format to any floating point format.}
procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
{ Converts any grayscale format to any indexed format.}
procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; DstPal: PPalette32);

{ Converts any floating point format to any floating point format.}
procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
{ Converts any floating point format to any ARGB format.}
procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
{ Converts any floating point format to any grayscale format.}
procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
{ Converts any floating point format to any indexed format.}
procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; DstPal: PPalette32);

{ Converts any indexed format to any indexed format.}
procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32);
{ Converts any indexed format to any ARGB format.}
procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; SrcPal: PPalette32);
{ Converts any indexed format to any grayscale format.}
procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; SrcPal: PPalette32);
{ Converts any indexed format to any floating point  format.}
procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; SrcPal: PPalette32);


{ Special formats conversion functions }

{ Converts image to/from/between special image formats (dxtc, ...).}
procedure ConvertSpecial(var Image: TImageData; SrcInfo,
  DstInfo: PImageFormatInfo);


{ Inits all image format information. Called internally on startup.}
procedure InitImageFormats(var Infos: TImageFormatInfoArray);

implementation

{ TImageFormatInfo member functions }

{ Returns size in bytes of image in given standard format where
  Size = Width * Height * Bpp.}
function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
{ Checks if Width and Height are valid for given standard format.}
procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;
{ Returns size in bytes of image in given DXT format.}
function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
{ Checks if Width and Height are valid for given DXT format. If they are
  not valid, they are changed to pass the check.}
procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;

{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }

function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward;
procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward;
function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;

function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward;
procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward;
function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;

function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;


const
  // grayscale conversion channel weights
  GrayConv: TColorFPRec = (B: 0.114; G: 0.587; R: 0.299; A: 0.0);
  // contants for converting integer colors to floating point
  OneDiv8Bit: Single = 1.0 / 255.0;
  OneDiv16Bit: Single = 1.0 / 65535.0;

var
  PFR3G3B2: TPixelFormatInfo;
  PFX5R1G1B1: TPixelFormatInfo;
  PFR5G6B5: TPixelFormatInfo;
  PFA1R5G5B5: TPixelFormatInfo;
  PFA4R4G4B4: TPixelFormatInfo;
  PFX1R5G5B5: TPixelFormatInfo;
  PFX4R4G4B4: TPixelFormatInfo;
  FInfos: PImageFormatInfoArray;

var
  // Free Pascal generates hundreds of warnings here
{$WARNINGS OFF}

  // indexed formats
  Index8Info: TImageFormatInfo = (
    Format: ifIndex8;
    Name: 'Index8';
    BytesPerPixel: 1;
    ChannelCount: 1;
    PaletteEntries: 256;
    IsIndexed: True;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  // grayscale formats
  Gray8Info: TImageFormatInfo = (
    Format: ifGray8;
    Name: 'Gray8';
    BytesPerPixel: 1;
    ChannelCount: 1;
    HasGrayChannel: True;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Channel8Bit;
    GetPixelFP: GetPixelFPChannel8Bit;
    SetPixel32: SetPixel32Channel8Bit;
    SetPixelFP: SetPixelFPChannel8Bit);

  A8Gray8Info: TImageFormatInfo = (
    Format: ifA8Gray8;
    Name: 'A8Gray8';
    BytesPerPixel: 2;
    ChannelCount: 2;
    HasGrayChannel: True;
    HasAlphaChannel: True;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Channel8Bit;
    GetPixelFP: GetPixelFPChannel8Bit;
    SetPixel32: SetPixel32Channel8Bit;
    SetPixelFP: SetPixelFPChannel8Bit);

  Gray16Info: TImageFormatInfo = (
    Format: ifGray16;
    Name: 'Gray16';
    BytesPerPixel: 2;
    ChannelCount: 1;
    HasGrayChannel: True;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  Gray32Info: TImageFormatInfo = (
    Format: ifGray32;
    Name: 'Gray32';
    BytesPerPixel: 4;
    ChannelCount: 1;
    HasGrayChannel: True;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  Gray64Info: TImageFormatInfo = (
    Format: ifGray64;
    Name: 'Gray64';
    BytesPerPixel: 8;
    ChannelCount: 1;
    HasGrayChannel: True;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  A16Gray16Info: TImageFormatInfo = (
    Format: ifA16Gray16;
    Name: 'A16Gray16';
    BytesPerPixel: 4;
    ChannelCount: 2;
    HasGrayChannel: True;
    HasAlphaChannel: True;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  // ARGB formats
  X5R1G1B1Info: TImageFormatInfo = (
    Format: ifX5R1G1B1;
    Name: 'X5R1G1B1';
    BytesPerPixel: 1;
    ChannelCount: 3;
    UsePixelFormat: True;
    PixelFormat: @PFX5R1G1B1;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  R3G3B2Info: TImageFormatInfo = (
    Format: ifR3G3B2;
    Name: 'R3G3B2';
    BytesPerPixel: 1;
    ChannelCount: 3;
    UsePixelFormat: True;
    PixelFormat: @PFR3G3B2;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  R5G6B5Info: TImageFormatInfo = (
    Format: ifR5G6B5;
    Name: 'R5G6B5';
    BytesPerPixel: 2;
    ChannelCount: 3;
    UsePixelFormat: True;
    PixelFormat: @PFR5G6B5;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  A1R5G5B5Info: TImageFormatInfo = (
    Format: ifA1R5G5B5;
    Name: 'A1R5G5B5';
    BytesPerPixel: 2;
    ChannelCount: 4;
    HasAlphaChannel: True;
    UsePixelFormat: True;
    PixelFormat: @PFA1R5G5B5;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  A4R4G4B4Info: TImageFormatInfo = (
    Format: ifA4R4G4B4;
    Name: 'A4R4G4B4';
    BytesPerPixel: 2;
    ChannelCount: 4;
    HasAlphaChannel: True;
    UsePixelFormat: True;
    PixelFormat: @PFA4R4G4B4;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  X1R5G5B5Info: TImageFormatInfo = (
    Format: ifX1R5G5B5;
    Name: 'X1R5G5B5';
    BytesPerPixel: 2;
    ChannelCount: 3;
    UsePixelFormat: True;
    PixelFormat: @PFX1R5G5B5;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  X4R4G4B4Info: TImageFormatInfo = (
    Format: ifX4R4G4B4;
    Name: 'X4R4G4B4';
    BytesPerPixel: 2;
    ChannelCount: 3;
    UsePixelFormat: True;
    PixelFormat: @PFX4R4G4B4;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  R8G8B8Info: TImageFormatInfo = (
    Format: ifR8G8B8;
    Name: 'R8G8B8';
    BytesPerPixel: 3;
    ChannelCount: 3;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Channel8Bit;
    GetPixelFP: GetPixelFPChannel8Bit;
    SetPixel32: SetPixel32Channel8Bit;
    SetPixelFP: SetPixelFPChannel8Bit);

  A8R8G8B8Info: TImageFormatInfo = (
    Format: ifA8R8G8B8;
    Name: 'A8R8G8B8';
    BytesPerPixel: 4;
    ChannelCount: 4;
    HasAlphaChannel: True;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32ifA8R8G8B8;
    GetPixelFP: GetPixelFPifA8R8G8B8;
    SetPixel32: SetPixel32ifA8R8G8B8;
    SetPixelFP: SetPixelFPifA8R8G8B8);

  X8R8G8B8Info: TImageFormatInfo = (
    Format: ifX8R8G8B8;
    Name: 'X8R8G8B8';
    BytesPerPixel: 4;
    ChannelCount: 3;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Channel8Bit;
    GetPixelFP: GetPixelFPChannel8Bit;
    SetPixel32: SetPixel32Channel8Bit;
    SetPixelFP: SetPixelFPChannel8Bit);

  R16G16B16Info: TImageFormatInfo = (
    Format: ifR16G16B16;
    Name: 'R16G16B16';
    BytesPerPixel: 6;
    ChannelCount: 3;
    RBSwapFormat: ifB16G16R16;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  A16R16G16B16Info: TImageFormatInfo = (
    Format: ifA16R16G16B16;
    Name: 'A16R16G16B16';
    BytesPerPixel: 8;
    ChannelCount: 4;
    HasAlphaChannel: True;
    RBSwapFormat: ifA16B16G16R16;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  B16G16R16Info: TImageFormatInfo = (
    Format: ifB16G16R16;
    Name: 'B16G16R16';
    BytesPerPixel: 6;
    ChannelCount: 3;
    IsRBSwapped: True;
    RBSwapFormat: ifR16G16B16;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  A16B16G16R16Info: TImageFormatInfo = (
    Format: ifA16B16G16R16;
    Name: 'A16B16G16R16';
    BytesPerPixel: 8;
    ChannelCount: 4;
    HasAlphaChannel: True;
    IsRBSwapped: True;
    RBSwapFormat: ifA16R16G16B16;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  // floating point formats
  R32FInfo: TImageFormatInfo = (
    Format: ifR32F;
    Name: 'R32F';
    BytesPerPixel: 4;
    ChannelCount: 1;
    IsFloatingPoint: True;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPFloat32;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPFloat32);

 A32R32G32B32FInfo: TImageFormatInfo = (
    Format: ifA32R32G32B32F;
    Name: 'A32R32G32B32F';
    BytesPerPixel: 16;
    ChannelCount: 4;
    HasAlphaChannel: True;
    IsFloatingPoint: True;
    RBSwapFormat: ifA32B32G32R32F;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPFloat32;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPFloat32);

  A32B32G32R32FInfo: TImageFormatInfo = (
    Format: ifA32B32G32R32F;
    Name: 'A32B32G32R32F';
    BytesPerPixel: 16;
    ChannelCount: 4;
    HasAlphaChannel: True;
    IsFloatingPoint: True;
    IsRBSwapped: True;
    RBSwapFormat: ifA32R32G32B32F;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPFloat32;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPFloat32);

  R16FInfo: TImageFormatInfo = (
    Format: ifR16F;
    Name: 'R16F';
    BytesPerPixel: 2;
    ChannelCount: 1;
    IsFloatingPoint: True;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

 A16R16G16B16FInfo: TImageFormatInfo = (
    Format: ifA16R16G16B16F;
    Name: 'A16R16G16B16F';
    BytesPerPixel: 8;
    ChannelCount: 4;
    HasAlphaChannel: True;
    IsFloatingPoint: True;
    RBSwapFormat: ifA16B16G16R16F;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  A16B16G16R16FInfo: TImageFormatInfo = (
    Format: ifA16B16G16R16F;
    Name: 'A16B16G16R16F';
    BytesPerPixel: 8;
    ChannelCount: 4;
    HasAlphaChannel: True;
    IsFloatingPoint: True;
    IsRBSwapped: True;
    RBSwapFormat: ifA16R16G16B16F;
    GetPixelsSize: GetStdPixelsSize;
    CheckDimensions: CheckStdDimensions;
    GetPixel32: GetPixel32Generic;
    GetPixelFP: GetPixelFPGeneric;
    SetPixel32: SetPixel32Generic;
    SetPixelFP: SetPixelFPGeneric);

  // special formats
  DXT1Info: TImageFormatInfo = (
    Format: ifDXT1;
    Name: 'DXT1';
    ChannelCount: 4;
    HasAlphaChannel: True;
    IsSpecial: True;
    GetPixelsSize: GetDXTPixelsSize;
    CheckDimensions: CheckDXTDimensions);

  DXT3Info: TImageFormatInfo = (
    Format: ifDXT3;
    Name: 'DXT3';
    ChannelCount: 4;
    HasAlphaChannel: True;
    IsSpecial: True;
    GetPixelsSize: GetDXTPixelsSize;
    CheckDimensions: CheckDXTDimensions);

  DXT5Info: TImageFormatInfo = (
    Format: ifDXT5;
    Name: 'DXT5';
    ChannelCount: 4;
    HasAlphaChannel: True;
    IsSpecial: True;
    GetPixelsSize: GetDXTPixelsSize;
    CheckDimensions: CheckDXTDimensions);

{$WARNINGS ON}

function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward;

procedure InitImageFormats(var Infos: TImageFormatInfoArray);
begin
  FInfos := @Infos;

  Infos[ifDefault] := @A8R8G8B8Info;
  // indexed formats
  Infos[ifIndex8] := @Index8Info;
  // grayscale formats
  Infos[ifGray8] := @Gray8Info;
  Infos[ifA8Gray8] := @A8Gray8Info;
  Infos[ifGray16] := @Gray16Info;
  Infos[ifGray32] := @Gray32Info;
  Infos[ifGray64] := @Gray64Info;
  Infos[ifA16Gray16] := @A16Gray16Info;
  // ARGB formats
  Infos[ifX5R1G1B1] := @X5R1G1B1Info;
  Infos[ifR3G3B2] := @R3G3B2Info;
  Infos[ifR5G6B5] := @R5G6B5Info;
  Infos[ifA1R5G5B5] := @A1R5G5B5Info;
  Infos[ifA4R4G4B4] := @A4R4G4B4Info;
  Infos[ifX1R5G5B5] := @X1R5G5B5Info;
  Infos[ifX4R4G4B4] := @X4R4G4B4Info;
  Infos[ifR8G8B8] := @R8G8B8Info;
  Infos[ifA8R8G8B8] := @A8R8G8B8Info;
  Infos[ifX8R8G8B8] := @X8R8G8B8Info;
  Infos[ifR16G16B16] := @R16G16B16Info;
  Infos[ifA16R16G16B16] := @A16R16G16B16Info;
  Infos[ifB16G16R16] := @B16G16R16Info;
  Infos[ifA16B16G16R16] := @A16B16G16R16Info;
  // floating point formats
  Infos[ifR32F] := @R32FInfo;
  Infos[ifA32R32G32B32F] := @A32R32G32B32FInfo;
  Infos[ifA32B32G32R32F] := @A32B32G32R32FInfo;
  Infos[ifR16F] := @R16FInfo;
  Infos[ifA16R16G16B16F] := @A16R16G16B16FInfo;
  Infos[ifA16B16G16R16F] := @A16B16G16R16FInfo;
  // special formats
  Infos[ifDXT1] := @DXT1Info;
  Infos[ifDXT3] := @DXT3Info;
  Infos[ifDXT5] := @DXT5Info;

  PFR3G3B2 := PixelFormat(0, 3, 3, 2);
  PFX5R1G1B1 := PixelFormat(0, 1, 1, 1);
  PFR5G6B5 := PixelFormat(0, 5, 6, 5);
  PFA1R5G5B5 := PixelFormat(1, 5, 5, 5);
  PFA4R4G4B4 := PixelFormat(4, 4, 4, 4);
  PFX1R5G5B5 := PixelFormat(0, 5, 5, 5);
  PFX4R4G4B4 := PixelFormat(0, 4, 4, 4);
end;


{ Internal unit helper functions }

function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo;
begin
  Result.ABitMask := ((1 shl ABitCount) - 1) shl (RBitCount + GBitCount +
    BBitCount);
  Result.RBitMask := ((1 shl RBitCount) - 1) shl (GBitCount + BBitCount);
  Result.GBitMask := ((1 shl GBitCount) - 1) shl (BBitCount);
  Result.BBitMask := (1 shl BBitCount) - 1;
  Result.ABitCount := ABitCount;
  Result.RBitCount := RBitCount;
  Result.GBitCount := GBitCount;
  Result.BBitCount := BBitCount;
  Result.AShift := RBitCount + GBitCount + BBitCount;
  Result.RShift := GBitCount + BBitCount;
  Result.GShift := BBitCount;
  Result.BShift := 0;
  Result.ARecDiv := Max(1, Pow2Int(Result.ABitCount) - 1);
  Result.RRecDiv := Max(1, Pow2Int(Result.RBitCount) - 1);
  Result.GRecDiv := Max(1, Pow2Int(Result.GBitCount) - 1);
  Result.BRecDiv := Max(1, Pow2Int(Result.BBitCount) - 1);
end;

function PixelFormatMask(ABitMask, RBitMask, GBitMask, BBitMask: LongWord): TPixelFormatInfo;

  function GetBitCount(B: LongWord): LongWord;
  var
    I: LongWord;
  begin
    I := 0;
    while (I < 31) and (((1 shl I) and B) = 0) do
      Inc(I);
    Result := 0;
    while ((1 shl I) and B) <> 0 do
    begin
      Inc(I);
      Inc(Result);
    end;
  end;

begin
  Result := PixelFormat(GetBitCount(ABitMask), GetBitCount(RBitMask),
    GetBitCount(GBitMask), GetBitCount(BBitMask));
end;

function PFSetARGB(const PF: TPixelFormatInfo; A, R, G, B: Byte): TColor32;
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
  with PF do
    Result :=
      (A shl ABitCount shr 8 shl AShift) or
      (R shl RBitCount shr 8 shl RShift) or
      (G shl GBitCount shr 8 shl GShift) or
      (B shl BBitCount shr 8 shl BShift);
end;

procedure PFGetARGB(const PF: TPixelFormatInfo; Color: LongWord;
  var A, R, G, B: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF}
begin
  with PF do
   begin
     A := (Color and ABitMask shr AShift) * 255 div ARecDiv;
     R := (Color and RBitMask shr RShift) * 255 div RRecDiv;
     G := (Color and GBitMask shr GShift) * 255 div GRecDiv;
     B := (Color and BBitMask shl BShift) * 255 div BRecDiv;
    end;
end;

function PFSetColor(const PF: TPixelFormatInfo; ARGB: TColor32): LongWord;
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
  with PF do
    Result :=
      (Byte(ARGB shr 24) shl ABitCount shr 8 shl AShift) or
      (Byte(ARGB shr 16) shl RBitCount shr 8 shl RShift) or
      (Byte(ARGB shr 8) shl GBitCount shr 8 shl GShift) or
      (Byte(ARGB) shl BBitCount shr 8 shl BShift);
end;

function PFGetColor(const PF: TPixelFormatInfo; Color: LongWord): TColor32;
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
  with PF, TColor32Rec(Result) do
   begin
     A := (Color and ABitMask shr AShift) * 255 div ARecDiv;
     R := (Color and RBitMask shr RShift) * 255 div RRecDiv;
     G := (Color and GBitMask shr GShift) * 255 div GRecDiv;
     B := (Color and BBitMask shl BShift) * 255 div BRecDiv;
    end;
end;

{ Additional image manipulation functions (usually used internally by Imaging unit) }

const
  MaxPossibleColors = 4096;
  HashSize = 32768;
  AlphaWeight = 1024;
  RedWeight = 612;
  GreenWeight = 1202;
  BlueWeight = 234;

type
  PColorBin = ^TColorBin;
  TColorBin = record
    Color: TColor32Rec;
    Number: LongInt;
    Next: PColorBin;
  end;

  THashTable = array[0..HashSize - 1] of PColorBin;

  TColorBox = record
    AMin, AMax,
    RMin, RMax,
    GMin, GMax,
    BMin, BMax: LongInt;
    Total: LongInt;
    Represented: TColor32Rec;
    List: PColorBin;
  end;

var
  Table: THashTable;
  Box: array[0..MaxPossibleColors - 1] of TColorBox;
  Boxes: LongInt;
  BoxesCreated: Boolean = False;

procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte;
  DstPal: PPalette32; Actions: TReduceColorsActions);

  procedure CreateHistogram (Src: PByte; SrcInfo: PImageFormatInfo;
    ChannelMask: Byte);
  var
    A, R, G, B: Byte;
    I, Addr: LongInt;
    PC: PColorBin;
    Col: TColor32Rec;
  begin
    for I := 0 to NumPixels - 1 do
    begin
      Col := GetPixel32Generic(Src, SrcInfo, nil);
      A := Col.A and ChannelMask;
      R := Col.R and ChannelMask;
      G := Col.G and ChannelMask;
      B := Col.B and ChannelMask;

      Addr := (A + 11 * B + 59 * R + 119 * G) mod HashSize;
      PC := Table[Addr];

      while (PC <> nil) and ((PC.Color.R <> R) or (PC.Color.G <> G) or
        (PC.Color.B <> B) or (PC.Color.A <> A)) do
        PC := PC.Next;

      if PC = nil then
      begin
        New(PC);
        PC.Color.R := R;
        PC.Color.G := G;
        PC.Color.B := B;
        PC.Color.A := A;
        PC.Number := 1;
        PC.Next := Table[Addr];
        Table[Addr] := PC;
      end
      else
        Inc(PC^.Number);
      Inc(Src, SrcInfo.BytesPerPixel);
    end;
  end;

  procedure InitBox (var Box : TColorBox);
  begin
    Box.AMin := 256;
    Box.RMin := 256;
    Box.GMin := 256;
    Box.BMin := 256;
    Box.AMax := -1;
    Box.RMax := -1;
    Box.GMax := -1;
    Box.BMax := -1;
    Box.Total := 0;
    Box.List := nil;
  end;

  procedure ChangeBox (var Box: TColorBox; const C: TColorBin);
  begin
    with C.Color do
    begin
      if A < Box.AMin then Box.AMin := A;
      if A > Box.AMax then Box.AMax := A;
      if B < Box.BMin then Box.BMin := B;
      if B > Box.BMax then Box.BMax := B;
      if G < Box.GMin then Box.GMin := G;
      if G > Box.GMax then Box.GMax := G;
      if R < Box.RMin then Box.RMin := R;
      if R > Box.RMax then Box.RMax := R;
    end;
    Inc(Box.Total, C.Number);
  end;

  procedure MakeColormap;
  var
    I, J: LongInt;
    CP, Pom: PColorBin;
    Cut, LargestIdx, Largest, Size, S: LongInt;
    CutA, CutR, CutG, CutB: Boolean;
    SumA, SumR, SumG, SumB: LongInt;
    Temp: TColorBox;
  begin
    I := 0;
    Boxes := 1;
    LargestIdx := 0;
    while (I < HashSize) and (Table[I] = nil) do
      Inc(i);
    if I < HashSize then
    begin
      // put all colors into Box[0]
      InitBox(Box[0]);
      repeat
        CP := Table[I];
        while CP.Next <> nil do
        begin
          ChangeBox(Box[0], CP^);
          CP := CP.Next;
        end;
        ChangeBox(Box[0], CP^);
        CP.Next := Box[0].List;
        Box[0].List := Table[I];
        Table[I] := nil;
        repeat
          Inc(I)
        until (I = HashSize) or (Table[I] <> nil);
      until I = HashSize;
      // now all colors are in Box[0]
      repeat
        // cut one color box
        Largest := 0;
        for I := 0 to Boxes - 1 do
          with Box[I] do
          begin
            Size := (AMax - AMin) * AlphaWeight;
            S := (RMax - RMin) * RedWeight;
            if S > Size then
              Size := S;
            S := (GMax - GMin) * GreenWeight;
            if S > Size then
              Size := S;
            S := (BMax - BMin) * BlueWeight;
            if S > Size then
              Size := S;
            if Size > Largest then
            begin
              Largest := Size;
              LargestIdx := I;
            end;
          end;
        if Largest > 0 then
        begin
          // cutting Box[LargestIdx] into Box[LargestIdx] and Box[Boxes]
          CutR := False;
          CutG := False;
          CutB := False;
          CutA := False;
          with Box[LargestIdx] do
          begin
            if (AMax - AMin) * AlphaWeight = Largest then
            begin
              Cut := (AMax + AMin) shr 1;
              CutA := True;
            end
            else
              if (RMax - RMin) * RedWeight = Largest then
              begin
                Cut := (RMax + RMin) shr 1;
                CutR := True;
              end
              else
                if (GMax - GMin) * GreenWeight = Largest then
                begin
                  Cut := (GMax + GMin) shr 1;
                  CutG := True;
                end
                else
                begin
                  Cut := (BMax + BMin) shr 1;
                  CutB := True;
                end;
            CP := List;
          end;
          InitBox(Box[LargestIdx]);
          InitBox(Box[Boxes]);
          repeat
            // distribute one color
            Pom := CP.Next;
            with CP.Color do
            begin
              if (CutA and (A <= Cut)) or (CutR and (R <= Cut)) or
                (CutG and (G <= Cut)) or (CutB and (B <= Cut)) then
                I := LargestIdx
              else
                I := Boxes;
            end;
            CP.Next := Box[i].List;
            Box[i].List := CP;
            ChangeBox(Box[i], CP^);
            CP := Pom;
          until CP = nil;
          Inc(Boxes);
        end;
      until (Boxes = MaxColors) or (Largest = 0);
      // compute box representation
      for I := 0 to Boxes - 1 do
      begin
        SumR := 0;
        SumG := 0;
        SumB := 0;
        SumA := 0;
        repeat
          CP := Box[I].List;
          Inc(SumR, CP.Color.R * CP.Number);
          Inc(SumG, CP.Color.G * CP.Number);
          Inc(SumB, CP.Color.B * CP.Number);
          Inc(SumA, CP.Color.A * CP.Number);
          Box[I].List := CP.Next;
          Dispose(CP);
        until Box[I].List = nil;
        with Box[I] do
        begin
          Represented.A := SumA div Total;
          Represented.R := SumR div Total;
          Represented.G := SumG div Total;
          Represented.B := SumB div Total;
          AMin := AMin and ChannelMask;
          RMin := RMin and ChannelMask;
          GMin := GMin and ChannelMask;
          BMin := BMin and ChannelMask;
          AMax := (AMax and ChannelMask) + (not ChannelMask);
          RMax := (RMax and ChannelMask) + (not ChannelMask);
          GMax := (GMax and ChannelMask) + (not ChannelMask);
          BMax := (BMax and ChannelMask) + (not ChannelMask);
        end;
      end;
      // sort color boxes
      for I := 0 to Boxes - 2 do
      begin
        Largest := 0;
        for J := I to Boxes - 1 do
          if Box[J].Total > Largest then
          begin
            Largest := Box[J].Total;
            LargestIdx := J;
          end;
        if LargestIdx <> I then
        begin
          Temp := Box[I];
          Box[I] := Box[LargestIdx];
          Box[LargestIdx] := Temp;
        end;
      end;
    end;
  end;

  procedure FillOutputPalette;
  var
    I: LongInt;
  begin
    FillChar(DstPal^, SizeOf(TColor32Rec) * MaxColors, $FF);
    for I := 0 to MaxColors - 1 do
      with Box[I].Represented do
        begin
          DstPal[I].A := A;
          DstPal[I].R := R;
          DstPal[I].G := G;
          DstPal[I].B := B;
        end;
  end;

  function MapColor(const Col: TColor32Rec) : LongInt;
  var
    I: LongInt;
  begin
    I := 0;
    with Col do
      while (I < Boxes) and ((Box[I].AMin > A) or (Box[I].AMax < A) or
        (Box[I].RMin > R) or (Box[I].RMax < R) or (Box[I].GMin > G) or
        (Box[I].GMax < G) or (Box[I].BMin > B) or (Box[I].BMax < B)) do
        Inc(I);
    if I = Boxes then
      MapColor := 0
    else
      MapColor := I;
  end;

  procedure MapImage(Src, Dst: PByte; SrcInfo, DstInfo: PImageFormatInfo);
  var
    I: LongInt;
    Col: TColor32Rec;
  begin
    for I := 0 to NumPixels - 1 do
    begin
      Col := GetPixel32Generic(Src, SrcInfo, nil);
      IndexSetDstPixel(Dst, DstInfo, MapColor(Col));
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end;
  end;

begin
  MaxColors := ClampInt(MaxColors, 2, MaxPossibleColors);
  if raCreateHistogram in Actions then
    FillChar(Table, SizeOf(Table), 0);
  if raUpdateHistogram in Actions then
    CreateHistogram(Src, SrcInfo, ChannelMask);
  if raMakeColorMap in Actions then
  begin
    MakeColorMap;
    FillOutputPalette;
  end;
  if raMapImage in Actions then
    MapImage(Src, Dst, SrcInfo, DstInfo);
end;

procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
  SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
  DstHeight: LongInt);
var
  Info: TImageFormatInfo;
  ScaleX, ScaleY, X, Y, Xp, Yp: LongInt;
  DstPixel, SrcLine: PByte;
begin
  GetImageFormatInfo(SrcImage.Format, Info);
  Assert(SrcImage.Format = DstImage.Format);
  Assert(not Info.IsSpecial);
  // Use integers instead of floats for source image pixel coords
  // Xp and Yp coords must be shifted right to get read source image coords
  ScaleX := (SrcWidth shl 16) div DstWidth;
  ScaleY := (SrcHeight shl 16) div DstHeight;
  Yp := 0;
  for Y := 0 to DstHeight - 1 do
  begin
    Xp := 0;
    SrcLine := @PByteArray(SrcImage.Bits)[((SrcY + Yp shr 16) * SrcImage.Width + SrcX) * Info.BytesPerPixel];
    DstPixel := @PByteArray(DstImage.Bits)[((DstY + Y) * DstImage.Width + DstX) * Info.BytesPerPixel];
    for X := 0 to DstWidth - 1 do
    begin
      case Info.BytesPerPixel of
        1: PByte(DstPixel)^ := PByteArray(SrcLine)[Xp shr 16];
        2: PWord(DstPixel)^ := PWordArray(SrcLine)[Xp shr 16];
        3: PColor24Rec(DstPixel)^ := PPalette24(SrcLine)[Xp shr 16];
        4: PColor32(DstPixel)^ := PLongWordArray(SrcLine)[Xp shr 16];
        6: PColor48Rec(DstPixel)^ := PColor48RecArray(SrcLine)[Xp shr 16];
        8: PColor64(DstPixel)^ := PInt64Array(SrcLine)[Xp shr 16];
        16: PColorFPRec(DstPixel)^ := PColorFPRecArray(SrcLine)[Xp shr 16];
      end;
      Inc(DstPixel, Info.BytesPerPixel);
      Inc(Xp, ScaleX);
    end;
    Inc(Yp, ScaleY);
  end;
end;

{ Filter function for nearest filtering. Also known as box filter.}
function FilterNearest(Value: Single): Single;
begin
  if (Value > -0.5) and (Value <= 0.5) then
    Result := 1
  else
    Result := 0;
end;

{ Filter function for linear filtering. Also known as triangle or Bartlett filter.}
function FilterLinear(Value: Single): Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 1.0 then
    Result := 1.0 - Value
  else
    Result := 0.0;
end;

{ Cosine filter.}
function FilterCosine(Value: Single): Single;
begin
  Result := 0;
  if Abs(Value) < 1 then
    Result := (Cos(Value * Pi) + 1) / 2;
end;

{ f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1 }
function FilterHermite(Value: Single): Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 1 then
    Result := (2 * Value - 3) * Sqr(Value) + 1
  else
    Result := 0;
end;

{ Quadratic filter. Also known as Bell.}
function FilterQuadratic(Value: Single): Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 0.5 then
    Result := 0.75 - Sqr(Value)
  else
  if Value < 1.5 then
  begin
    Value := Value - 1.5;
    Result := 0.5 * Sqr(Value);
  end
  else
    Result := 0.0;
end;

{ Gaussian filter.}
function FilterGaussian(Value: Single): Single;
begin
  Result := Exp(-2.0 * Sqr(Value)) * Sqrt(2.0 / Pi);
end;

{ 4th order (cubic) b-spline filter.}
function FilterSpline(Value: Single): Single;
var
  Temp: Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 1.0 then
  begin
    Temp := Sqr(Value);
    Result := 0.5 * Temp * Value - Temp + 2.0 / 3.0;
  end
  else
  if Value < 2.0 then
  begin
    Value := 2.0 - Value;
    Result := Sqr(Value) * Value / 6.0;
  end
  else
    Result := 0.0;
end;

{ Lanczos-windowed sinc filter.}
function FilterLanczos(Value: Single): Single;

  function SinC(Value: Single): Single;
  begin
    if Value <> 0.0 then
    begin
      Value := Value * Pi;
      Result := Sin(Value) / Value;
    end
    else
      Result := 1.0;
  end;

begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 3.0 then
    Result := SinC(Value) * SinC(Value / 3.0)
  else
    Result := 0.0;
end;

{ Micthell cubic filter.}
function FilterMitchell(Value: Single): Single;
const
  B = 1.0 / 3.0;
  C = 1.0 / 3.0;
var
  Temp: Single;
begin
  if Value < 0.0 then
    Value := -Value;
  Temp := Sqr(Value);
  if Value < 1.0 then
  begin
    Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp)) +
      ((-18.0 + 12.0 * B + 6.0 * C) * Temp) +
      (6.0 - 2.0 * B));
    Result := Value / 6.0;
  end
  else
  if Value < 2.0 then
  begin
    Value := (((-B - 6.0 * C) * (Value * Temp)) +
      ((6.0 * B + 30.0 * C) * Temp) +
      ((-12.0 * B - 48.0 * C) * Value) +
      (8.0 * B + 24.0 * C));
    Result := Value / 6.0;
  end
  else
    Result := 0.0;
end;

{ CatmullRom spline filter.}
function FilterCatmullRom(Value: Single): Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 1.0 then
    Result := 0.5 * (2.0 + Sqr(Value) * (-5.0 + 3.0 * Value))
  else
  if Value < 2.0 then
    Result := 0.5 * (4.0 + Value * (-8.0 + Value * (5.0 - Value)))
  else
    Result := 0.0;
end;

const
  // Some built-in filter functions adn their default radii
  FilterFunctions: array[TSamplingFilter] of TFilterFunction = (
    FilterNearest, FilterLinear, FilterCosine, FilterHermite, FilterQuadratic,
    FilterGaussian, FilterSpline, FilterLanczos, FilterMitchell, FilterCatmullRom);
  FilterRadii: array[TSamplingFilter] of Single = (
    1.0, 1.0, 1.0, 1.0, 1.5,
    1.25, 2.0, 3.0, 2.0, 2.0);

procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
  SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
  DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean);
begin
  // Calls the other function with filter function and radius defined by Filter
  StretchResample(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY,
    DstWidth, DstHeight, FilterFunctions[Filter], FilterRadii[Filter]);
end;

{ The following resampling code is modified and extended code from Graphics32
  library by Alex A. Denisov.}
type
  TPointRec = record
    Pos: LongInt;
    Weight: Single;
  end;
  TCluster = array of TPointRec;
  TMappingTable = array of TCluster;

var
  FullEdge: Boolean = True;

function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
  Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
var
  I, J, K, N: LongInt;
  Left, Right, SrcWidth, DstWidth: LongInt;
  Weight, Scale, Center, Count: Single;
begin
  Result := nil;
  K := 0;
  SrcWidth := SrcHigh - SrcLow;
  DstWidth := DstHigh - DstLow;

  // Check some special cases
  if SrcWidth = 1 then
  begin
    SetLength(Result, DstWidth);
    for I := 0 to DstWidth - 1 do
    begin
      SetLength(Result[I], 1);
      Result[I][0].Pos := 0;
      Result[I][0].Weight := 1.0;
    end;
    Exit;
  end
  else
  if (SrcWidth = 0) or (DstWidth = 0) then
    Exit;

  if FullEdge then
    Scale := DstWidth / SrcWidth
  else
    Scale := (DstWidth - 1) / (SrcWidth - 1);

  SetLength(Result, DstWidth);

  // Pre-calculate filter contributions for a row or column
  if Scale = 0.0 then
  begin
    Assert(Length(Result) = 1);
    SetLength(Result[0], 1);
    Result[0][0].Pos := (SrcLow + SrcHigh) div 2;
    Result[0][0].Weight := 1.0;
  end
  else
  if Scale < 1.0 then
  begin
    // Sub-sampling - scales from bigger to smaller 
    Radius := Radius / Scale;
    for I := 0 to DstWidth - 1 do
    begin
      if FullEdge then
        Center := SrcLow - 0.5 + (I + 0.5) / Scale
      else
        Center := SrcLow + I / Scale;
      Left := Floor(Center - Radius);
      Right := Ceil(Center + Radius);
      Count := -1.0;
      for J := Left to Right do
      begin
        Weight := Filter((Center - J) * Scale) * Scale;
        if Weight <> 0.0 then
        begin
          Count := Count + Weight;
          K := Length(Result[I]);
          SetLength(Result[I], K + 1);
          Result[I][K].Pos := ClampInt(J, SrcLow, SrcHigh - 1);
          Result[I][K].Weight := Weight;
        end;
      end;
      if Length(Result[I]) = 0 then
      begin
        SetLength(Result[I], 1);
        Result[I][0].Pos := Floor(Center);
        Result[I][0].Weight := 1.0;
      end
      else
      if Count <> 0.0 then
        Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
    end;
  end
  else // if Scale > 1.0 then
  begin
    // Super-sampling - scales from smaller to bigger
    Scale := 1.0 / Scale;
    for I := 0 to DstWidth - 1 do
    begin
      if FullEdge then
        Center := SrcLow - 0.5 + (I + 0.5) * Scale
      else
        Center := SrcLow + I * Scale;
      Left := Floor(Center - Radius);
      Right := Ceil(Center + Radius);
      Count := -1.0;
      for J := Left to Right do
      begin
        Weight := Filter(Center - J);
        if Weight <> 0.0 then
        begin
          Count := Count + Weight;
          K := Length(Result[I]);
          SetLength(Result[I], K + 1);

          if WrapEdges then
          begin
            if J < 0 then
              N := SrcImageWidth + J
            else
            if J >= SrcImageWidth then
              N := J - SrcImageWidth
            else
              N := ClampInt(J, SrcLow, SrcHigh - 1);
          end
          else
            N := ClampInt(J, SrcLow, SrcHigh - 1);

          Result[I][K].Pos := N;
          Result[I][K].Weight := Weight;
        end;
      end;
      if Count <> 0.0 then
        Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
    end;
  end;
end;

procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
  SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
  DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
const
  Channel8BitMax: Single = 255.0;
var
  MapX, MapY: TMappingTable;
  I, J, X, Y: LongInt;
  XMinimum, XMaximum: LongInt;
  LineBuffer: array of TColorFPRec;
  ClusterX, ClusterY: TCluster;
  Weight, AccumA, AccumR, AccumG, AccumB: Single;
  DstLine: PByte;
  SrcColor: TColor32Rec;
  SrcFloat: TColorFPRec;
  Info: TImageFormatInfo;
  BytesPerChannel: LongInt;
  ChannelValueMax, InvChannelValueMax: Single;
  UseOptimizedVersion: Boolean;

  procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt);
  var
    I, J: LongInt;
  begin
    if Length(Map) > 0 then
    begin
      MinPos := Map[0][0].Pos;
      MaxPos := MinPos;
      for I := 0 to Length(Map) - 1 do
        for J := 0 to Length(Map[I]) - 1 do
        begin
          if MinPos > Map[I][J].Pos then
            MinPos := Map[I][J].Pos;
          if MaxPos < Map[I][J].Pos then
            MaxPos := Map[I][J].Pos;
        end;
    end;
  end;

begin
  GetImageFormatInfo(SrcImage.Format, Info);
  Assert(SrcImage.Format = DstImage.Format);
  Assert(not Info.IsSpecial and not Info.IsIndexed);
  BytesPerChannel := Info.BytesPerPixel div Info.ChannelCount;
  UseOptimizedVersion := (BytesPerChannel = 1) and not Info.UsePixelFormat;

  // Create horizontal and vertical mapping tables
  MapX := BuildMappingTable(DstX, DstX + DstWidth, SrcX, SrcX + SrcWidth,
    SrcImage.Width, Filter, Radius, WrapEdges);
  MapY := BuildMappingTable(DstY, DstY + DstHeight, SrcY, SrcY + SrcHeight,
    SrcImage.Height, Filter, Radius, WrapEdges);
  if (MapX = nil) or (MapY = nil) then
    Exit;
  ClusterX := nil;
  ClusterY := nil;

  try
    // Find min and max X coords of pixels that will contribute to target image
    FindExtremes(MapX, XMinimum, XMaximum);
    SetLength(LineBuffer, XMaximum - XMinimum + 1);

    if not UseOptimizedVersion then
    begin
      // Following code works for the rest of data formats
      for J := 0 to DstHeight - 1 do
      begin
        // First for each pixel in the current line sample vertically
        // and store results in LineBuffer. Then sample horizontally
        // using values in LineBuffer.
        ClusterY := MapY[J];
        for X := XMinimum to XMaximum do
        begin
          // Clear accumulators
          AccumA := 0.0;
          AccumR := 0.0;
          AccumG := 0.0;
          AccumB := 0.0;
          // For each pixel in line compute weighted sum of pixels
          // in source column that will contribute to this pixel
          for Y := 0 to Length(ClusterY) - 1 do
          begin
            // Accumulate this pixel's weighted value
            Weight := ClusterY[Y].Weight;
            SrcFloat := Info.GetPixelFP(@PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel], @Info, nil);
            AccumB := AccumB + SrcFloat.B * Weight;
            AccumG := AccumG + SrcFloat.G * Weight;
            AccumR := AccumR + SrcFloat.R * Weight;
            AccumA := AccumA + SrcFloat.A * Weight;
          end;
          // Store accumulated value for this pixel in buffer
          with LineBuffer[X - XMinimum] do
          begin
            A := AccumA;
            R := AccumR;
            G := AccumG;
            B := AccumB;
          end;
        end;

        DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX) * Info.BytesPerPixel];
        // Now compute final colors for targte pixels in the current row
        // by sampling horizontally
        for I := 0 to DstWidth - 1 do
        begin
          ClusterX := MapX[I];
          // Clear accumulator
          AccumA := 0.0;
          AccumR := 0.0;
          AccumG := 0.0;
          AccumB := 0.0;
          // Compute weighted sum of values (which are already
          // computed weighted sums of pixels in source columns stored in LineBuffer)
          // that will contribute to the current target pixel
          for X := 0 to Length(ClusterX) - 1 do
          begin
            Weight := ClusterX[X].Weight;
            with LineBuffer[ClusterX[X].Pos - XMinimum] do
            begin
              AccumB := AccumB + B * Weight;
              AccumG := AccumG + G * Weight;
              AccumR := AccumR + R * Weight;
              AccumA := AccumA + A * Weight;
            end;
          end;

          // Now compute final color to be written to dest image
          SrcFloat.A := AccumA;
          SrcFloat.R := AccumR;
          SrcFloat.G := AccumG;
          SrcFloat.B := AccumB;

          Info.SetPixelFP(DstLine, @Info, nil, SrcFloat);
          Inc(DstLine, Info.BytesPerPixel);
        end;
      end;
    end
    else
    begin
      // Following code is optimized for images with 8 bit channels
      for J := 0 to DstHeight - 1 do
      begin
        ClusterY := MapY[J];
        for X := XMinimum to XMaximum do
        begin
          AccumA := 0.0;
          AccumR := 0.0;
          AccumG := 0.0;
          AccumB := 0.0;
          for Y := 0 to Length(ClusterY) - 1 do
          begin
            Weight := ClusterY[Y].Weight;
            CopyPixel(
              @PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel],
              @SrcColor, Info.BytesPerPixel);

            AccumB := AccumB + SrcColor.B * Weight;
            if Info.ChannelCount > 1 then
              AccumG := AccumG + SrcColor.G * Weight;
            if Info.ChannelCount > 2 then
              AccumR := AccumR + SrcColor.R * Weight;
            if Info.ChannelCount > 3 then
              AccumA := AccumA + SrcColor.A * Weight;
          end;
          with LineBuffer[X - XMinimum] do
          begin
            A := AccumA;
            R := AccumR;
            G := AccumG;
            B := AccumB;
          end;
        end;

        DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX)* Info.BytesPerPixel];

        for I := 0 to DstWidth - 1 do
        begin
          ClusterX := MapX[I];
          AccumA := 0.0;
          AccumR := 0.0;
          AccumG := 0.0;
          AccumB := 0.0;
          for X := 0 to Length(ClusterX) - 1 do
          begin
            Weight := ClusterX[X].Weight;
            with LineBuffer[ClusterX[X].Pos - XMinimum] do
            begin
              AccumB := AccumB + B * Weight;
              if Info.ChannelCount > 1 then
                AccumG := AccumG + G * Weight;
              if Info.ChannelCount > 2 then
                AccumR := AccumR + R * Weight;
              if Info.ChannelCount > 3 then
                AccumA := AccumA + A * Weight;
            end;
          end;
          SrcColor.B := ClampToByte(Round(AccumB));
          if Info.ChannelCount > 1 then
            SrcColor.G := ClampToByte(Round(AccumG));
          if Info.ChannelCount > 2 then
            SrcColor.R := ClampToByte(Round(AccumR));
          if Info.ChannelCount > 3 then
            SrcColor.A := ClampToByte(Round(AccumA));

          CopyPixel(@SrcColor, DstLine, Info.BytesPerPixel);
          Inc(DstLine, Info.BytesPerPixel);
        end;
      end;
    end;

  finally
    MapX := nil;
    MapY := nil;
  end;
end;

procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt;
  var SmallerLevel: TImageData);
var
  Filter: TSamplingFilter;
  Info: TImageFormatInfo;
begin
  Assert(TestImage(BiggerLevel));
  Filter := TSamplingFilter(GetOption(ImagingMipMapFilter));
  NewImage(Width, Height, BiggerLevel.Format, SmallerLevel);
  GetImageFormatInfo(BiggerLevel.Format, Info);
  if Filter = sfNearest then
  begin
    StretchNearest(BiggerLevel, 0, 0, BiggerLevel.Width, BiggerLevel.Height,
      SmallerLevel, 0, 0, Width, Height);
  end
  else
  begin
    StretchResample(BiggerLevel, 0, 0, BiggerLevel.Width, BiggerLevel.Height,
      SmallerLevel, 0, 0, Width, Height, Filter);
  end;
end;


{ Various format support functions }

procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt);
begin
  case BytesPerPixel 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: PColorFPRec(Dest)^ := PColorFPRec(Src)^;
  end;
end;

function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean;
begin
  case BytesPerPixel of
    1: Result := PByte(PixelA)^ = PByte(PixelB)^;
    2: Result := PWord(PixelA)^ = PWord(PixelB)^;
    3: Result := (PWord(PixelA)^ = PWord(PixelB)^) and
         (PColor24Rec(PixelA).R = PColor24Rec(PixelB).R);
    4: Result := PLongWord(PixelA)^ = PLongWord(PixelB)^;
    6: Result := (PLongWord(PixelA)^ = PLongWord(PixelB)^) and
         (PColor48Rec(PixelA).R = PColor48Rec(PixelB).R);
    8: Result := PInt64(PixelA)^ = PInt64(PixelB)^;
    16: Result := (PFloatHelper(PixelA).Data2 = PFloatHelper(PixelB).Data2) and
          (PFloatHelper(PixelA).Data1 = PFloatHelper(PixelB).Data1);
  else
    Result := False;
  end;
end;

procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat,
  DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32);
var
  SrcInfo, DstInfo: PImageFormatInfo;
  PixFP: TColorFPRec;
begin
  SrcInfo := FInfos[SrcFormat];
  DstInfo := FInfos[DstFormat];

  PixFP := GetPixelFPGeneric(SrcPixel, SrcInfo, SrcPalette);
  SetPixelFPGeneric(DstPixel, DstInfo, DstPalette, PixFP);
end;

procedure ClampFloatPixel(var PixF: TColorFPRec);
begin
  if PixF.A > 1.0 then
    PixF.A := 1.0;
  if PixF.R > 1.0 then
    PixF.R := 1.0;
  if PixF.G > 1.0 then
    PixF.G := 1.0;
  if PixF.B > 1.0 then
    PixF.B := 1.0;

  if PixF.A < 0.0 then
    PixF.A := 0.0;
  if PixF.R < 0.0 then
    PixF.R := 0.0;
  if PixF.G < 0.0 then
    PixF.G := 0.0;
  if PixF.B < 0.0 then
    PixF.B := 0.0;
end;

procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
  Bpp, WidthBytes: LongInt);
var
  I, W: LongInt;
begin
  W := Width * Bpp;
  for I := 0 to Height - 1 do
    Move(PByteArray(DataIn)[I * W], PByteArray(DataOut)[I * WidthBytes], W);
end;

procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
  Bpp, WidthBytes: LongInt);
var
  I, W: LongInt;
begin
  W := Width * Bpp;
  for I := 0 to Height - 1 do
    Move(PByteArray(DataIn)[I * WidthBytes], PByteArray(DataOut)[I * W], W);
end;

function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean;
var
  I: LongInt;
begin
  Result := False;
  for I := 0 to NumPixels - 1 do
  begin
    if Data^ >= 1 shl 15 then
    begin
      Result := True;
      Exit;
    end;
    Inc(Data);
  end;
end;

function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
  LineWidth, Index: LongInt): Pointer;
var
  LineBytes: LongInt;
begin
  Assert(not FormatInfo.IsSpecial);
  LineBytes := FormatInfo.GetPixelsSize(FormatInfo.Format, LineWidth, 1);
  Result := @PByteArray(ImageBits)[Index * LineBytes];
end;

function IsImageFormatValid(Format: TImageFormat): Boolean;
begin
  Result := FInfos[Format] <> nil;
end;

const
  HalfMin:     Single = 5.96046448e-08; // Smallest positive half
  HalfMinNorm: Single = 6.10351562e-05; // Smallest positive normalized half
  HalfMax:     Single = 65504.0;        // Largest positive half
  HalfEpsilon: Single = 0.00097656;     // Smallest positive e for which half (1.0 + e) != half (1.0)
  HalfNaN:     THalfFloat = 65535;
  HalfPosInf:  THalfFloat = 31744;
  HalfNegInf:  THalfFloat = 64512;


{

  Half/Float conversions inspired by half class from OpenEXR library.


  Float (Pascal Single type) is an IEEE 754 single-precision

  floating point number.

  Bit layout of Single:

    31 (msb)
    |
    | 30     23
    | |      |
    | |      | 22                    0 (lsb)
    | |      | |                     |
    X XXXXXXXX XXXXXXXXXXXXXXXXXXXXXXX
    s e        m

  Bit layout of half:

    15 (msb)
    |
    | 14  10
    | |   |
    | |   | 9        0 (lsb)
    | |   | |        |
    X XXXXX XXXXXXXXXX
    s e     m

  S is the sign-bit, e is the exponent and m is the significand (mantissa).
}


function HalfToFloat(Half: THalfFloat): Single;
var
  Dst, Sign, Mantissa: LongWord;
  Exp: LongInt;
begin
  // extract sign, exponent, and mantissa from half number
  Sign := Half shr 15;
  Exp := (Half and $7C00) shr 10;
  Mantissa := Half and 1023;

  if (Exp > 0) and (Exp < 31) then
  begin
    // common normalized number
    Exp := Exp + (127 - 15);
    Mantissa := Mantissa shl 13;
    Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
    // Result := Power(-1, Sign) * Power(2, Exp - 15) * (1 + Mantissa / 1024);
  end
  else if (Exp = 0) and (Mantissa = 0) then
  begin
    // zero - preserve sign
    Dst := Sign shl 31;
  end
  else if (Exp = 0) and (Mantissa <> 0) then
  begin
    // denormalized number - renormalize it
    while (Mantissa and $00000400) = 0 do
    begin
      Mantissa := Mantissa shl 1;
      Dec(Exp);
    end;
    Inc(Exp);
    Mantissa := Mantissa and not $00000400;
    // now assemble normalized number
    Exp := Exp + (127 - 15);
    Mantissa := Mantissa shl 13;
    Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
    // Result := Power(-1, Sign) * Power(2, -14) * (Mantissa / 1024);
  end
  else if (Exp = 31) and (Mantissa = 0) then
  begin
    // +/- infinity
    Dst := (Sign shl 31) or $7F800000;
  end
  else //if (Exp = 31) and (Mantisa <> 0) then
  begin
    // not a number - preserve sign and mantissa
    Dst := (Sign shl 31) or $7F800000 or (Mantissa shl 13);
  end;

  // reinterpret LongWord as Single
  Result := PSingle(@Dst)^;
end;

function FloatToHalf(Float: Single): THalfFloat;
var
  Src: LongWord;
  Sign, Exp, Mantissa: LongInt;
begin
  Src := PLongWord(@Float)^;
  // extract sign, exponent, and mantissa from Single number
  Sign := Src shr 31;
  Exp := LongInt((Src and $7F800000) shr 23) - 127 + 15;
  Mantissa := Src and $007FFFFF;

  if (Exp > 0) and (Exp < 30) then
  begin
    // simple case - round the significand and combine it with the sign and exponent
    Result := (Sign shl 15) or (Exp shl 10) or ((Mantissa + $00001000) shr 13);
  end
  else if Src = 0 then
  begin
    // input float is zero - return zero
    Result := 0;
  end
  else
  begin
    // difficult case - lengthy conversion
    if Exp <= 0 then
    begin
      if Exp < -10 then
      begin
        // input float's value is less than HalfMin, return zero
        Result := 0;
      end
      else
      begin
        // Float is a normalized Single whose magnitude is less than HalfNormMin.
        // We convert it to denormalized half.
        Mantissa := (Mantissa or $00800000) shr (1 - Exp);
        // round to nearest
        if (Mantissa and $00001000) > 0 then
          Mantissa := Mantissa + $00002000;
        // assemble Sign and Mantissa (Exp is zero to get denotmalized number)
        Result := (Sign shl 15) or (Mantissa shr 13);
      end;
    end
    else if Exp = 255 - 127 + 15 then
    begin
      if Mantissa = 0 then
      begin
        // input float is infinity, create infinity half with original sign
        Result := (Sign shl 15) or $7C00;
      end
      else
      begin
        // input float is NaN, create half NaN with original sign and mantissa
        Result := (Sign shl 15) or $7C00 or (Mantissa shr 13);
      end;
    end
    else
    begin
      // Exp is > 0 so input float is normalized Single

      // round to nearest
      if (Mantissa and $00001000) > 0 then
      begin
        Mantissa := Mantissa + $00002000;
        if (Mantissa and $00800000) > 0 then
        begin
          Mantissa := 0;
          Exp := Exp + 1;
        end;
      end;

      if Exp > 30 then
      begin
        // exponent overflow - return infinity half
        Result := (Sign shl 15) or $7C00;
      end
      else
        // assemble normalized half
        Result := (Sign shl 15) or (Exp shl 10) or (Mantissa shr 13);
    end;
  end;
end;

function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec;
begin
  Result.A := HalfToFloat(ColorHF.A);
  Result.R := HalfToFloat(ColorHF.R);
  Result.G := HalfToFloat(ColorHF.G);
  Result.B := HalfToFloat(ColorHF.B);
end;

function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec;
begin
  Result.A := FloatToHalf(ColorFP.A);
  Result.R := FloatToHalf(ColorFP.R);
  Result.G := FloatToHalf(ColorFP.G);
  Result.B := FloatToHalf(ColorFP.B);
end;


{ Pixel readers/writers for different image formats }

procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; var Pix:
  TColor64Rec);
var
  A, R, G, B: Byte;
begin
  FillChar(Pix, SizeOf(Pix), 0);
  // returns 64 bit color value with 16 bits for each channel
  case SrcInfo.BytesPerPixel of
    1:
      begin
        PFGetARGB(SrcInfo.PixelFormat^, Src^, A, R, G, B);
        Pix.A := A shl 8;
        Pix.R := R shl 8;
        Pix.G := G shl 8;
        Pix.B := B shl 8;
      end;
    2:
      begin
        PFGetARGB(SrcInfo.PixelFormat^, PWord(Src)^, A, R, G, B);
        Pix.A := A shl 8;
        Pix.R := R shl 8;
        Pix.G := G shl 8;
        Pix.B := B shl 8;
      end;
    3:
      with Pix do
      begin
        R := MulDiv(PColor24Rec(Src).R, 65535, 255);
        G := MulDiv(PColor24Rec(Src).G, 65535, 255);
        B := MulDiv(PColor24Rec(Src).B, 65535, 255);
      end;
    4:
      with Pix do
      begin
        A := MulDiv(PColor32Rec(Src).A, 65535, 255);
        R := MulDiv(PColor32Rec(Src).R, 65535, 255);
        G := MulDiv(PColor32Rec(Src).G, 65535, 255);
        B := MulDiv(PColor32Rec(Src).B, 65535, 255);
      end;
    6:
      with Pix do
      begin
        R := PColor48Rec(Src).R;
        G := PColor48Rec(Src).G;
        B := PColor48Rec(Src).B;
      end;
    8: Pix.Color := PColor64(Src)^;
  end;
  // if src has no alpha, we set it to max (otherwise we would have to
  // test if dest has alpha or not in each ChannelToXXX function)
  if not SrcInfo.HasAlphaChannel then
    Pix.A := 65535;

  if SrcInfo.IsRBSwapped then
    SwapValues(Pix.R, Pix.B);
end;

procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
  const Pix: TColor64Rec);
var
  PixW: TColor64Rec;
begin
  PixW := Pix;
  if DstInfo.IsRBSwapped then
    SwapValues(PixW.R, PixW.B);
  // Pix contains 64 bit color value with 16 bit for each channel
  case DstInfo.BytesPerPixel of
    1: Dst^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8,
        PixW.R shr 8, PixW.G shr 8, PixW.B shr 8);
    2: PWord(Dst)^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8,
        PixW.R shr 8, PixW.G shr 8, PixW.B shr 8);
    3:
      with PColor24Rec(Dst)^ do
      begin
        R := MulDiv(PixW.R, 255, 65535);
        G := MulDiv(PixW.G, 255, 65535);
        B := MulDiv(PixW.B, 255, 65535);
      end;
    4:
      with PColor32Rec(Dst)^ do
      begin
        A := MulDiv(PixW.A, 255, 65535);
        R := MulDiv(PixW.R, 255, 65535);
        G := MulDiv(PixW.G, 255, 65535);
        B := MulDiv(PixW.B, 255, 65535);
      end;
    6:
      with PColor48Rec(Dst)^ do
      begin
        R := PixW.R;
        G := PixW.G;
        B := PixW.B;
      end;
    8: PColor64(Dst)^ := PixW.Color;
  end;
end;

procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
  var Gray: TColor64Rec; var Alpha: Word);
begin
  FillChar(Gray, SizeOf(Gray), 0);
  // Source alpha is scaled to 16 bits and stored in Alpha,
  // grayscale value is scaled to 64 bits and stored in Gray
  case SrcInfo.BytesPerPixel of
    1: Gray.A := MulDiv(Src^, 65535, 255);
    2:
      if SrcInfo.HasAlphaChannel then
        with PWordRec(Src)^ do
        begin
          Alpha := MulDiv(High, 65535, 255);
          Gray.A := MulDiv(Low, 65535, 255);
        end
      else
        Gray.A := PWord(Src)^;
    4:
      if SrcInfo.HasAlphaChannel then
        with PLongWordRec(Src)^ do
        begin
          Alpha := High;
          Gray.A := Low;
        end
      else
        with PLongWordRec(Src)^ do
        begin
          Gray.A := High;
          Gray.R := Low;
        end;
    8: Gray.Color := PColor64(Src)^;
  end;
  // if src has no alpha, we set it to max (otherwise we would have to
  // test if dest has alpha or not in each GrayToXXX function)
  if not SrcInfo.HasAlphaChannel then
    Alpha := 65535;
end;

procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
  const Gray: TColor64Rec; Alpha: Word);
begin
  // Gray contains grayscale value scaled to 64 bits, Alpha contains
  // alpha value scaled to 16 bits
  case DstInfo.BytesPerPixel of
    1: Dst^ := MulDiv(Gray.A, 255, 65535);
    2:
      if DstInfo.HasAlphaChannel then
        with PWordRec(Dst)^ do
        begin
          High := MulDiv(Alpha, 255, 65535);
          Low := MulDiv(Gray.A, 255, 65535);
        end
      else
        PWord(Dst)^ := Gray.A;
    4:
      if DstInfo.HasAlphaChannel then
        with PLongWordRec(Dst)^ do
        begin
          High := Alpha;
          Low := Gray.A;
        end
      else
        with PLongWordRec(Dst)^ do
        begin
          High := Gray.A;
          Low := Gray.R;
        end;
    8: PColor64(Dst)^ := Gray.Color;
  end;
end;

procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
  var Pix: TColorFPRec);
var
  PixHF: TColorHFRec;
begin
  if SrcInfo.BytesPerPixel in [4, 16] then
  begin
    // IEEE 754 single-precision channels
    FillChar(Pix, SizeOf(Pix), 0);
    case SrcInfo.BytesPerPixel of
      4: Pix.R := PSingle(Src)^;
      16: Pix := PColorFPRec(Src)^;
    end;
  end
  else
  begin
    // half float channels
    FillChar(PixHF, SizeOf(PixHF), 0);
    case SrcInfo.BytesPerPixel of
      2: PixHF.R := PHalfFloat(Src)^;
      8: PixHF := PColorHFRec(Src)^;
    end;
    Pix := ColorHalfToFloat(PixHF);
  end;
  // if src has no alpha, we set it to max (otherwise we would have to
  // test if dest has alpha or not in each FloatToXXX function)
  if not SrcInfo.HasAlphaChannel then
    Pix.A := 1.0;
  if SrcInfo.IsRBSwapped then
    SwapValues(Pix.R, Pix.B);
end;

procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
  const Pix: TColorFPRec);
var
  PixW: TColorFPRec;
  PixHF: TColorHFRec;
begin
  PixW := Pix;
  if DstInfo.IsRBSwapped then
    SwapValues(PixW.R, PixW.B);
  if DstInfo.BytesPerPixel in [4, 16] then
  begin
    case DstInfo.BytesPerPixel of
      4: PSingle(Dst)^ := PixW.R;
      16: PColorFPRec(Dst)^ := PixW;
    end;
  end
  else
  begin
    PixHF := ColorFloatToHalf(PixW);
    case DstInfo.BytesPerPixel of
      2: PHalfFloat(Dst)^ := PixHF.R;
      8: PColorHFRec(Dst)^ := PixHF;
    end;
  end;
end;

procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
  var Index: LongWord);
begin
  case SrcInfo.BytesPerPixel of
    1: Index := Src^;
  end;
end;

procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
  Index: LongWord);
begin
  case DstInfo.BytesPerPixel of
    1: Dst^ := Byte(Index);
    2: PWord(Dst)^ := Word(Index);
    4: PLongWord(Dst)^ := Index;
  end;
end;


{ Pixel readers/writers for 32bit and FP colors}

function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
var
  Pix64: TColor64Rec;
  PixF: TColorFPRec;
  Alpha: Word;
  Index: LongWord;
begin
  if Info.Format = ifA8R8G8B8 then
  begin
    Result := PColor32Rec(Bits)^
  end
  else if Info.Format = ifR8G8B8 then
  begin
    PColor24Rec(@Result)^ := PColor24Rec(Bits)^;
    Result.A := $FF;
  end
  else if Info.IsFloatingPoint then
  begin
    FloatGetSrcPixel(Bits, Info, PixF);
    Result.A := ClampToByte(Round(PixF.A * 255.0));
    Result.R := ClampToByte(Round(PixF.R * 255.0));
    Result.G := ClampToByte(Round(PixF.G * 255.0));
    Result.B := ClampToByte(Round(PixF.B * 255.0));
  end
  else if Info.HasGrayChannel then
  begin
    GrayGetSrcPixel(Bits, Info, Pix64, Alpha);
    Result.A := MulDiv(Alpha, 255, 65535);
    Result.R := MulDiv(Pix64.A, 255, 65535);
    Result.G := MulDiv(Pix64.A, 255, 65535);
    Result.B := MulDiv(Pix64.A, 255, 65535);
  end
  else if Info.IsIndexed then
  begin
    IndexGetSrcPixel(Bits, Info, Index);
    Result := Palette[Index];
  end
  else
  begin
    ChannelGetSrcPixel(Bits, Info, Pix64);
    Result.A := MulDiv(Pix64.A, 255, 65535);
    Result.R := MulDiv(Pix64.R, 255, 65535);
    Result.G := MulDiv(Pix64.G, 255, 65535);
    Result.B := MulDiv(Pix64.B, 255, 65535);
  end;
end;

procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
var
  Pix64: TColor64Rec;
  PixF: TColorFPRec;
  Alpha: Word;
  Index: LongWord;
begin
  if Info.Format = ifA8R8G8B8 then
  begin
    PColor32Rec(Bits)^ := Color
  end
  else if Info.Format = ifR8G8B8 then
  begin
    PColor24Rec(Bits)^ := Color.Color24Rec;
  end
  else if Info.IsFloatingPoint then
  begin
    PixF.A := Color.A * OneDiv8Bit;
    PixF.R := Color.R * OneDiv8Bit;
    PixF.G := Color.G * OneDiv8Bit;
    PixF.B := Color.B * OneDiv8Bit;
    FloatSetDstPixel(Bits, Info, PixF);
  end
  else if Info.HasGrayChannel then
  begin
    Alpha := MulDiv(Color.A, 65535, 255);
    Pix64.Color := 0;
    Pix64.A := MulDiv(Round(GrayConv.R * Color.R + GrayConv.G * Color.G +
      GrayConv.B * Color.B), 65535, 255);
    GraySetDstPixel(Bits, Info, Pix64, Alpha);
  end
  else if Info.IsIndexed then
  begin
    Index := FindColor(Palette, Info.PaletteEntries, Color.Color);
    IndexSetDstPixel(Bits, Info, Index);
  end
  else
  begin
    Pix64.A := MulDiv(Color.A, 65535, 255);
    Pix64.R := MulDiv(Color.R, 65535, 255);
    Pix64.G := MulDiv(Color.G, 65535, 255);
    Pix64.B := MulDiv(Color.B, 65535, 255);
    ChannelSetDstPixel(Bits, Info, Pix64);
  end;
end;

function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
var
  Pix32: TColor32Rec;
  Pix64: TColor64Rec;
  Alpha: Word;
  Index: LongWord;
begin
  if Info.IsFloatingPoint then
  begin
    FloatGetSrcPixel(Bits, Info, Result);
  end
  else if Info.HasGrayChannel then
  begin
    GrayGetSrcPixel(Bits, Info, Pix64, Alpha);
    Result.A := Alpha * OneDiv16Bit;
    Result.R := Pix64.A * OneDiv16Bit;
    Result.G := Pix64.A * OneDiv16Bit;
    Result.B := Pix64.A * OneDiv16Bit;
  end
  else if Info.IsIndexed then
  begin
    IndexGetSrcPixel(Bits, Info, Index);
    Pix32 := Palette[Index];
    Result.A := Pix32.A * OneDiv8Bit;
    Result.R := Pix32.R * OneDiv8Bit;
    Result.G := Pix32.G * OneDiv8Bit;
    Result.B := Pix32.B * OneDiv8Bit;
  end
  else
  begin
    ChannelGetSrcPixel(Bits, Info, Pix64);
    Result.A := Pix64.A * OneDiv16Bit;
    Result.R := Pix64.R * OneDiv16Bit;
    Result.G := Pix64.G * OneDiv16Bit;
    Result.B := Pix64.B * OneDiv16Bit;
  end;
end;

procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
var
  Pix32: TColor32Rec;
  Pix64: TColor64Rec;
  Alpha: Word;
  Index: LongWord;
begin
  if Info.IsFloatingPoint then
  begin
    FloatSetDstPixel(Bits, Info, Color);
  end
  else if Info.HasGrayChannel then
  begin
    Alpha := ClampToWord(Round(Color.A * 65535.0));
    Pix64.Color := 0;
    Pix64.A := ClampToWord(Round((GrayConv.R * Color.R + GrayConv.G * Color.G +
      GrayConv.B * Color.B) * 65535.0));
    GraySetDstPixel(Bits, Info, Pix64, Alpha);
  end
  else if Info.IsIndexed then
  begin
    Pix32.A := ClampToByte(Round(Color.A * 255.0));
    Pix32.R := ClampToByte(Round(Color.R * 255.0));
    Pix32.G := ClampToByte(Round(Color.G * 255.0));
    Pix32.B := ClampToByte(Round(Color.B * 255.0));
    Index := FindColor(Palette, Info.PaletteEntries, Pix32.Color);
    IndexSetDstPixel(Bits, Info, Index);
  end
  else
  begin
    Pix64.A := ClampToWord(Round(Color.A * 65535.0));
    Pix64.R := ClampToWord(Round(Color.R * 65535.0));
    Pix64.G := ClampToWord(Round(Color.G * 65535.0));
    Pix64.B := ClampToWord(Round(Color.B * 65535.0));
    ChannelSetDstPixel(Bits, Info, Pix64);
  end;
end;


{ Image format conversion functions }

procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
var
  I: LongInt;
  Pix64: TColor64Rec;
begin
  // two most common conversions (RGB->ARGB and ARGB->RGB for 24/32 bit
  // images) are made separately from general ARGB conversion to
  // make them faster
  if (SrcInfo.BytesPerPixel = 3) and (DstInfo.BytesPerPixel = 4) then
  for I := 0 to NumPixels - 1 do
    begin
      PColor24Rec(Dst)^ := PColor24Rec(Src)^;
      PColor32Rec(Dst).A := 255;
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end
  else
  if (SrcInfo.BytesPerPixel = 4) and (DstInfo.BytesPerPixel = 3) then
    for I := 0 to NumPixels - 1 do
    begin
      PColor24Rec(Dst)^ := PColor24Rec(Src)^;
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end
  else
    for I := 0 to NumPixels - 1 do
    begin
      // general ARGB conversion
      ChannelGetSrcPixel(Src, SrcInfo, Pix64);
      ChannelSetDstPixel(Dst, DstInfo, Pix64);
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end;
end;

procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
var
  I: LongInt;
  Pix64: TColor64Rec;
  Alpha: Word;
begin
  // two most common conversions (R8G8B8->Gray8 nad A8R8G8B8->Gray8)
  // are made separately from general conversions to make them faster
  if (SrcInfo.BytesPerPixel in [3, 4]) and (DstInfo.Format = ifGray8) then
    for I := 0 to NumPixels - 1 do
    begin
      Dst^ := Round(GrayConv.R * PColor24Rec(Src).R + GrayConv.G * PColor24Rec(Src).G +
        GrayConv.B * PColor24Rec(Src).B);
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end
  else
    for I := 0 to NumPixels - 1 do
    begin
      ChannelGetSrcPixel(Src, SrcInfo, Pix64);

      // alpha is saved from source pixel to Alpha,
      // Gray value is computed and set to highest word of Pix64 so
      // Pix64.Color contains grayscale value scaled to 64 bits
      Alpha := Pix64.A;
      with GrayConv do
        Pix64.A := Round(R * Pix64.R + G * Pix64.G + B * Pix64.B);

      GraySetDstPixel(Dst, DstInfo, Pix64, Alpha);
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end;
end;

procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
var
  I: LongInt;
  Pix64: TColor64Rec;
  PixF: TColorFPRec;
begin
  for I := 0 to NumPixels - 1 do
  begin
    ChannelGetSrcPixel(Src, SrcInfo, Pix64);

    // floating point channel values are scaled to 1.0
    PixF.A := Pix64.A * OneDiv16Bit;
    PixF.R := Pix64.R * OneDiv16Bit;
    PixF.G := Pix64.G * OneDiv16Bit;
    PixF.B := Pix64.B * OneDiv16Bit;

    FloatSetDstPixel(Dst, DstInfo, PixF);
    Inc(Src, SrcInfo.BytesPerPixel);
    Inc(Dst, DstInfo.BytesPerPixel);
  end;
end;

procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; DstPal: PPalette32);
begin
  ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries,
    GetOption(ImagingColorReductionMask), DstPal);
end;

procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
var
  I: LongInt;
  Gray: TColor64Rec;
  Alpha: Word;
begin
  // two most common conversions (Gray8->Gray16 nad Gray16->Gray8)
  // are made separately from general conversions to make them faster
  if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifGray16) then
  begin
    for I := 0 to NumPixels - 1 do
      PWordArray(Dst)[I] := PByteArray(Src)[I] shl 8;
  end
  else
    if (DstInfo.Format = ifGray8) and (SrcInfo.Format = ifGray16) then
    begin
      for I := 0 to NumPixels - 1 do
        PByteArray(Dst)[I] := PWordArray(Src)[I] shr 8;
    end
    else
      for I := 0 to NumPixels - 1 do
      begin
        // general grayscale conversion
        GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
        GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
        Inc(Src, SrcInfo.BytesPerPixel);
        Inc(Dst, DstInfo.BytesPerPixel);
      end;
end;

procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
var
  I: LongInt;
  Pix64: TColor64Rec;
  Alpha: Word;
begin
  // two most common conversions (Gray8->R8G8B8 nad Gray8->A8R8G8B8)
  // are made separately from general conversions to make them faster
  if (DstInfo.BytesPerPixel in [3, 4]) and (SrcInfo.Format = ifGray8) then
    for I := 0 to NumPixels - 1 do
    begin
      PColor24Rec(Dst).R := Src^;
      PColor24Rec(Dst).G := Src^;
      PColor24Rec(Dst).B := Src^;
      if DstInfo.HasAlphaChannel then
        PColor32Rec(Dst).A := $FF;
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end
  else
    for I := 0 to NumPixels - 1 do
    begin
      GrayGetSrcPixel(Src, SrcInfo, Pix64, Alpha);

      // most significant word of grayscale value is used for
      // each channel and alpha channel is set to Alpha
      Pix64.R := Pix64.A;
      Pix64.G := Pix64.A;
      Pix64.B := Pix64.A;
      Pix64.A := Alpha;

      ChannelSetDstPixel(Dst, DstInfo, Pix64);
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end;
end;

procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
var
  I: LongInt;
  Gray: TColor64Rec;
  PixF: TColorFPRec;
  Alpha: Word;
begin
  for I := 0 to NumPixels - 1 do
  begin
    GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
    // most significant word of grayscale value is used for
    // each channel and alpha channel is set to Alpha
    // then all is scaled to 0..1
    PixF.R := Gray.A * OneDiv16Bit;
    PixF.G := Gray.A * OneDiv16Bit;
    PixF.B := Gray.A * OneDiv16Bit;
    PixF.A := Alpha * OneDiv16Bit;

    FloatSetDstPixel(Dst, DstInfo, PixF);
    Inc(Src, SrcInfo.BytesPerPixel);
    Inc(Dst, DstInfo.BytesPerPixel);
  end;
end;

procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; DstPal: PPalette32);
var
  I: LongInt;
  Idx: LongWord;
  Gray: TColor64Rec;
  Alpha, Shift: Word;
begin
  FillGrayscalePalette(DstPal, DstInfo.PaletteEntries);
  Shift := Log2Int(DstInfo.PaletteEntries);
  // most common conversion (Gray8->Index8)
  // is made separately from general conversions to make it faster
  if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifIndex8) then
    for I := 0 to NumPixels - 1 do
    begin
      Dst^ := Src^;
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end
  else
    for I := 0 to NumPixels - 1 do
    begin
      // gray value is read from src and index to precomputed
      // grayscale palette is computed and written to dst
      // (we assume here that there will be no more than 65536 palette
      // entries in dst format, gray value is shifted so the highest
      // gray value match the highest possible index in palette)
      GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
      Idx := Gray.A shr (16 - Shift);
      IndexSetDstPixel(Dst, DstInfo, Idx);
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end;
end;

procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
var
  I: LongInt;
  PixF: TColorFPRec;
begin
  for I := 0 to NumPixels - 1 do
  begin
    // general floating point conversion
    FloatGetSrcPixel(Src, SrcInfo, PixF);
    FloatSetDstPixel(Dst, DstInfo, PixF);
    Inc(Src, SrcInfo.BytesPerPixel);
    Inc(Dst, DstInfo.BytesPerPixel);
  end;
end;

procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
var
  I: LongInt;
  Pix64: TColor64Rec;
  PixF: TColorFPRec;
begin
  for I := 0 to NumPixels - 1 do
  begin
    FloatGetSrcPixel(Src, SrcInfo, PixF);
    ClampFloatPixel(PixF);

    // floating point channel values are scaled to 1.0
    Pix64.A := ClampToWord(Round(PixF.A * 65535));
    Pix64.R := ClampToWord(Round(PixF.R * 65535));
    Pix64.G := ClampToWord(Round(PixF.G * 65535));
    Pix64.B := ClampToWord(Round(PixF.B * 65535));

    ChannelSetDstPixel(Dst, DstInfo, Pix64);
    Inc(Src, SrcInfo.BytesPerPixel);
    Inc(Dst, DstInfo.BytesPerPixel);
  end;
end;

procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo);
var
  I: LongInt;
  PixF: TColorFPRec;
  Gray: TColor64Rec;
  Alpha: Word;
begin
  for I := 0 to NumPixels - 1 do
  begin
    FloatGetSrcPixel(Src, SrcInfo, PixF);
    ClampFloatPixel(PixF);

    // alpha is saved from source pixel to Alpha,
    // Gray value is computed and set to highest word of Pix64 so
    // Pix64.Color contains grayscale value scaled to 64 bits
    Alpha := ClampToWord(Round(PixF.A * 65535.0));
    Gray.A := ClampToWord(Round((GrayConv.R * PixF.R + GrayConv.G * PixF.G +
      GrayConv.B * PixF.B) * 65535.0));

    GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
    Inc(Src, SrcInfo.BytesPerPixel);
    Inc(Dst, DstInfo.BytesPerPixel);
  end;
end;

procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; DstPal: PPalette32);
begin
  ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries,
    GetOption(ImagingColorReductionMask), DstPal);
end;

procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32);
var
  I: LongInt;
begin
  // there is only one indexed format now, so it is just a copy
  for I := 0 to NumPixels - 1 do
  begin
    Dst^ := Src^;
    Inc(Src, SrcInfo.BytesPerPixel);
    Inc(Dst, DstInfo.BytesPerPixel);
  end;
  for I := 0 to SrcInfo.PaletteEntries - 1 do
    DstPal[I] := SrcPal[I];
end;

procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; SrcPal: PPalette32);
var
  I: LongInt;
  Pix64: TColor64Rec;
  Idx: LongWord;
begin
  // two most common conversions (Index8->R8G8B8 nad Index8->A8R8G8B8)
  // are made separately from general conversions to make them faster
  if (SrcInfo.Format = ifIndex8) and (DstInfo.Format in [ifR8G8B8, ifA8R8G8B8]) then
    for I := 0 to NumPixels - 1 do
    begin
      with PColor24Rec(Dst)^ do
      begin
        R := SrcPal[Src^].R;
        G := SrcPal[Src^].G;
        B := SrcPal[Src^].B;
      end;
      if DstInfo.Format = ifA8R8G8B8 then
        PColor32Rec(Dst).A := SrcPal[Src^].A;
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end
  else
    for I := 0 to NumPixels - 1 do
    begin
      // index to palette is read from source and color
      // is retrieved from palette entry. Color is then
      // scaled to 16bits and written to dest
      IndexGetSrcPixel(Src, SrcInfo, Idx);
      with Pix64 do
      begin
        A := SrcPal[Idx].A shl 8;
        R := SrcPal[Idx].R shl 8;
        G := SrcPal[Idx].G shl 8;
        B := SrcPal[Idx].B shl 8;
      end;
      ChannelSetDstPixel(Dst, DstInfo, Pix64);
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end;
end;

procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; SrcPal: PPalette32);
var
  I: LongInt;
  Gray: TColor64Rec;
  Alpha: Word;
  Idx: LongWord;
begin
  // most common conversion (Index8->Gray8)
  // is made separately from general conversions to make it faster
  if (SrcInfo.Format = ifIndex8) and (DstInfo.Format = ifGray8) then
  begin
    for I := 0 to NumPixels - 1 do
    begin
      Dst^ := Round(GrayConv.R * SrcPal[Src^].R + GrayConv.G * SrcPal[Src^].G +
        GrayConv.B * SrcPal[Src^].B);
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end
  end
  else
    for I := 0 to NumPixels - 1 do
    begin
      // index to palette is read from source and color
      // is retrieved from palette entry. Color is then
      // transformed to grayscale and assigned to the highest
      // byte of Gray value
      IndexGetSrcPixel(Src, SrcInfo, Idx);
      Alpha := SrcPal[Idx].A shl 8;
      Gray.A := MulDiv(Round(GrayConv.R * SrcPal[Idx].R + GrayConv.G * SrcPal[Idx].G +
        GrayConv.B * SrcPal[Idx].B), 65535, 255);
      GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
      Inc(Src, SrcInfo.BytesPerPixel);
      Inc(Dst, DstInfo.BytesPerPixel);
    end;
end;

procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
  DstInfo: PImageFormatInfo; SrcPal: PPalette32);
var
  I: LongInt;
  Idx: LongWord;
  PixF: TColorFPRec;
begin
  for I := 0 to NumPixels - 1 do
  begin
    // index to palette is read from source and color
    // is retrieved from palette entry. Color is then
    // scaled to 0..1 and written to dest
    IndexGetSrcPixel(Src, SrcInfo, Idx);
    with PixF do
    begin
      A := SrcPal[Idx].A * OneDiv8Bit;
      R := SrcPal[Idx].R * OneDiv8Bit;
      G := SrcPal[Idx].G * OneDiv8Bit;
      B := SrcPal[Idx].B * OneDiv8Bit;
    end;
    FloatSetDstPixel(Dst, DstInfo, PixF);
    Inc(Src, SrcInfo.BytesPerPixel);
    Inc(Dst, DstInfo.BytesPerPixel);
  end;
end;


{ Special formats conversion functions }

var
  UnSpecialFormat: TImageFormat = ifA8R8G8B8;

type
  // DXT RGB color block
  TDXTColorBlock = packed record
    Color0, Color1: Word;
    Mask: LongWord;
  end;
  PDXTColorBlock = ^TDXTColorBlock;

  // DXT explicit alpha for a block
  TDXTAlphaBlockExp = packed record
    Alphas: array[0..3] of Word;
  end;
  PDXTAlphaBlockExp = ^TDXTAlphaBlockExp;

  // DXT interpolated alpha for a block
  TDXTAlphaBlockInt = packed record
    Alphas: array[0..7] of Byte;
  end;
  PDXTAlphaBlockInt = ^TDXTAlphaBlockInt;

  TPixelInfo = record
    Color: Word;
    Alpha: Byte;
    Orig: TColor32Rec;
  end;

  TPixelBlock = array[0..15] of TPixelInfo;

function DecodeCol(Color : Word): TColor32Rec;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
  Result.A := $FF;
  {Result.R := ((Color and $F800) shr 11) shl 3;
  Result.G := ((Color and $07E0) shr 5) shl 2;
  Result.B := (Color and $001F) shl 3;}
  // this color expansion is slower but gives better results
  Result.R := (Color shr 11) * 255 div 31;
  Result.G := ((Color shr 5) and $3F) * 255 div 63;
  Result.B := (Color and $1F) * 255 div 31;
end;

procedure DecodeDXT1(SrcBits, DestBits: PByte; Width, Height: LongInt);
var
  Sel, X, Y, I, J, K: LongInt;
  Block: TDXTColorBlock;
  Colors: array[0..3] of TColor32Rec;
begin
  for Y := 0 to Height div 4 - 1 do
    for X := 0 to Width div 4 - 1 do
    begin
      Block := PDXTColorBlock(SrcBits)^;
      Inc(SrcBits, SizeOf(Block));
      // we read and decode endpoint colors
      Colors[0] := DecodeCol(Block.Color0);
      Colors[1] := DecodeCol(Block.Color1);
      // and interpolate between them
      if Block.Color0 > Block.Color1 then
      begin
        // interpolation for block without alpha
        Colors[2].A := $FF;
        Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
        Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
        Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
        Colors[3].A := $FF;
        Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
        Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
        Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
      end
      else
      begin
        // interpolation for block with alpha
        Colors[2].A := $FF;
        Colors[2].R := (Colors[0].R + Colors[1].R) shr 1;
        Colors[2].G := (Colors[0].G + Colors[1].G) shr 1;
        Colors[2].B := (Colors[0].B + Colors[1].B) shr 1;
        Colors[3].A := 0;
        Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
        Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
        Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
      end;

      // we distribute the dxt block colors across the 4x4 block of the
      // destination image accroding to the dxt block mask
      K := 0;
      for J := 0 to 3 do
        for I := 0 to 3 do
        begin
          Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
          if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then
            PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] :=
              Colors[Sel];
          Inc(K);
        end;
  end;
end;

procedure DecodeDXT3(SrcBits, DestBits: PByte; Width, Height: LongInt);
var
  Sel, X, Y, I, J, K: LongInt;
  Block: TDXTColorBlock;
  AlphaBlock: TDXTAlphaBlockExp;
  Colors: array[0..3] of TColor32Rec;
  AWord: Word;
begin
  for Y := 0 to Height div 4 - 1 do
    for X := 0 to Width div 4 - 1 do
    begin
      AlphaBlock := PDXTAlphaBlockExp(SrcBits)^;
      Inc(SrcBits, SizeOf(AlphaBlock));
      Block := PDXTColorBlock(SrcBits)^;
      Inc(SrcBits, SizeOf(Block));
      // we read and decode endpoint colors
      Colors[0] := DecodeCol(Block.Color0);
      Colors[1] := DecodeCol(Block.Color1);
      // and interpolate between them
      Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
      Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
      Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
      Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
      Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
      Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;

      // we distribute the dxt block colors and alphas
      // across the 4x4 block of the destination image
      // accroding to the dxt block mask and alpha block
      K := 0;
      for J := 0 to 3 do
      begin
        AWord := AlphaBlock.Alphas[J];
        for I := 0 to 3 do
        begin
          Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
          if (X shl 2 + I < Width) and (Y shl 2 + J < Height) then
          begin
            Colors[Sel].A := AWord and $0F;
            Colors[Sel].A := Colors[Sel].A or (Colors[Sel].A shl 4);
            PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] :=
              Colors[Sel];
          end;
          Inc(K);
          AWord := AWord shr 4;
        end;
      end;
  end;
end;

procedure DecodeDXT5(SrcBits, DestBits: PByte; Width, Height: LongInt);
var
  Sel, X, Y, I, J, K: LongInt;
  Block: TDXTColorBlock;
  AlphaBlock: TDXTAlphaBlockInt;
  Colors: array[0..3] of TColor32Rec;
  AMask: array[0..1] of LongWord;
begin
  for Y := 0 to Height div 4 - 1 do
    for X := 0 to Width div 4 - 1 do
    begin
      AlphaBlock := PDXTAlphaBlockInt(SrcBits)^;
      Inc(SrcBits, SizeOf(AlphaBlock));
      Block := PDXTColorBlock(SrcBits)^;
      Inc(SrcBits, SizeOf(Block));
      // we read and decode endpoint colors
      Colors[0] := DecodeCol(Block.Color0);
      Colors[1] := DecodeCol(Block.Color1);
      // and interpolate between them
      Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
      Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
      Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
      Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
      Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
      Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
      // 6 bit alpha mask is copied into two long words for
      // easier usage
      AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF;
      AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF;
      // alpha interpolation between two endpoint alphas
      with AlphaBlock do
        if Alphas[0] > Alphas[1] then
        begin
          // interpolation of six alphas
          Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7;
          Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7;
          Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7;
          Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7;
          Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7;
          Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7;
        end
        else
        begin
          // interpolation of four alphas, two alphas are set directly
          Alphas[2] := (4 * Alphas[0] + 1 * Alphas[1] + 2) div 5;
          Alphas[3] := (3 * Alphas[0] + 2 * Alphas[1] + 2) div 5;
          Alphas[4] := (2 * Alphas[0] + 3 * Alphas[1] + 2) div 5;
          Alphas[5] := (1 * Alphas[0] + 4 * Alphas[1] + 2) div 5;
          Alphas[6] := 0;
          Alphas[7] := $FF;
        end;

      // we distribute the dxt block colors and alphas
      // across the 4x4 block of the destination image
      // accroding to the dxt block mask and alpha block mask
      K := 0;
      for J := 0 to 3 do
        for I := 0 to 3 do
        begin
          Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
          if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then
          begin
            Colors[Sel].A := AlphaBlock.Alphas[AMask[J shr 1] and 7];
            PPalette32(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] :=
              Colors[Sel];
          end;
          Inc(K);
          AMask[J shr 1] := AMask[J shr 1] shr 3;
        end;
  end;
end;

procedure GetBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
  Width, Height: LongInt); 
var
  X, Y, I: LongInt;
  Src: PColor32Rec;
begin
  I := 0;
  // 4x4 pixel block is filled with information about every
  // pixel in the block: alpha, original color, 565 color
  for Y := 0 to 3 do
    for X := 0 to 3 do
    begin
      Src := @PPalette32(SrcBits)[(YPos shl 2 + Y) * Width + XPos shl 2 + X];
      Block[I].Color := ((Src.R shr 3) shl 11) or ((Src.G shr 2) shl 5) or
        (Src.B shr 3);
      Block[I].Alpha := Src.A;
      Block[I].Orig := Src^;
      Inc(I);
    end;
end;

function ColorDistance(const C1, C2: TColor32Rec): LongInt;
{$IFDEF USE_INLINE} inline;{$ENDIF}
begin
  Result := (C1.R - C2.R) * (C1.R - C2.R) +
    (C1.G - C2.G) * (C1.G - C2.G) + (C1.B - C2.B) * (C1.B - C2.B);
end;

procedure GetEndpoints(const Block: TPixelBlock; var Ep0, Ep1: Word);
var
  I, J, Farthest, Dist: LongInt;
  Colors: array[0..15] of TColor32Rec;
begin
  // we choose two colors from the pixel block which has the
  // largest distance between them
  for I := 0 to 15 do
    Colors[I] := Block[I].Orig;
  Farthest := -1;
  for I := 0 to 15 do
    for J := I + 1 to 15 do
    begin
      Dist := ColorDistance(Colors[I], Colors[J]);
      if Dist > Farthest then
      begin
        Farthest := Dist;
        Ep0 := Block[I].Color;
        Ep1 := Block[J].Color;
      end;
    end;
end;

procedure GetAlphaEndpoints(const Block: TPixelBlock; var Min, Max: Byte);
var
  I: LongInt;
begin
  Min := 255;
  Max := 0;
  // we choose the lowest and the highest alpha values
  for I := 0 to 15 do
  begin
    if Block[I].Alpha < Min then
      Min := Block[I].Alpha;
    if Block[I].Alpha > Max then
      Max := Block[I].Alpha;
  end;
end;

procedure FixEndpoints(var Ep0, Ep1: Word; HasAlpha: Boolean); 
var
  Temp: Word;
begin
  // if dxt block has alpha information, Ep0 must be smaller
  // than Ep1, if the  block has no alpha Ep1 must be smaller
  if HasAlpha then
  begin
    if Ep0 > Ep1 then
    begin
      Temp := Ep0;
      Ep0 := Ep1;
      Ep1 := Temp;
    end;
  end
  else
    if Ep0 < Ep1 then
    begin
      Temp := Ep0;
      Ep0 := Ep1;
      Ep1 := Temp;
    end;
end;

function GetColorMask(Ep0, Ep1: Word; NumCols: LongInt;
  const Block: TPixelBlock): LongWord;
var
  I, J, Closest, Dist: LongInt;
  Colors: array[0..3] of TColor32Rec;
  Mask: array[0..15] of Byte;
begin
  // we decode endpoint colors
  Colors[0] := DecodeCol(Ep0);
  Colors[1] := DecodeCol(Ep1);
  // and interpolate colors between (3 for DXT1 with alpha, 4 for the others)
  if NumCols = 3 then
  begin
    Colors[2].R := (Colors[0].R + Colors[1].R) shr 1;
    Colors[2].G := (Colors[0].G + Colors[1].G) shr 1;
    Colors[2].B := (Colors[0].B + Colors[1].B) shr 1;
    Colors[3].R := (Colors[0].R + Colors[1].R) shr 1;
    Colors[3].G := (Colors[0].G + Colors[1].G) shr 1;
    Colors[3].B := (Colors[0].B + Colors[1].B) shr 1;
  end
  else
  begin
    Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
    Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
    Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
    Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
    Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
    Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
  end;

  for I := 0 to 15 do
  begin
    // this is only for DXT1 with alpha
    if (Block[I].Alpha < 128) and (NumCols = 3) then
    begin
      Mask[I] := 3;
      Continue;
    end;
    // for each of the 16 input pixels the nearest color in the
    // 4 dxt colors is found
    Closest := MaxInt;
    for J := 0 to NumCols - 1 do
    begin
      Dist := ColorDistance(Block[I].Orig, Colors[J]);
      if Dist < Closest then
      begin
        Closest := Dist;
        Mask[I] := J;
      end;
    end;
  end;

  Result := 0;
  for I := 0 to 15 do
    Result := Result or (Mask[I] shl (I shl 1));
end;

procedure GetAlphaMask(Ep0, Ep1: Byte; var Block: TPixelBlock; Mask: PByteArray);
var
  Alphas: array[0..7] of Byte;
  M: array[0..15] of Byte;
  I, J, Closest, Dist: LongInt;
begin
  Alphas[0] := Ep0;
  Alphas[1] := Ep1;
  // interpolation between two given alpha endpoints
  // (I use 6 interpolated values mode)
  Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7;
  Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7;
  Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7;
  Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7;
  Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7;
  Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7;

  // the closest interpolated values for each of the input alpha
  // is found
  for I := 0 to 15 do
  begin
    Closest := MaxInt;
    for J := 0 to 7 do
    begin
      Dist := Abs(Alphas[J] - Block[I].Alpha);
      if Dist < Closest then
      begin
        Closest := Dist;
        M[I] := J;
      end;
    end;
  end;

  Mask[0] := M[0] or (M[1] shl 3) or ((M[2] and 3) shl 6);
  Mask[1] := ((M[2] and 4) shr 2) or (M[3] shl 1) or (M[4] shl 4) or
    ((M[5] and 1) shl 7);
  Mask[2] := ((M[5] and 6) shr 1) or (M[6] shl 2) or (M[7] shl 5);
  Mask[3] := M[8] or (M[9] shl 3) or ((M[10] and 3) shl 6);
  Mask[4] := ((M[10] and 4) shr 2) or (M[11] shl 1) or (M[12] shl 4) or
   ((M[13] and 1) shl 7);
  Mask[5] := ((M[13] and 6) shr 1) or (M[14] shl 2) or (M[15] shl 5);
end;


procedure EncodeDXT1(SrcBits: PByte; DestBits: PByte; Width, Height: LongInt);
var
  X, Y, I: LongInt;
  HasAlpha: Boolean;
  Block: TDXTColorBlock;
  Pixels: TPixelBlock;
begin
  for Y := 0 to Height div 4 - 1 do
    for X := 0 to Width div 4 - 1 do
    begin
      GetBlock(Pixels, SrcBits, X, Y, Width, Height);
      HasAlpha := False;
      for I := 0 to 15 do
        if Pixels[I].Alpha < 128 then
        begin
          HasAlpha := True;
          Break;
        end;
      GetEndpoints(Pixels, Block.Color0, Block.Color1);
      FixEndpoints(Block.Color0, Block.Color1, HasAlpha);
      if HasAlpha then
        Block.Mask := GetColorMask(Block.Color0, Block.Color1, 3, Pixels)
      else
        Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
      PDXTColorBlock(DestBits)^ := Block;
      Inc(DestBits, SizeOf(Block));
    end;
end;

procedure EncodeDXT3(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt);
var
  X, Y, I: LongInt;
  Block: TDXTColorBlock;
  AlphaBlock: TDXTAlphaBlockExp;
  Pixels: TPixelBlock;
begin
  for Y := 0 to Height div 4 - 1 do
    for X := 0 to Width div 4 - 1 do
    begin
      GetBlock(Pixels, SrcBits, X, Y, Width, Height);
      for I := 0 to 7 do
        PByteArray(@AlphaBlock.Alphas)[I] :=
          ((Pixels[I shl 1].Alpha shr 4) shl 4) or (Pixels[I shl 1 + 1].Alpha shr 4);
      GetEndpoints(Pixels, Block.Color0, Block.Color1);
      FixEndpoints(Block.Color0, Block.Color1, False);
      Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
      PDXTAlphaBlockExp(DestBits)^ := AlphaBlock;
      Inc(DestBits, SizeOf(AlphaBlock));
      PDXTColorBlock(DestBits)^ := Block;
      Inc(DestBits, SizeOf(Block));
    end;
end;

procedure EncodeDXT5(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt);
var
  X, Y: LongInt;
  Block: TDXTColorBlock;
  AlphaBlock: TDXTAlphaBlockInt;
  Pixels: TPixelBlock;
begin
  for Y := 0 to Height div 4 - 1 do
    for X := 0 to Width div 4 - 1 do
    begin
      GetBlock(Pixels, SrcBits, X, Y, Width, Height);
      GetEndpoints(Pixels, Block.Color0, Block.Color1);
      FixEndpoints(Block.Color0, Block.Color1, False);
      Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
      GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
      GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
        PByteArray(@AlphaBlock.Alphas[2]));
      PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
      Inc(DestBits, SizeOf(AlphaBlock));
      PDXTColorBlock(DestBits)^ := Block;
      Inc(DestBits, SizeOf(Block));
    end;
end;

procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer;
  SrcInfo, DstInfo: PImageFormatInfo);
begin
  case SrcInfo.Format of
    ifDXT1: DecodeDXT1(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
    ifDXT3: DecodeDXT3(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
    ifDXT5: DecodeDXT5(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
  end;
end;

procedure UnSpecialToSpecial(const DestImage: TImageData; SrcBits: Pointer;
  SrcInfo, DstInfo: PImageFormatInfo);
begin
  case DstInfo.Format of
    ifDXT1: EncodeDXT1(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
    ifDXT3: EncodeDXT3(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
    ifDXT5: EncodeDXT5(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
  end;
end;

procedure ConvertSpecial(var Image: TImageData;
  SrcInfo, DstInfo: PImageFormatInfo);
var
  WorkImage: TImageData;
  Width, Height: LongInt;
begin
  // first convert image to default non-special format
  if SrcInfo.IsSpecial then
  begin
    InitImage(WorkImage);
    NewImage(Image.Width, Image.Height, UnSpecialFormat, WorkImage);
    SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo, DstInfo);
    FreeImage(Image);
    Image := WorkImage;
  end
  else
    ConvertImage(Image, UnSpecialFormat);
  // we have now image in default non-special format and
  // if dest format is special we will convert to this special format
  if DstInfo.IsSpecial then
  begin
    Width := Image.Width;
    Height := Image.Height;
    DstInfo.CheckDimensions(DstInfo.Format, Width, Height);
    InitImage(WorkImage);
    NewImage(Width, Height, DstInfo.Format, WorkImage);
    ResizeImage(Image, Width, Height, rfNearest);
    UnSpecialToSpecial(WorkImage, Image.Bits, SrcInfo, DstInfo);
    FreeImage(Image);
    Image := WorkImage;
  end
  else
    ConvertImage(Image, DstInfo.Format);
end;

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

procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt);
begin
end;

function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
begin
  // DXT can be used only for images with dimensions that are
  // multiples of four
  CheckDXTDimensions(Format, Width, Height);
  Result := Width * Height;
  if Format = ifDXT1 then
    Result := Result div 2;
end;

procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt);
begin
  // DXT image dimensions must be multiples of four
  Width := (Width + 3) and not 3;
  Height := (Height + 3) and not 3;
end;

{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }

function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
begin
  Result.Color := PLongWord(Bits)^;
end;

procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
begin
  PLongWord(Bits)^ := Color.Color;
end;

function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
begin
  Result.A := PColor32Rec(Bits).A * OneDiv8Bit;
  Result.R := PColor32Rec(Bits).R * OneDiv8Bit;
  Result.G := PColor32Rec(Bits).G * OneDiv8Bit;
  Result.B := PColor32Rec(Bits).B * OneDiv8Bit;
end;

procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
begin
  PColor32Rec(Bits).A := ClampToByte(Round(Color.A * 255.0));
  PColor32Rec(Bits).R := ClampToByte(Round(Color.R * 255.0));
  PColor32Rec(Bits).G := ClampToByte(Round(Color.G * 255.0));
  PColor32Rec(Bits).B := ClampToByte(Round(Color.B * 255.0));
end;

function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
begin
  case Info.Format of
    ifR8G8B8, ifX8R8G8B8:
      begin
        Result.A := $FF;
        PColor24Rec(@Result)^ := PColor24Rec(Bits)^;
      end;
    ifGray8, ifA8Gray8:
      begin
        if Info.HasAlphaChannel then
          Result.A := PWordRec(Bits).High
        else
          Result.A := $FF;
        Result.R := PWordRec(Bits).Low;
        Result.G := PWordRec(Bits).Low;
        Result.B := PWordRec(Bits).Low;
      end;
  end;
end;

procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
begin
  case Info.Format of
    ifR8G8B8, ifX8R8G8B8:
      begin
        PColor24Rec(Bits)^ := PColor24Rec(@Color)^;
      end;
    ifGray8, ifA8Gray8:
      begin
        if Info.HasAlphaChannel then
          PWordRec(Bits).High := Color.A;
        PWordRec(Bits).Low := Round(GrayConv.R * Color.R + GrayConv.G * Color.G +
          GrayConv.B * Color.B);
      end;
  end;
end;

function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
begin
  case Info.Format of
    ifR8G8B8, ifX8R8G8B8:
      begin
        Result.A := 1.0;
        Result.R := PColor24Rec(Bits).R * OneDiv8Bit;
        Result.G := PColor24Rec(Bits).G * OneDiv8Bit;
        Result.B := PColor24Rec(Bits).B * OneDiv8Bit;
      end;
    ifGray8, ifA8Gray8:
      begin
        if Info.HasAlphaChannel then
          Result.A := PWordRec(Bits).High * OneDiv8Bit
        else
          Result.A := 1.0;
        Result.R := PWordRec(Bits).Low * OneDiv8Bit;
        Result.G := PWordRec(Bits).Low * OneDiv8Bit;
        Result.B := PWordRec(Bits).Low * OneDiv8Bit;
      end;
  end;
end;

procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
begin
  case Info.Format of
    ifR8G8B8, ifX8R8G8B8:
      begin
        PColor24Rec(Bits).R := ClampToByte(Round(Color.R * 255.0));
        PColor24Rec(Bits).G := ClampToByte(Round(Color.G * 255.0));
        PColor24Rec(Bits).B := ClampToByte(Round(Color.B * 255.0));
      end;
    ifGray8, ifA8Gray8:
      begin
        if Info.HasAlphaChannel then
          PWordRec(Bits).High := ClampToByte(Round(Color.A * 255.0));
        PWordRec(Bits).Low := ClampToByte(Round((GrayConv.R * Color.R + GrayConv.G * Color.G +
          GrayConv.B * Color.B) * 255.0));
      end;
  end;
end;

function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
begin
  case Info.Format of
    ifA32R32G32B32F:
      begin
        Result := PColorFPRec(Bits)^;
      end;
    ifA32B32G32R32F:
      begin
        Result := PColorFPRec(Bits)^;
        SwapValues(Result.R, Result.B);
      end;
    ifR32F:
      begin
        Result.A := 1.0;
        Result.R := PSingle(Bits)^;
        Result.G := 0.0;
        Result.B := 0.0;
      end;
  end;
end;

procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
begin
  case Info.Format of
    ifA32R32G32B32F:
      begin
        PColorFPRec(Bits)^ := Color;
      end;
    ifA32B32G32R32F:
      begin
        PColorFPRec(Bits)^ := Color;
        SwapValues(PColorFPRec(Bits).R, PColorFPRec(Bits).B);
      end;
    ifR32F:
      begin
        PSingle(Bits)^ := Color.R;
      end;
  end;
end;



{
  File Notes:

  -- TODOS ----------------------------------------------------
    - rewrite StretchRect for 8bit channels to use integer math

  -- 0.19 Changes/Bug Fixes -----------------------------------
    - StretchResample now uses pixel get/set functions stored in
      TImageFormatInfo so it is  much faster for formats that override
      them with optimized ones
    - added pixel set/get functions optimized for various image formats
      (to be stored in TImageFormatInfo)
    - bug in ConvertSpecial caused problems when converting DXTC images
      to bitmaps in ImagingCoponents
    - bug in StretchRect caused that it didn't work with ifR32F and
      ifR16F formats
    - removed leftover code in FillMipMapLevel which disabled
      filtered resizing of images witch ChannelSize <> 8bits
    - added half float converting functions and support for half based
      image formats where needed
    - added TranslatePixel and IsImageFormatValid functions
    - fixed possible range overflows when converting from FP to integer images
    - added pixel set/get functions: GetPixel32Generic, GetPixelFPGeneric,
      SetPixel32Generic, SetPixelFPGeneric
    - fixed occasional range overflows in StretchResample

  -- 0.17 Changes/Bug Fixes -----------------------------------
    - added StretchNearest, StretchResample and some sampling functions
    - added ChannelCount values to TImageFormatInfo constants
    - added resolution validity check to GetDXTPixelsSize

  -- 0.15 Changes/Bug Fixes -----------------------------------
    - added RBSwapFormat values to some TImageFromatInfo definitions
    - fixed bug in ConvertSpecial (causing DXT images to convert only to 32bit)
    - added CopyPixel, ComparePixels helper functions

  -- 0.13 Changes/Bug Fixes -----------------------------------
    - replaced pixel format conversions for colors not to be
      darkened when converting from low bit counts
    - ReduceColorsMedianCut was updated to support creating one
      optimal palette for more images and it is somewhat faster
      now too
    - there was ugly bug in DXTC dimensions checking
}

end.