aksdb
/
CentrED
1
0
Fork 0
Code Issues 2 Pull Requests Releases Wiki Activity
CentrED/Imaging/ImagingFormats.pas

3968 lines
125 KiB
Plaintext
Raw Normal View History

- Initial import from internal repository
2007-12-21 21:31:58 +01:00
{
$Id: ImagingFormats.pas 94 2007-06-21 19:29:49Z galfar $
Vampyre Imaging Library
by Marek Mauder
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);
{ Converts 1bit image data to 8bit (without scaling). Used by file
loaders for formats supporting 1bit images.}
procedure Convert1To8(DataIn, DataOut: Pointer; Width, Height,
WidthBytes: LongInt);
{ Converts 2bit image data to 8bit (without scaling). Used by file
loaders for formats supporting 2bit images.}
procedure Convert2To8(DataIn, DataOut: Pointer; Width, Height,
WidthBytes: LongInt);
{ Converts 4bit image data to 8bit (without scaling). Used by file
loaders for formats supporting 4bit images.}
procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height,
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(should 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;
{ Helper function for image file loaders. This function checks is similar
to Has16BitImageAlpha but works with A8R8G8B8 format.}
function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): 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;
{ Returns size in bytes of image in BTC format.}
function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): 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;
SpecialNearestFormat: ifA8R8G8B8);
DXT3Info: TImageFormatInfo = (
Format: ifDXT3;
Name: 'DXT3';
ChannelCount: 4;
HasAlphaChannel: True;
IsSpecial: True;
GetPixelsSize: GetDXTPixelsSize;
CheckDimensions: CheckDXTDimensions;
SpecialNearestFormat: ifA8R8G8B8);
DXT5Info: TImageFormatInfo = (
Format: ifDXT5;
Name: 'DXT5';
ChannelCount: 4;
HasAlphaChannel: True;
IsSpecial: True;
GetPixelsSize: GetDXTPixelsSize;
CheckDimensions: CheckDXTDimensions;
SpecialNearestFormat: ifA8R8G8B8);
BTCInfo: TImageFormatInfo = (
Format: ifBTC;
Name: 'BTC';
ChannelCount: 1;
HasAlphaChannel: False;
IsSpecial: True;
GetPixelsSize: GetBTCPixelsSize;
CheckDimensions: CheckDXTDimensions;
SpecialNearestFormat: ifGray8);
{$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;
Infos[ifBTC] := @BTCInfo;
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 (raUpdateHistogram in Actions) or (raMapImage in Actions) then
begin
Assert(not SrcInfo.IsSpecial);
Assert(not SrcInfo.IsIndexed);
end;
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;
CompatibleCopy: TImageData;
begin
Assert(TestImage(BiggerLevel));
Filter := TSamplingFilter(GetOption(ImagingMipMapFilter));
// If we have special format image we must create copy to allow pixel access
GetImageFormatInfo(BiggerLevel.Format, Info);
if Info.IsSpecial then
begin
InitImage(CompatibleCopy);
CloneImage(BiggerLevel, CompatibleCopy);
ConvertImage(CompatibleCopy, ifDefault);
end
else
CompatibleCopy := BiggerLevel;
// Create new smaller image
NewImage(Width, Height, CompatibleCopy.Format, SmallerLevel);
GetImageFormatInfo(CompatibleCopy.Format, Info);
// If input is indexed we must copy its palette
if Info.IsIndexed then
CopyPalette(CompatibleCopy.Palette, SmallerLevel.Palette, 0, 0, Info.PaletteEntries);
if (Filter = sfNearest) or Info.IsIndexed then
begin
StretchNearest(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height,
SmallerLevel, 0, 0, Width, Height);
end
else
begin
StretchResample(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height,
SmallerLevel, 0, 0, Width, Height, Filter);
end;
// Free copy and convert result to special format if necessary
if CompatibleCopy.Format <> BiggerLevel.Format then
begin
ConvertImage(SmallerLevel, BiggerLevel.Format);
FreeImage(CompatibleCopy);
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;
procedure Convert1To8(DataIn, DataOut: Pointer; Width, Height,
WidthBytes: LongInt);
const
Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0);
var
X, Y: LongInt;
begin
for Y := 0 to Height - 1 do
for X := 0 to Width - 1 do
PByteArray(DataOut)[Y * Width + X] :=
(PByteArray(DataIn)[Y * WidthBytes + X shr 3] and
Mask1[X and 7]) shr Shift1[X and 7];
end;
procedure Convert2To8(DataIn, DataOut: Pointer; Width, Height,
WidthBytes: LongInt);
const
Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03);
Shift2: array[0..3] of Byte = (6, 4, 2, 0);
var
X, Y: LongInt;
begin
for Y := 0 to Height - 1 do
for X := 0 to Width - 1 do
PByteArray(DataOut)[Y * Width + X] :=
(PByteArray(DataIn)[X shr 2] and Mask2[X and 3]) shr
Shift2[X and 3];
end;
procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height,
WidthBytes: LongInt);
const
Mask4: array[0..1] of Byte = ($F0, $0F);
Shift4: array[0..1] of Byte = (4, 0);
var
X, Y: LongInt;
begin
for Y := 0 to Height - 1 do
for X := 0 to Width - 1 do
PByteArray(DataOut)[Y * Width + X] :=
(PByteArray(DataIn)[Y * WidthBytes + X shr 1] and
Mask4[X and 1]) shr Shift4[X and 1];
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 Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean;
var
I: LongInt;
begin
Result := False;
for I := 0 to NumPixels - 1 do
begin
if Data^ >= 1 shl 24 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)^;
if DstInfo.HasAlphaChannel then
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 }
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;
type
TBTCBlock = packed record
MLower, MUpper: Byte;
BitField: Word;
end;
PBTCBlock = ^TBTCBlock;
procedure EncodeBTC(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
var
X, Y, I, J: Integer;
Block: TBTCBlock;
M, MLower, MUpper, K: Integer;
Pixels: array[0..15] of Byte;
begin
for Y := 0 to Height div 4 - 1 do
for X := 0 to Width div 4 - 1 do
begin
M := 0;
MLower := 0;
MUpper := 0;
FillChar(Block, SizeOf(Block), 0);
K := 0;
// Store 4x4 pixels and compute average, lower, and upper intensity levels
for I := 0 to 3 do
for J := 0 to 3 do
begin
Pixels[K] := PByteArray(SrcBits)[(Y shl 2 + I) * Width + X shl 2 + J];
Inc(M, Pixels[K]);
Inc(K);
end;
M := M div 16;
K := 0;
// Now compute upper and lower levels, number of upper pixels,
// and update bit field (1 when pixel is above avg. level M)
for I := 0 to 15 do
begin
if Pixels[I] > M then
begin
Inc(MUpper, Pixels[I]);
Inc(K);
Block.BitField := Block.BitField or (1 shl I);
end
else
Inc(MLower, Pixels[I]);
end;
// Scale levels and save them to block
if K > 0 then
Block.MUpper := ClampToByte(MUpper div K)
else
Block.MUpper := 0;
Block.MLower := ClampToByte(MLower div (16 - K));
// Finally save block to dest data
PBTCBlock(DestBits)^ := Block;
Inc(DestBits, SizeOf(Block));
end;
end;
procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: LongInt);
var
X, Y, I, J, K: Integer;
Block: TBTCBlock;
Dest: PByte;
begin
for Y := 0 to Height div 4 - 1 do
for X := 0 to Width div 4 - 1 do
begin
Block := PBTCBlock(SrcBits)^;
Inc(SrcBits, SizeOf(Block));
K := 0;
// Just write MUpper when there is '1' in bit field and MLower
// when there is '0'
for I := 0 to 3 do
for J := 0 to 3 do
begin
Dest := @PByteArray(DestBits)[(Y shl 2 + I) * Width + X shl 2 + J];
if Block.BitField and (1 shl K) <> 0 then
Dest^ := Block.MUpper
else
Dest^ := Block.MLower;
Inc(K);
end;
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);
ifBTC: DecodeBTC (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);
ifBTC: EncodeBTC (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, SrcInfo.SpecialNearestFormat, WorkImage);
SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo, DstInfo);
FreeImage(Image);
Image := WorkImage;
end
else
ConvertImage(Image, DstInfo.SpecialNearestFormat);
// 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; // div 4 * 4;
Height := (Height + 3) and not 3; // div 4 * 4;
end;
function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
begin
// BTC can be used only for images with dimensions that are
// multiples of four
CheckDXTDimensions(Format, Width, Height);
Result := Width * Height div 4; // 2bits/pixel
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 ----------------------------------------------------
- nothing now
- rewrite StretchRect for 8bit channels to use integer math?
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added ifBTC image format support structures and functions.
-- 0.21 Changes/Bug Fixes -----------------------------------
- FillMipMapLevel now works well with indexed and special formats too.
- Moved Convert1To8 and Convert4To8 functions from ImagingBitmaps here
and created new Convert2To8 function. They are now used by more than one
file format loader.
-- 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.