summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (parent: ecfa6c6)
raw | patch | inline | side by side (parent: ecfa6c6)
| author | Ketmar Dark <ketmar@ketmar.no-ip.org> | |
| Sat, 23 Apr 2016 08:11:31 +0000 (11:11 +0300) | ||
| committer | Ketmar Dark <ketmar@ketmar.no-ip.org> | |
| Sat, 23 Apr 2016 08:12:12 +0000 (11:12 +0300) |
31 files changed:
index 22d8cb37e5877a01ca24dd1ff350be486e2bc2fe..f21fa641a021d4c06f7be1122f73878f05fcd88e 100644 (file)
{
- $Id: Imaging.pas 173 2009-09-04 17:05:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
interface
uses
- ImagingTypes, SysUtils, Classes;
+ SysUtils, Classes, Types, ImagingTypes;
type
- { Default Imaging excepton class.}
+ { Default Imaging excepton class }
EImagingError = class(Exception);
+ { Raised when function receives bad image (not passed TestImage).}
+ EImagingBadImage = class(Exception)
+ public
+ constructor Create;
+ end;
- { Dynamic array of TImageData records.}
+ { Dynamic array of TImageData records }
TDynImageDataArray = array of TImageData;
function CloneImage(const Image: TImageData; var Clone: TImageData): Boolean;
{ Converts image to the given format.}
function ConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean;
-{ Flips given image. Reverses the image along its horizontal axis \97 the top
+{ Flips given image. Reverses the image along its horizontal axis - the top
becomes the bottom and vice versa.}
function FlipImage(var Image: TImageData): Boolean;
{ Mirrors given image. Reverses the image along its vertical axis \97 the left
{ Splits image into XChunks x YChunks subimages. Default size of each chunk is
ChunkWidth x ChunkHeight. If PreserveSize si True chunks at the edges of
the image are also ChunkWidth x ChunkHeight sized and empty space is filled
- with Fill pixels. After calling this function XChunks contains number of
+ with optional Fill pixels. After calling this function XChunks contains number of
chunks along x axis and YChunks along y axis. To access chunk [X, Y] use this
index: Chunks[Y * XChunks + X].}
function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray;
ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
- PreserveSize: Boolean; Fill: Pointer): Boolean;
+ PreserveSize: Boolean; Fill: Pointer = nil): Boolean;
{ Creates palette with MaxColors based on the colors of images in Images array.
Use it when you want to convert several images to indexed format using
single palette for all of them. If ConvertImages is True images in array
function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32;
MaxColors: LongInt; ConvertImages: Boolean): Boolean;
{ Rotates image by Angle degrees counterclockwise. All angles are allowed.}
-function RotateImage(var Image: TImageData; Angle: Single): Boolean;
+procedure RotateImage(var Image: TImageData; Angle: Single);
{ Drawing/Pixel functions }
@@ -310,12 +314,36 @@ function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
{ User can set his own file IO functions used when loading from/saving to
files by this function.}
-procedure SetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
- TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc:
+procedure SetUserFileIO(OpenProc: TOpenProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc:
TSeekProc; TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc);
{ Sets file IO functions to Imaging default.}
procedure ResetFileIO;
+{ Raw Image IO Functions }
+
+procedure ReadRawImageFromFile(const FileName: string; Width, Height: Integer;
+ Format: TImageFormat; var Image: TImageData; Offset: Integer = 0; RowLength: Integer = 0);
+procedure ReadRawImageFromStream(Stream: TStream; Width, Height: Integer;
+ Format: TImageFormat; var Image: TImageData; Offset: Integer = 0; RowLength: Integer = 0);
+procedure ReadRawImageFromMemory(Data: Pointer; DataSize: Integer; Width, Height: Integer;
+ Format: TImageFormat; var Image: TImageData; Offset: Integer = 0; RowLength: Integer = 0);
+procedure ReadRawImageRect(Data: Pointer; Left, Top, Width, Height: Integer;
+ var Image: TImageData; Offset: Integer = 0; RowLength: Integer = 0);
+
+procedure WriteRawImageToFile(const FileName: string; const Image: TImageData;
+ Offset: Integer = 0; RowLength: Integer = 0);
+procedure WriteRawImageToStream(Stream: TStream; const Image: TImageData;
+ Offset: Integer = 0; RowLength: Integer = 0);
+procedure WriteRawImageToMemory(Data: Pointer; DataSize: Integer; const Image: TImageData;
+ Offset: Integer = 0; RowLength: Integer = 0);
+procedure WriteRawImageRect(Data: Pointer; Left, Top, Width, Height: Integer;
+ const Image: TImageData; Offset: Integer = 0; RowLength: Integer = 0);
+
+{ Convenience/helper Functions }
+
+procedure ResizeImageToFit(const SrcImage: TImageData; FitWidth, FitHeight: Integer;
+ Filter: TResizeFilter; var DestImage: TImageData);
+
{ ------------------------------------------------------------------------
Other Imaging Stuff
{ Record containg set of IO functions internaly used by image loaders/savers.}
TIOFunctions = record
- OpenRead: TOpenReadProc;
- OpenWrite: TOpenWriteProc;
+ Open: TOpenProc;
Close: TCloseProc;
Eof: TEofProc;
Seek: TSeekProc;
end;
PIOFunctions = ^TIOFunctions;
+type
+ TFileFormatFeature = (
+ ffLoad,
+ ffSave,
+ ffMultiImage,
+ ffReadOnSave,
+ ffProgress,
+ ffReadScanlines);
+
+ TFileFormatFeatures = set of TFileFormatFeature;
+
+ TMetadata = class;
+
{ Base class for various image file format loaders/savers which
descend from this class. If you want to add support for new image file
format the best way is probably to look at TImageFileFormat descendants'
implementations that are already part of Imaging.}
- {$TYPEINFO ON}
- TImageFileFormat = class(TObject)
+{$TYPEINFO ON}
+ TImageFileFormat = class
private
FExtensions: TStringList;
FMasks: TStringList;
+ function GetCanLoad: Boolean;
+ function GetCanSave: Boolean;
+ function GetIsMultiImageFormat: Boolean;
{ Does various checks and actions before LoadData method is called.}
function PrepareLoad(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstFrame: Boolean): Boolean;
index and sets FFirstIdx and FLastIdx for multi-images).}
function PrepareSave(Handle: TImagingHandle; const Images: TDynImageDataArray;
var Index: LongInt): Boolean;
+ { Returns file open mode used for saving images. Depends on defined Features.}
+ function GetSaveOpenMode: TOpenMode;
protected
FName: string;
- FCanLoad: Boolean;
- FCanSave: Boolean;
- FIsMultiImageFormat: Boolean;
+ FFeatures: TFileFormatFeatures;
FSupportedFormats: TImageFormats;
FFirstIdx, FLastIdx: LongInt;
+ FMetadata: TMetadata;
+ { Descendants must override this method and define file format name and
+ capabilities.}
+ procedure Define; virtual;
{ Defines filename masks for this image file format. AMasks should be
in format '*.ext1,*.ext2,umajo.*'.}
procedure AddMasks(const AMasks: string);
and contains data that passed TestFormat method's check.}
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstFrame: Boolean): Boolean; virtual;
- { Method which must be overrided in descendants if they are be capable
+ { Method which must be overriden in descendants if they are be capable
of saving images. Images are checked to have length >0 and
that they contain valid images. For single-image file formats
Index contain valid index to Images array (to image which should be saved).
(proper widht and height for example).}
function IsSupported(const Image: TImageData): Boolean; virtual;
public
- constructor Create; virtual;
+ constructor Create(AMetadata: TMetadata = nil); virtual;
destructor Destroy; override;
{ Loads images from file source.}
{ Description of this format.}
property Name: string read FName;
{ Indicates whether images in this format can be loaded.}
- property CanLoad: Boolean read FCanLoad;
+ property CanLoad: Boolean read GetCanLoad;
{ Indicates whether images in this format can be saved.}
- property CanSave: Boolean read FCanSave;
+ property CanSave: Boolean read GetCanSave;
{ Indicates whether images in this format can contain multiple image levels.}
- property IsMultiImageFormat: Boolean read FIsMultiImageFormat;
+ property IsMultiImageFormat: Boolean read GetIsMultiImageFormat;
{ List of filename extensions for this format.}
property Extensions: TStringList read FExtensions;
- { List of filename mask that are used to associate filenames
+ { List of filename masks that are used to associate filenames
with TImageFileFormat descendants. Typical mask looks like
'*.bmp' or 'texture.*' (supports file formats which use filename instead
of extension to identify image files).}
can be saved only in one those formats.}
property SupportedFormats: TImageFormats read GetSupportedFormats;
end;
- {$TYPEINFO OFF}
+{$TYPEINFO OFF}
{ Class reference for TImageFileFormat class}
TImageFileFormatClass = class of TImageFileFormat;
+ { Physical resolution unit.}
+ TResolutionUnit = (
+ ruSizeInMicroMeters, // value is pixel size in micrometers
+ ruDpi, // value is pixels/dots per inch
+ ruDpm, // value is pixels/dots per meter
+ ruDpcm // value is pixels/dots per centimeter
+ );
+
+ { Class for storage of single metadata item.}
+ TMetadataItem = class
+ public
+ Id: string;
+ ImageIndex: Integer;
+ Value: Variant;
+ end;
+
+ { Metadata manager class.}
+ TMetadata = class
+ private
+ FLoadMetaItems: TStringList;
+ FSaveMetaItems: TStringList;
+ procedure AddMetaToList(List: TStringList; const Id: string; const Value: Variant; ImageIndex: Integer);
+ procedure ClearMetaList(List: TStringList);
+ function GetMetaById(const Id: string): Variant;
+ function GetMetaByIdMulti(const Id: string; ImageIndex: Integer): Variant;
+ function GetMetaCount: Integer;
+ function GetMetaByIdx(Index: Integer): TMetadataItem;
+ function GetSaveMetaById(const Id: string): Variant;
+ function GetSaveMetaByIdMulti(const Id: string; ImageIndex: Integer): Variant;
+ procedure TranslateUnits(ResolutionUnit: TResolutionUnit; var XRes, YRes: Single);
+ public
+ constructor Create;
+ destructor Destroy; override;
+
+ procedure SetMetaItem(const Id: string; const Value: Variant; ImageIndex: Integer = 0);
+ procedure SetMetaItemForSaving(const Id: string; const Value: Variant; ImageIndex: Integer = 0);
+ function HasMetaItem(const Id: string; ImageIndex: Integer = 0): Boolean;
+ function HasMetaItemForSaving(const Id: string; ImageIndex: Integer = 0): Boolean;
+
+ procedure ClearMetaItems;
+ procedure ClearMetaItemsForSaving;
+ function GetMetaItemName(const Id: string; ImageIndex: Integer): string;
+ { Copies loaded meta items to items-for-save stack. Use this when you want to
+ save metadata that have been just loaded (e.g. resaving image in
+ different file format but keeping the metadata).}
+ procedure CopyLoadedMetaItemsForSaving;
+
+ function GetPhysicalPixelSize(ResUnit: TResolutionUnit; var XSize,
+ YSize: Single; MetaForSave: Boolean = False; ImageIndex: Integer = 0): Boolean;
+ procedure SetPhysicalPixelSize(ResUnit: TResolutionUnit; XSize, YSize: Single;
+ MetaForSave: Boolean = False; ImageIndex: Integer = 0);
+
+ property MetaItems[const Id: string]: Variant read GetMetaById;
+ property MetaItemsMulti[const Id: string; ImageIndex: Integer]: Variant read GetMetaByIdMulti;
+ { Number of loaded metadata items.}
+ property MetaItemCount: Integer read GetMetaCount;
+ property MetaItemsByIdx[Index: Integer]: TMetadataItem read GetMetaByIdx;
+ property MetaItemsForSaving[const Id: string]: Variant read GetSaveMetaById;
+ property MetaItemsForSavingMulti[const Id: string; ImageIndex: Integer]: Variant read GetSaveMetaByIdMulti;
+ end;
+
+const
+ { Metadata item id constants }
+
+ { Physical size of one pixel in micrometers. Type of value is Float.}
+ SMetaPhysicalPixelSizeX = 'PhysicalPixelSizeX';
+ SMetaPhysicalPixelSizeY = 'PhysicalPixelSizeY';
+ { Delay for frame of animation (how long it should stay visible) in milliseconds.
+ Type of value is Integer.}
+ SMetaFrameDelay = 'FrameDelay';
+ { Number of times animation should be looped (0 = infinite looping). Type is Int. }
+ SMetaAnimationLoops = 'AnimationLoops';
+ { Gamma correction value. Type is Float.}
+ SMetaGamma = 'Gamma';
+ { Exposure value for HDR etc. Type is Float.}
+ SMetaExposure = 'Exposure';
+ { EXIF image metadata raw blob.}
+ SMetaExifBlob = 'ExifBlob';
+ { XMP image metadata raw blob.}
+ SMetaXmpBlob = 'XmpBlob';
+ { IPTC image metadata raw blob.}
+ SMetaIptcBlob = 'IptcBlob';
+
+var
+ GlobalMetadata: TMetadata;
+
{ Returns symbolic name of given format.}
function GetFormatName(Format: TImageFormat): string;
{ Returns string with information about given Image.}
function GetVersionStr: string;
{ If Condition is True then TruePart is retured, otherwise FalsePart is returned.}
function IffFormat(Condition: Boolean; const TruePart, FalsePart: TImageFormat): TImageFormat;
-{ Registers new image loader/saver so it can be used by LoadFrom/SaveTo
- functions.}
-procedure RegisterImageFileFormat(AClass: TImageFileFormatClass);
+
{ Registers new option so it can be used by SetOption and GetOption functions.
Returns True if registration was succesful - that is Id is valid and is
not already taken by another option.}
function RegisterOption(OptionId: LongInt; Variable: PLongInt): Boolean;
+
+{ Registers new image loader/saver so it can be used by LoadFrom/SaveTo
+ functions.}
+procedure RegisterImageFileFormat(AClass: TImageFileFormatClass);
{ Returns image format loader/saver according to given extension
or nil if not found.}
function FindImageFileFormatByExt(const Ext: string): TImageFileFormat;
@@ -525,10 +660,15 @@ function GetFilterIndexExtension(Index: LongInt; OpenFileFilter: Boolean): strin
string is defined by GetImageFileFormatsFilter function.
Returned index is in range 1..N (as FilterIndex property of TOpenDialog/TSaveDialog)}
function GetFileNameFilterIndex(const FileName: string; OpenFileFilter: Boolean): LongInt;
+
{ Returns current IO functions.}
function GetIO: TIOFunctions;
{ Raises EImagingError with given message.}
-procedure RaiseImaging(const Msg: string; const Args: array of const);
+procedure RaiseImaging(const Msg: string; const Args: array of const); overload;
+procedure RaiseImaging(const Msg: string); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+
+const
+ SImagingLibTitle = 'Vampyre Imaging Library';
implementation
{$IFNDEF DONT_LINK_PNM}
ImagingPortableMaps,
{$ENDIF}
+{$IFNDEF DONT_LINK_RADHDR}
+ ImagingRadiance,
+{$ENDIF}
{$IFNDEF DONT_LINK_EXTRAS}
ImagingExtras,
{$ENDIF}
- ImagingFormats, ImagingUtility, ImagingIO;
+ //ImagingDebug,
+ ImagingFormats, ImagingUtility, ImagingIO, Variants;
resourcestring
- SImagingTitle = 'Vampyre Imaging Library';
SExceptMsg = 'Exception Message';
SAllFilter = 'All Images';
SUnknownFormat = 'Unknown and unsupported format';
+
SErrorFreeImage = 'Error while freeing image. %s';
SErrorCloneImage = 'Error while cloning image. %s';
SErrorFlipImage = 'Error while flipping image. %s';
SErrorRotateImage = 'Error while rotating image %s by %.2n degrees';
SErrorStretchRect = 'Error while stretching rect from image %s to image %s.';
SErrorEmptyStream = 'Input stream has no data. Check Position property.';
+ SErrorInvalidInputImage = 'Invalid input image.';
+
+ SErrorBadImage = 'Bad image detected.';
const
- // initial size of array with options information
+ // Initial size of array with options information
InitialOptions = 256;
- // max depth of the option stack
+ // Max depth of the option stack
OptionStackDepth = 8;
- // do not change the default format now, its too late
+ // Do not change the default format now, its too late
DefaultImageFormat: TImageFormat = ifA8R8G8B8;
+ // Format used to create metadata IDs for frames loaded form multiimages.
+ SMetaIdForSubImage = '%s/%d';
type
TOptionArray = array of PLongInt;
end;
var
- // currently set IO functions
+ // Currently set IO functions
IO: TIOFunctions;
- // list with all registered TImageFileFormat classes
+ // List with all registered TImageFileFormat classes
ImageFileFormats: TList = nil;
- // array with registered options (pointers to their values)
+ // Aarray with registered options (pointers to their values)
Options: TOptionArray = nil;
- // array containing addional infomation about every image format
+ // Array containing addional infomation about every image format
ImageFormatInfos: TImageFormatInfoArray;
- // stack used by PushOptions/PopOtions functions
+ // Stack used by PushOptions/PopOtions functions
OptionStack: TOptionStack = nil;
var
- // variable for ImagingColorReduction option
+ // Variable for ImagingColorReduction option
ColorReductionMask: LongInt = $FF;
- // variable for ImagingLoadOverrideFormat option
+ // Variable for ImagingLoadOverrideFormat option
LoadOverrideFormat: TImageFormat = ifUnknown;
- // variable for ImagingSaveOverrideFormat option
+ // Variable for ImagingSaveOverrideFormat option
SaveOverrideFormat: TImageFormat = ifUnknown;
- // variable for ImagingSaveOverrideFormat option
+ // Variable for ImagingSaveOverrideFormat option
MipMapFilter: TSamplingFilter = sfLinear;
+ // Variable for ImagingBinaryTreshold option
+ BinaryTreshold: Integer = 128;
+
+{ Exceptions }
+constructor EImagingBadImage.Create;
+begin
+ inherited Create(SErrorBadImage);
+end;
{ Internal unit functions }
{ Frees options array and stack.}
procedure FreeOptions; forward;
-{$IFDEF USE_INLINE}
-{ Those inline functions are copied here from ImagingFormats
- because Delphi 9/10 cannot inline them if they are declared in
- circularly dependent units.}
-
-procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); inline;
-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; inline;
-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;
+function UpdateExceptMessage(E: Exception; const MsgToPrepend: string; const Args: array of const): Exception;
+begin
+ Result := E;
+ E.Message := Format(MsgToPrepend, Args) + ' ' + SExceptMsg + ': ' + E.Message
end;
-{$ENDIF}
{ ------------------------------------------------------------------------
Low Level Interface Functions
end;
Result := TestImage(Image);
except
- RaiseImaging(SErrorNewImage, [Width, Height, GetFormatName(Format)]);
+ on E: Exception do
+ begin
+ FreeMem(Image.Bits);
+ FreeMem(Image.Palette);
+ InitImage(Image);
+ raise UpdateExceptMessage(E, SErrorNewImage, [Width, Height, GetFormatName(Format)]);
+ end;
end;
end;
end;
InitImage(Image);
except
- RaiseImaging(SErrorFreeImage, [ImageToStr(Image)]);
+ raise UpdateExceptMessage(GetExceptObject, SErrorFreeImage, [ImageToStr(Image)]);
end;
end;
Assert(FileName <> '');
Result := '';
SetFileIO;
+ Handle := IO.Open(PChar(FileName), omReadOnly);
try
- Handle := IO.OpenRead(PChar(FileName));
- try
- // First file format according to FileName and test if the data in
- // file is really in that format
- for I := 0 to ImageFileFormats.Count - 1 do
+ // First file format according to FileName and test if the data in
+ // file is really in that format
+ for I := 0 to ImageFileFormats.Count - 1 do
+ begin
+ Fmt := TImageFileFormat(ImageFileFormats[I]);
+ if Fmt.TestFileName(FileName) and Fmt.TestFormat(Handle) then
begin
- Fmt := TImageFileFormat(ImageFileFormats[I]);
- if Fmt.TestFileName(FileName) and Fmt.TestFormat(Handle) then
- begin
- Result := Fmt.Extensions[0];
- Exit;
- end;
+ Result := Fmt.Extensions[0];
+ Exit;
end;
- // No file format was found with filename search so try data-based search
- for I := 0 to ImageFileFormats.Count - 1 do
+ end;
+ // No file format was found with filename search so try data-based search
+ for I := 0 to ImageFileFormats.Count - 1 do
+ begin
+ Fmt := TImageFileFormat(ImageFileFormats[I]);
+ if Fmt.TestFormat(Handle) then
begin
- Fmt := TImageFileFormat(ImageFileFormats[I]);
- if Fmt.TestFormat(Handle) then
- begin
- Result := Fmt.Extensions[0];
- Exit;
- end;
+ Result := Fmt.Extensions[0];
+ Exit;
end;
- finally
- IO.Close(Handle);
end;
- except
- Result := '';
+ finally
+ IO.Close(Handle);
end;
end;
Assert(Stream <> nil);
Result := '';
SetStreamIO;
+ Handle := IO.Open(Pointer(Stream), omReadOnly);
try
- Handle := IO.OpenRead(Pointer(Stream));
- try
- for I := 0 to ImageFileFormats.Count - 1 do
+ for I := 0 to ImageFileFormats.Count - 1 do
+ begin
+ Fmt := TImageFileFormat(ImageFileFormats[I]);
+ if Fmt.TestFormat(Handle) then
begin
- Fmt := TImageFileFormat(ImageFileFormats[I]);
- if Fmt.TestFormat(Handle) then
- begin
- Result := Fmt.Extensions[0];
- Exit;
- end;
+ Result := Fmt.Extensions[0];
+ Exit;
end;
- finally
- IO.Close(Handle);
end;
- except
- Result := '';
+ finally
+ IO.Close(Handle);
end;
end;
IORec.Data := Data;
IORec.Position := 0;
IORec.Size := Size;
+ Handle := IO.Open(@IORec, omReadOnly);
try
- Handle := IO.OpenRead(@IORec);
- try
- for I := 0 to ImageFileFormats.Count - 1 do
+ for I := 0 to ImageFileFormats.Count - 1 do
+ begin
+ Fmt := TImageFileFormat(ImageFileFormats[I]);
+ if Fmt.TestFormat(Handle) then
begin
- Fmt := TImageFileFormat(ImageFileFormats[I]);
- if Fmt.TestFormat(Handle) then
- begin
- Result := Fmt.Extensions[0];
- Exit;
- end;
+ Result := Fmt.Extensions[0];
+ Exit;
end;
- finally
- IO.Close(Handle);
end;
- except
- Result := '';
+ finally
+ IO.Close(Handle);
end;
end;
Move(Image.Bits^, Clone.Bits^, Clone.Size);
Result := True;
except
- RaiseImaging(SErrorCloneImage, [ImageToStr(Image)]);
+ raise UpdateExceptMessage(GetExceptObject, SErrorCloneImage, [ImageToStr(Image)]);
end;
end;
Result := True;
except
- RaiseImaging(SErrorConvertImage, [GetFormatName(DestFormat), ImageToStr(Image)]);
+ raise UpdateExceptMessage(GetExceptObject, SErrorConvertImage, [GetFormatName(DestFormat), ImageToStr(Image)]);
end;
end;
var
WorkImage: TImageData;
begin
- Assert((NewWidth > 0) and (NewHeight > 0));
+ Assert((NewWidth > 0) and (NewHeight > 0), 'New width or height is zero.');
Result := False;
if TestImage(Image) and ((Image.Width <> NewWidth) or (Image.Height <> NewHeight)) then
try
Image := WorkImage;
Result := True;
except
- RaiseImaging(SErrorResizeImage, [ImageToStr(Image)]);
+ raise UpdateExceptMessage(GetExceptObject, SErrorResizeImage, [ImageToStr(Image)]);
end;
end;
FreeImage(CloneARGB);
Result := True;
except
- RaiseImaging(SErrorMapImage, [ImageToStr(Image)]);
+ raise UpdateExceptMessage(GetExceptObject, SErrorMapImage, [ImageToStr(Image)]);
end;
end;
else
begin
// Create smaller edge chunk
- XTrunc := Image.Width - (Image.Width div ChunkWidth) * ChunkWidth;
- YTrunc := Image.Height - (Image.Height div ChunkHeight) * ChunkHeight;
+ XTrunc := Image.Width - X * ChunkWidth;
+ YTrunc := Image.Height - Y * ChunkHeight;
NewImage(XTrunc, YTrunc, Image.Format, Chunks[Y * XChunks + X]);
CopyRect(Image, X * ChunkWidth, Y * ChunkHeight, XTrunc, YTrunc,
Chunks[Y * XChunks + X], 0, 0);
Result := True;
except
- RaiseImaging(SErrorSplitImage, [ImageToStr(Image), ChunkWidth, ChunkHeight]);
+ raise UpdateExceptMessage(GetExceptObject, SErrorSplitImage,
+ [ImageToStr(Image), ChunkWidth, ChunkHeight]);
end;
end;
end;
end;
-function RotateImage(var Image: TImageData; Angle: Single): Boolean;
+procedure RotateImage(var Image: TImageData; Angle: Single);
var
OldFmt: TImageFormat;
if (XPos >= 0) and (XPos < Dst.Width) then
begin
for J := 0 to Bpp - 1 do
- PixSrc.Channels[J] := PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]);
+ PixSrc.Channels[J] := ClampToByte(PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]));
CopyPixel(@PixSrc, @LineDst[XPos * Bpp], Bpp);
end;
PixOldLeft := PixLeft;
if (YPos >= 0) and (YPos < Dst.Height) then
begin
for J := 0 to Bpp - 1 do
- PixSrc.Channels[J] := PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]);
+ PixSrc.Channels[J] := ClampToByte(PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]));
CopyPixel(@PixSrc, @PByteArray(Dst.Bits)[(YPos * Dst.Width + Col) * Bpp], Bpp);
end;
PixOldLeft := PixLeft;
// 1st shear (horizontal)
DstWidth := Trunc(SrcWidth + SrcHeight * Abs(AngleTan) + 0.5);
DstHeight := SrcHeight;
+ InitImage(TempImage1);
NewImage(DstWidth, DstHeight, TempFormat, TempImage1);
for I := 0 to DstHeight - 1 do
XShear(Image, TempImage1, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp);
end;
- // 2nd shear (vertical)
+ // 2nd shear (vertical)
FreeImage(Image);
DstHeight := Trunc(SrcWidth * Abs(AngleSin) + SrcHeight * AngleCos + 0.5) + 1;
+ InitImage(TempImage2);
NewImage(DstWidth, DstHeight, TempFormat, TempImage2);
if AngleSin >= 0 then
end;
begin
- Result := False;
-
if TestImage(Image) then
try
while Angle >= 360 do
Angle := Angle + 360;
if (Angle = 0) or (Abs(Angle) = 360) then
- begin
- Result := True;
Exit;
- end;
OldFmt := Image.Format;
if ImageFormatInfos[Image.Format].IsSpecial then
if OldFmt <> Image.Format then
ConvertImage(Image, OldFmt);
- Result := True;
except
- RaiseImaging(SErrorRotateImage, [ImageToStr(Image), Angle]);
+ raise UpdateExceptMessage(GetExceptObject, SErrorRotateImage, [ImageToStr(Image), Angle]);
end;
end;
Info: PImageFormatInfo;
WorkImage: TImageData;
OldFormat: TImageFormat;
+ Resampling: TSamplingFilter;
begin
Result := False;
OldFormat := ifUnknown;
if Info.IsIndexed then
Filter := rfNearest;
- case Filter of
- rfNearest: StretchNearest(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight,
+ if Filter = rfNearest then
+ begin
+ StretchNearest(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight,
DstImage, DstX, DstY, DstWidth, DstHeight);
- rfBilinear: StretchResample(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight,
- DstImage, DstX, DstY, DstWidth, DstHeight, sfLinear);
- rfBicubic: StretchResample(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight,
- DstImage, DstX, DstY, DstWidth, DstHeight, sfCatmullRom);
+ end
+ else
+ begin
+ Resampling := sfNearest;
+ case Filter of
+ rfBilinear: Resampling := sfLinear;
+ rfBicubic: Resampling := DefaultCubicFilter;
+ rfLanczos: Resampling := sfLanczos;
+ end;
+ StretchResample(WorkImage, SrcX, SrcY, SrcWidth, SrcHeight,
+ DstImage, DstX, DstY, DstWidth, DstHeight, Resampling);
end;
// If dest image was in special format we convert it back
{ IO Functions }
-procedure SetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
- TOpenWriteProc;
+procedure SetUserFileIO(OpenProc: TOpenProc;
CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc; TellProc:
TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc);
begin
- FileIO.OpenRead := OpenReadProc;
- FileIO.OpenWrite := OpenWriteProc;
+ FileIO.Open := OpenProc;
FileIO.Close := CloseProc;
FileIO.Eof := EofProc;
FileIO.Seek := SeekProc;
FileIO := OriginalFileIO;
end;
+{ Raw Image IO Functions }
+
+procedure ReadRawImage(Handle: TImagingHandle; Width, Height: Integer;
+ Format: TImageFormat; out Image: TImageData; Offset, RowLength: Integer);
+var
+ WidthBytes, I: Integer;
+ Info: PImageFormatInfo;
+begin
+ Info := ImageFormatInfos[Format];
+ // Calc scanline size
+ WidthBytes := Info.GetPixelsSize(Format, Width, 1);
+ if RowLength = 0 then
+ RowLength := WidthBytes;
+ // Create new image if needed - don't need to allocate new one if there is already
+ // one with desired size and format
+ if (Image.Width <> Width) or (Image.Height <> Height) or (Image.Format <> Format) then
+ NewImage(Width, Height, Format, Image);
+ // Move past the header
+ IO.Seek(Handle, Offset, smFromCurrent);
+ // Read scanlines from input
+ for I := 0 to Height - 1 do
+ begin
+ IO.Read(Handle, @PByteArray(Image.Bits)[I * WidthBytes], WidthBytes);
+ IO.Seek(Handle, RowLength - WidthBytes, smFromCurrent);
+ end;
+end;
+
+procedure ReadRawImageFromFile(const FileName: string; Width, Height: Integer;
+ Format: TImageFormat; var Image: TImageData; Offset, RowLength: Integer);
+var
+ Handle: TImagingHandle;
+begin
+ Assert(FileName <> '');
+ // Set IO ops to file ops and open given file
+ SetFileIO;
+ Handle := IO.Open(PChar(FileName), omReadOnly);
+ try
+ ReadRawImage(Handle, Width, Height, Format, Image, Offset, RowLength);
+ finally
+ IO.Close(Handle);
+ end;
+end;
+
+procedure ReadRawImageFromStream(Stream: TStream; Width, Height: Integer;
+ Format: TImageFormat; var Image: TImageData; Offset, RowLength: Integer);
+var
+ Handle: TImagingHandle;
+begin
+ Assert(Stream <> nil);
+ if Stream.Size - Stream.Position = 0 then
+ RaiseImaging(SErrorEmptyStream, []);
+ // Set IO ops to stream ops and open given stream
+ SetStreamIO;
+ Handle := IO.Open(Pointer(Stream), omReadOnly);
+ try
+ ReadRawImage(Handle, Width, Height, Format, Image, Offset, RowLength);
+ finally
+ IO.Close(Handle);
+ end;
+end;
+
+procedure ReadRawImageFromMemory(Data: Pointer; DataSize: Integer; Width, Height: Integer;
+ Format: TImageFormat; var Image: TImageData; Offset, RowLength: Integer);
+var
+ Handle: TImagingHandle;
+ MemRec: TMemoryIORec;
+begin
+ Assert((Data <> nil) and (DataSize > 0));
+ // Set IO ops to memory ops and open given stream
+ SetMemoryIO;
+ MemRec := PrepareMemIO(Data, DataSize);
+ Handle := IO.Open(@MemRec, omReadOnly);
+ try
+ ReadRawImage(Handle, Width, Height, Format, Image, Offset, RowLength);
+ finally
+ IO.Close(Handle);
+ end;
+end;
+
+procedure ReadRawImageRect(Data: Pointer; Left, Top, Width, Height: Integer;
+ var Image: TImageData; Offset, RowLength: Integer);
+var
+ DestScanBytes, RectBytes, I: Integer;
+ Info: PImageFormatInfo;
+ Src, Dest: PByte;
+begin
+ Assert(Data <> nil);
+ Assert((Left + Width <= Image.Width) and (Top + Height <= Image.Height));
+ Info := ImageFormatInfos[Image.Format];
+
+ // Calc scanline size
+ DestScanBytes := Info.GetPixelsSize(Info.Format, Image.Width, 1);
+ RectBytes := Info.GetPixelsSize(Info.Format, Width, 1);
+ if RowLength = 0 then
+ RowLength := RectBytes;
+
+ Src := Data;
+ Dest := @PByteArray(Image.Bits)[Top * DestScanBytes + Info.GetPixelsSize(Info.Format, Left, 1)];
+ // Move past the header
+ Inc(Src, Offset);
+
+ // Read lines into rect in the existing image
+ for I := 0 to Height - 1 do
+ begin
+ Move(Src^, Dest^, RectBytes);
+ Inc(Src, RowLength);
+ Inc(Dest, DestScanBytes);
+ end;
+end;
+
+procedure WriteRawImage(Handle: TImagingHandle; const Image: TImageData;
+ Offset, RowLength: Integer);
+var
+ WidthBytes, I: Integer;
+ Info: PImageFormatInfo;
+begin
+ Info := ImageFormatInfos[Image.Format];
+ // Calc scanline size
+ WidthBytes := Info.GetPixelsSize(Image.Format, Image.Width, 1);
+ if RowLength = 0 then
+ RowLength := WidthBytes;
+ // Move past the header
+ IO.Seek(Handle, Offset, smFromCurrent);
+ // Write scanlines to output
+ for I := 0 to Image.Height - 1 do
+ begin
+ IO.Write(Handle, @PByteArray(Image.Bits)[I * WidthBytes], WidthBytes);
+ IO.Seek(Handle, RowLength - WidthBytes, smFromCurrent);
+ end;
+end;
+
+procedure WriteRawImageToFile(const FileName: string; const Image: TImageData;
+ Offset, RowLength: Integer);
+var
+ Handle: TImagingHandle;
+begin
+ Assert(FileName <> '');
+ // Set IO ops to file ops and open given file
+ SetFileIO;
+ Handle := IO.Open(PChar(FileName), omCreate);
+ try
+ WriteRawImage(Handle, Image, Offset, RowLength);
+ finally
+ IO.Close(Handle);
+ end;
+end;
+
+procedure WriteRawImageToStream(Stream: TStream; const Image: TImageData;
+ Offset, RowLength: Integer);
+var
+ Handle: TImagingHandle;
+begin
+ Assert(Stream <> nil);
+ // Set IO ops to stream ops and open given stream
+ SetStreamIO;
+ Handle := IO.Open(Pointer(Stream), omCreate);
+ try
+ WriteRawImage(Handle, Image, Offset, RowLength);
+ finally
+ IO.Close(Handle);
+ end;
+end;
+
+procedure WriteRawImageToMemory(Data: Pointer; DataSize: Integer; const Image: TImageData;
+ Offset, RowLength: Integer);
+var
+ Handle: TImagingHandle;
+ MemRec: TMemoryIORec;
+begin
+ Assert((Data <> nil) and (DataSize > 0));
+ // Set IO ops to memory ops and open given stream
+ SetMemoryIO;
+ MemRec := PrepareMemIO(Data, DataSize);
+ Handle := IO.Open(@MemRec, omCreate);
+ try
+ WriteRawImage(Handle, Image, Offset, RowLength);
+ finally
+ IO.Close(Handle);
+ end;
+end;
+
+procedure WriteRawImageRect(Data: Pointer; Left, Top, Width, Height: Integer;
+ const Image: TImageData; Offset, RowLength: Integer);
+var
+ SrcScanBytes, RectBytes, I: Integer;
+ Info: PImageFormatInfo;
+ Src, Dest: PByte;
+begin
+ Assert(Data <> nil);
+ Assert((Left + Width <= Image.Width) and (Top + Height <= Image.Height));
+ Info := ImageFormatInfos[Image.Format];
+
+ // Calc scanline size
+ SrcScanBytes := Info.GetPixelsSize(Info.Format, Image.Width, 1);
+ RectBytes := Info.GetPixelsSize(Info.Format, Width, 1);
+ if RowLength = 0 then
+ RowLength := RectBytes;
+
+ Src := @PByteArray(Image.Bits)[Top * SrcScanBytes + Info.GetPixelsSize(Info.Format, Left, 1)];
+ Dest := Data;
+ // Move past the header
+ Inc(Dest, Offset);
+
+ // Write lines from rect of the existing image
+ for I := 0 to Height - 1 do
+ begin
+ Move(Src^, Dest^, RectBytes);
+ Inc(Dest, RowLength);
+ Inc(Src, SrcScanBytes);
+ end;
+end;
+
+{ Convenience/helper Functions }
+
+procedure ResizeImageToFit(const SrcImage: TImageData; FitWidth, FitHeight: Integer;
+ Filter: TResizeFilter; var DestImage: TImageData);
+var
+ CurSize, FitSize, DestSize: TSize;
+begin
+ if not TestImage(SrcImage) then
+ raise EImagingError.Create(SErrorInvalidInputImage);
+
+ FitSize.CX := FitWidth;
+ FitSize.CY := FitHeight;
+ CurSize.CX := SrcImage.Width;
+ CurSize.CY := SrcImage.Height;
+ DestSize := ImagingUtility.ScaleSizeToFit(CurSize, FitSize);
+
+ NewImage(Max(DestSize.CX, 1), Max(DestSize.CY, 1), SrcImage.Format, DestImage);
+ if SrcImage.Palette <> nil then
+ CopyPalette(SrcImage.Palette, DestImage.Palette, 0, 0, ImageFormatInfos[SrcImage.Format].PaletteEntries);
+
+ StretchRect(SrcImage, 0, 0, CurSize.CX, CurSize.CY, DestImage, 0, 0,
+ DestSize.CX, DestSize.CY, Filter);
+end;
{ ------------------------------------------------------------------------
Other Imaging Stuff
Assert(AClass <> nil);
if ImageFileFormats = nil then
ImageFileFormats := TList.Create;
+ if GlobalMetadata = nil then
+ GlobalMetadata := TMetadata.Create;
if ImageFileFormats <> nil then
ImageFileFormats.Add(AClass.Create);
end;
begin
WholeMsg := Msg;
if GetExceptObject <> nil then
+ begin
WholeMsg := WholeMsg + ' ' + SExceptMsg + ': ' +
GetExceptObject.Message;
+ end;
raise EImagingError.CreateFmt(WholeMsg, Args);
end;
+procedure RaiseImaging(const Msg: string);
+begin
+ RaiseImaging(Msg, []);
+end;
+
{ Internal unit functions }
function CheckOptionValue(OptionId, Value: LongInt): LongInt;
TImageFileFormat class implementation
}
-constructor TImageFileFormat.Create;
+constructor TImageFileFormat.Create(AMetadata: TMetadata);
begin
inherited Create;
FName := SUnknownFormat;
FExtensions := TStringList.Create;
FMasks := TStringList.Create;
+ if AMetadata = nil then
+ FMetadata := GlobalMetadata
+ else
+ FMetadata := AMetadata;
+ Define;
end;
destructor TImageFileFormat.Destroy;
inherited Destroy;
end;
+procedure TImageFileFormat.Define;
+begin
+end;
+
function TImageFileFormat.PrepareLoad(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstFrame: Boolean): Boolean;
begin
+ FMetadata.ClearMetaItems; // Clear old metadata
FreeImagesInArray(Images);
SetLength(Images, 0);
Result := Handle <> nil;
begin
CheckOptionsValidity;
Result := False;
- if FCanSave then
+ if CanSave then
begin
Len := Length(Images);
Assert(Len > 0);
if Len = 0 then Exit;
// Check index of image to be saved (-1 as index means save all images)
- if FIsMultiImageFormat then
+ if IsMultiImageFormat then
begin
if (Index >= Len) then
Index := 0;
end;
for I := FFirstIdx to FLastIdx - 1 do
+ begin
if not TestImage(Images[I]) then
Exit;
+ end;
end
else
begin
Handle: TImagingHandle;
begin
Result := False;
- if FCanLoad then
+ if CanLoad then
try
// Set IO ops to file ops and open given file
SetFileIO;
- Handle := IO.OpenRead(PChar(FileName));
+ Handle := IO.Open(PChar(FileName), omReadOnly);
try
// Test if file contains valid image and if so then load it
if TestFormat(Handle) then
begin
Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and
LoadData(Handle, Images, OnlyFirstlevel);
- Result := Result and PostLoadCheck(Images, Result);
+ Result := PostLoadCheck(Images, Result);
end
else
RaiseImaging(SFileNotValid, [FileName, Name]);
begin
Result := False;
OldPosition := Stream.Position;
- if FCanLoad then
+ if CanLoad then
try
// Set IO ops to stream ops and "open" given memory
SetStreamIO;
- Handle := IO.OpenRead(Pointer(Stream));
+ Handle := IO.Open(Pointer(Stream), omReadOnly);
try
// Test if stream contains valid image and if so then load it
if TestFormat(Handle) then
begin
Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and
LoadData(Handle, Images, OnlyFirstlevel);
- Result := Result and PostLoadCheck(Images, Result);
+ Result := PostLoadCheck(Images, Result);
end
else
RaiseImaging(SStreamNotValid, [@Stream, Name]);
end;
except
Stream.Position := OldPosition;
+ FreeImagesInArray(Images);
RaiseImaging(SErrorLoadingStream, [@Stream, FExtensions[0]]);
end;
end;
IORec: TMemoryIORec;
begin
Result := False;
- if FCanLoad then
+ if CanLoad then
try
// Set IO ops to memory ops and "open" given memory
SetMemoryIO;
IORec := PrepareMemIO(Data, Size);
- Handle := IO.OpenRead(@IORec);
+ Handle := IO.Open(@IORec,omReadOnly);
try
// Test if memory contains valid image and if so then load it
if TestFormat(Handle) then
begin
Result := PrepareLoad(Handle, Images, OnlyFirstLevel) and
LoadData(Handle, Images, OnlyFirstlevel);
- Result := Result and PostLoadCheck(Images, Result);
+ Result := PostLoadCheck(Images, Result);
end
else
RaiseImaging(SMemoryNotValid, [Data, Size, Name]);
Ext, FName: string;
begin
Result := False;
- if FCanSave and TestImagesInArray(Images) then
+ if CanSave and TestImagesInArray(Images) then
try
SetFileIO;
Len := Length(Images);
- if FIsMultiImageFormat or
- (not FIsMultiImageFormat and (OnlyFirstLevel or (Len = 1))) then
+ if IsMultiImageFormat or
+ (not IsMultiImageFormat and (OnlyFirstLevel or (Len = 1))) then
begin
- Handle := IO.OpenWrite(PChar(FileName));
+ Handle := IO.Open(PChar(FileName), GetSaveOpenMode);
try
if OnlyFirstLevel then
Index := 0
Result := True;
for I := 0 to Len - 1 do
begin
- Handle := IO.OpenWrite(PChar(Format(FName + '%.3d' + Ext, [I])));
+ Handle := IO.Open(PChar(Format(FName + '%.3d' + Ext, [I])), GetSaveOpenMode);
try
Index := I;
Result := Result and PrepareSave(Handle, Images, Index) and
end;
end;
except
- RaiseImaging(SErrorSavingFile, [FileName, FExtensions[0]]);
+ raise UpdateExceptMessage(GetExceptObject, SErrorSavingFile, [FileName, FExtensions[0]]);
end;
end;
begin
Result := False;
OldPosition := Stream.Position;
- if FCanSave and TestImagesInArray(Images) then
+ if CanSave and TestImagesInArray(Images) then
try
SetStreamIO;
- Handle := IO.OpenWrite(PChar(Stream));
+ Handle := IO.Open(PChar(Stream), GetSaveOpenMode);
try
- if FIsMultiImageFormat or OnlyFirstLevel then
+ if IsMultiImageFormat or OnlyFirstLevel then
begin
if OnlyFirstLevel then
Index := 0
end;
except
Stream.Position := OldPosition;
- RaiseImaging(SErrorSavingStream, [@Stream, FExtensions[0]]);
+ raise UpdateExceptMessage(GetExceptObject, SErrorSavingStream, [@Stream, FExtensions[0]]);
end;
end;
IORec: TMemoryIORec;
begin
Result := False;
- if FCanSave and TestImagesInArray(Images) then
+ if CanSave and TestImagesInArray(Images) then
try
SetMemoryIO;
IORec := PrepareMemIO(Data, Size);
- Handle := IO.OpenWrite(PChar(@IORec));
+ Handle := IO.Open(PChar(@IORec), GetSaveOpenMode);
try
- if FIsMultiImageFormat or OnlyFirstLevel then
+ if IsMultiImageFormat or OnlyFirstLevel then
begin
if OnlyFirstLevel then
Index := 0
IO.Close(Handle);
end;
except
- RaiseImaging(SErrorSavingMemory, [Data, Size, FExtensions[0]]);
+ raise UpdateExceptMessage(GetExceptObject, SErrorSavingMemory, [Data, Size, FExtensions[0]]);
end;
end;
OnlyName := ExtractFileName(FileName);
// For each mask test if filename matches it
for I := 0 to FMasks.Count - 1 do
- if MatchFileNameMask(OnlyName, FMasks[I], False) then
+ if StrMaskMatch(OnlyName, FMasks[I], False) then
begin
Result := True;
Exit;
begin
end;
+function TImageFileFormat.GetCanLoad: Boolean;
+begin
+ Result := ffLoad in FFeatures;
+end;
+
+function TImageFileFormat.GetCanSave: Boolean;
+begin
+ Result := ffSave in FFeatures;
+end;
+
+function TImageFileFormat.GetIsMultiImageFormat: Boolean;
+begin
+ Result := ffMultiImage in FFeatures;
+end;
+
+function TImageFileFormat.GetSaveOpenMode: TOpenMode;
+begin
+ // TODO: fix
+ //if ffReadOnSave in FFeatures then
+ // Result := omReadWrite
+ //else
+ Result := omCreate;
+end;
+
{ TOptionStack class implementation }
constructor TOptionStack.Create;
end;
end;
+{ TMetadata }
+
+procedure TMetadata.SetMetaItem(const Id: string; const Value: Variant;
+ ImageIndex: Integer);
+begin
+ AddMetaToList(FLoadMetaItems, Id, Value, ImageIndex);
+end;
+
+procedure TMetadata.SetMetaItemForSaving(const Id: string; const Value: Variant;
+ ImageIndex: Integer);
+begin
+ AddMetaToList(FSaveMetaItems, Id, Value, ImageIndex);
+end;
+
+procedure TMetadata.AddMetaToList(List: TStringList; const Id: string;
+ const Value: Variant; ImageIndex: Integer);
+var
+ Item: TMetadataItem;
+ Idx: Integer;
+ FullId: string;
+begin
+ FullId := GetMetaItemName(Id, ImageIndex);
+ if List.Find(FullId, Idx) then
+ (List.Objects[Idx] as TMetadataItem).Value := Value
+ else
+ begin
+ Item := TMetadataItem.Create;
+ Item.Id := Id;
+ Item.ImageIndex := ImageIndex;
+ Item.Value := Value;
+ List.AddObject(FullId, Item);
+ end;
+end;
+
+procedure TMetadata.ClearMetaItems;
+begin
+ ClearMetaList(FLoadMetaItems);
+end;
+
+procedure TMetadata.ClearMetaItemsForSaving;
+begin
+ ClearMetaList(FSaveMetaItems);
+end;
+
+procedure TMetadata.ClearMetaList(List: TStringList);
+var
+ I: Integer;
+begin
+ for I := 0 to List.Count - 1 do
+ List.Objects[I].Free;
+ List.Clear;
+end;
+
+procedure TMetadata.CopyLoadedMetaItemsForSaving;
+var
+ I: Integer;
+ Copy, Orig: TMetadataItem;
+begin
+ ClearMetaItemsForSaving;
+ for I := 0 to FLoadMetaItems.Count - 1 do
+ begin
+ Orig := TMetadataItem(FLoadMetaItems.Objects[I]);
+ Copy := TMetadataItem.Create;
+ Copy.Id := Orig.Id;
+ Copy.ImageIndex := Orig.ImageIndex;
+ Copy.Value := Orig.Value;
+ FSaveMetaItems.AddObject(GetMetaItemName(Copy.Id, Copy.ImageIndex), Copy);
+ end;
+end;
+
+constructor TMetadata.Create;
+begin
+ inherited;
+ FLoadMetaItems := TStringList.Create;
+ FLoadMetaItems.Sorted := True;
+ FSaveMetaItems := TStringList.Create;
+ FSaveMetaItems.Sorted := True;
+end;
+
+destructor TMetadata.Destroy;
+begin
+ ClearMetaItems;
+ ClearMetaItemsForSaving;
+ FLoadMetaItems.Free;
+ FSaveMetaItems.Free;
+ inherited;
+end;
+
+function TMetadata.GetMetaById(const Id: string): Variant;
+var
+ Idx: Integer;
+begin
+ if FLoadMetaItems.Find(Id, Idx) then
+ Result := (FLoadMetaItems.Objects[Idx] as TMetadataItem).Value
+ else
+ Result := Variants.Null;
+end;
+
+function TMetadata.GetMetaByIdMulti(const Id: string; ImageIndex: Integer): Variant;
+begin
+ Result := GetMetaById(GetMetaItemName(Id, ImageIndex));
+end;
+
+function TMetadata.GetSaveMetaById(const Id: string): Variant;
+var
+ Idx: Integer;
+begin
+ if FSaveMetaItems.Find(Id, Idx) then
+ Result := (FSaveMetaItems.Objects[Idx] as TMetadataItem).Value
+ else
+ Result := Variants.Null;
+end;
+
+function TMetadata.GetSaveMetaByIdMulti(const Id: string;
+ ImageIndex: Integer): Variant;
+begin
+ Result := GetSaveMetaById(GetMetaItemName(Id, ImageIndex));
+end;
+
+function TMetadata.GetMetaByIdx(Index: Integer): TMetadataItem;
+begin
+ Result := FLoadMetaItems.Objects[Index] as TMetadataItem;
+end;
+
+function TMetadata.GetMetaCount: Integer;
+begin
+ Result := FLoadMetaItems.Count;
+end;
+
+function TMetadata.GetMetaItemName(const Id: string;
+ ImageIndex: Integer): string;
+begin
+ Result := Iff(ImageIndex = 0, Id, Format(SMetaIdForSubImage, [Id, ImageIndex]));
+end;
+
+function TMetadata.GetPhysicalPixelSize(ResUnit: TResolutionUnit; var XSize,
+ YSize: Single; MetaForSave: Boolean; ImageIndex: Integer): Boolean;
+type
+ TGetter = function(const Id: string; ImageIndex: Integer): Variant of object;
+var
+ Getter: TGetter;
+ XMeta, YMeta: Variant;
+begin
+ if MetaForSave then
+ Getter := GetSaveMetaByIdMulti
+ else
+ Getter := GetMetaByIdMulti;
+
+ XMeta := Getter(SMetaPhysicalPixelSizeX, ImageIndex);
+ YMeta := Getter(SMetaPhysicalPixelSizeY, ImageIndex);
+ XSize := -1;
+ YSize := -1;
+
+ Result := not VarIsNull(XMeta) or not VarIsNull(YMeta);
+
+ if not Result then
+ Exit;
+
+ if not VarIsNull(XMeta) then
+ XSize := XMeta;
+ if not VarIsNull(YMeta) then
+ YSize := YMeta;
+
+ if XSize < 0 then
+ XSize := YSize;
+ if YSize < 0 then
+ YSize := XSize;
+
+ TranslateUnits(ResUnit, XSize, YSize);
+end;
+
+procedure TMetadata.SetPhysicalPixelSize(ResUnit: TResolutionUnit; XSize,
+ YSize: Single; MetaForSave: Boolean; ImageIndex: Integer);
+type
+ TAdder = procedure(const Id: string; const Value: Variant; ImageIndex: Integer) of object;
+var
+ Adder: TAdder;
+begin
+ TranslateUnits(ResUnit, XSize, YSize);
+
+ if MetaForSave then
+ Adder := SetMetaItemForSaving
+ else
+ Adder := SetMetaItem;
+
+ Adder(SMetaPhysicalPixelSizeX, XSize, ImageIndex);
+ Adder(SMetaPhysicalPixelSizeY, YSize, ImageIndex);
+end;
+
+procedure TMetadata.TranslateUnits(ResolutionUnit: TResolutionUnit; var XRes,
+ YRes: Single);
+var
+ UnitSize: Single;
+begin
+ case ResolutionUnit of
+ ruDpi: UnitSize := 25400;
+ ruDpm: UnitSize := 1e06;
+ ruDpcm: UnitSize := 1e04;
+ else
+ UnitSize := 1;
+ end;
+ if ResolutionUnit <> ruSizeInMicroMeters then
+ begin
+ XRes := UnitSize / XRes;
+ YRes := UnitSize / YRes;
+ end;
+end;
+
+function TMetadata.HasMetaItem(const Id: string; ImageIndex: Integer): Boolean;
+begin
+ Result := GetMetaByIdMulti(Id, ImageIndex) <> Variants.Null;
+end;
+
+function TMetadata.HasMetaItemForSaving(const Id: string; ImageIndex: Integer): Boolean;
+begin
+ Result := GetSaveMetaByIdMulti(Id, ImageIndex) <> Variants.Null;
+end;
+
initialization
{$IFDEF MEMCHECK}
{$IF CompilerVersion >= 18}
System.ReportMemoryLeaksOnShutdown := True;
{$IFEND}
{$ENDIF}
+ if GlobalMetadata = nil then
+ GlobalMetadata := TMetadata.Create;
if ImageFileFormats = nil then
ImageFileFormats := TList.Create;
InitImageFormats;
RegisterOption(ImagingLoadOverrideFormat, @LoadOverrideFormat);
RegisterOption(ImagingSaveOverrideFormat, @SaveOverrideFormat);
RegisterOption(ImagingMipMapFilter, @MipMapFilter);
+ RegisterOption(ImagingBinaryTreshold, @BinaryTreshold);
finalization
FreeOptions;
FreeImageFileFormats;
+ GlobalMetadata.Free;
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
+ -- 0.77.1 ---------------------------------------------------
+ - Updated IO Open functions according to changes in ImagingTypes.
+ - Fixed bug in SplitImage that could cause wrong size of edge chunks.
+ - Metadata support fixes and extensions (frame delays, animation loops).
+
+ -- 0.26.5 Changes/Bug Fixes ---------------------------------
+ - Started reworking exception raising to keep the original class type
+ (e.g. in NewImage EOutOfMemory could be raised but was hidden
+ by EImagingError raised afterwards in NewImage try/except).
+ - Fixed possible AV in Rotate45 subproc of RotateImage.
+ - Added ReadRawXXX and WriteRawXXX functions for raw image bits IO.
+ - Implemented ImagingBinaryTreshold option.
+ - Added support for simple image metadata loading/saving.
+ - Moved file format definition (name, exts, caps, ...) from
+ constructor to new Define method.
+ - Fixed some memory leaks caused by failures during image loading.
+
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Extended RotateImage to allow arbitrary angle rotations.
- Reversed the order file formats list is searched so
index 943f476ed5a4a20afc15fb792bfcd5b243a1bfa0..4c4aac611491da0b5a543bd88b1e98e7c64c81cf 100644 (file)
{
- $Id: ImagingBitmap.pas 129 2008-08-06 20:01:30Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
-{ This unit contains image format loader/saver for Windows Bitmap images.}
+{
+ This unit contains image format loader/saver for Windows Bitmap images.
+}
unit ImagingBitmap;
{$I ImagingOptions.inc}
TBitmapFileFormat = class(TImageFileFormat)
protected
FUseRLE: LongBool;
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
- constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
{ Controls that RLE compression is used during saving. Accessible trough
{ TBitmapFileFormat class implementation }
-constructor TBitmapFileFormat.Create;
+procedure TBitmapFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SBitmapFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
+ FFeatures := [ffLoad, ffSave];
FSupportedFormats := BitmapSupportedFormats;
FUseRLE := BitmapDefaultRLE;
// 1 and 4 bpp images are supported only for loading which is now
// so we now convert them to 8bpp (and unalign scanlines).
case BI.BitCount of
- 1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes);
+ 1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes, False);
4:
begin
// RLE4 bitmaps are translated to 8bit during RLE decoding
if BI.Compression <> BI_RLE4 then
- Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes);
+ Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes, False);
end;
end;
// Enlarge palette
index 0069502b61d391ad14c0e64e3f45f6ea7925d68f..448191cdcbb3591739c383cabed62bcf81efc58b 100644 (file)
{
- $Id: ImagingCanvases.pas 174 2009-09-08 09:37:59Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
-{
- This unit contains canvas classes for drawing and applying effects.
-}
+{ This unit contains canvas classes for drawing and applying effects.}
unit ImagingCanvases;
{$I ImagingOptions.inc}
DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
// Blend the two pixels (Src 'over' Dest alpha composition operation)
DestPix.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A;
- SrcAlpha := IffFloat(DestPix.A = 0, 0, SrcPix.A / DestPix.A);
+ if DestPix.A = 0 then
+ SrcAlpha := 0
+ else
+ SrcAlpha := SrcPix.A / DestPix.A;
DestAlpha := 1.0 - SrcAlpha;
DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha;
DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha;
if FPenMode = pmClear then Exit;
// If line is vertical or horizontal just call appropriate method
- if X2 - X1 = 0 then
+ if X2 = X1 then
begin
- HorzLine(X1, X2, Y1);
+ VertLine(X1, Y1, Y2);
Exit;
end;
- if Y2 - Y1 = 0 then
+ if Y2 = Y1 then
begin
- VertLine(X1, Y1, Y2);
+ HorzLine(X1, X2, Y1);
Exit;
end;
PixelWriteProc: TPixelWriteProc);
const
FilterMapping: array[TResizeFilter] of TSamplingFilter =
- (sfNearest, sfLinear, DefaultCubicFilter);
+ (sfNearest, sfLinear, DefaultCubicFilter, sfLanczos);
var
X, Y, I, J, SrcX, SrcY, SrcWidth, SrcHeight: Integer;
DestX, DestY, DestWidth, DestHeight, SrcBpp, DestBpp: Integer;
- SrcPix, PDest: TColorFPRec;
+ SrcPix: TColorFPRec;
MapX, MapY: TMappingTable;
XMinimum, XMaximum: Integer;
LineBuffer: array of TColorFPRec;
procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect;
DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
var
- X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4,
- FracX, FracY, InvFracY, T1, T2: Integer;
+ X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4, InvFracY, T1, T2: Integer;
+ FracX, FracY: Cardinal;
SrcX, SrcY, SrcWidth, SrcHeight: Integer;
DestX, DestY, DestWidth, DestHeight: Integer;
SrcLine, SrcLine2: PColor32RecArray;
end;
T2 := Iff(T1 < SrcWidth - 1, T1 + 1, T1);
- Weight2:= (Cardinal(InvFracY) * FracX) shr 16; // cast to Card, Int can overflow gere
+ Weight2:= Integer((Cardinal(InvFracY) * FracX) shr 16); // cast to Card, Int can overflow here
Weight1:= InvFracY - Weight2;
- Weight4:= (Cardinal(FracY) * FracX) shr 16;
+ Weight4:= Integer((Cardinal(FracY) * FracX) shr 16);
Weight3:= FracY - Weight4;
Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 +
Inc(Yp, ScaleY);
end;
end;
- {
-
- // Generate mapping tables
- MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth,
- FPData.Width, FilterFunction, Radius, False);
- MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight,
- FPData.Height, FilterFunction, Radius, False);
- FindExtremes(MapX, XMinimum, XMaximum);
- SetLength(LineBuffer, XMaximum - XMinimum + 1);
-
- for J := 0 to DestHeight - 1 do
- begin
- ClusterY := MapY[J];
- for X := XMinimum to XMaximum do
- begin
- AccumA := 0;
- AccumR := 0;
- AccumG := 0;
- AccumB := 0;
- for Y := 0 to Length(ClusterY) - 1 do
- begin
- Weight := Round(ClusterY[Y].Weight * 256);
- SrcColor := FScanlines[ClusterY[Y].Pos, X];
-
- AccumB := AccumB + SrcColor.B * Weight;
- AccumG := AccumG + SrcColor.G * Weight;
- AccumR := AccumR + SrcColor.R * Weight;
- AccumA := AccumA + SrcColor.A * Weight;
- end;
- with LineBuffer[X - XMinimum] do
- begin
- A := AccumA;
- R := AccumR;
- G := AccumG;
- B := AccumB;
- end;
- end;
-
- DestPtr := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + J, DestX];
-
- for I := 0 to DestWidth - 1 do
- begin
- ClusterX := MapX[I];
- AccumA := 0;
- AccumR := 0;
- AccumG := 0;
- AccumB := 0;
- for X := 0 to Length(ClusterX) - 1 do
- begin
- Weight := Round(ClusterX[X].Weight * 256);
- 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;
-
- AccumA := ClampInt(AccumA, 0, $00FF0000);
- AccumR := ClampInt(AccumR, 0, $00FF0000);
- AccumG := ClampInt(AccumG, 0, $00FF0000);
- AccumB := ClampInt(AccumB, 0, $00FF0000);
- SrcColor.Color := (Cardinal(AccumA and $00FF0000) shl 8) or
- (AccumR and $00FF0000) or ((AccumG and $00FF0000) shr 8) or ((AccumB and $00FF0000) shr 16);
-
- AlphaBlendPixels(@SrcColor, DestPtr);
-
- Inc(DestPtr);
- end;
- end; }
end;
procedure TFastARGB32Canvas.UpdateCanvasState;
-- TODOS ----------------------------------------------------
- more more more ...
- implement pen width everywhere
- - add blending (*image and object drawing)
- more objects (arc, polygon)
+ -- 0.26.5 Changes/Bug Fixes ---------------------------------
+ - Fixed bug that could raise floating point error in DrawAlpha
+ and StretchDrawAlpha.
+ - Fixed bug in TImagingCanvas.Line that caused not drawing
+ of horz or vert lines.
+
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha)
- Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation.
index c00c105c5323ba3d0d511b339c674abd1d4fb129..b196fdd1048689ef64c73ba6831f65b9c7f59c3c 100644 (file)
{
- $Id: ImagingClasses.pas 173 2009-09-04 17:05:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
{ Base abstract high level class wrapper to low level Imaging structures and
functions.}
TBaseImage = class(TPersistent)
+ private
+ function GetEmpty: Boolean;
protected
FPData: PImageData;
FOnDataSizeChanged: TNotifyEvent;
FOnPixelsChanged: TNotifyEvent;
function GetFormat: TImageFormat; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetHeight: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetSize: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetWidth: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetHeight: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetSize: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetWidth: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetBits: Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPalette: PPalette32; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetPaletteEntries: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetScanLine(Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetPaletteEntries: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetScanline(Index: Integer): Pointer;
+ function GetPixelPointer(X, Y: Integer): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetScanlineSize: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetFormatInfo: TImageFormatInfo; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetBoundsRect: TRect;
procedure SetFormat(const Value: TImageFormat); {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetHeight(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetWidth(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetHeight(const Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetWidth(const Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetPointer; virtual; abstract;
procedure DoDataSizeChanged; virtual;
procedure DoPixelsChanged; virtual;
- published
public
constructor Create; virtual;
constructor CreateFromImage(AImage: TBaseImage);
{ Creates a new image data with the given size and format. Old image
data is lost. Works only for the current image of TMultiImage.}
- procedure RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat);
+ procedure RecreateImageData(AWidth, AHeight: Integer; AFormat: TImageFormat);
+ { Maps underlying image data to given TImageData record. Both TBaseImage and
+ TImageData now share some image memory (bits). So don't call FreeImage
+ on TImageData afterwards since this TBaseImage would get really broken.}
+ procedure MapImageData(const ImageData: TImageData);
+ { Deletes current image.}
+ procedure Clear;
+
{ Resizes current image with optional resampling.}
- procedure Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
+ procedure Resize(NewWidth, NewHeight: Integer; Filter: TResizeFilter);
+
+ procedure ResizeToFit(FitWidth, FitHeight: Integer; Filter: TResizeFilter; DstImage: TBaseImage);
{ Flips current image. Reverses the image along its horizontal axis the top
becomes the bottom and vice versa.}
procedure Flip;
negative X and Y coordinates.
Note that copying is fastest for images in the same data format
(and slowest for images in special formats).}
- procedure CopyTo(SrcX, SrcY, Width, Height: LongInt; DstImage: TBaseImage; DstX, DstY: LongInt);
+ procedure CopyTo(SrcX, SrcY, Width, Height: Integer; DstImage: TBaseImage; DstX, DstY: Integer);
{ Stretches the contents of the source rectangle to the destination rectangle
with optional resampling. No blending is performed - alpha is
simply copied/resampled to destination image. Note that stretching is
fastest for images in the same data format (and slowest for
images in special formats).}
- procedure StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt; DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter);
+ procedure StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: Integer; DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: Integer; Filter: TResizeFilter);
{ Replaces pixels with OldPixel in the given rectangle by NewPixel.
OldPixel and NewPixel should point to the pixels in the same format
as the given image is in.}
- procedure ReplaceColor(X, Y, Width, Height: LongInt; OldColor, NewColor: Pointer);
+ procedure ReplaceColor(X, Y, Width, Height: Integer; OldColor, NewColor: Pointer);
{ Swaps SrcChannel and DstChannel color or alpha channels of image.
Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
identify channels.}
- procedure SwapChannels(SrcChannel, DstChannel: LongInt);
+ procedure SwapChannels(SrcChannel, DstChannel: Integer);
{ Loads current image data from file.}
procedure LoadFromFile(const FileName: string); virtual;
procedure SaveToStream(const Ext: string; Stream: TStream);
{ Width of current image in pixels.}
- property Width: LongInt read GetWidth write SetWidth;
+ property Width: Integer read GetWidth write SetWidth;
{ Height of current image in pixels.}
- property Height: LongInt read GetHeight write SetHeight;
+ property Height: Integer read GetHeight write SetHeight;
{ Image data format of current image.}
property Format: TImageFormat read GetFormat write SetFormat;
{ Size in bytes of current image's data.}
- property Size: LongInt read GetSize;
+ property Size: Integer read GetSize;
{ Pointer to memory containing image bits.}
property Bits: Pointer read GetBits;
{ Pointer to palette for indexed format images. It is nil for others.
Max palette entry is at index [PaletteEntries - 1].}
property Palette: PPalette32 read GetPalette;
{ Number of entries in image's palette}
- property PaletteEntries: LongInt read GetPaletteEntries;
+ property PaletteEntries: Integer read GetPaletteEntries;
{ Provides indexed access to each line of pixels. Does not work with special
format images (like DXT).}
- property ScanLine[Index: LongInt]: Pointer read GetScanLine;
+ property Scanline[Index: Integer]: Pointer read GetScanline;
{ Returns pointer to image pixel at [X, Y] coordinates.}
- property PixelPointers[X, Y: LongInt]: Pointer read GetPixelPointer;
+ property PixelPointer[X, Y: Integer]: Pointer read GetPixelPointer;
+ { Size/length of one image scanline in bytes.}
+ property ScanlineSize: Integer read GetScanlineSize;
{ Extended image format information.}
property FormatInfo: TImageFormatInfo read GetFormatInfo;
{ This gives complete access to underlying TImageData record.
{ Indicates whether the current image is valid (proper format,
allowed dimensions, right size, ...).}
property Valid: Boolean read GetValid;
- {{ Specifies the bounding rectangle of the image.}
+ { Indicates whether image containst any data (size in bytes > 0).}
+ property Empty: Boolean read GetEmpty;
+ { Specifies the bounding rectangle of the image.}
property BoundsRect: TRect read GetBoundsRect;
{ This event occurs when the image data size has just changed. That means
image width, height, or format has been changed.}
procedure SetPointer; override;
public
constructor Create; override;
- constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault);
+ constructor CreateFromParams(AWidth, AHeight: Integer; AFormat: TImageFormat = ifDefault);
constructor CreateFromData(const AData: TImageData);
constructor CreateFromFile(const FileName: string);
constructor CreateFromStream(Stream: TStream);
destructor Destroy; override;
{ Assigns single image from another single image or multi image.}
procedure Assign(Source: TPersistent); override;
+ { Assigns single image from image data record.}
+ procedure AssignFromImageData(const AImageData: TImageData);
end;
{ Extension of TBaseImage which uses array of TImageData records to
TMultiImage = class(TBaseImage)
protected
FDataArray: TDynImageDataArray;
- FActiveImage: LongInt;
- procedure SetActiveImage(Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetImageCount: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetImageCount(Value: LongInt);
+ FActiveImage: Integer;
+ procedure SetActiveImage(Value: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetImageCount: Integer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetImageCount(Value: Integer);
function GetAllImagesValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetImage(Index: LongInt): TImageData; {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetImage(Index: LongInt; Value: TImageData); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetImage(Index: Integer): TImageData; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetImage(Index: Integer; Value: TImageData); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetPointer; override;
- function PrepareInsert(Index, Count: LongInt): Boolean;
- procedure DoInsertImages(Index: LongInt; const Images: TDynImageDataArray);
- procedure DoInsertNew(Index: LongInt; AWidth, AHeight: LongInt; AFormat: TImageFormat);
+ function PrepareInsert(Index, Count: Integer): Boolean;
+ procedure DoInsertImages(Index: Integer; const Images: TDynImageDataArray);
+ procedure DoInsertNew(Index: Integer; AWidth, AHeight: Integer; AFormat: TImageFormat);
public
constructor Create; override;
- constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat; Images: LongInt);
- constructor CreateFromArray(ADataArray: TDynImageDataArray);
+ constructor CreateFromParams(AWidth, AHeight: Integer; AFormat: TImageFormat; ImageCount: Integer);
+ constructor CreateFromArray(const ADataArray: TDynImageDataArray);
constructor CreateFromFile(const FileName: string);
constructor CreateFromStream(Stream: TStream);
destructor Destroy; override;
{ Assigns multi image from another multi image or single image.}
procedure Assign(Source: TPersistent); override;
+ { Assigns multi image from array of image data records.}
+ procedure AssignFromArray(const ADataArray: TDynImageDataArray);
{ Adds new image at the end of the image array. }
- procedure AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload;
+ function AddImage(AWidth, AHeight: Integer; AFormat: TImageFormat = ifDefault): Integer; overload;
{ Adds existing image at the end of the image array. }
- procedure AddImage(const Image: TImageData); overload;
+ function AddImage(const Image: TImageData): Integer; overload;
{ Adds existing image (Active image of a TmultiImage)
at the end of the image array. }
- procedure AddImage(Image: TBaseImage); overload;
+ function AddImage(Image: TBaseImage): Integer; overload;
{ Adds existing image array ((all images of a multi image))
at the end of the image array. }
procedure AddImages(const Images: TDynImageDataArray); overload;
procedure AddImages(Images: TMultiImage); overload;
{ Inserts new image image at the given position in the image array. }
- procedure InsertImage(Index, AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload;
+ procedure InsertImage(Index, AWidth, AHeight: Integer; AFormat: TImageFormat = ifDefault); overload;
{ Inserts existing image at the given position in the image array. }
- procedure InsertImage(Index: LongInt; const Image: TImageData); overload;
+ procedure InsertImage(Index: Integer; const Image: TImageData); overload;
{ Inserts existing image (Active image of a TmultiImage)
at the given position in the image array. }
- procedure InsertImage(Index: LongInt; Image: TBaseImage); overload;
+ procedure InsertImage(Index: Integer; Image: TBaseImage); overload;
{ Inserts existing image at the given position in the image array. }
- procedure InsertImages(Index: LongInt; const Images: TDynImageDataArray); overload;
+ procedure InsertImages(Index: Integer; const Images: TDynImageDataArray); overload;
{ Inserts existing images (all images of a TmultiImage) at
the given position in the image array. }
- procedure InsertImages(Index: LongInt; Images: TMultiImage); overload;
+ procedure InsertImages(Index: Integer; Images: TMultiImage); overload;
{ Exchanges two images at the given positions in the image array. }
- procedure ExchangeImages(Index1, Index2: LongInt);
+ procedure ExchangeImages(Index1, Index2: Integer);
{ Deletes image at the given position in the image array.}
- procedure DeleteImage(Index: LongInt);
+ procedure DeleteImage(Index: Integer);
{ Rearranges images so that the first image will become last and vice versa.}
procedure ReverseImages;
+ { Deletes all images.}
+ procedure ClearAll;
{ Converts all images to another image data format.}
procedure ConvertImages(Format: TImageFormat);
{ Resizes all images.}
- procedure ResizeImages(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
+ procedure ResizeImages(NewWidth, NewHeight: Integer; Filter: TResizeFilter);
{ Overloaded loading method that will add new image to multiimage if
image array is empty bero loading. }
{ Indicates active image of this multi image. All methods inherited
from TBaseImage operate on this image only.}
- property ActiveImage: LongInt read FActiveImage write SetActiveImage;
+ property ActiveImage: Integer read FActiveImage write SetActiveImage;
{ Number of images of this multi image.}
- property ImageCount: LongInt read GetImageCount write SetImageCount;
+ property ImageCount: Integer read GetImageCount write SetImageCount;
{ This value is True if all images of this TMultiImage are valid.}
property AllImagesValid: Boolean read GetAllImagesValid;
{ This gives complete access to underlying TDynImageDataArray.
property DataArray: TDynImageDataArray read FDataArray;
{ Array property for accessing individual images of TMultiImage. When you
set image at given index the old image is freed and the source is cloned.}
- property Images[Index: LongInt]: TImageData read GetImage write SetImage; default;
+ property Images[Index: Integer]: TImageData read GetImage write SetImage; default;
end;
implementation
const
- DefaultWidth = 16;
- DefaultHeight = 16;
- DefaultImages = 1;
+ DefaultWidth = 16;
+ Defaultheight = 16;
function GetArrayFromImageData(const ImageData: TImageData): TDynImageDataArray;
begin
inherited Destroy;
end;
-function TBaseImage.GetWidth: LongInt;
+function TBaseImage.GetWidth: Integer;
begin
if Valid then
Result := FPData.Width
Result := 0;
end;
-function TBaseImage.GetHeight: LongInt;
+function TBaseImage.GetHeight: Integer;
begin
if Valid then
Result := FPData.Height
Result := ifUnknown;
end;
-function TBaseImage.GetScanLine(Index: LongInt): Pointer;
+function TBaseImage.GetScanline(Index: Integer): Pointer;
var
Info: TImageFormatInfo;
begin
Result := nil;
end;
-function TBaseImage.GetPixelPointer(X, Y: LongInt): Pointer;
+function TBaseImage.GetScanlineSize: Integer;
+begin
+ if Valid then
+ Result := FormatInfo.GetPixelsSize(Format, Width, 1)
+ else
+ Result := 0;
+end;
+
+function TBaseImage.GetPixelPointer(X, Y: Integer): Pointer;
begin
if Valid then
Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * GetFormatInfo.BytesPerPixel]
Result := nil;
end;
-function TBaseImage.GetSize: LongInt;
+function TBaseImage.GetSize: Integer;
begin
if Valid then
Result := FPData.Size
Result := nil;
end;
-function TBaseImage.GetPaletteEntries: LongInt;
+function TBaseImage.GetPaletteEntries: Integer;
begin
Result := GetFormatInfo.PaletteEntries;
end;
Result := Rect(0, 0, GetWidth, GetHeight);
end;
-procedure TBaseImage.SetWidth(const Value: LongInt);
+function TBaseImage.GetEmpty: Boolean;
+begin
+ Result := FPData.Size = 0;
+end;
+
+procedure TBaseImage.SetWidth(const Value: Integer);
begin
Resize(Value, GetHeight, rfNearest);
end;
-procedure TBaseImage.SetHeight(const Value: LongInt);
+procedure TBaseImage.SetHeight(const Value: Integer);
begin
Resize(GetWidth, Value, rfNearest);
end;
FOnPixelsChanged(Self);
end;
-procedure TBaseImage.RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat);
+procedure TBaseImage.RecreateImageData(AWidth, AHeight: Integer; AFormat: TImageFormat);
begin
if Assigned(FPData) and Imaging.NewImage(AWidth, AHeight, AFormat, FPData^) then
DoDataSizeChanged;
end;
-procedure TBaseImage.Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
+procedure TBaseImage.MapImageData(const ImageData: TImageData);
+begin
+ Clear;
+ FPData.Width := ImageData.Width;
+ FPData.Height := ImageData.Height;
+ FPData.Format := ImageData.Format;
+ FPData.Size := ImageData.Size;
+ FPData.Bits := ImageData.Bits;
+ FPData.Palette := ImageData.Palette;
+end;
+
+procedure TBaseImage.Clear;
+begin
+ FreeImage(FPData^);
+end;
+
+procedure TBaseImage.Resize(NewWidth, NewHeight: Integer; Filter: TResizeFilter);
begin
if Valid and Imaging.ResizeImage(FPData^, NewWidth, NewHeight, Filter) then
DoDataSizeChanged;
end;
+procedure TBaseImage.ResizeToFit(FitWidth, FitHeight: Integer;
+ Filter: TResizeFilter; DstImage: TBaseImage);
+begin
+ if Valid and Assigned(DstImage) then
+ begin
+ Imaging.ResizeImageToFit(FPData^, FitWidth, FitHeight, Filter,
+ DstImage.FPData^);
+ DstImage.DoDataSizeChanged;
+ end;
+end;
+
procedure TBaseImage.Flip;
begin
if Valid and Imaging.FlipImage(FPData^) then
procedure TBaseImage.Rotate(Angle: Single);
begin
- if Valid and Imaging.RotateImage(FPData^, Angle) then
+ if Valid then
+ begin
+ Imaging.RotateImage(FPData^, Angle);
DoPixelsChanged;
+ end;
end;
-procedure TBaseImage.CopyTo(SrcX, SrcY, Width, Height: LongInt;
- DstImage: TBaseImage; DstX, DstY: LongInt);
+procedure TBaseImage.CopyTo(SrcX, SrcY, Width, Height: Integer;
+ DstImage: TBaseImage; DstX, DstY: Integer);
begin
if Valid and Assigned(DstImage) and DstImage.Valid then
begin
end;
end;
-procedure TBaseImage.StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt;
- DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter);
+procedure TBaseImage.StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: Integer;
+ DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: Integer; Filter: TResizeFilter);
begin
if Valid and Assigned(DstImage) and DstImage.Valid then
begin
constructor TSingleImage.Create;
begin
inherited Create;
- RecreateImageData(DefaultWidth, DefaultHeight, ifDefault);
+ Clear;
end;
-constructor TSingleImage.CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat);
+constructor TSingleImage.CreateFromParams(AWidth, AHeight: Integer; AFormat: TImageFormat);
begin
inherited Create;
RecreateImageData(AWidth, AHeight, AFormat);
constructor TSingleImage.CreateFromData(const AData: TImageData);
begin
inherited Create;
- if Imaging.TestImage(AData) then
- begin
- Imaging.CloneImage(AData, FImageData);
- DoDataSizeChanged;
- end
- else
- Create;
+ AssignFromImageData(AData);
end;
constructor TSingleImage.CreateFromFile(const FileName: string);
begin
if Source = nil then
begin
- Create;
+ Clear;
end
else if Source is TSingleImage then
begin
- CreateFromData(TSingleImage(Source).FImageData);
+ AssignFromImageData(TSingleImage(Source).FImageData);
end
else if Source is TMultiImage then
begin
if TMultiImage(Source).Valid then
- CreateFromData(TMultiImage(Source).FPData^)
+ AssignFromImageData(TMultiImage(Source).FPData^)
else
- Assign(nil);
+ Clear;
end
else
inherited Assign(Source);
end;
+procedure TSingleImage.AssignFromImageData(const AImageData: TImageData);
+begin
+ if Imaging.TestImage(AImageData) then
+ begin
+ Imaging.CloneImage(AImageData, FImageData);
+ DoDataSizeChanged;
+ end
+ else
+ Clear;
+end;
{ TMultiImage class implementation }
constructor TMultiImage.Create;
begin
- SetImageCount(DefaultImages);
- SetActiveImage(0);
+ inherited Create;
end;
-constructor TMultiImage.CreateFromParams(AWidth, AHeight: LongInt;
- AFormat: TImageFormat; Images: LongInt);
+constructor TMultiImage.CreateFromParams(AWidth, AHeight: Integer;
+ AFormat: TImageFormat; ImageCount: Integer);
var
- I: LongInt;
+ I: Integer;
begin
Imaging.FreeImagesInArray(FDataArray);
- SetLength(FDataArray, Images);
+ SetLength(FDataArray, ImageCount);
for I := 0 to GetImageCount - 1 do
Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[I]);
- SetActiveImage(0);
+ if GetImageCount > 0 then
+ SetActiveImage(0);
end;
-constructor TMultiImage.CreateFromArray(ADataArray: TDynImageDataArray);
-var
- I: LongInt;
+constructor TMultiImage.CreateFromArray(const ADataArray: TDynImageDataArray);
begin
- Imaging.FreeImagesInArray(FDataArray);
- SetLength(FDataArray, Length(ADataArray));
- for I := 0 to GetImageCount - 1 do
- begin
- // Clone only valid images
- if Imaging.TestImage(ADataArray[I]) then
- Imaging.CloneImage(ADataArray[I], FDataArray[I])
- else
- Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]);
- end;
- SetActiveImage(0);
+ AssignFromArray(ADataArray);
end;
constructor TMultiImage.CreateFromFile(const FileName: string);
inherited Destroy;
end;
-procedure TMultiImage.SetActiveImage(Value: LongInt);
+procedure TMultiImage.SetActiveImage(Value: Integer);
begin
FActiveImage := Value;
SetPointer;
end;
-function TMultiImage.GetImageCount: LongInt;
+function TMultiImage.GetImageCount: Integer;
begin
Result := Length(FDataArray);
end;
-procedure TMultiImage.SetImageCount(Value: LongInt);
+procedure TMultiImage.SetImageCount(Value: Integer);
var
- I, OldCount: LongInt;
+ I, OldCount: Integer;
begin
if Value > GetImageCount then
begin
Result := (GetImageCount > 0) and TestImagesInArray(FDataArray);
end;
-function TMultiImage.GetImage(Index: LongInt): TImageData;
+function TMultiImage.GetImage(Index: Integer): TImageData;
begin
if (Index >= 0) and (Index < GetImageCount) then
Result := FDataArray[Index];
end;
-procedure TMultiImage.SetImage(Index: LongInt; Value: TImageData);
+procedure TMultiImage.SetImage(Index: Integer; Value: TImageData);
begin
if (Index >= 0) and (Index < GetImageCount) then
Imaging.CloneImage(Value, FDataArray[Index]);
end;
end;
-function TMultiImage.PrepareInsert(Index, Count: LongInt): Boolean;
+function TMultiImage.PrepareInsert(Index, Count: Integer): Boolean;
var
- I: LongInt;
+ I: Integer;
begin
// Inserting to empty image will add image at index 0
if GetImageCount = 0 then
Result := False;
end;
-procedure TMultiImage.DoInsertImages(Index: LongInt; const Images: TDynImageDataArray);
+procedure TMultiImage.DoInsertImages(Index: Integer; const Images: TDynImageDataArray);
var
- I, Len: LongInt;
+ I, Len: Integer;
begin
Len := Length(Images);
if PrepareInsert(Index, Len) then
end;
end;
-procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: LongInt;
+procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: Integer;
AFormat: TImageFormat);
begin
if PrepareInsert(Index, 1) then
begin
if Source = nil then
begin
- Create;
+ ClearAll;
end
else if Source is TMultiImage then
begin
- CreateFromArray(TMultiImage(Source).FDataArray);
+ AssignFromArray(TMultiImage(Source).FDataArray);
SetActiveImage(TMultiImage(Source).ActiveImage);
end
else if Source is TSingleImage then
begin
SetLength(Arr, 1);
Arr[0] := TSingleImage(Source).FImageData;
- CreateFromArray(Arr);
- Arr := nil;
+ AssignFromArray(Arr);
end
else
inherited Assign(Source);
end;
-procedure TMultiImage.AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat);
+procedure TMultiImage.AssignFromArray(const ADataArray: TDynImageDataArray);
+var
+ I: Integer;
begin
- DoInsertNew(GetImageCount, AWidth, AHeight, AFormat);
+ Imaging.FreeImagesInArray(FDataArray);
+ SetLength(FDataArray, Length(ADataArray));
+ for I := 0 to GetImageCount - 1 do
+ begin
+ // Clone only valid images
+ if Imaging.TestImage(ADataArray[I]) then
+ Imaging.CloneImage(ADataArray[I], FDataArray[I])
+ else
+ Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]);
+ end;
+ if GetImageCount > 0 then
+ SetActiveImage(0);
end;
-procedure TMultiImage.AddImage(const Image: TImageData);
+function TMultiImage.AddImage(AWidth, AHeight: Integer; AFormat: TImageFormat): Integer;
begin
- DoInsertImages(GetImageCount, GetArrayFromImageData(Image));
+ Result := GetImageCount;
+ DoInsertNew(Result, AWidth, AHeight, AFormat);
end;
-procedure TMultiImage.AddImage(Image: TBaseImage);
+function TMultiImage.AddImage(const Image: TImageData): Integer;
+begin
+ Result := GetImageCount;
+ DoInsertImages(Result, GetArrayFromImageData(Image));
+end;
+
+function TMultiImage.AddImage(Image: TBaseImage): Integer;
begin
if Assigned(Image) and Image.Valid then
- DoInsertImages(GetImageCount, GetArrayFromImageData(Image.FPData^));
+ begin
+ Result := GetImageCount;
+ DoInsertImages(Result, GetArrayFromImageData(Image.FPData^));
+ end
+ else
+ Result := -1;
end;
procedure TMultiImage.AddImages(const Images: TDynImageDataArray);
DoInsertImages(GetImageCount, Images.FDataArray);
end;
-procedure TMultiImage.InsertImage(Index, AWidth, AHeight: LongInt;
+procedure TMultiImage.InsertImage(Index, AWidth, AHeight: Integer;
AFormat: TImageFormat);
begin
DoInsertNew(Index, AWidth, AHeight, AFormat);
end;
-procedure TMultiImage.InsertImage(Index: LongInt; const Image: TImageData);
+procedure TMultiImage.InsertImage(Index: Integer; const Image: TImageData);
begin
DoInsertImages(Index, GetArrayFromImageData(Image));
end;
-procedure TMultiImage.InsertImage(Index: LongInt; Image: TBaseImage);
+procedure TMultiImage.InsertImage(Index: Integer; Image: TBaseImage);
begin
if Assigned(Image) and Image.Valid then
DoInsertImages(Index, GetArrayFromImageData(Image.FPData^));
end;
-procedure TMultiImage.InsertImages(Index: LongInt;
+procedure TMultiImage.InsertImages(Index: Integer;
const Images: TDynImageDataArray);
begin
DoInsertImages(Index, FDataArray);
end;
-procedure TMultiImage.InsertImages(Index: LongInt; Images: TMultiImage);
+procedure TMultiImage.InsertImages(Index: Integer; Images: TMultiImage);
begin
DoInsertImages(Index, Images.FDataArray);
end;
-procedure TMultiImage.ExchangeImages(Index1, Index2: LongInt);
+procedure TMultiImage.ExchangeImages(Index1, Index2: Integer);
var
TempData: TImageData;
begin
end;
end;
-procedure TMultiImage.DeleteImage(Index: LongInt);
+procedure TMultiImage.DeleteImage(Index: Integer);
var
- I: LongInt;
+ I: Integer;
begin
if (Index >= 0) and (Index < GetImageCount) then
begin
end;
end;
+procedure TMultiImage.ClearAll;
+begin
+ ImageCount := 0;
+end;
+
procedure TMultiImage.ConvertImages(Format: TImageFormat);
var
- I: LongInt;
+ I: Integer;
begin
for I := 0 to GetImageCount - 1 do
Imaging.ConvertImage(FDataArray[I], Format);
end;
-procedure TMultiImage.ResizeImages(NewWidth, NewHeight: LongInt;
+procedure TMultiImage.ResizeImages(NewWidth, NewHeight: Integer;
Filter: TResizeFilter);
var
- I: LongInt;
+ I: Integer;
begin
- for I := 0 to GetImageCount do
+ for I := 0 to GetImageCount - 1 do
Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter);
end;
-- TODOS ----------------------------------------------------
- nothing now
- - add SetPalette, create some pal wrapper first
- - put all low level stuff here like ReplaceColor etc, change
- CopyTo to Copy, and add overload Copy(SrcRect, DstX, DstY) ...
+
+ -- 0.77.1 ---------------------------------------------------
+ - Added TSingleImage.AssignFromData and TMultiImage.AssigntFromArray
+ as a replacement for constructors used as methods (that is
+ compiler error in Delphi XE3).
+ - Added TBaseImage.ResizeToFit method.
+ - Changed TMultiImage to have default state with no images.
+ - TMultiImage.AddImage now returns index of newly added image.
+ - Fixed img index bug in TMultiImage.ResizeImages
+
+ -- 0.26.5 Changes/Bug Fixes ---------------------------------
+ - Added MapImageData method to TBaseImage
+ - Added Empty property to TBaseImage.
+ - Added Clear method to TBaseImage.
+ - Added ScanlineSize property to TBaseImage.
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- Added TMultiImage.ReverseImages method.
index 22c1c8f7d68f23fe644f32a2804e5dd38c3f6036..c7fd4289bbd9dde8ae102d170b850c06a4444a9e 100644 (file)
{
- $Id: ImagingColors.pas 173 2009-09-04 17:05:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
{ Converts YCoCg to RGB color.}
procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
+//procedure RGBToHSL(R, G, B: Byte; var H, S, L: Byte);
+//procedure HSLToRGB(H, S, L: Byte; var R, G, B: Byte);
implementation
index 3945362ad51f08bda9b01182cfaa8bcd6b100a7e..61451fe8a16ff8e2dbc6738dd4ad7611335a8c39 100644 (file)
{
- $Id: ImagingComponents.pas 171 2009-09-02 01:34:19Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
{$IFDEF LCL}
{$DEFINE COMPONENT_SET_LCL}
+ {$UNDEF COMPONENT_SET_VCL}
{$ENDIF}
{$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
uses
{$IF Defined(LCL)}
{$IF Defined(LCLGTK2)}
- GLib2, GDK2, GTK2, GTKDef, GTKProc,
- {$ELSEIF Defined(LCLGTK)}
- GDK, GTK, GTKDef, GTKProc,
+ GLib2, GDK2, GTK2, GTK2Def, GTK2Proc,
{$IFEND}
{$IFEND}
{$IFNDEF DONT_LINK_BITMAP}
{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
ImagingNetworkGraphics,
{$IFEND}
- ImagingUtility;
+ ImagingFormats, ImagingUtility;
resourcestring
SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s';
begin
PF := DataFormatToPixelFormat(Data.Format);
GetImageFormatInfo(Data.Format, Info);
+
+ if (PF = pf8bit) and PaletteHasAlpha(Data.Palette, Info.PaletteEntries) then
+ begin
+ // Some indexed images may have valid alpha data, dont lose it!
+ // (e.g. transparent 8bit PNG or GIF images)
+ PF := pfCustom;
+ end;
+
if PF = pfCustom then
begin
// Convert from formats not supported by Graphics unit
if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then
Imaging.ConvertImage(WorkData, ifA8R8G8B8)
else
+ begin
{$IFDEF COMPONENT_SET_VCL}
if Info.IsIndexed or Info.HasGrayChannel then
Imaging.ConvertImage(WorkData, ifIndex8)
{$ELSE}
Imaging.ConvertImage(WorkData, ifA8R8G8B8);
{$ENDIF}
+ end;
PF := DataFormatToPixelFormat(WorkData.Format);
GetImageFormatInfo(WorkData.Format, Info);
RawImage.Description.LineEnd);
// Copy scanlines
for I := 0 to Data.Height - 1 do
+ begin
Move(PByteArray(RawImage.Data)[I * LineLazBytes],
PByteArray(Data.Bits)[I * LineBytes], LineBytes);
- { If you get complitation error here upgrade to Lazarus 0.9.24+ }
+ end;
+ // May need to swap RB order, depends on wifget set
+ if RawImage.Description.BlueShift > RawImage.Description.RedShift then
+ SwapChannels(Data, ChannelRed, ChannelBlue);
+
RawImage.FreeData;
end;
{$ENDIF}
@@ -768,17 +781,19 @@ procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const Image
begin
DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect);
end;
-{$ELSEIF Defined(LCLGTK) or Defined(LCLGTK2)}
+{$ELSEIF Defined(LCLGTK2)}
+ type
+ TDeviceContext = TGtk2DeviceContext;
procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
SrcWidth, SrcHeight: Integer; ImageData: TImageData);
var
P: TPoint;
begin
- P := TGtkDeviceContext(Dest).Offset;
+ P := TDeviceContext(Dest).Offset;
Inc(DstX, P.X);
Inc(DstY, P.Y);
- gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC,
+ gdk_draw_rgb_32_image(TDeviceContext(Dest).Drawable, TDeviceContext(Dest).GC,
DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
@PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4);
end;
-- TODOS ----------------------------------------------------
- nothing now
+ -- 0.77.1 ---------------------------------------------------
+ - Fixed bug in ConvertBitmapToData causing images from GTK2 bitmaps
+ to have swapped RB channels.
+ - LCL: Removed GTK1 support (deprecated).
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Transparency of 8bit images (like loaded from 8bit PNG or GIF) is
+ kept intact during conversion to TBitmap in ConvertDataToBitmap
+ (32bit bitmap is created).
+
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Setting AlphaFormat property of TBitmap in ConvertDataToBitmap
when using Delphi 2009+.
index a2eb09c03a15d426af6b81cf089fd0345f825f89..94104953b9b7d8cf0a26cc1d4f108c139a38f2d4 100644 (file)
{
- $Id: ImagingDds.pas 129 2008-08-06 20:01:30Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
TImageFormat. It supports plain textures, cube textures and
volume textures, all of these can have mipmaps. It can also
load some formats which have no exact TImageFormat, but can be easily
- converted to one (bump map formats).
+ converted to one (bump map formats, etc.).
You can get some information about last loaded DDS file by calling
GetOption with ImagingDDSLoadedXXX options and you can set some
saving options by calling SetOption with ImagingDDSSaveXXX or you can
at least number of images to build cube/volume based on current
Depth and MipMapCount settings.}
TDDSFileFormat = class(TImageFileFormat)
- protected
+ private
FLoadedCubeMap: LongBool;
FLoadedVolume: LongBool;
FLoadedMipMapCount: LongInt;
FSaveDepth: LongInt;
procedure ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt;
IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt);
+ protected
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
- constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
procedure CheckOptionsValidity; override;
published
property SaveDepth: LongInt read FSaveDepth write FSaveDepth;
end;
+const
+ { DDS related metadata Ids }
+
+ { DXGI format of textures stored in DDS files with DX10 extension. Type is
+ Enum (value corresponding to DXGI_FORMAT enum from DX SDK).}
+ SMetaDdsDxgiFormat = 'DdsDxgiFormat';
+ { Number of mipmaps for each main image in DDS file.}
+ SMetaDdsMipMapCount = 'DdsMipMapCount';
+ { Texture array size stored in DDS file (DX10 extension).}
+ SMetaDdsArraySize = 'DdsArraySize';
+
implementation
const
(Byte('1') shl 24));
FOURCC_ATI2 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
(Byte('2') shl 24));
+ FOURCC_DX10 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('1') shl 16) or
+ (Byte('0') shl 24));
{ Some D3DFORMAT values used in DDS files as FourCC value.}
D3DFMT_A16B16G16R16 = 36;
Desc: TDDSurfaceDesc2; // Surface description
end;
+ { Resoirce types for D3D 10+ }
+ TD3D10ResourceDimension = (
+ D3D10_RESOURCE_DIMENSION_UNKNOWN = 0,
+ D3D10_RESOURCE_DIMENSION_BUFFER = 1,
+ D3D10_RESOURCE_DIMENSION_TEXTURE1D = 2,
+ D3D10_RESOURCE_DIMENSION_TEXTURE2D = 3,
+ D3D10_RESOURCE_DIMENSION_TEXTURE3D = 4
+ );
+
+ { Texture formats for D3D 10+ }
+ TDXGIFormat = (
+ DXGI_FORMAT_UNKNOWN = 0,
+ DXGI_FORMAT_R32G32B32A32_TYPELESS = 1,
+ DXGI_FORMAT_R32G32B32A32_FLOAT = 2,
+ DXGI_FORMAT_R32G32B32A32_UINT = 3,
+ DXGI_FORMAT_R32G32B32A32_SINT = 4,
+ DXGI_FORMAT_R32G32B32_TYPELESS = 5,
+ DXGI_FORMAT_R32G32B32_FLOAT = 6,
+ DXGI_FORMAT_R32G32B32_UINT = 7,
+ DXGI_FORMAT_R32G32B32_SINT = 8,
+ DXGI_FORMAT_R16G16B16A16_TYPELESS = 9,
+ DXGI_FORMAT_R16G16B16A16_FLOAT = 10,
+ DXGI_FORMAT_R16G16B16A16_UNORM = 11,
+ DXGI_FORMAT_R16G16B16A16_UINT = 12,
+ DXGI_FORMAT_R16G16B16A16_SNORM = 13,
+ DXGI_FORMAT_R16G16B16A16_SINT = 14,
+ DXGI_FORMAT_R32G32_TYPELESS = 15,
+ DXGI_FORMAT_R32G32_FLOAT = 16,
+ DXGI_FORMAT_R32G32_UINT = 17,
+ DXGI_FORMAT_R32G32_SINT = 18,
+ DXGI_FORMAT_R32G8X24_TYPELESS = 19,
+ DXGI_FORMAT_D32_FLOAT_S8X24_UINT = 20,
+ DXGI_FORMAT_R32_FLOAT_X8X24_TYPELESS = 21,
+ DXGI_FORMAT_X32_TYPELESS_G8X24_UINT = 22,
+ DXGI_FORMAT_R10G10B10A2_TYPELESS = 23,
+ DXGI_FORMAT_R10G10B10A2_UNORM = 24,
+ DXGI_FORMAT_R10G10B10A2_UINT = 25,
+ DXGI_FORMAT_R11G11B10_FLOAT = 26,
+ DXGI_FORMAT_R8G8B8A8_TYPELESS = 27,
+ DXGI_FORMAT_R8G8B8A8_UNORM = 28,
+ DXGI_FORMAT_R8G8B8A8_UNORM_SRGB = 29,
+ DXGI_FORMAT_R8G8B8A8_UINT = 30,
+ DXGI_FORMAT_R8G8B8A8_SNORM = 31,
+ DXGI_FORMAT_R8G8B8A8_SINT = 32,
+ DXGI_FORMAT_R16G16_TYPELESS = 33,
+ DXGI_FORMAT_R16G16_FLOAT = 34,
+ DXGI_FORMAT_R16G16_UNORM = 35,
+ DXGI_FORMAT_R16G16_UINT = 36,
+ DXGI_FORMAT_R16G16_SNORM = 37,
+ DXGI_FORMAT_R16G16_SINT = 38,
+ DXGI_FORMAT_R32_TYPELESS = 39,
+ DXGI_FORMAT_D32_FLOAT = 40,
+ DXGI_FORMAT_R32_FLOAT = 41,
+ DXGI_FORMAT_R32_UINT = 42,
+ DXGI_FORMAT_R32_SINT = 43,
+ DXGI_FORMAT_R24G8_TYPELESS = 44,
+ DXGI_FORMAT_D24_UNORM_S8_UINT = 45,
+ DXGI_FORMAT_R24_UNORM_X8_TYPELESS = 46,
+ DXGI_FORMAT_X24_TYPELESS_G8_UINT = 47,
+ DXGI_FORMAT_R8G8_TYPELESS = 48,
+ DXGI_FORMAT_R8G8_UNORM = 49,
+ DXGI_FORMAT_R8G8_UINT = 50,
+ DXGI_FORMAT_R8G8_SNORM = 51,
+ DXGI_FORMAT_R8G8_SINT = 52,
+ DXGI_FORMAT_R16_TYPELESS = 53,
+ DXGI_FORMAT_R16_FLOAT = 54,
+ DXGI_FORMAT_D16_UNORM = 55,
+ DXGI_FORMAT_R16_UNORM = 56,
+ DXGI_FORMAT_R16_UINT = 57,
+ DXGI_FORMAT_R16_SNORM = 58,
+ DXGI_FORMAT_R16_SINT = 59,
+ DXGI_FORMAT_R8_TYPELESS = 60,
+ DXGI_FORMAT_R8_UNORM = 61,
+ DXGI_FORMAT_R8_UINT = 62,
+ DXGI_FORMAT_R8_SNORM = 63,
+ DXGI_FORMAT_R8_SINT = 64,
+ DXGI_FORMAT_A8_UNORM = 65,
+ DXGI_FORMAT_R1_UNORM = 66,
+ DXGI_FORMAT_R9G9B9E5_SHAREDEXP = 67,
+ DXGI_FORMAT_R8G8_B8G8_UNORM = 68,
+ DXGI_FORMAT_G8R8_G8B8_UNORM = 69,
+ DXGI_FORMAT_BC1_TYPELESS = 70,
+ DXGI_FORMAT_BC1_UNORM = 71,
+ DXGI_FORMAT_BC1_UNORM_SRGB = 72,
+ DXGI_FORMAT_BC2_TYPELESS = 73,
+ DXGI_FORMAT_BC2_UNORM = 74,
+ DXGI_FORMAT_BC2_UNORM_SRGB = 75,
+ DXGI_FORMAT_BC3_TYPELESS = 76,
+ DXGI_FORMAT_BC3_UNORM = 77,
+ DXGI_FORMAT_BC3_UNORM_SRGB = 78,
+ DXGI_FORMAT_BC4_TYPELESS = 79,
+ DXGI_FORMAT_BC4_UNORM = 80,
+ DXGI_FORMAT_BC4_SNORM = 81,
+ DXGI_FORMAT_BC5_TYPELESS = 82,
+ DXGI_FORMAT_BC5_UNORM = 83,
+ DXGI_FORMAT_BC5_SNORM = 84,
+ DXGI_FORMAT_B5G6R5_UNORM = 85,
+ DXGI_FORMAT_B5G5R5A1_UNORM = 86,
+ DXGI_FORMAT_B8G8R8A8_UNORM = 87,
+ DXGI_FORMAT_B8G8R8X8_UNORM = 88,
+ DXGI_FORMAT_R10G10B10_XR_BIAS_A2_UNORM = 89,
+ DXGI_FORMAT_B8G8R8A8_TYPELESS = 90,
+ DXGI_FORMAT_B8G8R8A8_UNORM_SRGB = 91,
+ DXGI_FORMAT_B8G8R8X8_TYPELESS = 92,
+ DXGI_FORMAT_B8G8R8X8_UNORM_SRGB = 93,
+ DXGI_FORMAT_BC6H_TYPELESS = 94,
+ DXGI_FORMAT_BC6H_UF16 = 95,
+ DXGI_FORMAT_BC6H_SF16 = 96,
+ DXGI_FORMAT_BC7_TYPELESS = 97,
+ DXGI_FORMAT_BC7_UNORM = 98,
+ DXGI_FORMAT_BC7_UNORM_SRGB = 99,
+ DXGI_FORMAT_AYUV = 100,
+ DXGI_FORMAT_Y410 = 101,
+ DXGI_FORMAT_Y416 = 102,
+ DXGI_FORMAT_NV12 = 103,
+ DXGI_FORMAT_P010 = 104,
+ DXGI_FORMAT_P016 = 105,
+ DXGI_FORMAT_420_OPAQUE = 106,
+ DXGI_FORMAT_YUY2 = 107,
+ DXGI_FORMAT_Y210 = 108,
+ DXGI_FORMAT_Y216 = 109,
+ DXGI_FORMAT_NV11 = 110,
+ DXGI_FORMAT_AI44 = 111,
+ DXGI_FORMAT_IA44 = 112,
+ DXGI_FORMAT_P8 = 113,
+ DXGI_FORMAT_A8P8 = 114,
+ DXGI_FORMAT_B4G4R4A4_UNORM = 115
+ );
+
+ { DX10 extension header for DDS file format }
+ TDX10Header = packed record
+ DXGIFormat: TDXGIFormat;
+ ResourceDimension: TD3D10ResourceDimension;
+ MiscFlags: LongWord;
+ ArraySize: LongWord;
+ Reserved: LongWord;
+ end;
{ TDDSFileFormat class implementation }
-constructor TDDSFileFormat.Create;
+procedure TDDSFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SDDSFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := True;
+ FFeatures := [ffLoad, ffSave, ffMultiImage];
FSupportedFormats := DDSSupportedFormats;
FSaveCubeMap := False;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
Hdr: TDDSFileHeader;
+ HdrDX10: TDX10Header;
SrcFormat: TImageFormat;
FmtInfo: TImageFormatInfo;
NeedsSwapChannels: Boolean;
- CurrentWidth, CurrentHeight, ImageCount, LoadSize, I, PitchOrLinear: LongInt;
+ CurrentWidth, CurrentHeight, ImageCount, LoadSize, I,
+ PitchOrLinear, MainImageLinearSize: Integer;
Data: PByte;
UseAsPitch: Boolean;
UseAsLinear: Boolean;
(DDPF.BlueMask = PF.BBitMask);
end;
+ function FindFourCCFormat(FourCC: LongWord): TImageFormat;
+ begin
+ // Handle FourCC and large ARGB formats
+ case FourCC of
+ D3DFMT_A16B16G16R16: Result := ifA16B16G16R16;
+ D3DFMT_R32F: Result := ifR32F;
+ D3DFMT_A32B32G32R32F: Result := ifA32B32G32R32F;
+ D3DFMT_R16F: Result := ifR16F;
+ D3DFMT_A16B16G16R16F: Result := ifA16B16G16R16F;
+ FOURCC_DXT1: Result := ifDXT1;
+ FOURCC_DXT3: Result := ifDXT3;
+ FOURCC_DXT5: Result := ifDXT5;
+ FOURCC_ATI1: Result := ifATI1N;
+ FOURCC_ATI2: Result := ifATI2N;
+ else
+ Result := ifUnknown;
+ end;
+ end;
+
+ function FindDX10Format(DXGIFormat: TDXGIFormat; var NeedsSwapChannels: Boolean): TImageFormat;
+ begin
+ Result := ifUnknown;
+ NeedsSwapChannels := False;
+
+ case DXGIFormat of
+ DXGI_FORMAT_UNKNOWN: ;
+ DXGI_FORMAT_R32G32B32A32_TYPELESS, DXGI_FORMAT_R32G32B32A32_FLOAT:
+ Result := ifA32B32G32R32F;
+ DXGI_FORMAT_R32G32B32A32_UINT: ;
+ DXGI_FORMAT_R32G32B32A32_SINT: ;
+ DXGI_FORMAT_R32G32B32_TYPELESS, DXGI_FORMAT_R32G32B32_FLOAT:
+ Result := ifB32G32R32F;
+ DXGI_FORMAT_R32G32B32_UINT: ;
+ DXGI_FORMAT_R32G32B32_SINT: ;
+ DXGI_FORMAT_R16G16B16A16_FLOAT:
+ Result := ifA16B16G16R16F;
+ DXGI_FORMAT_R16G16B16A16_TYPELESS, DXGI_FORMAT_R16G16B16A16_UNORM,
+ DXGI_FORMAT_R16G16B16A16_UINT, DXGI_FORMAT_R16G16B16A16_SNORM,
+ DXGI_FORMAT_R16G16B16A16_SINT:
+ Result := ifA16B16G16R16;
+ DXGI_FORMAT_R32G32_TYPELESS: ;
+ DXGI_FORMAT_R32G32_FLOAT: ;
+ DXGI_FORMAT_R32G32_UINT: ;
+ DXGI_FORMAT_R32G32_SINT: ;
+ DXGI_FORMAT_R32G8X24_TYPELESS: ;
+ DXGI_FORMAT_D32_FLOAT_S8X24_UINT: ;
+ DXGI_FORMAT_R32_FLOAT_X8X24_TYPELESS: ;
+ DXGI_FORMAT_X32_TYPELESS_G8X24_UINT: ;
+ DXGI_FORMAT_R10G10B10A2_TYPELESS: ;
+ DXGI_FORMAT_R10G10B10A2_UNORM: ;
+ DXGI_FORMAT_R10G10B10A2_UINT: ;
+ DXGI_FORMAT_R11G11B10_FLOAT: ;
+ DXGI_FORMAT_R8G8B8A8_TYPELESS, DXGI_FORMAT_R8G8B8A8_UNORM,
+ DXGI_FORMAT_R8G8B8A8_UINT, DXGI_FORMAT_R8G8B8A8_SNORM,DXGI_FORMAT_R8G8B8A8_SINT,
+ DXGI_FORMAT_R8G8B8A8_UNORM_SRGB:
+ begin
+ Result := ifA8R8G8B8;
+ NeedsSwapChannels := True;
+ end;
+ DXGI_FORMAT_R16G16_TYPELESS: ;
+ DXGI_FORMAT_R16G16_FLOAT: ;
+ DXGI_FORMAT_R16G16_UNORM: ;
+ DXGI_FORMAT_R16G16_UINT: ;
+ DXGI_FORMAT_R16G16_SNORM: ;
+ DXGI_FORMAT_R16G16_SINT: ;
+ DXGI_FORMAT_R32_TYPELESS, DXGI_FORMAT_R32_UINT, DXGI_FORMAT_R32_SINT:
+ Result := ifGray32;
+ DXGI_FORMAT_D32_FLOAT, DXGI_FORMAT_R32_FLOAT:
+ Result := ifR32F;
+ DXGI_FORMAT_R24G8_TYPELESS: ;
+ DXGI_FORMAT_D24_UNORM_S8_UINT: ;
+ DXGI_FORMAT_R24_UNORM_X8_TYPELESS: ;
+ DXGI_FORMAT_X24_TYPELESS_G8_UINT: ;
+ DXGI_FORMAT_R8G8_TYPELESS, DXGI_FORMAT_R8G8_UNORM, DXGI_FORMAT_R8G8_UINT,
+ DXGI_FORMAT_R8G8_SNORM, DXGI_FORMAT_R8G8_SINT:
+ Result := ifA8Gray8;
+ DXGI_FORMAT_R16_TYPELESS, DXGI_FORMAT_D16_UNORM, DXGI_FORMAT_R16_UNORM,
+ DXGI_FORMAT_R16_UINT, DXGI_FORMAT_R16_SNORM, DXGI_FORMAT_R16_SINT:
+ Result := ifGray16;
+ DXGI_FORMAT_R16_FLOAT:
+ Result := ifR16F;
+ DXGI_FORMAT_R8_TYPELESS, DXGI_FORMAT_R8_UNORM, DXGI_FORMAT_R8_UINT,
+ DXGI_FORMAT_R8_SNORM, DXGI_FORMAT_R8_SINT, DXGI_FORMAT_A8_UNORM:
+ Result := ifGray8;
+ DXGI_FORMAT_R1_UNORM: ;
+ DXGI_FORMAT_R9G9B9E5_SHAREDEXP: ;
+ DXGI_FORMAT_R8G8_B8G8_UNORM: ;
+ DXGI_FORMAT_G8R8_G8B8_UNORM: ;
+ DXGI_FORMAT_BC1_TYPELESS, DXGI_FORMAT_BC1_UNORM, DXGI_FORMAT_BC1_UNORM_SRGB:
+ Result := ifDXT1;
+ DXGI_FORMAT_BC2_TYPELESS, DXGI_FORMAT_BC2_UNORM, DXGI_FORMAT_BC2_UNORM_SRGB:
+ Result := ifDXT3;
+ DXGI_FORMAT_BC3_TYPELESS, DXGI_FORMAT_BC3_UNORM, DXGI_FORMAT_BC3_UNORM_SRGB:
+ Result := ifDXT5;
+ DXGI_FORMAT_BC4_TYPELESS, DXGI_FORMAT_BC4_UNORM, DXGI_FORMAT_BC4_SNORM:
+ Result := ifATI1N;
+ DXGI_FORMAT_BC5_TYPELESS, DXGI_FORMAT_BC5_UNORM, DXGI_FORMAT_BC5_SNORM:
+ Result := ifATI2N;
+ DXGI_FORMAT_B5G6R5_UNORM:
+ Result := ifR5G6B5;
+ DXGI_FORMAT_B5G5R5A1_UNORM:
+ Result := ifA1R5G5B5;
+ DXGI_FORMAT_B8G8R8A8_UNORM, DXGI_FORMAT_B8G8R8A8_TYPELESS:
+ Result := ifA8R8G8B8;
+ DXGI_FORMAT_B8G8R8X8_UNORM, DXGI_FORMAT_B8G8R8X8_TYPELESS:
+ Result := ifX8R8G8B8;
+ DXGI_FORMAT_R10G10B10_XR_BIAS_A2_UNORM: ;
+ DXGI_FORMAT_B8G8R8A8_UNORM_SRGB: ;
+ DXGI_FORMAT_B8G8R8X8_UNORM_SRGB: ;
+ DXGI_FORMAT_BC6H_TYPELESS: ;
+ DXGI_FORMAT_BC6H_UF16: ;
+ DXGI_FORMAT_BC6H_SF16: ;
+ DXGI_FORMAT_BC7_TYPELESS: ;
+ DXGI_FORMAT_BC7_UNORM: ;
+ DXGI_FORMAT_BC7_UNORM_SRGB: ;
+ DXGI_FORMAT_P8: ;
+ DXGI_FORMAT_A8P8: ;
+ DXGI_FORMAT_B4G4R4A4_UNORM:
+ Result := ifA4R4G4B4;
+ end;
+ end;
+
begin
Result := False;
ImageCount := 1;
FLoadedDepth := 1;
FLoadedVolume := False;
FLoadedCubeMap := False;
+ ZeroMemory(@HdrDX10, SizeOf(HdrDX10));
with GetIO, Hdr, Hdr.Desc.PixelFormat do
begin
- Read(Handle, @Hdr, SizeOF(Hdr));
- {
- // Set position to the end of the header (for possible future versions
- // ith larger header)
- Seek(Handle, Hdr.Desc.Size + SizeOf(Hdr.Magic) - SizeOf(Hdr),
- smFromCurrent);
- }
+ Read(Handle, @Hdr, SizeOf(Hdr));
+
SrcFormat := ifUnknown;
NeedsSwapChannels := False;
+
// Get image data format
if (Flags and DDPF_FOURCC) = DDPF_FOURCC then
begin
- // Handle FourCC and large ARGB formats
- case FourCC of
- D3DFMT_A16B16G16R16: SrcFormat := ifA16B16G16R16;
- D3DFMT_R32F: SrcFormat := ifR32F;
- D3DFMT_A32B32G32R32F: SrcFormat := ifA32B32G32R32F;
- D3DFMT_R16F: SrcFormat := ifR16F;
- D3DFMT_A16B16G16R16F: SrcFormat := ifA16B16G16R16F;
- FOURCC_DXT1: SrcFormat := ifDXT1;
- FOURCC_DXT3: SrcFormat := ifDXT3;
- FOURCC_DXT5: SrcFormat := ifDXT5;
- FOURCC_ATI1: SrcFormat := ifATI1N;
- FOURCC_ATI2: SrcFormat := ifATI2N;
- end;
+ if FourCC = FOURCC_DX10 then
+ begin
+ Read(Handle, @HdrDX10, SizeOf(HdrDX10));
+ SrcFormat := FindDX10Format(HdrDX10.DXGIFormat, NeedsSwapChannels);
+ FMetadata.SetMetaItem(SMetaDdsDxgiFormat, HdrDX10.DXGIFormat);
+ FMetadata.SetMetaItem(SMetaDdsArraySize, HdrDX10.ArraySize);
+ end
+ else
+ SrcFormat := FindFourCCFormat(FourCC);
end
else if (Flags and DDPF_RGB) = DDPF_RGB then
begin
case BitCount of
16:
begin
- if MasksEqual(Desc.PixelFormat,
- GetFormatInfo(ifA4R4G4B4).PixelFormat) then
+ if MasksEqual(Desc.PixelFormat, GetFormatInfo(ifA4R4G4B4).PixelFormat) then
SrcFormat := ifA4R4G4B4;
- if MasksEqual(Desc.PixelFormat,
- GetFormatInfo(ifA1R5G5B5).PixelFormat) then
+ if MasksEqual(Desc.PixelFormat, GetFormatInfo(ifA1R5G5B5).PixelFormat) then
SrcFormat := ifA1R5G5B5;
end;
32:
end;
// If DDS format is not supported we will exit
- if SrcFormat = ifUnknown then Exit;
+ if SrcFormat = ifUnknown then
+ Exit;
// File contains mipmaps for each subimage.
{ Some DDS writers ignore setting proper Caps and Flags so
if Desc.MipMaps > 1 then
begin
FLoadedMipMapCount := Desc.MipMaps;
+ FMetadata.SetMetaItem(SMetaDdsMipMapCount, Desc.MipMaps);
ImageCount := Desc.MipMaps;
end;
// Main image pitch or linear size
PitchOrLinear := Desc.PitchOrLinearSize;
+ // Check: some writers just write garbage to pitch/linear size fields and flags
+ MainImageLinearSize := FmtInfo.GetPixelsSize(SrcFormat, Desc.Width, Desc.Height);
+ if UseAsLinear and ((PitchOrLinear < MainImageLinearSize) or
+ (PitchOrLinear * Integer(Desc.Height) = MainImageLinearSize)) then
+ begin
+ // Explicitly set linear size
+ PitchOrLinear := MainImageLinearSize;
+ end;
+
for I := 0 to ImageCount - 1 do
begin
// Compute dimensions of surrent subimage based on texture type and
// number of mipmaps
ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth,
- FloadedCubeMap, FLoadedVolume, CurrentWidth, CurrentHeight);
+ FLoadedCubeMap, FLoadedVolume, CurrentWidth, CurrentHeight);
NewImage(CurrentWidth, CurrentHeight, SrcFormat, Images[I]);
if (I > 0) or (PitchOrLinear = 0) then
-- TODOS ----------------------------------------------------
- nothing now
+ -- 0.77.1 ----------------------------------------------------
+ - Texture and D3D specific info stored in DDS is now available as metadata
+ (loading).
+ - Added support for loading DDS files with DX10 extension
+ (http://msdn.microsoft.com/en-us/library/windows/desktop/bb943991(v=vs.85).aspx)
+ and few compatibility fixes.
+
-- 0.25.0 Changes/Bug Fixes ---------------------------------
- Added support for 3Dc ATI1/2 formats.
diff --git a/src/lib/vampimg/ImagingExport.pas b/src/lib/vampimg/ImagingExport.pas
+++ /dev/null
@@ -1,890 +0,0 @@
-{
- $Id: ImagingExport.pas 173 2009-09-04 17:05:52Z 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 function contains functions exported from Imaging dynamic link library.
- All string are exported as PChars and all var parameters are exported
- as pointers. All posible exceptions getting out of dll are catched.}
-unit ImagingExport;
-
-{$I ImagingOptions.inc}
-
-interface
-
-uses
- ImagingTypes,
- Imaging;
-
-{ Returns version of Imaging library. }
-procedure ImGetVersion(var Major, Minor, Patch: LongInt); cdecl;
-{ Look at InitImage for details.}
-procedure ImInitImage(var Image: TImageData); cdecl;
-{ Look at NewImage for details.}
-function ImNewImage(Width, Height: LongInt; Format: TImageFormat;
- var Image: TImageData): Boolean; cdecl;
-{ Look at TestImage for details.}
-function ImTestImage(var Image: TImageData): Boolean; cdecl;
-{ Look at FreeImage for details.}
-function ImFreeImage(var Image: TImageData): Boolean; cdecl;
-{ Look at DetermineFileFormat for details. Ext should have enough space for
- result file extension.}
-function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean; cdecl;
-{ Look at DetermineMemoryFormat for details. Ext should have enough space for
- result file extension.}
-function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean; cdecl;
-{ Look at IsFileFormatSupported for details.}
-function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean; cdecl;
-{ Look at EnumFileFormats for details.}
-function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
- var CanSave, IsMultiImageFormat: Boolean): Boolean; cdecl;
-
-{ Inits image list.}
-function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean; cdecl;
-{ Returns size of image list.}
-function ImGetImageListSize(ImageList: TImageDataList): LongInt; cdecl;
-{ Returns image list's element at given index. Output image is not cloned it's
- Bits point to Bits in list => do not free OutImage.}
-function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt;
- var OutImage: TImageData): Boolean; cdecl;
-{ Sets size of image list.}
-function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt): Boolean; cdecl;
-{ Sets image list element at given index. Input image is not cloned - image in
- list will point to InImage's Bits.}
-function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt;
- const InImage: TImageData): Boolean; cdecl;
-{ Returns True if all images in list pass ImTestImage test. }
-function ImTestImagesInList(ImageList: TImageDataList): Boolean; cdecl;
-{ Frees image list and all images in it.}
-function ImFreeImageList(var ImageList: TImageDataList): Boolean; cdecl;
-
-{ Look at LoadImageFromFile for details.}
-function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean; cdecl;
-{ Look at LoadImageFromMemory for details.}
-function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; cdecl;
-{ Look at LoadMultiImageFromFile for details.}
-function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList): Boolean; cdecl;
-{ Look at LoadMultiImageFromMemory for details.}
-function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
- var ImageList: TImageDataList): Boolean; cdecl;
-
-{ Look at SaveImageToFile for details.}
-function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean; cdecl;
-{ Look at SaveImageToMemory for details.}
-function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
- const Image: TImageData): Boolean; cdecl;
-{ Look at SaveMultiImageToFile for details.}
-function ImSaveMultiImageToFile(FileName: PAnsiChar; ImageList: TImageDataList): Boolean; cdecl;
-{ Look at SaveMultiImageToMemory for details.}
-function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
- ImageList: TImageDataList): Boolean; cdecl;
-
-{ Look at CloneImage for details.}
-function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean; cdecl;
-{ Look at ConvertImage for details.}
-function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean; cdecl;
-{ Look at FlipImage for details.}
-function ImFlipImage(var Image: TImageData): Boolean; cdecl;
-{ Look at MirrorImage for details.}
-function ImMirrorImage(var Image: TImageData): Boolean; cdecl;
-{ Look at ResizeImage for details.}
-function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
- Filter: TResizeFilter): Boolean; cdecl;
-{ Look at SwapChannels for details.}
-function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean; cdecl;
-{ Look at ReduceColors for details.}
-function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean; cdecl;
-{ Look at GenerateMipMaps for details.}
-function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt;
- var MipMaps: TImageDataList): Boolean; cdecl;
-{ Look at MapImageToPalette for details.}
-function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32;
- Entries: LongInt): Boolean; cdecl;
-{ Look at SplitImage for details.}
-function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
- ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
- PreserveSize: Boolean; Fill: Pointer): Boolean; cdecl;
-{ Look at MakePaletteForImages for details.}
-function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
- MaxColors: LongInt; ConvertImages: Boolean): Boolean; cdecl;
-{ Look at RotateImage for details.}
-function ImRotateImage(var Image: TImageData; Angle: Single): Boolean; cdecl;
-
-{ Look at CopyRect for details.}
-function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
- var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl;
-{ Look at FillRect for details.}
-function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
- Fill: Pointer): Boolean; cdecl;
-{ Look at ReplaceColor for details.}
-function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
- OldPixel, NewPixel: Pointer): Boolean; cdecl;
-{ Look at StretchRect for details.}
-function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
- SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
- DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl;
-{ Look at GetPixelDirect for details.}
-procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl;
-{ Look at SetPixelDirect for details.}
-procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl;
-{ Look at GetPixel32 for details.}
-function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl;
-{ Look at SetPixel32 for details.}
-procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec); cdecl;
-{ Look at GetPixelFP for details.}
-function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl;
-{ Look at SetPixelFP for details.}
-procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec); cdecl;
-
-{ Look at NewPalette for details.}
-function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean; cdecl;
-{ Look at FreePalette for details.}
-function ImFreePalette(var Pal: PPalette32): Boolean; cdecl;
-{ Look at CopyPalette for details.}
-function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean; cdecl;
-{ Look at FindColor for details.}
-function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt; cdecl;
-{ Look at FillGrayscalePalette for details.}
-function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean; cdecl;
-{ Look at FillCustomPalette for details.}
-function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
- BBits: Byte; Alpha: Byte): Boolean; cdecl;
-{ Look at SwapChannelsOfPalette for details.}
-function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
- DstChannel: LongInt): Boolean; cdecl;
-
-{ Look at SetOption for details.}
-function ImSetOption(OptionId, Value: LongInt): Boolean; cdecl;
-{ Look at GetOption for details.}
-function ImGetOption(OptionId: LongInt): LongInt; cdecl;
-{ Look at PushOptions for details.}
-function ImPushOptions: Boolean; cdecl;
-{ Look at PopOptions for details.}
-function ImPopOptions: Boolean; cdecl;
-
-{ Look at GetImageFormatInfo for details.}
-function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean; cdecl;
-{ Look at GetPixelsSize for details.}
-function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; cdecl;
-
-{ Look at SetUserFileIO for details.}
-procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
- TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc;
- TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc); cdecl;
-{ Look at ResetFileIO for details.}
-procedure ImResetFileIO; cdecl;
-
-{ These are only for documentation generation reasons.}
-{ Loads Imaging functions from dll/so library.}
-function ImLoadLibrary: Boolean;
-{ Frees Imaging functions loaded from dll/so and releases library.}
-function ImFreeLibrary: Boolean;
-
-implementation
-
-uses
- SysUtils,
- ImagingUtility;
-
-function ImLoadLibrary: Boolean; begin Result := True; end;
-function ImFreeLibrary: Boolean; begin Result := True; end;
-
-type
- TInternalList = record
- List: TDynImageDataArray;
- end;
- PInternalList = ^TInternalList;
-
-procedure ImGetVersion(var Major, Minor, Patch: LongInt);
-begin
- Major := ImagingVersionMajor;
- Minor := ImagingVersionMinor;
- Patch := ImagingVersionPatch;
-end;
-
-procedure ImInitImage(var Image: TImageData);
-begin
- try
- Imaging.InitImage(Image);
- except
- end;
-end;
-
-function ImNewImage(Width, Height: LongInt; Format: TImageFormat;
- var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.NewImage(Width, Height, Format, Image);
- except
- Result := False;
- end;
-end;
-
-function ImTestImage(var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.TestImage(Image);
- except
- Result := False;
- end;
-end;
-
-function ImFreeImage(var Image: TImageData): Boolean;
-begin
- try
- Imaging.FreeImage(Image);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean;
-var
- S: string;
-begin
- try
- S := Imaging.DetermineFileFormat(FileName);
- Result := S <> '';
- StrCopy(Ext, PAnsiChar(AnsiString(S)));
- except
- Result := False;
- end;
-end;
-
-function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean;
-var
- S: string;
-begin
- try
- S := Imaging.DetermineMemoryFormat(Data, Size);
- Result := S <> '';
- StrCopy(Ext, PAnsiChar(AnsiString(S)));
- except
- Result := False;
- end;
-end;
-
-function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean;
-begin
- try
- Result := Imaging.IsFileFormatSupported(FileName);
- except
- Result := False;
- end;
-end;
-
-function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
- var CanSave, IsMultiImageFormat: Boolean): Boolean;
-var
- StrName, StrDefaultExt, StrMasks: string;
-begin
- try
- Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave,
- IsMultiImageFormat);
- StrCopy(Name, PAnsiChar(AnsiString(StrName)));
- StrCopy(DefaultExt, PAnsiChar(AnsiString(StrDefaultExt)));
- StrCopy(Masks, PAnsiChar(AnsiString(StrMasks)));
- except
- Result := False;
- end;
-end;
-
-function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean;
-var
- Int: PInternalList;
-begin
- try
- try
- ImFreeImageList(ImageList);
- except
- end;
- New(Int);
- SetLength(Int.List, Size);
- ImageList := TImageDataList(Int);
- Result := True;
- except
- Result := False;
- ImageList := nil;
- end;
-end;
-
-function ImGetImageListSize(ImageList: TImageDataList): LongInt;
-begin
- try
- Result := Length(PInternalList(ImageList).List);
- except
- Result := -1;
- end;
-end;
-
-function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt;
- var OutImage: TImageData): Boolean;
-begin
- try
- Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1);
- ImCloneImage(PInternalList(ImageList).List[Index], OutImage);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt):
- Boolean;
-var
- I, OldSize: LongInt;
-begin
- try
- OldSize := Length(PInternalList(ImageList).List);
- if NewSize < OldSize then
- for I := NewSize to OldSize - 1 do
- Imaging.FreeImage(PInternalList(ImageList).List[I]);
- SetLength(PInternalList(ImageList).List, NewSize);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt;
- const InImage: TImageData): Boolean;
-begin
- try
- Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1);
- ImCloneImage(InImage, PInternalList(ImageList).List[Index]);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImTestImagesInList(ImageList: TImageDataList): Boolean;
-var
- I: LongInt;
- Arr: TDynImageDataArray;
-begin
- Arr := nil;
- try
- Arr := PInternalList(ImageList).List;
- Result := True;
- for I := 0 to Length(Arr) - 1 do
- begin
- Result := Result and Imaging.TestImage(Arr[I]);
- if not Result then Break;
- end;
- except
- Result := False;
- end;
-end;
-
-function ImFreeImageList(var ImageList: TImageDataList): Boolean;
-var
- Int: PInternalList;
-begin
- try
- if ImageList <> nil then
- begin
- Int := PInternalList(ImageList);
- FreeImagesInArray(Int.List);
- Dispose(Int);
- ImageList := nil;
- end;
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.LoadImageFromFile(FileName, Image);
- except
- Result := False;
- end;
-end;
-
-function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.LoadImageFromMemory(Data, Size, Image);
- except
- Result := False;
- end;
-end;
-
-function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList):
- Boolean;
-begin
- try
- ImInitImageList(0, ImageList);
- Result := Imaging.LoadMultiImageFromFile(FileName,
- PInternalList(ImageList).List);
- except
- Result := False;
- end;
-end;
-
-function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
- var ImageList: TImageDataList): Boolean;
-begin
- try
- ImInitImageList(0, ImageList);
- Result := Imaging.LoadMultiImageFromMemory(Data, Size, PInternalList(ImageList).List);
- except
- Result := False;
- end;
-end;
-
-function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.SaveImageToFile(FileName, Image);
- except
- Result := False;
- end;
-end;
-
-function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
- const Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.SaveImageToMemory(Ext, Data, Size, Image);
- except
- Result := False;
- end;
-end;
-
-function ImSaveMultiImageToFile(FileName: PAnsiChar;
- ImageList: TImageDataList): Boolean;
-begin
- try
- Result := Imaging.SaveMultiImageToFile(FileName,
- PInternalList(ImageList).List);
- except
- Result := False;
- end;
-end;
-
-function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
- ImageList: TImageDataList): Boolean;
-begin
- try
- Result := Imaging.SaveMultiImageToMemory(Ext, Data, Size^,
- PInternalList(ImageList).List);
- except
- Result := False;
- end;
-end;
-
-function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean;
-begin
- try
- Result := Imaging.CloneImage(Image, Clone);
- except
- Result := False;
- end;
-end;
-
-function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean;
-begin
- try
- Result := Imaging.ConvertImage(Image, DestFormat);
- except
- Result := False;
- end;
-end;
-
-function ImFlipImage(var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.FlipImage(Image);
- except
- Result := False;
- end;
-end;
-
-function ImMirrorImage(var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.MirrorImage(Image);
- except
- Result := False;
- end;
-end;
-
-function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
- Filter: TResizeFilter): Boolean;
-begin
- try
- Result := Imaging.ResizeImage(Image, NewWidth, NewHeight, Filter);
- except
- Result := False;
- end;
-end;
-
-function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt):
- Boolean;
-begin
- try
- Result := Imaging.SwapChannels(Image, SrcChannel, DstChannel);
- except
- Result := False;
- end;
-end;
-
-function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean;
-begin
- try
- Result := Imaging.ReduceColors(Image, MaxColors);
- except
- Result := False;
- end;
-end;
-
-function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt;
- var MipMaps: TImageDataList): Boolean;
-begin
- try
- ImInitImageList(0, MipMaps);
- Result := Imaging.GenerateMipMaps(Image, Levels,
- PInternalList(MipMaps).List);
- except
- Result := False;
- end;
-end;
-
-function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32;
- Entries: LongInt): Boolean;
-begin
- try
- Result := Imaging.MapImageToPalette(Image, Pal, Entries);
- except
- Result := False;
- end;
-end;
-
-function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
- ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
- PreserveSize: Boolean; Fill: Pointer): Boolean;
-begin
- try
- ImInitImageList(0, Chunks);
- Result := Imaging.SplitImage(Image, PInternalList(Chunks).List,
- ChunkWidth, ChunkHeight, XChunks, YChunks, PreserveSize, Fill);
- except
- Result := False;
- end;
-end;
-
-function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
- MaxColors: LongInt; ConvertImages: Boolean): Boolean;
-begin
- try
- Result := Imaging.MakePaletteForImages(PInternalList(Images).List,
- Pal, MaxColors, ConvertImages);
- except
- Result := False;
- end;
-end;
-
-function ImRotateImage(var Image: TImageData; Angle: Single): Boolean;
-begin
- try
- Result := Imaging.RotateImage(Image, Angle);
- except
- Result := False;
- end;
-end;
-
-function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
- var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl;
-begin
- try
- Result := Imaging.CopyRect(SrcImage, SrcX, SrcY, Width, Height,
- DstImage, DstX, DstY);
- except
- Result := False;
- end;
-end;
-
-function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
- Fill: Pointer): Boolean;
-begin
- try
- Result := Imaging.FillRect(Image, X, Y, Width, Height, Fill);
- except
- Result := False;
- end;
-end;
-
-function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
- OldPixel, NewPixel: Pointer): Boolean;
-begin
- try
- Result := Imaging.ReplaceColor(Image, X, Y, Width, Height, OldPixel, NewPixel);
- except
- Result := False;
- end;
-end;
-
-function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
- SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
- DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl;
-begin
- try
- Result := Imaging.StretchRect(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight,
- DstImage, DstX, DstY, DstWidth, DstHeight, Filter);
- except
- Result := False;
- end;
-end;
-
-procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
-begin
- try
- Imaging.GetPixelDirect(Image, X, Y, Pixel);
- except
- end;
-end;
-
-procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
-begin
- try
- Imaging.SetPixelDirect(Image, X, Y, Pixel);
- except
- end;
-end;
-
-function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl;
-begin
- try
- Result := Imaging.GetPixel32(Image, X, Y);
- except
- Result.Color := 0;
- end;
-end;
-
-procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec);
-begin
- try
- Imaging.SetPixel32(Image, X, Y, Color);
- except
- end;
-end;
-
-function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl;
-begin
- try
- Result := Imaging.GetPixelFP(Image, X, Y);
- except
- FillChar(Result, SizeOf(Result), 0);
- end;
-end;
-
-procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec);
-begin
- try
- Imaging.SetPixelFP(Image, X, Y, Color);
- except
- end;
-end;
-
-function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean;
-begin
- try
- Imaging.NewPalette(Entries, Pal);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImFreePalette(var Pal: PPalette32): Boolean;
-begin
- try
- Imaging.FreePalette(Pal);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean;
-begin
- try
- Imaging.CopyPalette(SrcPal, DstPal, SrcIdx, DstIdx, Count);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt;
-begin
- try
- Result := Imaging.FindColor(Pal, Entries, Color);
- except
- Result := 0;
- end;
-end;
-
-function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean;
-begin
- try
- Imaging.FillGrayscalePalette(Pal, Entries);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
- BBits: Byte; Alpha: Byte): Boolean;
-begin
- try
- Imaging.FillCustomPalette(Pal, Entries, RBits, GBits, BBits, Alpha);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
- DstChannel: LongInt): Boolean;
-begin
- try
- Imaging.SwapChannelsOfPalette(Pal, Entries, SrcChannel, DstChannel);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImSetOption(OptionId, Value: LongInt): Boolean;
-begin
- try
- Result := Imaging.SetOption(OptionId, Value);
- except
- Result := False;
- end;
-end;
-
-function ImGetOption(OptionId: LongInt): LongInt;
-begin
- try
- Result := GetOption(OptionId);
- except
- Result := InvalidOption;
- end;
-end;
-
-function ImPushOptions: Boolean;
-begin
- try
- Result := Imaging.PushOptions;
- except
- Result := False;
- end;
-end;
-
-function ImPopOptions: Boolean;
-begin
- try
- Result := Imaging.PopOptions;
- except
- Result := False;
- end;
-end;
-
-function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean;
-begin
- try
- Result := Imaging.GetImageFormatInfo(Format, Info);
- except
- Result := False;
- end;
-end;
-
-function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
-begin
- try
- Result := Imaging.GetPixelsSize(Format, Width, Height);
- except
- Result := 0;
- end;
-end;
-
-procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
- TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc;
- TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc);
-begin
- try
- Imaging.SetUserFileIO(OpenReadProc, OpenWriteProc, CloseProc, EofProc,
- SeekProc, TellProc, ReadProc, WriteProc);
- except
- end;
-end;
-
-procedure ImResetFileIO;
-begin
- try
- Imaging.ResetFileIO;
- except
- end;
-end;
-
-{
- Changes/Bug Fixes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
-
- -- 0.26.3 ---------------------------------------------------
- - changed PChars to PAnsiChars and some more D2009 friendly
- casts.
-
- -- 0.19 -----------------------------------------------------
- - updated to reflect changes in low level interface (added pixel set/get, ...)
- - changed ImInitImage to procedure to reflect change in Imaging.pas
- - added ImIsFileFormatSupported
-
- -- 0.15 -----------------------------------------------------
- - behaviour of ImGetImageListElement and ImSetImageListElement
- has changed - list items are now cloned rather than referenced,
- because of this ImFreeImageListKeepImages was no longer needed
- and was removed
- - many function headers were changed - mainly pointers were
- replaced with var and const parameters
-
- -- 0.13 -----------------------------------------------------
- - added TestImagesInList function and new 0.13 functions
- - images were not freed when image list was resized in ImSetImageListSize
- - ImSaveMultiImageTo* recreated the input image list with size = 0
-
-}
-end.
index 865e81edc60bc1c19d3ea35078530ffd2bd2f3cb..d32f0f9bb259830ed9b0affcebe9f6b8e5caacd0 100644 (file)
{
- $Id: ImagingExtras.pas 171 2009-09-02 01:34:19Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
//{$DEFINE DONT_LINK_PSD} // link support for PSD images
//{$DEFINE DONT_LINK_PCX} // link support for PCX images
//{$DEFINE DONT_LINK_XPM} // link support for XPM images
-{ $IFNDEF FULL_FEATURE_SET}
+//{$IFNDEF FULL_FEATURE_SET}
{$DEFINE DONT_LINK_ELDER} // link support for Elder Imagery images
-{ $ENDIF}
+//{$ENDIF}
-{$IF not (Defined(DELPHI) or
+{$IF not (
+ (Defined(DCC) and Defined(CPUX86) and not Defined(MACOS)) or
(Defined(FPC) and not Defined(MSDOS) and
- ((Defined(CPU86) and (Defined(LINUX) or Defined(WIN32) or Defined(DARWIN)) or
- (Defined(CPUX86_64) and Defined(LINUX)))))
+ ((Defined(CPUX86) and (Defined(LINUX) or Defined(WIN32) or Defined(MACOS)) or
+ (Defined(CPUX64) and Defined(LINUX)))))
)}
// JPEG2000 only for 32bit Windows/Linux/OSX and for 64bit Unix with FPC
{$DEFINE DONT_LINK_JPEG2000}
{$IFEND}
-{$IF not Defined(DELPHI)}
+{$IF not (Defined(DCC) and Defined(CPUX86) and not Defined(MACOS))}
{$DEFINE DONT_LINK_TIFF} // Only for Delphi now
{$IFEND}
Default value is False (0).}
ImagingJpeg2000LosslessCompression = 57;
{ Specifies compression scheme used when saving TIFF images. Supported values
- are 0 (Uncompressed), 1 (LZW), 2 (PackBits RLE), 3 (Deflate - ZLib), 4 (JPEG).
+ are 0 (Uncompressed), 1 (LZW), 2 (PackBits RLE), 3 (Deflate - ZLib), 4 (JPEG),
+ 5 (CCITT Group 4 fax encoding - for binary images only).
Default is 1 (LZW). Note that not all images can be stored with
JPEG compression - these images will be saved with default compression if
JPEG is set.}
ImagingTiffCompression = 65;
+ { Controls compression quality when selected TIFF compression is Jpeg.
+ It is number in range 1..100. 1 means small/ugly file,
+ 100 means large/nice file. Accessible trough ImagingTiffJpegQuality option.}
+ ImagingTiffJpegQuality = 66;
+ { When activated (True = 1) existing TIFF files are not overwritten when saving but
+ new images are instead appended thus producing multipage TIFFs.
+ Default value is False (0).}
+ ImagingTiffAppendMode = 67;
{ If enabled image data is saved as layer of PSD file. This is required
to get proper transparency when opened in Photoshop for images with
alpha data (will be opened with one layer, RGB color channels, and transparency).
ImagingJpeg2000,
{$ENDIF}
{$IFNDEF DONT_LINK_TIFF}
- ImagingTiff,
+ ImagingLibTiffDelphi,
{$ENDIF}
{$IFNDEF DONT_LINK_PSD}
ImagingPsd,
{
File Notes:
- -- TODOS ----------------------------------------------------
+ -- TODOS -----------------------------------------------------
- nothing now
+ -- 0.77 -----------------------------------------------------
+ - Added ImagingTiffAppendMode option.
+
+ -- 0.26.5 Changes/Bug Fixes ---------------------------------
+ - Added Group 4 Fax encoding as compression for TIFF files.
+ - Added ImagingTiffJpegQuality option.
+
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Allowed JPEG2000 for Mac OS X x86
index 956f491876d1146fe4b8ab51ce8ffd640d1aa12c..b42b4ac1478e14ab698480228e6e1b2a84b0f1f3 100644 (file)
{
- $Id: ImagingFormats.pas 174 2009-09-08 09:37:59Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
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}
+{ Helper function that converts pixel in any format to 32bit ARGB pixel.
+ For common formats it's faster than calling GetPixel32 etc.}
+procedure ConvertToPixel32(SrcPix: PByte; DestPix: PColor32Rec;
+ const SrcInfo: TImageFormatInfo; SrcPalette: PPalette32 = nil); {$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 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);
+{ Converts 1bit image data to 8bit. Used mostly by file loaders for formats
+ supporting 1bit images. Scaling of pixel values to 8bits is optional
+ (indexed formats don't need this).}
+procedure Convert1To8(DataIn, DataOut: PByte; Width, Height,
+ WidthBytes: LongInt; ScaleTo8Bits: Boolean);
+{ Converts 2bit image data to 8bit. Used mostly by file loaders for formats
+ supporting 2bit images. Scaling of pixel values to 8bits is optional
+ (indexed formats don't need this).}
+procedure Convert2To8(DataIn, DataOut: PByte; Width, Height,
+ WidthBytes: LongInt; ScaleTo8Bits: Boolean);
+{ Converts 4bit image data to 8bit. Used mostly by file loaders for formats
+ supporting 4bit images. Scaling of pixel values to 8bits is optional
+ (indexed formats don't need this).}
+procedure Convert4To8(DataIn, DataOut: PByte; Width, Height,
+ WidthBytes: LongInt; ScaleTo8Bits: Boolean);
{ 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
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.}
+ to Has16BitImageAlpha but works with A8R8G8B8/X8R8G8B8 format.}
function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean;
+{ Checks if there is any relevant alpha data (any entry has alpha <> 255)
+ in the given palette.}
+function PaletteHasAlpha(Palette: PPalette32; PaletteEntries: Integer): Boolean;
+
{ Provides indexed access to each line of pixels. Does not work with special
format images.}
function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
@@ -351,6 +361,12 @@ function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt
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;
+{ Returns size in bytes of image in binary format (1bit image).}
+function GetBinaryPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
+
+function GetBCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
+procedure CheckBCDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;
+
{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }
SetPixel32: SetPixel32Generic;
SetPixelFP: SetPixelFPGeneric);
+ R32G32B32FInfo: TImageFormatInfo = (
+ Format: ifR32G32B32F;
+ Name: 'R32G32B32F';
+ BytesPerPixel: 12;
+ ChannelCount: 3;
+ IsFloatingPoint: True;
+ RBSwapFormat: ifB32G32R32F;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPFloat32;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPFloat32);
+
+ B32G32R32FInfo: TImageFormatInfo = (
+ Format: ifB32G32R32F;
+ Name: 'B32G32R32F';
+ BytesPerPixel: 12;
+ ChannelCount: 3;
+ IsFloatingPoint: True;
+ IsRBSwapped: True;
+ RBSwapFormat: ifR32G32B32F;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPFloat32;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPFloat32);
+
// special formats
DXT1Info: TImageFormatInfo = (
Format: ifDXT1;
CheckDimensions: CheckDXTDimensions;
SpecialNearestFormat: ifA8R8G8B8);
+ BinaryInfo: TImageFormatInfo = (
+ Format: ifBinary;
+ Name: 'Binary';
+ ChannelCount: 1;
+ HasAlphaChannel: False;
+ IsSpecial: True;
+ GetPixelsSize: GetBinaryPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ SpecialNearestFormat: ifGray8);
+
+ {ETC1Info: TImageFormatInfo = (
+ Format: ifETC1;
+ Name: 'ETC1';
+ ChannelCount: 3;
+ HasAlphaChannel: False;
+ IsSpecial: True;
+ IsPasstrough: True;
+ GetPixelsSize: GetBCPixelsSize;
+ CheckDimensions: CheckBCDimensions;
+ SpecialNearestFormat: ifR8G8B8);
+
+ ETC2RGBInfo: TImageFormatInfo = (
+ Format: ifETC2RGB;
+ Name: 'ETC2RGB';
+ ChannelCount: 3;
+ HasAlphaChannel: False;
+ IsSpecial: True;
+ IsPasstrough: True;
+ GetPixelsSize: GetBCPixelsSize;
+ CheckDimensions: CheckBCDimensions;
+ SpecialNearestFormat: ifR8G8B8);
+
+ ETC2RGBAInfo: TImageFormatInfo = (
+ Format: ifETC2RGBA;
+ Name: 'ETC2RGBA';
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsSpecial: True;
+ IsPasstrough: True;
+ GetPixelsSize: GetBCPixelsSize;
+ CheckDimensions: CheckBCDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);
+
+ ETC2PAInfo: TImageFormatInfo = (
+ Format: ifETC2PA;
+ Name: 'ETC2PA';
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsSpecial: True;
+ IsPasstrough: True;
+ GetPixelsSize: GetBCPixelsSize;
+ CheckDimensions: CheckBCDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);
+
+ DXBC6Info: TImageFormatInfo = (
+ Format: ifDXBC6;
+ Name: 'DXBC6';
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsSpecial: True;
+ IsPasstrough: True;
+ GetPixelsSize: GetBCPixelsSize;
+ CheckDimensions: CheckBCDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);
+
+ DXBC7Info: TImageFormatInfo = (
+ Format: ifDXBC6;
+ Name: 'DXBC7';
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsSpecial: True;
+ IsPasstrough: True;
+ GetPixelsSize: GetBCPixelsSize;
+ CheckDimensions: CheckBCDimensions;
+ SpecialNearestFormat: ifA8R8G8B8); }
+
+ {PVRTCInfo: TImageFormatInfo = (
+ Format: ifPVRTC;
+ Name: 'PVRTC';
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsSpecial: True;
+ IsPasstrough: True;
+ GetPixelsSize: GetBCPixelsSize;
+ CheckDimensions: CheckBCDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);}
+
{$WARNINGS ON}
function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward;
Infos[ifR16F] := @R16FInfo;
Infos[ifA16R16G16B16F] := @A16R16G16B16FInfo;
Infos[ifA16B16G16R16F] := @A16B16G16R16FInfo;
+ Infos[ifR32G32B32F] := @R32G32B32FInfo;
+ Infos[ifB32G32R32F] := @B32G32R32FInfo;
// special formats
Infos[ifDXT1] := @DXT1Info;
Infos[ifDXT3] := @DXT3Info;
Infos[ifBTC] := @BTCInfo;
Infos[ifATI1N] := @ATI1NInfo;
Infos[ifATI2N] := @ATI2NInfo;
+ Infos[ifBinary] := @BinaryInfo;
PFR3G3B2 := PixelFormat(0, 3, 3, 2);
PFX5R1G1B1 := PixelFormat(0, 1, 1, 1);
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;
+ 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;
function PFGetColor(const PF: TPixelFormatInfo; Color: LongWord): TColor32;
{$IFDEF USE_INLINE}inline;{$ENDIF}
begin
- Result := 0;
- 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;
+ //with PF, TColor32Rec(Result) do
+ begin
+ TColor32Rec(Result).A := (Color and PF.ABitMask shr PF.AShift) * 255 div PF.ARecDiv;
+ TColor32Rec(Result).R := (Color and PF.RBitMask shr PF.RShift) * 255 div PF.RRecDiv;
+ TColor32Rec(Result).G := (Color and PF.GBitMask shr PF.GShift) * 255 div PF.GRecDiv;
+ TColor32Rec(Result).B := (Color and PF.BBitMask shl PF.BShift) * 255 div PF.BRecDiv;
+ end;
end;
DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
const
Channel8BitMax: Single = 255.0;
-type
- TBufferItem = record
- A, R, G, B: Integer;
- end;
var
MapX, MapY: TMappingTable;
I, J, X, Y: LongInt;
XMinimum, XMaximum: LongInt;
LineBufferFP: array of TColorFPRec;
- LineBufferInt: array of TBufferItem;
ClusterX, ClusterY: TCluster;
Weight, AccumA, AccumR, AccumG, AccumB: Single;
- IWeight, IAccumA, IAccumR, IAccumG, IAccumB: Integer;
DstLine: PByte;
- SrcColor: TColor32Rec;
SrcFloat: TColorFPRec;
Info: TImageFormatInfo;
BytesPerChannel: LongInt;
- ChannelValueMax, InvChannelValueMax: Single;
- UseOptimizedVersion: Boolean;
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,
// Find min and max X coords of pixels that will contribute to target image
FindExtremes(MapX, XMinimum, XMaximum);
- if not UseOptimizedVersion then
+ SetLength(LineBufferFP, XMaximum - XMinimum + 1);
+ // Following code works for the rest of data formats
+ for J := 0 to DstHeight - 1 do
begin
- SetLength(LineBufferFP, XMaximum - XMinimum + 1);
- // Following code works for the rest of data formats
- for J := 0 to DstHeight - 1 do
+ // 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
- // 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
+ // Clear accumulators
+ AccumA := 0;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 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
- // Clear accumulators
- AccumA := 0;
- AccumR := 0;
- AccumG := 0;
- AccumB := 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 LineBufferFP[X - XMinimum] do
- begin
- A := AccumA;
- R := AccumR;
- G := AccumG;
- B := AccumB;
- end;
+ // 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;
-
- 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
+ // Store accumulated value for this pixel in buffer
+ with LineBufferFP[X - XMinimum] do
begin
- ClusterX := MapX[I];
- // Clear accumulator
- AccumA := 0;
- AccumR := 0;
- AccumG := 0;
- AccumB := 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 LineBufferFP[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);
+ A := AccumA;
+ R := AccumR;
+ G := AccumG;
+ B := AccumB;
end;
end;
- end
- else
- begin
- SetLength(LineBufferInt, XMaximum - XMinimum + 1);
- // Following code is optimized for images with 8 bit channels
- for J := 0 to DstHeight - 1 do
+
+ 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
- ClusterY := MapY[J];
- for X := XMinimum to XMaximum do
+ ClusterX := MapX[I];
+ // Clear accumulator
+ AccumA := 0;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 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
- IAccumA := 0;
- IAccumR := 0;
- IAccumG := 0;
- IAccumB := 0;
- for Y := 0 to Length(ClusterY) - 1 do
+ Weight := ClusterX[X].Weight;
+ with LineBufferFP[ClusterX[X].Pos - XMinimum] do
begin
- IWeight := Round(256 * ClusterY[Y].Weight);
- CopyPixel(
- @PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel],
- @SrcColor, Info.BytesPerPixel);
-
- IAccumB := IAccumB + SrcColor.B * IWeight;
- IAccumG := IAccumG + SrcColor.G * IWeight;
- IAccumR := IAccumR + SrcColor.R * IWeight;
- IAccumA := IAccumA + SrcColor.A * IWeight;
- end;
- with LineBufferInt[X - XMinimum] do
- begin
- A := IAccumA;
- R := IAccumR;
- G := IAccumG;
- B := IAccumB;
+ AccumB := AccumB + B * Weight;
+ AccumG := AccumG + G * Weight;
+ AccumR := AccumR + R * Weight;
+ AccumA := AccumA + A * Weight;
end;
end;
- DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX)* Info.BytesPerPixel];
-
- for I := 0 to DstWidth - 1 do
- begin
- ClusterX := MapX[I];
- IAccumA := 0;
- IAccumR := 0;
- IAccumG := 0;
- IAccumB := 0;
- for X := 0 to Length(ClusterX) - 1 do
- begin
- IWeight := Round(256 * ClusterX[X].Weight);
- with LineBufferInt[ClusterX[X].Pos - XMinimum] do
- begin
- IAccumB := IAccumB + B * IWeight;
- IAccumG := IAccumG + G * IWeight;
- IAccumR := IAccumR + R * IWeight;
- IAccumA := IAccumA + A * IWeight;
- end;
- end;
-
- SrcColor.B := ClampInt(IAccumB, 0, $00FF0000) shr 16;
- SrcColor.G := ClampInt(IAccumG, 0, $00FF0000) shr 16;
- SrcColor.R := ClampInt(IAccumR, 0, $00FF0000) shr 16;
- SrcColor.A := ClampInt(IAccumA, 0, $00FF0000) shr 16;
+ // Now compute final color to be written to dest image
+ SrcFloat.A := AccumA;
+ SrcFloat.R := AccumR;
+ SrcFloat.G := AccumG;
+ SrcFloat.B := AccumB;
- CopyPixel(@SrcColor, DstLine, Info.BytesPerPixel);
- Inc(DstLine, Info.BytesPerPixel);
- end;
+ Info.SetPixelFP(DstLine, @Info, nil, SrcFloat);
+ Inc(DstLine, Info.BytesPerPixel);
end;
end;
4: PLongWord(Dest)^ := PLongWord(Src)^;
6: PColor48Rec(Dest)^ := PColor48Rec(Src)^;
8: PInt64(Dest)^ := PInt64(Src)^;
+ 12: PColor96FPRec(Dest)^ := PColor96FPRec(Src)^;
16: PColorFPRec(Dest)^ := PColorFPRec(Src)^;
end;
end;
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);
+ 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);
+ 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);
+ 12: Result := (PFloatHelper(PixelA).Data = PFloatHelper(PixelB).Data) and
+ (PFloatHelper(PixelA).Data32 = PFloatHelper(PixelB).Data32);
+ 16: Result := (PFloatHelper(PixelA).Data = PFloatHelper(PixelB).Data) and
+ (PFloatHelper(PixelA).Data64 = PFloatHelper(PixelB).Data64);
else
Result := False;
end;
PixF.B := 0.0;
end;
+procedure ConvertToPixel32(SrcPix: PByte; DestPix: PColor32Rec;
+ const SrcInfo: TImageFormatInfo; SrcPalette: PPalette32);
+begin
+ case SrcInfo.Format of
+ ifIndex8:
+ begin
+ DestPix^ := SrcPalette[SrcPix^];
+ end;
+ ifGray8:
+ begin
+ DestPix.R := SrcPix^;
+ DestPix.G := SrcPix^;
+ DestPix.B := SrcPix^;
+ DestPix.A := 255;
+ end;
+ ifA8Gray8:
+ begin
+ DestPix.R := SrcPix^;
+ DestPix.G := SrcPix^;
+ DestPix.B := SrcPix^;
+ DestPix.A := PWordRec(SrcPix).High;
+ end;
+ ifGray16:
+ begin
+ DestPix.R := PWord(SrcPix)^ shr 8;
+ DestPix.G := DestPix.R;
+ DestPix.B := DestPix.R;
+ DestPix.A := 255;
+ end;
+ ifR8G8B8:
+ begin
+ DestPix.Color24Rec := PColor24Rec(SrcPix)^;
+ DestPix.A := 255;
+ end;
+ ifA8R8G8B8:
+ begin
+ DestPix^ := PColor32Rec(SrcPix)^;
+ end;
+ ifR16G16B16:
+ begin
+ DestPix.R := PColor48Rec(SrcPix).R shr 8;
+ DestPix.G := PColor48Rec(SrcPix).G shr 8;
+ DestPix.B := PColor48Rec(SrcPix).B shr 8;
+ DestPix.A := 255;
+ end;
+ ifA16R16G16B16:
+ begin
+ DestPix.R := PColor64Rec(SrcPix).R shr 8;
+ DestPix.G := PColor64Rec(SrcPix).G shr 8;
+ DestPix.B := PColor64Rec(SrcPix).B shr 8;
+ DestPix.A := PColor64Rec(SrcPix).A shr 8;
+ end;
+ else
+ DestPix^ := SrcInfo.GetPixel32(SrcPix, @SrcInfo, SrcPalette);
+ end;
+end;
+
procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
Bpp, WidthBytes: LongInt);
var
Move(PByteArray(DataIn)[I * WidthBytes], PByteArray(DataOut)[I * W], W);
end;
-procedure Convert1To8(DataIn, DataOut: Pointer; Width, Height,
- WidthBytes: LongInt);
+procedure Convert1To8(DataIn, DataOut: PByte; Width, Height,
+ WidthBytes: LongInt; ScaleTo8Bits: Boolean);
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);
+ Scaling: Byte = 255;
var
X, Y: LongInt;
+ InArray: PByteArray absolute DataIn;
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];
+ begin
+ DataOut^ := (InArray[Y * WidthBytes + X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
+ if ScaleTo8Bits then
+ DataOut^ := DataOut^ * Scaling;
+ Inc(DataOut);
+ end;
end;
-procedure Convert2To8(DataIn, DataOut: Pointer; Width, Height,
- WidthBytes: LongInt);
+procedure Convert2To8(DataIn, DataOut: PByte; Width, Height,
+ WidthBytes: LongInt; ScaleTo8Bits: Boolean);
const
Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03);
Shift2: array[0..3] of Byte = (6, 4, 2, 0);
+ Scaling: Byte = 85;
var
X, Y: LongInt;
+ InArray: PByteArray absolute DataIn;
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];
+ begin
+ DataOut^ := (InArray[Y * WidthBytes + X shr 2] and Mask2[X and 3]) shr Shift2[X and 3];
+ if ScaleTo8Bits then
+ DataOut^ := DataOut^ * Scaling;
+ Inc(DataOut);
+ end;
end;
-procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height,
- WidthBytes: LongInt);
+procedure Convert4To8(DataIn, DataOut: PByte; Width, Height,
+ WidthBytes: LongInt; ScaleTo8Bits: Boolean);
const
Mask4: array[0..1] of Byte = ($F0, $0F);
Shift4: array[0..1] of Byte = (4, 0);
+ Scaling: Byte = 17;
var
X, Y: LongInt;
+ InArray: PByteArray absolute DataIn;
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];
+ begin
+ DataOut^ := (InArray[Y * WidthBytes + X shr 1] and Mask4[X and 1]) shr Shift4[X and 1];
+ if ScaleTo8Bits then
+ DataOut^ := DataOut^ * Scaling;
+ Inc(DataOut);
+ end;
end;
function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean;
end;
end;
+function PaletteHasAlpha(Palette: PPalette32; PaletteEntries: Integer): Boolean;
+var
+ I: Integer;
+begin
+ for I := 0 to PaletteEntries - 1 do
+ begin
+ if Palette[I].A <> 255 then
+ begin
+ Result := True;
+ Exit;
+ end;
+ end;
+ Result := False;
+end;
+
function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
LineWidth, Index: LongInt): Pointer;
var
{
-
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:
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
+ // 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
+ // Common normalized number
Exp := Exp + (127 - 15);
Mantissa := Mantissa shl 13;
Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
end
else if (Exp = 0) and (Mantissa = 0) then
begin
- // zero - preserve sign
+ // Zero - preserve sign
Dst := Sign shl 31;
end
else if (Exp = 0) and (Mantissa <> 0) then
begin
- // denormalized number - renormalize it
+ // Denormalized number - renormalize it
while (Mantissa and $00000400) = 0 do
begin
Mantissa := Mantissa shl 1;
end;
Inc(Exp);
Mantissa := Mantissa and not $00000400;
- // now assemble normalized number
+ // Now assemble normalized number
Exp := Exp + (127 - 15);
Mantissa := Mantissa shl 13;
Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
end
else //if (Exp = 31) and (Mantisa <> 0) then
begin
- // not a number - preserve sign and mantissa
+ // Not a number - preserve sign and mantissa
Dst := (Sign shl 31) or $7F800000 or (Mantissa shl 13);
end;
- // reinterpret LongWord as Single
+ // Reinterpret LongWord as Single
Result := PSingle(@Dst)^;
end;
Sign, Exp, Mantissa: LongInt;
begin
Src := PLongWord(@Float)^;
- // extract sign, exponent, and mantissa from Single number
+ // 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
+ // 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
+ // Input float is zero - return zero
Result := 0;
end
else
begin
- // difficult case - lengthy conversion
+ // Difficult case - lengthy conversion
if Exp <= 0 then
begin
if Exp < -10 then
begin
- // input float's value is less than HalfMin, return zero
+ // Input float's value is less than HalfMin, return zero
Result := 0;
end
else
// 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
+ // Round to nearest
if (Mantissa and $00001000) > 0 then
Mantissa := Mantissa + $00002000;
- // assemble Sign and Mantissa (Exp is zero to get denotmalized number)
+ // Assemble Sign and Mantissa (Exp is zero to get denormalized number)
Result := (Sign shl 15) or (Mantissa shr 13);
end;
end
begin
if Mantissa = 0 then
begin
- // input float is infinity, create infinity half with original sign
+ // 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
+ // Input float is NaN, create half NaN with original sign and mantissa
Result := (Sign shl 15) or $7C00 or (Mantissa shr 13);
end;
end
begin
// Exp is > 0 so input float is normalized Single
- // round to nearest
+ // Round to nearest
if (Mantissa and $00001000) > 0 then
begin
Mantissa := Mantissa + $00002000;
if Exp > 30 then
begin
- // exponent overflow - return infinity half
+ // Exponent overflow - return infinity half
Result := (Sign shl 15) or $7C00;
end
else
- // assemble normalized half
+ // Assemble normalized half
Result := (Sign shl 15) or (Exp shl 10) or (Mantissa shr 13);
end;
end;
var
A, R, G, B: Byte;
begin
- FillChar(Pix, SizeOf(Pix), 0);
A := 0;
R := 0;
G := 0;
B := 0;
+ FillChar(Pix, SizeOf(Pix), 0);
// returns 64 bit color value with 16 bits for each channel
case SrcInfo.BytesPerPixel of
1:
var
PixHF: TColorHFRec;
begin
- if SrcInfo.BytesPerPixel in [4, 16] then
+ Assert(SrcInfo.BytesPerPixel in [2, 4, 8, 12, 16]);
+
+ if SrcInfo.BytesPerPixel in [4, 12, 16] then
begin
// IEEE 754 single-precision channels
FillChar(Pix, SizeOf(Pix), 0);
case SrcInfo.BytesPerPixel of
4: Pix.R := PSingle(Src)^;
+ 12: Pix.Color96Rec := PColor96FPRec(Src)^;
16: Pix := PColorFPRec(Src)^;
end;
end
else
begin
- // half float channels
+ // Half float channels
FillChar(PixHF, SizeOf(PixHF), 0);
case SrcInfo.BytesPerPixel of
2: PixHF.R := PHalfFloat(Src)^;
end;
Pix := ColorHalfToFloat(PixHF);
end;
- // if src has no alpha, we set it to max (otherwise we would have to
+
+ // 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;
PixW: TColorFPRec;
PixHF: TColorHFRec;
begin
+ Assert(DstInfo.BytesPerPixel in [2, 4, 8, 12, 16]);
+
PixW := Pix;
if DstInfo.IsRBSwapped then
SwapValues(PixW.R, PixW.B);
- if DstInfo.BytesPerPixel in [4, 16] then
+
+ if DstInfo.BytesPerPixel in [4, 12, 16] then
begin
case DstInfo.BytesPerPixel of
- 4: PSingle(Dst)^ := PixW.R;
+ 4: PSingle(Dst)^ := PixW.R;
+ 12: PColor96FPRec(Dst)^:= PixW.Color96Rec;
16: PColorFPRec(Dst)^ := PixW;
end;
end
PWordArray(Dst)[I] := PByteArray(Src)[I] shl 8;
end
else
+ begin
if (DstInfo.Format = ifGray8) and (SrcInfo.Format = ifGray16) then
begin
for I := 0 to NumPixels - 1 do
Inc(Src, SrcInfo.BytesPerPixel);
Inc(Dst, DstInfo.BytesPerPixel);
end;
+ end;
end;
procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
end;
end;
+procedure EncodeBinary(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
+var
+ Src: PByte absolute SrcBits;
+ Bitmap: PByteArray absolute DestBits;
+ X, Y, WidthBytes: Integer;
+ PixelTresholded, Treshold: Byte;
+begin
+ Treshold := ClampToByte(GetOption(ImagingBinaryTreshold));
+ WidthBytes := (Width + 7) div 8;
+
+ for Y := 0 to Height - 1 do
+ for X := 0 to Width - 1 do
+ begin
+ if Src^ > Treshold then
+ PixelTresholded := 255
+ else
+ PixelTresholded := 0;
+
+ Bitmap[Y * WidthBytes + X div 8] := Bitmap[Y * WidthBytes + X div 8] or // OR current value of byte with following:
+ (PixelTresholded and 1) // To make 1 from 255, 0 remains 0
+ shl (7 - (X mod 8)); // Put current bit to proper place in byte
+
+ Inc(Src);
+ end;
+end;
+
procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: Integer);
var
X, Y, I, J, K: Integer;
end;
end;
+procedure DecodeBinary(SrcBits, DestBits: PByte; Width, Height: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
+begin
+ Convert1To8(SrcBits, DestBits, Width, Height, (Width + 7) div 8, True);
+end;
+
procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer;
SpecialFormat: TImageFormat);
begin
ifBTC: DecodeBTC (SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
ifATI1N: DecodeATI1N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
ifATI2N: DecodeATI2N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ ifBinary: DecodeBinary(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
end;
end;
ifBTC: EncodeBTC (SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
ifATI1N: EncodeATI1N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
ifATI2N: EncodeATI2N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ ifBinary: EncodeBinary(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
end;
end;
Result := Width * Height div 4; // 2bits/pixel
end;
+function GetBCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
+begin
+ raise ENotImplemented.Create();
+end;
+
+procedure CheckBCDimensions(Format: TImageFormat; var Width, Height: LongInt);
+begin
+ raise ENotImplemented.Create();
+end;
+
+function GetBinaryPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
+begin
+ // Binary images are aligned on BYTE boundary
+ Result := ((Width + 7) div 8) * Height; // 1bit/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;
function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
begin
- result.A := 0;
- result.R := 0;
- result.G := 0;
- result.B := 0;
+ Result.A := 0;
+ Result.R := 0;
+ Result.G := 0;
+ Result.B := 0;
case Info.Format of
ifR8G8B8, ifX8R8G8B8:
begin
function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
begin
- result.A := 0.0;
- result.R := 0.0;
- result.G := 0.0;
- result.B := 0.0;
+ Result.A := 0;
+ Result.R := 0;
+ Result.G := 0;
+ Result.B := 0;
case Info.Format of
ifR8G8B8, ifX8R8G8B8:
begin
function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
begin
- result.A := 0.0;
- result.R := 0.0;
- result.G := 0.0;
- result.B := 0.0;
case Info.Format of
- ifA32R32G32B32F:
+ ifA32R32G32B32F, ifA32B32G32R32F:
begin
Result := PColorFPRec(Bits)^;
end;
- ifA32B32G32R32F:
+ ifR32G32B32F, ifB32G32R32F:
begin
- Result := PColorFPRec(Bits)^;
- SwapValues(Result.R, Result.B);
+ Result.A := 1.0;
+ Result.Color96Rec := PColor96FPRec(Bits)^;
end;
ifR32F:
begin
Result.B := 0.0;
end;
end;
+ if Info.IsRBSwapped then
+ SwapValues(Result.R, Result.B);
end;
procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
begin
case Info.Format of
- ifA32R32G32B32F:
+ ifA32R32G32B32F, ifA32B32G32R32F:
begin
PColorFPRec(Bits)^ := Color;
end;
- ifA32B32G32R32F:
+ ifR32G32B32F, ifB32G32R32F:
begin
- PColorFPRec(Bits)^ := Color;
- SwapValues(PColorFPRec(Bits).R, PColorFPRec(Bits).B);
+ PColor96FPRec(Bits)^ := Color.Color96Rec;
end;
ifR32F:
begin
PSingle(Bits)^ := Color.R;
end;
end;
+ if Info.IsRBSwapped then
+ SwapValues(PColor96FPRec(Bits).R, PColor96FPRec(Bits).B);
end;
initialization
-- TODOS ----------------------------------------------------
- nothing now
+ -- 0.77 Changes/Bug Fixes -------------------------------------
+ - NOT YET: Added support for Passtrough image data formats.
+ - Added ConvertToPixel32 helper function.
+
+ -- 0.26.5 Changes/Bug Fixes -----------------------------------
+ - Removed optimized codepatch for few data formats from StretchResample
+ function. It was quite buggy and not so much faster anyway.
+ - Added PaletteHasAlpha function.
+ - Added support functions for ifBinary data format.
+ - Added optional pixel scaling to Convert1To8, Convert2To8,
+ abd Convert4To8 functions.
+
-- 0.26.3 Changes/Bug Fixes -----------------------------------
- Filtered resampling ~10% faster now.
- Fixed DXT3 alpha encoding.
index 0f3d9cda99575daca473c9318aa91ed227b6c30f..a38e33adbb67ccde804a5a65ca4d5d4e8dcfa754 100644 (file)
{
- $Id: ImagingGif.pas 157 2009-02-15 14:24:58Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle;
Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer);
protected
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
- constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
const
GIFSignature: TChar3 = 'GIF';
GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a');
+ GIFDefaultDelay = 65;
// Masks for accessing fields in PackedFields of TGIFHeader
GIFGlobalColorTable = $80;
GIFUserInput = $02;
GIFDisposalMethod = $1C;
+const
+ // Netscape sub block types
+ GIFAppLoopExtension = 1;
+ GIFAppBufferExtension = 2;
+
type
TGIFHeader = packed record
// File header part
Terminator: Byte;
end;
-const
- // Netscape sub block types
- GIFAppLoopExtension = 1;
- GIFAppBufferExtension = 2;
-
type
TGIFIdentifierCode = array[0..7] of AnsiChar;
TGIFAuthenticationCode = array[0..2] of AnsiChar;
TGIFFileFormat implementation
}
-constructor TGIFFileFormat.Create;
+procedure TGIFFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SGIFFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := True;
+ FFeatures := [ffLoad, ffSave, ffMultiImage];
FSupportedFormats := GIFSupportedFormats;
FLoadAnimated := GIFDefaultLoadAnimated;
RawCode := Context.Buf[Word(ByteIndex)] +
(Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
if Context.CodeSize > 8 then
- RawCode := RawCode + (LongInt(Context.Buf[ByteIndex + 2]) shl 16);
+ RawCode := RawCode + (Integer(Context.Buf[ByteIndex + 2]) shl 16);
RawCode := RawCode shr (Context.Inx and 7);
Context.Inx := Context.Inx + Byte(Context.CodeSize);
Result := RawCode and Context.ReadMask;
if BlockSize >= SizeOf(AppRec) then
begin
Read(Handle, @AppRec, SizeOf(AppRec));
- if (AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0') then
+ if ((AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0')) or
+ ((AppRec.Identifier = 'ANIMEXTS') and (AppRec.Authentication = '1.0')) then
begin
Read(Handle, @BlockSize, SizeOf(BlockSize));
while BlockSize <> 0 do
// Read loop count
Read(Handle, @LoopCount, SizeOf(LoopCount));
Dec(BlockSize, SizeOf(LoopCount));
+ if LoopCount > 0 then
+ Inc(LoopCount); // Netscape extension is really "repeats" not "loops"
+ FMetadata.SetMetaItem(SMetaAnimationLoops, LoopCount);
end;
GIFAppBufferExtension:
begin
FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
end;
+ FMetadata.SetMetaItem(SMetaFrameDelay, Integer(GraphicExt.DelayTime * 10), Idx);
end
else
FrameInfos[Idx].HasTransparency := False;
end;
end;
+ procedure SetFrameDelay(Idx: Integer; var Ext: TGraphicControlExtension);
+ begin
+ if FMetadata.HasMetaItemForSaving(SMetaFrameDelay, Idx) then
+ Ext.DelayTime := FMetadata.MetaItemsForSavingMulti[SMetaFrameDelay, Idx] div 10
+ else
+ Ext.DelayTime := GIFDefaultDelay;
+ end;
+
+ procedure SaveGlobalMetadata;
+ var
+ AppExt: TGIFApplicationRec;
+ BlockSize, LoopExtId: Byte;
+ Repeats: Word;
+ begin
+ if FMetadata.HasMetaItemForSaving(SMetaAnimationLoops) then
+ with GetIO do
+ begin
+ FillChar(AppExt, SizeOf(AppExt), 0);
+ AppExt.Identifier := 'NETSCAPE';
+ AppExt.Authentication := '2.0';
+ Repeats := FMetadata.MetaItemsForSaving[SMetaAnimationLoops];
+ if Repeats > 0 then
+ Dec(Repeats);
+ LoopExtId := GIFAppLoopExtension;
+
+ Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
+ Write(Handle, @GIFApplicationExtension, SizeOf(GIFApplicationExtension));
+ BlockSize := 11;
+ Write(Handle, @BlockSize, SizeOf(BlockSize));
+ Write(Handle, @AppExt, SizeOf(AppExt));
+ BlockSize := 3;
+ Write(Handle, @BlockSize, SizeOf(BlockSize));
+ Write(Handle, @LoopExtId, SizeOf(LoopExtId));
+ Write(Handle, @Repeats, SizeOf(Repeats));
+ Write(Handle, @GIFBlockTerminator, SizeOf(GIFBlockTerminator));
+ end;
+ end;
+
begin
// Fill header with data, select size of largest image in array as
// logical screen size
// Prepare default GC extension with delay
FillChar(GraphicExt, Sizeof(GraphicExt), 0);
- GraphicExt.DelayTime := 65;
+ GraphicExt.DelayTime := GIFDefaultDelay;
GraphicExt.BlockSize := 4;
+ SaveGlobalMetadata;
+
for I := FFirstIdx to FLastIdx do
begin
if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
// Write Graphic Control Extension with default delay
Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension));
+ SetFrameDelay(I, GraphicExt);
Write(Handle, @GraphicExt, SizeOf(GraphicExt));
// Write frame marker and fill and write image descriptor for this frame
Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor));
Write(Handle, @Palette[J].B, SizeOf(Palette[J].B));
end;
- // Fonally compress image data
+ // Finally compress image data
LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits);
finally
function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
Header: TGIFHeader;
- ReadCount: LongInt;
+ ReadCount: Integer;
begin
Result := False;
if Handle <> nil then
-- TODOS ----------------------------------------------------
- nothing now
+ -- 0.77 Changes/Bug Fixes -----------------------------------
+ - Fixed crash when resaving GIF with animation metadata.
+ - Writes frame delays of GIF animations from metadata.
+ - Reads and writes looping of GIF animations stored into/from metadata.
+
+ -- 0.26.5 Changes/Bug Fixes ---------------------------------
+ - Reads frame delays from GIF animations into metadata.
+
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Fixed bug - loading of GIF with NETSCAPE app extensions
failed with Delphi 2009.
index c26b4512184c1319f14404374441bc0a1bc4f35a..32d2bc2865f250b2100246e59e8a07cf9a9a308f 100644 (file)
{
- $Id: ImagingIO.pas 100 2007-06-28 21:09:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
function GetInputSize(IOFunctions: TIOFunctions; Handle: TImagingHandle): LongInt;
{ Helper function that initializes TMemoryIORec with given params.}
function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec;
+{ Reads one text line from input (CR+LF, CR, or LF as line delimiter).}
+function ReadLine(IOFunctions: TIOFunctions; Handle: TImagingHandle;
+ out Line: AnsiString; FailOnControlChars: Boolean = False): Boolean;
+{ Writes one text line to input with optional line delimiter.}
+procedure WriteLine(IOFunctions: TIOFunctions; Handle: TImagingHandle;
+ const Line: AnsiString; const LineEnding: AnsiString = sLineBreak);
implementation
type
{ Based on TaaBufferedStream
Copyright (c) Julian M Bucknall 1997, 1999 }
- TBufferedStream = class(TObject)
+ TBufferedStream = class
private
FBuffer: PByteArray;
FBufSize: Integer;
{ File IO functions }
-function FileOpenRead(FileName: PChar): TImagingHandle; cdecl;
+function FileOpen(FileName: PChar; Mode: TOpenMode): TImagingHandle; cdecl;
+var
+ Stream: TStream;
begin
- Result := TBufferedStream.Create(TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite));
-end;
+ Stream := nil;
-function FileOpenWrite(FileName: PChar): TImagingHandle; cdecl;
-begin
- Result := TBufferedStream.Create(TFileStream.Create(FileName, fmCreate or fmShareDenyWrite));
+ case Mode of
+ omReadOnly: Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
+ omCreate: Stream := TFileStream.Create(FileName, fmCreate);
+ omReadWrite:
+ begin
+ if FileExists(FileName) then
+ Stream := TFileStream.Create(FileName, fmOpenReadWrite or fmShareExclusive)
+ else
+ Stream := TFileStream.Create(FileName, fmCreate);
+ end;
+ end;
+
+ Assert(Stream <> nil);
+ Result := TBufferedStream.Create(Stream);
end;
procedure FileClose(Handle: TImagingHandle); cdecl;
{ Stream IO functions }
-function StreamOpenRead(FileName: PChar): TImagingHandle; cdecl;
-begin
- Result := FileName;
-end;
-
-function StreamOpenWrite(FileName: PChar): TImagingHandle; cdecl;
+function StreamOpen(FileName: PChar; Mode: TOpenMode): TImagingHandle; cdecl;
begin
Result := FileName;
end;
{ Memory IO functions }
-function MemoryOpenRead(FileName: PChar): TImagingHandle; cdecl;
-begin
- Result := FileName;
-end;
-
-function MemoryOpenWrite(FileName: PChar): TImagingHandle; cdecl;
+function MemoryOpen(FileName: PChar; Mode: TOpenMode): TImagingHandle; cdecl;
begin
Result := FileName;
end;
Result.Size := Size;
end;
+function ReadLine(IOFunctions: TIOFunctions; Handle: TImagingHandle;
+ out Line: AnsiString; FailOnControlChars: Boolean): Boolean;
+const
+ MaxLine = 1024;
+var
+ EolPos, Pos: Integer;
+ C: AnsiChar;
+ EolReached: Boolean;
+ Endings: set of AnsiChar;
+begin
+ Line := '';
+ Pos := 0;
+ EolPos := 0;
+ EolReached := False;
+ Endings := [#10, #13];
+ Result := True;
+
+ while not IOFunctions.Eof(Handle) do
+ begin
+ IOFunctions.Read(Handle, @C, SizeOf(C));
+
+ if FailOnControlChars and (Byte(C) < $20) then
+ begin
+ Break;
+ end;
+
+ if not (C in Endings) then
+ begin
+ if EolReached then
+ begin
+ IOFunctions.Seek(Handle, EolPos, smFromBeginning);
+ Exit;
+ end
+ else
+ begin
+ SetLength(Line, Length(Line) + 1);
+ Line[Length(Line)] := C;
+ end;
+ end
+ else if not EolReached then
+ begin
+ EolReached := True;
+ EolPos := IOFunctions.Tell(Handle);
+ end;
+
+ Inc(Pos);
+ if Pos >= MaxLine then
+ begin
+ Break;
+ end;
+ end;
+
+ Result := False;
+ IOFunctions.Seek(Handle, -Pos, smFromCurrent);
+end;
+
+procedure WriteLine(IOFunctions: TIOFunctions; Handle: TImagingHandle;
+ const Line: AnsiString; const LineEnding: AnsiString);
+var
+ ToWrite: AnsiString;
+begin
+ ToWrite := Line + LineEnding;
+ IOFunctions.Write(Handle, @ToWrite[1], Length(ToWrite));
+end;
+
initialization
- OriginalFileIO.OpenRead := FileOpenRead;
- OriginalFileIO.OpenWrite := FileOpenWrite;
+ OriginalFileIO.Open := FileOpen;
OriginalFileIO.Close := FileClose;
OriginalFileIO.Eof := FileEof;
OriginalFileIO.Seek := FileSeek;
OriginalFileIO.Read := FileRead;
OriginalFileIO.Write := FileWrite;
- StreamIO.OpenRead := StreamOpenRead;
- StreamIO.OpenWrite := StreamOpenWrite;
+ StreamIO.Open := StreamOpen;
StreamIO.Close := StreamClose;
StreamIO.Eof := StreamEof;
StreamIO.Seek := StreamSeek;
StreamIO.Read := StreamRead;
StreamIO.Write := StreamWrite;
- MemoryIO.OpenRead := MemoryOpenRead;
- MemoryIO.OpenWrite := MemoryOpenWrite;
+ MemoryIO.Open := MemoryOpen;
MemoryIO.Close := MemoryClose;
MemoryIO.Eof := MemoryEof;
MemoryIO.Seek := MemorySeek;
-- TODOS ----------------------------------------------------
- nothing now
+ -- 0.77.1 ---------------------------------------------------
+ - Updated IO Open functions according to changes in ImagingTypes.
+ - Added ReadLine and WriteLine functions.
+
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added merge between buffered read-only and write-only file
stream adapters - TIFF saving needed both reading and writing.
index f01d183273e465e8fdb0c21ac50718e12d9fef3e..ef9a5e7e2629a60f9bed2daac20820a5a074bf51 100644 (file)
{
- $Id: ImagingJpeg.pas 168 2009-08-22 18:50:21Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
{ $DEFINE PASJPEG}
{ Automatically use FPC's PasJpeg when compiling with Lazarus. But not when
- WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html}
+ WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html.
+ Fixed in FPC revision 13963: http://bugs.freepascal.org/view.php?id=14928 }
{$IF Defined(LCL) and not Defined(WINDOWS)}
{$UNDEF IMJPEGLIB}
{$DEFINE PASJPEG}
{$IFEND}
+{ We usually want to skip the rest of the corrupted file when loading JEPG files
+ instead of getting exception. JpegLib's error handler can only be
+ exited using setjmp/longjmp ("non-local goto") functions to get error
+ recovery when loading corrupted JPEG files. This is implemented in assembler
+ and currently available only for 32bit Delphi targets and FPC.}
+{$DEFINE ErrorJmpRecovery}
+{$IF Defined(DCC) and not Defined(CPUX86)}
+ {$UNDEF ErrorJmpRecovery}
+{$IFEND}
+
interface
uses
FQuality: LongInt;
FProgressive: LongBool;
procedure SetJpegIO(const JpegIO: TIOFunctions); virtual;
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
- constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
procedure CheckOptionsValidity; override;
published
{ Intenal unit jpeglib support functions }
+{$IFDEF ErrorJmpRecovery}
+ {$IFDEF DCC}
+ type
+ jmp_buf = record
+ EBX,
+ ESI,
+ EDI,
+ ESP,
+ EBP,
+ EIP: LongWord;
+ end;
+ pjmp_buf = ^jmp_buf;
+
+ { JmpLib SetJmp/LongJmp Library
+ (C)Copyright 2003, 2004 Will DeWitt Jr. <edge@boink.net> }
+ function SetJmp(out jmpb: jmp_buf): Integer;
+ asm
+ { -> EAX jmpb }
+ { <- EAX Result }
+ MOV EDX, [ESP] // Fetch return address (EIP)
+ // Save task state
+ MOV [EAX+jmp_buf.&EBX], EBX
+ MOV [EAX+jmp_buf.&ESI], ESI
+ MOV [EAX+jmp_buf.&EDI], EDI
+ MOV [EAX+jmp_buf.&ESP], ESP
+ MOV [EAX+jmp_buf.&EBP], EBP
+ MOV [EAX+jmp_buf.&EIP], EDX
+
+ SUB EAX, EAX
+ @@1:
+ end;
+
+ procedure LongJmp(const jmpb: jmp_buf; retval: Integer);
+ asm
+ { -> EAX jmpb }
+ { EDX retval }
+ { <- EAX Result }
+ XCHG EDX, EAX
+
+ MOV ECX, [EDX+jmp_buf.&EIP]
+ // Restore task state
+ MOV EBX, [EDX+jmp_buf.&EBX]
+ MOV ESI, [EDX+jmp_buf.&ESI]
+ MOV EDI, [EDX+jmp_buf.&EDI]
+ MOV ESP, [EDX+jmp_buf.&ESP]
+ MOV EBP, [EDX+jmp_buf.&EBP]
+ MOV [ESP], ECX // Restore return address (EIP)
+
+ TEST EAX, EAX // Ensure retval is <> 0
+ JNZ @@1
+ MOV EAX, 1
+ @@1:
+ end;
+ {$ENDIF}
+
+type
+ TJmpBuf = jmp_buf;
+ TErrorClientData = record
+ JmpBuf: TJmpBuf;
+ ScanlineReadReached: Boolean;
+ end;
+ PErrorClientData = ^TErrorClientData;
+{$ENDIF}
+
procedure JpegError(CInfo: j_common_ptr);
-var
- Buffer: string;
+
+ procedure RaiseError;
+ var
+ Buffer: AnsiString;
+ begin
+ // Create the message and raise exception
+ CInfo.err.format_message(CInfo, Buffer);
+ // Warning: you can get "Invalid argument index in format" exception when
+ // using FPC (see http://bugs.freepascal.org/view.php?id=21229).
+ // Fixed in FPC 2.7.1
+ {$IF Defined(FPC) and (FPC_FULLVERSION <= 20701)}
+ raise EImagingError.CreateFmt(SJPEGError + ' %d', [CInfo.err.msg_code]);
+ {$ELSE}
+ raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + string(Buffer), [CInfo.err.msg_code]);
+ {$IFEND}
+ end;
+
begin
- { Create the message and raise exception }
- CInfo^.err^.format_message(CInfo, buffer);
- raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + Buffer, [CInfo.err^.msg_code]);
+{$IFDEF ErrorJmpRecovery}
+ // Only recovers on loads and when header is sucessfully loaded
+ // (error occurs when reading scanlines)
+ if (CInfo.client_data <> nil) and
+ PErrorClientData(CInfo.client_data).ScanlineReadReached then
+ begin
+ // Non-local jump to error handler in TJpegFileFormat.LoadData
+ longjmp(PErrorClientData(CInfo.client_data).JmpBuf, 1)
+ end
+ else
+ RaiseError;
+{$ELSE}
+ RaiseError;
+{$ENDIF}
end;
procedure OutputMessage(CurInfo: j_common_ptr);
if NBytes <= 0 then
begin
- PChar(Src.Buffer)[0] := #$FF;
- PChar(Src.Buffer)[1] := Char(JPEG_EOI);
+ PByteArray(Src.Buffer)[0] := $FF;
+ PByteArray(Src.Buffer)[1] := JPEG_EOI;
NBytes := 2;
end;
Src.Pub.next_input_byte := Src.Buffer;
Dest.Output := Handle;
end;
-procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
+procedure SetupErrorMgr(var jc: TJpegContext);
begin
- FillChar(jc, sizeof(jc), 0);
// Set standard error handlers and then override some
jc.common.err := jpeg_std_error(JpegErrorMgr);
jc.common.err.error_exit := JpegError;
jc.common.err.output_message := OutputMessage;
+end;
+procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
+begin
jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
JpegStdioSrc(jc.d, Handle);
jpeg_read_header(@jc.d, True);
procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
Saver: TJpegFileFormat);
begin
- FillChar(jc, sizeof(jc), 0);
- // Set standard error handlers and then override some
- jc.common.err := jpeg_std_error(JpegErrorMgr);
- jc.common.err.error_exit := JpegError;
- jc.common.err.output_message := OutputMessage;
-
jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
JpegStdioDest(jc.c, Handle);
if Saver.FGrayScale then
jc.c.in_color_space := JCS_GRAYSCALE
else
- jc.c.in_color_space := JCS_YCbCr;
+ jc.c.in_color_space := JCS_RGB;
jpeg_set_defaults(@jc.c);
jpeg_set_quality(@jc.c, Saver.FQuality, True);
if Saver.FProgressive then
{ TJpegFileFormat class implementation }
-constructor TJpegFileFormat.Create;
+procedure TJpegFileFormat.Define;
begin
- inherited Create;
FName := SJpegFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
+ FFeatures := [ffLoad, ffSave];
FSupportedFormats := JpegSupportedFormats;
FQuality := JpegDefaultQuality;
jc: TJpegContext;
Info: TImageFormatInfo;
Col32: PColor32Rec;
-{$IFDEF RGBSWAPPED}
+ NeedsRedBlueSwap: Boolean;
Pix: PColor24Rec;
+{$IFDEF ErrorJmpRecovery}
+ ErrorClient: TErrorClientData;
{$ENDIF}
+
+ procedure LoadMetaData;
+ var
+ XDensity, YDensity: Single;
+ ResUnit: TResolutionUnit;
+ begin
+ // Density unit: 0 - undef, 1 - inch, 2 - cm
+ if jc.d.saw_JFIF_marker and (jc.d.density_unit > 0) and
+ (jc.d.X_density > 0) and (jc.d.Y_density > 0) then
+ begin
+ XDensity := jc.d.X_density;
+ YDensity := jc.d.Y_density;
+ ResUnit := ruDpi;
+ if jc.d.density_unit = 2 then
+ ResUnit := ruDpcm;
+ FMetadata.SetPhysicalPixelSize(ResUnit, XDensity, YDensity);
+ end;
+ end;
+
begin
// Copy IO functions to global var used in JpegLib callbacks
Result := False;
with JIO, Images[0] do
try
+ ZeroMemory(@jc, SizeOf(jc));
+ SetupErrorMgr(jc);
+ {$IFDEF ErrorJmpRecovery}
+ ZeroMemory(@ErrorClient, SizeOf(ErrorClient));
+ jc.common.client_data := @ErrorClient;
+ if setjmp(ErrorClient.JmpBuf) <> 0 then
+ begin
+ Result := True;
+ Exit;
+ end;
+ {$ENDIF}
InitDecompressor(Handle, jc);
+
case jc.d.out_color_space of
JCS_GRAYSCALE: Format := ifGray8;
JCS_RGB: Format := ifR8G8B8;
else
Exit;
end;
+
NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
jpeg_start_decompress(@jc.d);
GetImageFormatInfo(Format, Info);
LinesPerCall := 1;
Dest := Bits;
+ // If Jpeg's colorspace is RGB and not YCbCr we need to swap
+ // R and B to get Imaging's native order
+ NeedsRedBlueSwap := jc.d.jpeg_color_space = JCS_RGB;
+ {$IFDEF RGBSWAPPED}
+ // Force R-B swap for FPC's PasJpeg
+ NeedsRedBlueSwap := True;
+ {$ENDIF}
+
+ {$IFDEF ErrorJmpRecovery}
+ ErrorClient.ScanlineReadReached := True;
+ {$ENDIF}
+
while jc.d.output_scanline < jc.d.output_height do
begin
LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
- {$IFDEF RGBSWAPPED}
- if Format = ifR8G8B8 then
+ if NeedsRedBlueSwap and (Format = ifR8G8B8) then
begin
Pix := PColor24Rec(Dest);
for I := 0 to Width - 1 do
Inc(Pix);
end;
end;
- {$ENDIF}
Inc(Dest, PtrInc * LinesRead);
end;
end;
end;
+ // Store supported metadata
+ LoadMetaData;
+
jpeg_finish_output(@jc.d);
jpeg_finish_decompress(@jc.d);
Result := True;
I: LongInt;
Pix: PColor24Rec;
{$ENDIF}
+
+ procedure SaveMetaData;
+ var
+ XRes, YRes: Single;
+ begin
+ if FMetadata.GetPhysicalPixelSize(ruDpcm, XRes, YRes, True) then
+ begin
+ jc.c.density_unit := 2; // Dots per cm
+ jc.c.X_density := Round(XRes);
+ jc.c.Y_density := Round(YRes)
+ end;
+ end;
+
begin
Result := False;
// Copy IO functions to global var used in JpegLib callbacks
SetJpegIO(GetIO);
+
// Makes image to save compatible with Jpeg saving capabilities
if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
with JIO, ImageToSave do
try
+ ZeroMemory(@jc, SizeOf(jc));
+ SetupErrorMgr(jc);
+
GetImageFormatInfo(Format, Info);
FGrayScale := Format = ifGray8;
InitCompressor(Handle, jc, Self);
GetMem(Line, PtrInc);
{$ENDIF}
+ // Save supported metadata
+ SaveMetaData;
+
jpeg_start_compress(@jc.c, True);
while (jc.c.next_scanline < jc.c.image_height) do
begin
-- TODOS ----------------------------------------------------
- nothing now
+ -- 0.77.1 ---------------------------------------------------
+ - Able to read corrupted JPEG files - loads partial image
+ and skips the corrupted parts (FPC and x86 Delphi).
+ - Fixed reading of physical resolution metadata, could cause
+ "divided by zero" later on for some files.
+
+ -- 0.26.5 Changes/Bug Fixes ---------------------------------
+ - Fixed loading of some JPEGs with certain APPN markers (bug in JpegLib).
+ - Fixed swapped Red-Blue order when loading Jpegs with
+ jc.d.jpeg_color_space = JCS_RGB.
+ - Added loading and saving of physical pixel size metadata.
+
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Changed the Jpeg error manager, messages were not properly formated.
diff --git a/src/lib/vampimg/ImagingNetworkGraphics.pas b/src/lib/vampimg/ImagingNetworkGraphics.pas
index 7b2ab93a5e0f8245634f17fd291fc0dfe036890f..364cbcf42ac0afb9d41e94ada37de6cd15351a97 100644 (file)
{
- $Id: ImagingNetworkGraphics.pas 171 2009-09-02 01:34:19Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
{$I ImagingOptions.inc}
-{ If MN support is enabled we must make sure PNG and JNG are enabled too.}
+{ If MNG support is enabled we must make sure PNG and JNG are enabled too.}
{$IFNDEF DONT_LINK_MNG}
{$UNDEF DONT_LINK_PNG}
{$UNDEF DONT_LINK_JNG}
FLossyAlpha: LongBool;
FQuality: LongInt;
FProgressive: LongBool;
+ FZLibStategy: Integer;
function GetSupportedFormats: TImageFormats; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
+ procedure Define; override;
public
- constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
procedure CheckOptionsValidity; override;
published
private
FLoadAnimated: LongBool;
protected
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
- public
- constructor Create; override;
published
property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
end;
Many frame compression settings can be modified by options interface.}
TMNGFileFormat = class(TNetworkGraphicsFileFormat)
protected
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
- public
- constructor Create; override;
end;
{$ENDIF}
with alpha = 0).}
TJNGFileFormat = class(TNetworkGraphicsFileFormat)
protected
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
- public
- constructor Create; override;
end;
{$ENDIF}
NGDefaultQuality = 90;
NGLosslessFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8, ifGray16,
ifA16Gray16, ifR8G8B8, ifA8R8G8B8, ifR16G16B16, ifA16R16G16B16, ifB16G16R16,
- ifA16B16G16R16];
+ ifA16B16G16R16, ifBinary];
NGLossyFormats: TImageFormats = [ifGray8, ifA8Gray8, ifR8G8B8, ifA8R8G8B8];
PNGDefaultLoadAnimated = True;
+ NGDefaultZLibStartegy = 1; // Z_FILTERED
SPNGFormatName = 'Portable Network Graphics';
SPNGMasks = '*.png';
end;
PfcTL = ^TfcTL;
+ { pHYs chunk format - encodes the absolute or relative dimensions of pixels.}
+ TpHYs = packed record
+ PixelsPerUnitX: LongWord;
+ PixelsPerUnitY: LongWord;
+ UnitSpecifier: Byte;
+ end;
+ PpHYs = ^TpHYs;
+
const
{ PNG file identifier.}
PNGSignature: TChar8 = #$89'PNG'#$0D#$0A#$1A#$0A;
acTLChunk: TChar4 = 'acTL';
fcTLChunk: TChar4 = 'fcTL';
fdATChunk: TChar4 = 'fdAT';
+ pHYsChunk: TChar4 = 'pHYs';
{ APNG frame dispose operations.}
DisposeOpNone = 0;
type
{ Helper class that holds information about MNG frame in PNG or JNG format.}
- TFrameInfo = class(TObject)
+ TFrameInfo = class
public
+ Index: Integer;
FrameWidth, FrameHeight: LongInt;
IsJpegFrame: Boolean;
IHDR: TIHDR;
JHDR: TJHDR;
fcTL: TfcTL;
+ pHYs: TpHYs;
Palette: PPalette24;
PaletteEntries: LongInt;
Transparency: Pointer;
IDATMemory: TMemoryStream;
JDATMemory: TMemoryStream;
JDAAMemory: TMemoryStream;
- constructor Create;
+ constructor Create(AIndex: Integer);
destructor Destroy; override;
procedure AssignSharedProps(Source: TFrameInfo);
end;
{ Defines type of Network Graphics file.}
TNGFileType = (ngPNG, ngAPNG, ngMNG, ngJNG);
- TNGFileHandler = class(TObject)
+ TNGFileHandler = class
public
+ FileFormat: TNetworkGraphicsFileFormat;
FileType: TNGFileType;
Frames: array of TFrameInfo;
MHDR: TMHDR; // Main header for MNG files
GlobalPaletteEntries: LongInt;
GlobalTransparency: Pointer;
GlobalTransparencySize: LongInt;
+ constructor Create(AFileFormat: TNetworkGraphicsFileFormat);
destructor Destroy; override;
procedure Clear;
function GetLastFrame: TFrameInfo;
function AddFrameInfo: TFrameInfo;
+ procedure LoadMetaData;
end;
{ Network Graphics file parser and frame converter.}
LossyAlpha: Boolean;
Quality: LongInt;
Progressive: Boolean;
+ ZLibStrategy: Integer;
function SaveFile(Handle: TImagingHandle): Boolean;
procedure AddFrame(const Image: TImageData; IsJpegFrame: Boolean);
procedure StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer; FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream);
{$IFNDEF DONT_LINK_JNG}
procedure StoreImageToJNGFrame(const JHDR: TJHDR; const Image: TImageData; IDATStream, JDATStream, JDAAStream: TMemoryStream);
{$ENDIF}
- procedure SetFileOptions(FileFormat: TNetworkGraphicsFileFormat);
+ procedure SetFileOptions;
end;
{$IFNDEF DONT_LINK_JNG}
end;
end;
-const
- { Helper constants for 1/2/4 bit to 8 bit conversions.}
- 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);
- Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03);
- Shift2: array[0..3] of Byte = (6, 4, 2, 0);
- Mask4: array[0..1] of Byte = ($F0, $0F);
- Shift4: array[0..1] of Byte = (4, 0);
-
-function Get1BitPixel(Line: PByteArray; X: LongInt): Byte;
-begin
- Result := (Line[X shr 3] and Mask1[X and 7]) shr
- Shift1[X and 7];
-end;
-
-function Get2BitPixel(Line: PByteArray; X: LongInt): Byte;
-begin
- Result := (Line[X shr 2] and Mask2[X and 3]) shr
- Shift2[X and 3];
-end;
-
-function Get4BitPixel(Line: PByteArray; X: LongInt): Byte;
-begin
- Result := (Line[X shr 1] and Mask4[X and 1]) shr
- Shift4[X and 1];
-end;
-
{$IFNDEF DONT_LINK_JNG}
{ TCustomIOJpegFileFormat class implementation }
{ TFrameInfo class implementation }
-constructor TFrameInfo.Create;
+constructor TFrameInfo.Create(AIndex: Integer);
begin
+ Index := AIndex;
IDATMemory := TMemoryStream.Create;
JDATMemory := TMemoryStream.Create;
JDAAMemory := TMemoryStream.Create;
GlobalTransparencySize := 0;
end;
+constructor TNGFileHandler.Create(AFileFormat: TNetworkGraphicsFileFormat);
+begin
+ FileFormat := AFileFormat;
+end;
+
function TNGFileHandler.GetLastFrame: TFrameInfo;
var
Len: LongInt;
Result := nil;
end;
+procedure TNGFileHandler.LoadMetaData;
+var
+ I: Integer;
+ Delay, Denom: Integer;
+begin
+ if FileType = ngAPNG then
+ begin
+ // Num plays of APNG animation
+ FileFormat.FMetadata.SetMetaItem(SMetaAnimationLoops, acTL.NumPlay);
+ end;
+
+ for I := 0 to High(Frames) do
+ begin
+ if Frames[I].pHYs.UnitSpecifier = 1 then
+ begin
+ // Store physical pixel dimensions, in PNG stored as pixels per meter DPM
+ FileFormat.FMetadata.SetPhysicalPixelSize(ruDpm, Frames[I].pHYs.PixelsPerUnitX,
+ Frames[I].pHYs.PixelsPerUnitY);
+ end;
+ if FileType = ngAPNG then
+ begin
+ // Store frame delay of APNG file frame
+ Denom := Frames[I].fcTL.DelayDenom;
+ if Denom = 0 then
+ Denom := 100;
+ Delay := Round(1000 * (Frames[I].fcTL.DelayNumer / Denom));
+ FileFormat.FMetadata.SetMetaItem(SMetaFrameDelay, Delay, I);
+ end;
+ end;
+end;
+
function TNGFileHandler.AddFrameInfo: TFrameInfo;
var
Len: LongInt;
begin
Len := Length(Frames);
SetLength(Frames, Len + 1);
- Result := TFrameInfo.Create;
+ Result := TFrameInfo.Create(Len);
Frames[Len] := Result;
end;
SwapEndianLongWord(@acTL, SizeOf(acTL) div SizeOf(LongWord));
end;
+ procedure LoadpHYs;
+ begin
+ ReadChunkData;
+ with GetLastFrame do
+ begin
+ pHYs := PpHYs(ChunkData)^;
+ SwapEndianLongWord(@pHYs, SizeOf(pHYs) div SizeOf(LongWord));
+ end;
+ end;
+
begin
Result := False;
Clear;
else if Chunk.ChunkID = tRNSChunk then LoadtRNS
else if Chunk.ChunkID = bKGDChunk then LoadbKGD
else if Chunk.ChunkID = acTLChunk then HandleacTL
+ else if Chunk.ChunkID = pHYsChunk then LoadpHYs
else SkipChunkData;
until Eof(Handle) or (Chunk.ChunkID = MENDChunk) or
((FileType <> ngMNG) and (Chunk.ChunkID = IENDChunk));
Data, TotalBuffer, ZeroLine, PrevLine: Pointer;
BitCount, TotalSize, TotalPos, BytesPerPixel, I, Pass,
SrcDataSize, BytesPerLine, InterlaceLineBytes, InterlaceWidth: LongInt;
+ Info: TImageFormatInfo;
procedure DecodeAdam7;
const
end;
end;
- procedure Convert124To8(DataIn: Pointer; DataOut: Pointer; Width, Height,
- WidthBytes: LongInt; Indexed: Boolean);
- var
- X, Y, Mul: LongInt;
- GetPixel: TGetPixelFunc;
- begin
- GetPixel := Get1BitPixel;
- Mul := 255;
- case IHDR.BitDepth of
- 2:
- begin
- Mul := 85;
- GetPixel := Get2BitPixel;
- end;
- 4:
- begin
- Mul := 17;
- GetPixel := Get4BitPixel;
- end;
- end;
- if Indexed then Mul := 1;
-
- for Y := 0 to Height - 1 do
- for X := 0 to Width - 1 do
- PByteArray(DataOut)[Y * Width + X] :=
- GetPixel(@PByteArray(DataIn)[Y * WidthBytes], X) * Mul;
- end;
-
procedure TransformLOCOToRGB(Data: PByte; NumPixels, BytesPerPixel: LongInt);
var
I: LongInt;
end;
end;
+ function CheckBinaryPalette: Boolean;
+ begin
+ with GetLastFrame do
+ Result := (PaletteEntries = 2) and
+ (Palette[0].R = 0) and (Palette[0].G = 0) and (Palette[0].B = 0) and
+ (Palette[1].R = 255) and (Palette[1].G = 255) and (Palette[1].B = 255);
+ end;
+
begin
Image.Width := FrameWidth;
Image.Height := FrameHeight;
begin
// Gray scale image
case IHDR.BitDepth of
- 1, 2, 4, 8: Image.Format := ifGray8;
- 16: Image.Format := ifGray16;
+ 1: Image.Format := ifBinary;
+ 2, 4, 8: Image.Format := ifGray8;
+ 16: Image.Format := ifGray16;
end;
BitCount := IHDR.BitDepth;
end;
3:
begin
// Indexed image
- case IHDR.BitDepth of
- 1, 2, 4, 8: Image.Format := ifIndex8;
- end;
+ if (IHDR.BitDepth = 1) and CheckBinaryPalette then
+ Image.Format := ifBinary
+ else
+ Image.Format := ifIndex8;
BitCount := IHDR.BitDepth;
end;
4:
end;
end;
- // Start decoding
+ GetImageFormatInfo(Image.Format, Info);
+ BytesPerPixel := (BitCount + 7) div 8;
+
LineBuffer[True] := nil;
LineBuffer[False] := nil;
TotalBuffer := nil;
ZeroLine := nil;
- BytesPerPixel := (BitCount + 7) div 8;
ActLine := True;
+
+ // Start decoding
with Image do
try
BytesPerLine := (Width * BitCount + 7) div 8;
end;
end;
- Size := Width * Height * BytesPerPixel;
+ Size := Info.GetPixelsSize(Info.Format, Width, Height);
if Size <> SrcDataSize then
begin
// If source data size is different from size of image in assigned
// format we must convert it (it is in 1/2/4 bit count)
GetMem(Bits, Size);
- case IHDR.ColorType of
- 0: Convert124To8(Data, Bits, Width, Height, BytesPerLine, False);
- 3: Convert124To8(Data, Bits, Width, Height, BytesPerLine, True);
+ case IHDR.BitDepth of
+ 1:
+ begin
+ // Convert only indexed, keep black and white in ifBinary
+ if IHDR.ColorType <> 0 then
+ Convert1To8(Data, Bits, Width, Height, BytesPerLine, False);
+ end;
+ 2: Convert2To8(Data, Bits, Width, Height, BytesPerLine, IHDR.ColorType = 0);
+ 4: Convert4To8(Data, Bits, Width, Height, BytesPerLine, IHDR.ColorType = 0);
end;
FreeMem(Data);
end
JpegFormat := TCustomIOJpegFileFormat.Create;
JpegFormat.SetCustomIO(StreamIO);
Stream.Position := 0;
- Handle := StreamIO.OpenRead(Pointer(Stream));
+ Handle := StreamIO.Open(Pointer(Stream), omReadOnly);
try
JpegFormat.LoadData(Handle, DynImages, True);
DestImage := DynImages[0];
procedure ConvertbKGD;
begin
FillChar(BackGroundColor, SizeOf(BackGroundColor), 0);
- Move(Frame.Background^, BackGroundColor, Min(Frame.BackgroundSize,
- SizeOf(BackGroundColor)));
+ Move(Frame.Background^, BackGroundColor, Min(Frame.BackgroundSize, SizeOf(BackGroundColor)));
if IsColorFormat then
SwapValues(BackGroundColor.R, BackGroundColor.B);
SwapEndianWord(@BackGroundColor, 3);
end;
// if palette alphas were loaded from file then use them
if Alphas <> nil then
+ begin
for I := 0 to Min(AlphasSize, FmtInfo.PaletteEntries) - 1 do
Palette[I].A := Alphas[I];
+ end;
end;
end;
procedure ApplyColorKey;
var
DestFmt: TImageFormat;
+ Col32, Bkg32: TColor32Rec;
OldPixel, NewPixel: Pointer;
begin
case Image.Format of
else
DestFmt := ifUnknown;
end;
+
if DestFmt <> ifUnknown then
begin
if not IsBackGroundPresent then
BackGroundColor := ColorKey;
ConvertImage(Image, DestFmt);
- OldPixel := @ColorKey;
- NewPixel := @BackGroundColor;
+
// Now back color and color key must be converted to image's data format, looks ugly
case Image.Format of
ifA8Gray8:
begin
- TColor32Rec(TInt64Rec(ColorKey).Low).B := Byte(ColorKey.B);
- TColor32Rec(TInt64Rec(ColorKey).Low).G := $FF;
- TColor32Rec(TInt64Rec(BackGroundColor).Low).B := Byte(BackGroundColor.B);
+ Col32 := Color32(0, 0, $FF, Byte(ColorKey.B));
+ Bkg32 := Color32(0, 0, 0, Byte(BackGroundColor.B));
end;
ifA16Gray16:
begin
end;
ifA8R8G8B8:
begin
- TColor32Rec(TInt64Rec(ColorKey).Low).R := Byte(ColorKey.R);
- TColor32Rec(TInt64Rec(ColorKey).Low).G := Byte(ColorKey.G);
- TColor32Rec(TInt64Rec(ColorKey).Low).B := Byte(ColorKey.B);
- TColor32Rec(TInt64Rec(ColorKey).Low).A := $FF;
- TColor32Rec(TInt64Rec(BackGroundColor).Low).R := Byte(BackGroundColor.R);
- TColor32Rec(TInt64Rec(BackGroundColor).Low).G := Byte(BackGroundColor.G);
- TColor32Rec(TInt64Rec(BackGroundColor).Low).B := Byte(BackGroundColor.B);
+ Col32 := Color32($FF, Byte(ColorKey.R), Byte(ColorKey.G), Byte(ColorKey.B));
+ Bkg32 := Color32(0, Byte(BackGroundColor.R), Byte(BackGroundColor.G), Byte(BackGroundColor.B));
end;
ifA16R16G16B16:
begin
ColorKey.A := $FFFF;
end;
end;
+
+ if Image.Format in [ifA8Gray8, ifA8R8G8B8] then
+ begin
+ OldPixel := @Col32;
+ NewPixel := @Bkg32;
+ end
+ else
+ begin
+ OldPixel := @ColorKey;
+ NewPixel := @BackGroundColor;
+ end;
+
ReplaceColor(Image, 0, 0, Image.Width, Image.Height, OldPixel, NewPixel);
end;
end;
(not Frame.IsJpegFrame and (Frame.IHDR.ColorType in [2, 6]));
// Convert some chunk data to useful format
- if Frame.Transparency <> nil then
+ if Frame.TransparencySize > 0 then
ConverttRNS;
- if Frame.Background <> nil then
+ if Frame.BackgroundSize > 0 then
ConvertbKGD;
// Build palette for indexed images
Filter := 0;
case PreFilter of
6:
- if not ((IHDR.BitDepth < 8) or (IHDR.ColorType = 3))
- then Adaptive := True;
+ if not ((IHDR.BitDepth < 8) or (IHDR.ColorType = 3)) then
+ Adaptive := True;
0..4: Filter := PreFilter;
else
if IHDR.ColorType in [2, 6] then
Filter := 4
end;
+
// Prepare data for compression
CompBuffer := nil;
FillChar(FilterLines, SizeOf(FilterLines), 0);
- BytesPerPixel := FmtInfo.BytesPerPixel;
- BytesPerLine := LongInt(IHDR.Width) * BytesPerPixel;
+ BytesPerPixel := Max(1, FmtInfo.BytesPerPixel);
+ BytesPerLine := FmtInfo.GetPixelsSize(FmtInfo.Format, LongInt(IHDR.Width), 1);
TotalSize := (BytesPerLine + 1) * LongInt(IHDR.Height);
GetMem(TotalBuffer, TotalSize);
GetMem(ZeroLine, BytesPerLine);
FillChar(ZeroLine^, BytesPerLine, 0);
+ PrevLine := ZeroLine;
+
if Adaptive then
+ begin
for I := 0 to 4 do
GetMem(FilterLines[I], BytesPerLine);
- PrevLine := ZeroLine;
+ end;
+
try
// Process next scanlines
for I := 0 to IHDR.Height - 1 do
begin
// Filter scanline
if Adaptive then
+ begin
AdaptiveFilter(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine],
- PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1])
+ PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1]);
+ end
else
+ begin
FilterScanline(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine],
PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1]);
+ end;
PrevLine := @PByteArray(Bits)[I * BytesPerLine];
// Swap red and blue if necessary
if (IHDR.ColorType in [2, 6]) and not FmtInfo.IsRBSwapped then
+ begin
SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1],
- IHDR.Width, IHDR.BitDepth, FmtInfo.BytesPerPixel);
+ IHDR.Width, IHDR.BitDepth, BytesPerPixel);
+ end;
// Images with 16 bit channels must be swapped because of PNG's big endianess
if IHDR.BitDepth = 16 then
+ begin
SwapEndianWord(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1],
BytesPerLine div SizeOf(Word));
+ end;
// Set filter used for this scanline
PByteArray(TotalBuffer)[I * (BytesPerLine + 1)] := Filter;
end;
// Compress IDAT data
- CompressBuf(TotalBuffer, TotalSize, CompBuffer, CompSize, CompressLevel);
+ CompressBuf(TotalBuffer, TotalSize, CompBuffer, CompSize,
+ CompressLevel, ZLibStrategy);
// Write IDAT data to stream
IDATStream.WriteBuffer(CompBuffer^, CompSize);
finally
JpegFormat.FQuality := Quality;
SetLength(DynImages, 1);
DynImages[0] := Image;
- Handle := StreamIO.OpenWrite(Pointer(Stream));
+ Handle := StreamIO.Open(Pointer(Stream), omCreate);
try
JpegFormat.SaveData(Handle, DynImages, 0);
finally
@@ -1615,6 +1663,7 @@ procedure TNGFileSaver.AddFrame(const Image: TImageData; IsJpegFrame: Boolean);
var
Frame: TFrameInfo;
FmtInfo: TImageFormatInfo;
+ Index: Integer;
procedure StorePalette;
var
end;
end;
+ procedure FillFrameControlChunk(const IHDR: TIHDR; var fcTL: TfcTL);
+ var
+ Delay: Integer;
+ begin
+ fcTL.SeqNumber := 0; // Decided when writing to file
+ fcTL.Width := IHDR.Width;
+ fcTL.Height := IHDR.Height;
+ fcTL.XOffset := 0;
+ fcTL.YOffset := 0;
+ fcTL.DelayNumer := 1;
+ fcTL.DelayDenom := 3;
+ if FileFormat.FMetadata.HasMetaItemForSaving(SMetaFrameDelay, Index) then
+ begin
+ // Metadata contains frame delay information in milliseconds
+ Delay := FileFormat.FMetadata.MetaItemsForSavingMulti[SMetaFrameDelay, Index];
+ fcTL.DelayNumer := Delay;
+ fcTL.DelayDenom := 1000;
+ end;
+ fcTL.DisposeOp := DisposeOpNone;
+ fcTL.BlendOp := BlendOpSource;
+ SwapEndianLongWord(@fcTL, 5);
+ fcTL.DelayNumer := SwapEndianWord(fcTL.DelayNumer);
+ fcTL.DelayDenom := SwapEndianWord(fcTL.DelayDenom);
+ end;
+
begin
// Add new frame
Frame := AddFrameInfo;
Frame.IsJpegFrame := IsJpegFrame;
+ Index := Length(Frames) - 1;
with Frame do
begin
IHDR.BitDepth := IHDR.BitDepth div 2;
end;
end
+ else if FmtInfo.Format = ifBinary then
+ begin
+ IHDR.ColorType := 0;
+ IHDR.BitDepth := 1;
+ end
+ else if FmtInfo.IsIndexed then
+ IHDR.ColorType := 3
+ else if FmtInfo.HasAlphaChannel then
+ begin
+ IHDR.ColorType := 6;
+ IHDR.BitDepth := IHDR.BitDepth div 4;
+ end
else
begin
- if FmtInfo.IsIndexed then
- IHDR.ColorType := 3
- else
- if FmtInfo.HasAlphaChannel then
- begin
- IHDR.ColorType := 6;
- IHDR.BitDepth := IHDR.BitDepth div 4;
- end
- else
- begin
- IHDR.ColorType := 2;
- IHDR.BitDepth := IHDR.BitDepth div 3;
- end;
+ IHDR.ColorType := 2;
+ IHDR.BitDepth := IHDR.BitDepth div 3;
end;
if FileType = ngAPNG then
begin
// Fill fcTL chunk of APNG file
- fcTL.SeqNumber := 0; // Decided when writing to file
- fcTL.Width := IHDR.Width;
- fcTL.Height := IHDR.Height;
- fcTL.XOffset := 0;
- fcTL.YOffset := 0;
- fcTL.DelayNumer := 1;
- fcTL.DelayDenom := 3;
- fcTL.DisposeOp := DisposeOpNone;
- fcTL.BlendOp := BlendOpSource;
- SwapEndianLongWord(@fcTL, 5);
- fcTL.DelayNumer := SwapEndianWord(fcTL.DelayNumer);
- fcTL.DelayDenom := SwapEndianWord(fcTL.DelayDenom);
+ FillFrameControlChunk(IHDR, fcTL);
end;
// Compress PNG image and store it to stream
GetIO.Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));
end;
+ procedure WriteGlobalMetaDataChunks(Frame: TFrameInfo);
+ var
+ XRes, YRes: Single;
+ begin
+ if FileFormat.FMetadata.GetPhysicalPixelSize(ruDpm, XRes, YRes, True) then
+ begin
+ // Save pHYs chunk
+ Frame.pHYs.UnitSpecifier := 1;
+ // PNG stores physical resolution as dots per meter
+ Frame.pHYs.PixelsPerUnitX := Round(XRes);
+ Frame.pHYs.PixelsPerUnitY := Round(YRes);
+
+ Chunk.DataSize := SizeOf(Frame.pHYs);
+ Chunk.ChunkID := pHYsChunk;
+ SwapEndianLongWord(@Frame.pHYs, SizeOf(Frame.pHYs) div SizeOf(LongWord));
+ WriteChunk(Chunk, @Frame.pHYs);
+ end;
+ end;
+
procedure WritePNGMainImageChunks(Frame: TFrameInfo);
begin
with Frame do
WriteChunk(Chunk, Transparency);
end;
end;
+ // Write metadata related chunks
+ WriteGlobalMetaDataChunks(Frame);
end;
begin
if FileType = ngMNG then
begin
+ // MNG - main header before frames
SwapEndianLongWord(@MHDR, SizeOf(MHDR) div SizeOf(LongWord));
Chunk.DataSize := SizeOf(MHDR);
Chunk.ChunkID := MHDRChunk;
WriteChunk(Chunk, @MHDR);
+ end
+ else if FileType = ngAPNG then
+ begin
+ // APNG - IHDR and global chunks for all frames, then acTL chunk, then frames
+ // (fcTL+IDAT, fcTL+fdAT, fcTL+fdAT, fcTL+fdAT, ....)
+ WritePNGMainImageChunks(Frames[0]);
+
+ // Animation control chunk
+ acTL.NumFrames := Length(Frames);
+ if FileFormat.FMetadata.HasMetaItemForSaving(SMetaAnimationLoops) then
+ begin
+ // Number of plays of APNG animation
+ acTL.NumPlay:= FileFormat.FMetadata.MetaItemsForSaving[SMetaAnimationLoops];
+ end
+ else
+ acTL.NumPlay := 0;
+ SwapEndianLongWord(@acTL, SizeOf(acTL) div SizeOf(LongWord));
+
+ Chunk.DataSize := SizeOf(acTL);
+ Chunk.ChunkID := acTLChunk;
+ WriteChunk(Chunk, @acTL);
end;
for I := 0 to Length(Frames) - 1 do
Chunk.DataSize := SizeOf(JHDR);
Chunk.ChunkID := JHDRChunk;
WriteChunk(Chunk, @JHDR);
+ // Write metadata related chunks
+ WriteGlobalMetaDataChunks(Frames[I]);
// Write JNG image data
Chunk.DataSize := JDATMemory.Size;
Chunk.ChunkID := JDATChunk;
end
else if FileType = ngAPNG then
begin
- // APNG frame - first frame must have acTL and fcTL before IDAT,
- // subsequent frames have fcTL and fdAT.
- if I = 0 then
- begin
- WritePNGMainImageChunks(Frames[I]);
- Chunk.DataSize := SizeOf(acTL);
- Chunk.ChunkID := acTLChunk;
- WriteChunk(Chunk, @acTL);
- end;
- // Write fcTL before frame data
+ // APNG frame - Write fcTL before frame data
Chunk.DataSize := SizeOf(fcTL);
Chunk.ChunkID := fcTLChunk;
fcTl.SeqNumber := GetNextSeqNo;
end;
end;
-procedure TNGFileSaver.SetFileOptions(FileFormat: TNetworkGraphicsFileFormat);
+procedure TNGFileSaver.SetFileOptions;
begin
PreFilter := FileFormat.FPreFilter;
CompressLevel := FileFormat.FCompressLevel;
LossyAlpha := FileFormat.FLossyAlpha;
Quality := FileFormat.FQuality;
Progressive := FileFormat.FProgressive;
+ ZLibStrategy := FileFormat.FZLibStategy;
end;
-{ TAPNGAnimator class implemnetation }
+{ TAPNGAnimator class implementation }
class procedure TAPNGAnimator.Animate(var Images: TDynImageDataArray;
const acTL: TacTL; const SrcFrames: array of TFrameInfo);
for I := 0 to Len - 1 do
with SrcFrames[I] do
begin
- if (FrameWidth <> IHDR.Width) or (FrameHeight <> IHDR.Height) or (Len <> acTL.NumFrames) or
+ if (FrameWidth <> Integer(IHDR.Width)) or (FrameHeight <> Integer(IHDR.Height)) or (Len <> Integer(acTL.NumFrames)) or
(not ((fcTL.DisposeOp = DisposeOpNone) and (fcTL.BlendOp = BlendOpSource)) and
not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpSource)) and
not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpOver))) then
if (Len = 0) or not AnimatingNeeded then
Exit;
- if (Len = acTL.NumFrames + 1) and (SrcFrames[0].fcTL.Width = 0) then
+ if (Len = Integer(acTL.NumFrames) + 1) and (SrcFrames[0].fcTL.Width = 0) then
begin
// If default image (stored in IDAT chunk) isn't part of animation we ignore it
Offset := 1;
{ TNetworkGraphicsFileFormat class implementation }
-constructor TNetworkGraphicsFileFormat.Create;
+procedure TNetworkGraphicsFileFormat.Define;
begin
- inherited Create;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
+ inherited;
+ FFeatures := [ffLoad, ffSave];
FPreFilter := NGDefaultPreFilter;
FCompressLevel := NGDefaultCompressLevel;
FLossyCompression := NGDefaultLossyCompression;
FQuality := NGDefaultQuality;
FProgressive := NGDefaultProgressive;
+ FZLibStategy := NGDefaultZLibStartegy;
end;
procedure TNetworkGraphicsFileFormat.CheckOptionsValidity;
{ TPNGFileFormat class implementation }
-constructor TPNGFileFormat.Create;
+procedure TPNGFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SPNGFormatName;
- FIsMultiImageFormat := True;
+ FFeatures := FFeatures + [ffMultiImage];
FLoadAnimated := PNGDefaultLoadAnimated;
AddMasks(SPNGMasks);
RegisterOption(ImagingPNGPreFilter, @FPreFilter);
RegisterOption(ImagingPNGCompressLevel, @FCompressLevel);
RegisterOption(ImagingPNGLoadAnimated, @FLoadAnimated);
+ RegisterOption(ImagingPNGZLibStrategy, @FZLibStategy);
end;
function TPNGFileFormat.LoadData(Handle: TImagingHandle;
NGFileLoader: TNGFileLoader;
begin
Result := False;
- NGFileLoader := TNGFileLoader.Create;
+ NGFileLoader := TNGFileLoader.Create(Self);
try
// Use NG file parser to load file
if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
if not IsJpegFrame then
NGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight, IHDR, IDATMemory, Images[I]);
// Build palette, aply color key or background
+
NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[I], Images[I]);
Result := True;
end;
TAPNGAnimator.Animate(Images, NGFileLoader.acTL, NGFileLoader.Frames);
end;
finally
+ NGFileLoader.LoadMetaData; // Store metadata
NGFileLoader.Free;
end;
end;
DefaultFormat := ifDefault;
AnimWidth := 0;
AnimHeight := 0;
- NGFileSaver := TNGFileSaver.Create;
+ NGFileSaver := TNGFileSaver.Create(Self);
// Save images with more frames as APNG format
if Length(Images) > 1 then
begin
NGFileSaver.FileType := ngAPNG;
- NGFileSaver.acTL.NumFrames := FLastIdx - FFirstIdx + 1;
- NGFileSaver.acTL.NumPlay := 1;
- SwapEndianLongWord(@NGFileSaver.acTL, SizeOf(NGFileSaver.acTL) div SizeOf(LongWord));
// Get max dimensions of frames
AnimWidth := Images[FFirstIdx].Width;
AnimHeight := Images[FFirstIdx].Height;
end
else
NGFileSaver.FileType := ngPNG;
- NGFileSaver.SetFileOptions(Self);
+
+ NGFileSaver.SetFileOptions;
with NGFileSaver do
try
{ TMNGFileFormat class implementation }
-constructor TMNGFileFormat.Create;
+procedure TMNGFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SMNGFormatName;
- FIsMultiImageFormat := True;
+ FFeatures := FFeatures + [ffMultiImage];
AddMasks(SMNGMasks);
FSignature := MNGSignature;
I, Len: LongInt;
begin
Result := False;
- NGFileLoader := TNGFileLoader.Create;
+ NGFileLoader := TNGFileLoader.Create(Self);
try
// Use NG file parser to load file
if NGFileLoader.LoadFile(Handle) then
Result := True;
end;
finally
+ NGFileLoader.LoadMetaData; // Store metadata
NGFileLoader.Free;
end;
end;
LargestWidth := 0;
LargestHeight := 0;
- NGFileSaver := TNGFileSaver.Create;
+ NGFileSaver := TNGFileSaver.Create(Self);
NGFileSaver.FileType := ngMNG;
- NGFileSaver.SetFileOptions(Self);
+ NGFileSaver.SetFileOptions;
with NGFileSaver do
try
{ TJNGFileFormat class implementation }
-constructor TJNGFileFormat.Create;
+procedure TJNGFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SJNGFormatName;
AddMasks(SJNGMasks);
RegisterOption(ImagingJNGAlphaCompressLevel, @FCompressLevel);
RegisterOption(ImagingJNGQuality, @FQuality);
RegisterOption(ImagingJNGProgressive, @FProgressive);
+
end;
function TJNGFileFormat.LoadData(Handle: TImagingHandle;
NGFileLoader: TNGFileLoader;
begin
Result := False;
- NGFileLoader := TNGFileLoader.Create;
+ NGFileLoader := TNGFileLoader.Create(Self);
try
// Use NG file parser to load file
if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
Result := True;
end;
finally
+ NGFileLoader.LoadMetaData; // Store metadata
NGFileLoader.Free;
end;
end;
Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed);
if Result then
begin
- NGFileSaver := TNGFileSaver.Create;
+ NGFileSaver := TNGFileSaver.Create(Self);
with NGFileSaver do
try
FileType := ngJNG;
- SetFileOptions(Self);
+ SetFileOptions;
AddFrame(ImageToSave, True);
SaveFile(Handle);
finally
-- TODOS ----------------------------------------------------
- nothing now
+ -- 0.77 Changes/Bug Fixes -----------------------------------
+ - Reads and writes APNG animation loop count metadata.
+ - Writes frame delays of APNG from metadata.
+ - Fixed color keys in 8bit depth PNG/MNG loading.
+ - Fixed needless (and sometimes buggy) conversion to format with alpha
+ channel in FPC (GetMem(0) <> nil!).
+ - Added support for optional ZLib compression strategy.
+ - Added loading and saving of ifBinary (1bit black and white)
+ format images. During loading grayscale 1bpp and indexed 1bpp
+ (with only black and white colors in palette) are treated as ifBinary.
+ ifBinary are saved as 1bpp grayscale PNGs.
+
+ -- 0.26.5 Changes/Bug Fixes ---------------------------------
+ - Reads frame delays from APNG files into metadata.
+ - Added loading and saving of metadata from these chunks: pHYs.
+ - Simplified decoding of 1/2/4 bit images a bit (less code).
+
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Added APNG saving support.
- Added APNG support to NG loader and animating to PNG loader.
index 85653ad5397ba99846ca4821c1341b93e62c33a0..deb21e4daa319be550bd5eca5ac6172887c28e6e 100644 (file)
-{ $Id: ImagingOptions.inc 174 2009-09-08 09:37:59Z galfar $ }
-
{
User Options
Following defines and options can be changed by user.
{ $DEFINE IMAGING_DEBUG} // If defined, debug info, range/IO/overflow
// checking, stack frames, assertions, and
// other debugging options will be turned on.
-{$DEFINE IMAGING_RELEASE} // If defined, all debug info is off.
+{ $DEFINE IMAGING_RELEASE} // If defined, all debug info is off.
{$DEFINE DONT_LINK_MNG} // link support for MNG images
{$DEFINE DONT_LINK_JNG} // link support for JNG images
//{$DEFINE DONT_LINK_PNM} // link support for PortableMap images (PBM, PGM, PPM, PAM, PFM)
+{$DEFINE DONT_LINK_RADHDR} // link support for Radiance HDR/RGBE file format
//{$DEFINE DONT_LINK_EXTRAS} // link support for file formats defined in
// Extras package. Exactly which formats will be
{$WRITEABLECONST OFF} // Writeable constants: off
{$IFNDEF FPC}
- {$DEFINE DCC} // if not using FPC then DCC compiler is used (Delphi/Kylix)
+ {$DEFINE DCC} // if not using FPC then DCC compiler is used (Delphi/BCB)
// others are not supported
{$ENDIF}
{$IFDEF DCC}
- {$IFDEF LINUX}
- {$DEFINE KYLIX} // using Kylix
- {$ENDIF}
-{$ENDIF}
-
-{$IFDEF DCC}
- {$IFNDEF KYLIX}
- {$DEFINE DELPHI} // using Delphi
- {$ENDIF}
+ {$DEFINE DELPHI}
{$ENDIF}
{$IF (Defined(DCC) and (CompilerVersion >= 18.5))}
{$ENDIF}
{$IFEND}
+{$IF Defined (CPU86) and not Defined(CPUX86)}
+ {$DEFINE CPUX86} // Compatibility with Delphi
+{$IFEND}
+
+{$IF Defined (CPUX86_64) and not Defined(CPUX64)}
+ {$DEFINE CPUX64} // Compatibility with Delphi
+{$IFEND}
+
+{$IF Defined (DARWIN) and not Defined(MACOSX)}
+ {$DEFINE MACOS} // Compatibility with Delphi
+{$IFEND}
+
+{$IF Defined(DCC) and (CompilerVersion < 23)}
+ {$DEFINE CPUX86} // Compatibility with older Delphi
+{$IFEND}
{ Compiler capabilities }
// Define if compiler supports inlining of functions and procedures
-// Note that FPC inline support crashed in older versions (1.9.8)
-{$IF (Defined(DCC) and (CompilerVersion >= 17)) or (Defined(FPC) and Defined(CPU86))}
+{$IF (Defined(DCC) and (CompilerVersion >= 17)) or Defined(FPC)}
{$DEFINE HAS_INLINE}
{$IFEND}
// Define if compiler supports advanced records with methods
-{$IF (Defined(DCC) and (CompilerVersion >= 18)) }
+{$IF (Defined(DCC) and (CompilerVersion >= 18)) or
+ (Defined(FPC) and (FPC_FULLVERSION >= 20600))}
{$DEFINE HAS_ADVANCED_RECORDS}
{$IFEND}
// Define if compiler supports operator overloading
-// (unfortunately Delphi and FPC operator overloaing is not compatible)
-{$IF (Defined(DCC) and (CompilerVersion >= 18)) or Defined(FPC)}
+// (unfortunately Delphi and FPC operator overloading is not compatible).
+// FPC supports Delphi compatible operator overloads since 2.6.0
+{$IF (Defined(DCC) and (CompilerVersion >= 18)) or
+ (Defined(FPC) and (FPC_FULLVERSION >= 20600))}
{$DEFINE HAS_OPERATOR_OVERLOADING}
{$IFEND}
+// Anonymous methods
+{$IF Defined(DCC) and (CompilerVersion >= 20) }
+ {$DEFINE HAS_ANON_METHODS}
+{$IFEND}
+
+// Generic types (Delphi and FPC implementations incompatible).
+// Update: FPC supports Delphi compatible generics since 2.6.0
+{$IF (Defined(DCC) and (CompilerVersion >= 20)) or
+ (Defined(FPC) and (FPC_FULLVERSION >= 20600))}
+ {$DEFINE HAS_GENERICS}
+{$IFEND}
+
{ Imaging options check}
{$IFNDEF HAS_INLINE}
{$UNDEF USE_INLINE}
{$ENDIF}
-{$IFDEF FPC}
- {$IFNDEF CPU86}
- {$UNDEF USE_ASM}
- {$ENDIF}
-{$ENDIF}
+{$IF not Defined(CPUX86)}
+ {$UNDEF USE_ASM}
+{$IFEND}
{$IFDEF FPC}
{$DEFINE COMPONENT_SET_LCL}
{ Platform options }
-{$IFDEF WIN32}
+{$IF Defined(WIN32) or Defined(WIN64)}
{$DEFINE MSWINDOWS}
-{$ENDIF}
-
-{$IFDEF DPMI}
- {$DEFINE MSDOS}
-{$ENDIF}
+{$IFEND}
{$IFDEF LINUX}
{$DEFINE UNIX}
{$GOTO ON} // alow goto
{$PACKRECORDS 8} // same as ALING 8 for Delphi
{$PACKENUM 4} // Min enum size: 4 B
- {$CALLING REGISTER} // default calling convention is register
{$IFDEF CPU86}
{$ASMMODE INTEL} // intel assembler mode
{$ENDIF}
{$INLINE ON} // turns inlining on for compilers that support it
{$ENDIF}
-
{$WARNINGS OFF}
{$HINTS OFF}
{$NOTES OFF}
index 257ad76837440f15b948ea27f82e5fe686e83a12..d278542ed188bf86b33f225f9d0595cd67d316fd 100644 (file)
{
- $Id: ImagingPcx.pas 100 2007-06-28 21:09:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
to spread).}
TPCXFileFormat = class(TImageFileFormat)
protected
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
public
- constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
end;
{ TPCXFileFormat }
-constructor TPCXFileFormat.Create;
+procedure TPCXFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SPCXFormatName;
- FCanLoad := True;
- FCanSave := False;
- FIsMultiImageFormat := False;
+ FFeatures := [ffLoad];
AddMasks(SPCXMasks);
end;
else if FileDataFormat = ifMono then
begin
// Convert 1bit images to ifIndex8
- Convert1To8(UncompData, Bits, Width, Height, Hdr.BytesPerLine);
+ Convert1To8(UncompData, Bits, Width, Height, Hdr.BytesPerLine, False);
end
else if FileDataFormat = ifIndex2 then
begin
// usually use (from specs, I've never seen one myself) CGA palette
// which is not array of RGB tripplets. So 2bit PCXs are loaded but
// their colors would be wrong
- Convert2To8(UncompData, Bits, Width, Height, Hdr.BytesPerLine);
+ Convert2To8(UncompData, Bits, Width, Height, Hdr.BytesPerLine, False);
end
else if FileDataFormat = ifIndex4 then
begin
else if (Hdr.BitsPerPixel = 4) and (Hdr.Planes = 1) then
begin
// Convert 4bit images to ifIndex8
- Convert4To8(UncompData, Bits, Width, Height, Hdr.BytesPerLine);
+ Convert4To8(UncompData, Bits, Width, Height, Hdr.BytesPerLine, False);
end
end;
index 97e6c4e419fd8c966bc7a7577a53b33ba0421aff..89d862d2e02a7c9811f62eb4dbfa23d336cf2893 100644 (file)
{
- $Id: ImagingPortableMaps.pas 163 2009-07-28 21:44:10Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
protected
FIdNumbers: TChar2;
FSaveBinary: LongBool;
+ FUSFormat: TFormatSettings;
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
public
- constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
{ If set to True images will be saved in binary format. If it is False
PBM images can be loaded but not saved. Loaded images are returned in
ifGray8 format (witch pixel values scaled from 1bit to 8bit).}
TPBMFileFormat = class(TPortableMapFileFormat)
- public
- constructor Create; override;
+ protected
+ procedure Define; override;
end;
{ Portable Gray Map is used to store grayscale 8bit or 16bit images.
Raster data can be saved as text or binary data.}
TPGMFileFormat = class(TPortableMapFileFormat)
protected
+ procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
end;
{ Portable Pixel Map is used to store RGB images with 8bit or 16bit channels.
Raster data can be saved as text or binary data.}
TPPMFileFormat = class(TPortableMapFileFormat)
protected
+ procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
end;
{ Portable Arbitrary Map is format that can store image data formats
ifR8G8B8, ifR16G16R16, ifA8R8G8B8, and ifA16R16G16B16.}
TPAMFileFormat = class(TPortableMapFileFormat)
protected
+ procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
end;
{ Portable Float Map is unofficial extension of PNM format family which
or RGB images are supported by PFM format (so no alpha).}
TPFMFileFormat = class(TPortableMapFileFormat)
protected
+ procedure Define; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
end;
implementation
ifR8G8B8, ifR16G16B16, ifA8R8G8B8, ifA16R16G16B16];
SPFMFormatName = 'Portable Float Map';
SPFMMasks = '*.pfm';
- PFMSupportedFormats = [ifR32F, ifA32B32G32R32F];
+ PFMSupportedFormats = [ifR32F, ifB32G32R32F];
const
{ TAB, CR, LF, and Space are used as seperators in Portable map headers and data.}
{ TPortableMapFileFormat }
-constructor TPortableMapFileFormat.Create;
+procedure TPortableMapFileFormat.Define;
begin
- inherited Create;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
+ inherited;
+ FFeatures := [ffLoad, ffSave];
FSaveBinary := PortableMapDefaultBinary;
+ FUSFormat := GetFormatSettingsForFloats;
end;
function TPortableMapFileFormat.LoadData(Handle: TImagingHandle;
Dest: PByte;
MonoData: Pointer;
Info: TImageFormatInfo;
- PixelFP: TColorFPRec;
LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar;
LineEnd, LinePos: LongInt;
MapInfo: TPortableMapInfo;
I: TTupleType;
TupleTypeName: string;
Scale: Single;
- OldSeparator: Char;
begin
Result := False;
with GetIO do
// Read header of PFM file
MapInfo.Width := ReadIntValue;
MapInfo.Height := ReadIntValue;
- OldSeparator := DecimalSeparator;
- DecimalSeparator := '.';
- Scale := StrToFloatDef(ReadString, 0);
- DecimalSeparator := OldSeparator;
+ Scale := StrToFloatDef(ReadString, 0, FUSFormat);
MapInfo.IsBigEndian := Scale > 0.0;
if Id[1] = 'F' then
MapInfo.TupleType := ttRGBFP
LineEnd := 0;
LinePos := 0;
SetLength(Images, 1);
+
with GetIO, Images[0] do
begin
Format := ifUnknown;
ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16);
ttGrayScaleFP: Format := ifR32F;
- ttRGBFP: Format := ifA32B32G32R32F;
+ ttRGBFP: Format := ifB32G32R32F;
end;
// Exit if no matching data format was found
if Format = ifUnknown then Exit;
// FP images are in BGR order and endian swap maybe needed.
// Some programs store scanlines in bottom-up order but
// I will stick with Photoshops behaviour here
- for I := 0 to Width * Height - 1 do
- begin
- Read(Handle, @PixelFP, MapInfo.BitCount div 8);
- if MapInfo.TupleType = ttRGBFP then
- with PColorFPRec(Dest)^ do
- begin
- A := 1.0;
- R := PixelFP.R;
- G := PixelFP.G;
- B := PixelFP.B;
- if MapInfo.IsBigEndian then
- SwapEndianLongWord(PLongWord(Dest), 3);
- end
- else
- begin
- PSingle(Dest)^ := PixelFP.B;
- if MapInfo.IsBigEndian then
- SwapEndianLongWord(PLongWord(Dest), 1);
- end;
- Inc(Dest, Info.BytesPerPixel);
- end;
+ Read(Handle, Bits, Size);
+ if MapInfo.IsBigEndian then
+ SwapEndianLongWord(PLongWord(Dest), Size div SizeOf(LongWord));
end;
if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then
GetMem(MonoData, MonoSize);
try
Read(Handle, MonoData, MonoSize);
- Convert1To8(MonoData, Bits, Width, Height, ScanLineSize);
- // 1bit mono images must be scaled to 8bit (where 0=white, 1=black)
+ Convert1To8(MonoData, Bits, Width, Height, ScanLineSize, False);
+ // 1bit mono images must be scaled to 8bit, but inverted (where 0=white, 1=black)
for I := 0 to Width * Height - 1 do
PByteArray(Bits)[I] := 255 - PByteArray(Bits)[I] * 255;
finally
end;
procedure WriteHeader;
- var
- OldSeparator: Char;
begin
WriteString('P' + MapInfo.FormatId);
if not MapInfo.HasPAMHeader then
ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1));
ttGrayScaleFP, ttRGBFP:
begin
- OldSeparator := DecimalSeparator;
- DecimalSeparator := '.';
// Negative value indicates that raster data is saved in little endian
- WriteString(FloatToStr(-1.0));
- DecimalSeparator := OldSeparator;
+ WriteString(FloatToStr(-1.0, FUSFormat));
end;
end;
end
end
else
begin
- // 8bit RGB/ARGB images: read and blue must be swapped and
+ // 8bit RGB/ARGB images: red and blue must be swapped and
// 3 or 4 bytes must be written
Src := Bits;
for I := 0 to Width * Height - 1 do
begin
// Floating point images (no need to swap endian here - little
// endian is specified in file header)
- if MapInfo.TupleType = ttGrayScaleFP then
- begin
- // Grayscale images can be written in one Write call
- Write(Handle, Bits, Size);
- end
- else
- begin
- // Expected data format of PFM RGB file is B32G32R32F which is not
- // supported by Imaging. We must write pixels one by one and
- // write only RGB part of A32B32G32B32 image.
- Src := Bits;
- for I := 0 to Width * Height - 1 do
- begin
- Write(Handle, Src, SizeOf(Single) * 3);
- Inc(Src, Info.BytesPerPixel);
- end;
- end;
+ Write(Handle, Bits, Size);
end;
end;
Result := True;
{ TPBMFileFormat }
-constructor TPBMFileFormat.Create;
+procedure TPBMFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SPBMFormatName;
- FCanSave := False;
+ FFeatures := [ffLoad];
AddMasks(SPBMMasks);
FIdNumbers := '14';
end;
{ TPGMFileFormat }
-constructor TPGMFileFormat.Create;
+procedure TPGMFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SPGMFormatName;
FSupportedFormats := PGMSupportedFormats;
AddMasks(SPGMMasks);
{ TPPMFileFormat }
-constructor TPPMFileFormat.Create;
+procedure TPPMFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SPPMFormatName;
FSupportedFormats := PPMSupportedFormats;
AddMasks(SPPMMasks);
{ TPAMFileFormat }
-constructor TPAMFileFormat.Create;
+procedure TPAMFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SPAMFormatName;
FSupportedFormats := PAMSupportedFormats;
AddMasks(SPAMMasks);
{ TPFMFileFormat }
-constructor TPFMFileFormat.Create;
+procedure TPFMFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SPFMFormatName;
AddMasks(SPFMMasks);
FIdNumbers := 'Ff';
const Info: TImageFormatInfo);
begin
if (Info.ChannelCount > 1) or Info.IsIndexed then
- ConvertImage(Image, ifA32B32G32R32F)
+ ConvertImage(Image, ifB32G32R32F)
else
ConvertImage(Image, ifR32F);
end;
-- TODOS ----------------------------------------------------
- nothing now
+ -- 0.77.1 Changes/Bug Fixes -----------------------------------
+ - Native RGB floating point format of PFM is now supported by Imaging
+ so we use it now for saving instead of A32B32G32B32.
+ - String to float formatting changes (don't change global settings).
+
-- 0.26.3 Changes/Bug Fixes -----------------------------------
- Fixed D2009 Unicode related bug in PNM saving.
index a95ce969c6675beb1c053b61e0ad403432e90031..cd395caaa721929aec7493755f819a5f026bcc7f 100644 (file)
{
- $Id: ImagingPsd.pas 154 2008-12-27 15:41:09Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
RGB images but without actual conversion to RGB color space.
Also no layer information is loaded.}
TPSDFileFormat = class(TImageFileFormat)
- protected
+ private
FSaveAsLayer: LongBool;
+ protected
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
- constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
property SaveAsLayer: LongBool read FSaveAsLayer write FSaveAsLayer;
SPSDMasks = '*.psd,*.pdd';
PSDSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8,
ifR8G8B8, ifA8R8G8B8, ifGray16, ifA16Gray16, ifR16G16B16, ifA16R16G16B16,
- ifR32F, ifA32R32G32B32F];
+ ifR32F, ifR32G32B32F, ifA32R32G32B32F];
PSDDefaultSaveAsLayer = True;
const
TPSDFileFormat class implementation
}
-constructor TPSDFileFormat.Create;
+procedure TPSDFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SPSDFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
+ FFeatures := [ffLoad, ffSave];
FSupportedFormats := PSDSupportedFormats;
AddMasks(SPSDMasks);
Col64: TColor64Rec;
PCol32: PColor32Rec;
PCol64: PColor64Rec;
- PColF: PColorFPRec;
{ PackBits RLE decode code from Mike Lischke's GraphicEx library.}
procedure DecodeRLE(Source, Dest: PByte; PackedSize, UnpackedSize: LongInt);
// Read PSD header
Read(Handle, @Header, SizeOf(Header));
SwapHeader(Header);
+
// Determine image data format
Format := ifUnknown;
case Header.Mode of
Format := IffFormat(Header.Depth = 8, ifA8R8G8B8, ifA16R16G16B16);
end
else if Header.Depth = 32 then
- Format := ifA32R32G32B32F;
+ begin
+ if Header.Channels = 3 then
+ Format := ifR32G32B32F
+ else if Header.Channels >= 4 then
+ Format := ifA32R32G32B32F;
+ end;
end;
cmMono:; // Not supported
end;
end;
end;
- if Header.Depth = 32 then
- begin
- if (Header.Channels = 3) and (Header.Mode = cmRGB) then
- begin
- // RGB images were loaded as ARGB so we must wet alpha manually to 1.0
- PColF := Bits;
- for X := 0 to Width * Height - 1 do
- begin
- PColF.A := 1.0;
- Inc(PColF);
- end;
- end;
- end;
-
Result := True;
finally
FreeMem(LineBuffer);
if not SeparateChannelStorage then
begin
// This is for storing background merged image. There's only one
- // complession flag and one RLE lenghts table for all channels
+ // compression flag and one RLE lenghts table for all channels
WordVal := Swap(Compression);
GetIO.Write(Handle, @WordVal, SizeOf(WordVal));
if Compression = CompressionRLE then
begin
// Compress and write line
WrittenLineSize := PackLine(LineBuffer, RLEBuffer, LineSize);
- {RLELineSize := 7;
- RLEBuffer[0] := 129; RLEBuffer[1] := 255; RLEBuffer[2] := 131; RLEBuffer[3] := 100;
- RLEBuffer[4] := 1; RLEBuffer[5] := 0; RLEBuffer[6] := 255;}
RLELengths[ImageToSave.Height * I + Y] := SwapEndianWord(WrittenLineSize);
GetIO.Write(Handle, RLEBuffer, WrittenLineSize);
end
Write(Handle, @LongVal, SizeOf(LongVal)); // Layer section size, empty now
Write(Handle, @LayerCount, SizeOf(LayerCount)); // Layer count
Write(Handle, @R, SizeOf(R)); // Bounds rect
- Write(Handle, @WordVal, SizeOf(WordVal)); // Channeel count
+ Write(Handle, @WordVal, SizeOf(WordVal)); // Channel count
ChannelInfoOffset := Tell(Handle);
SetLength(ChannelDataSizes, Info.ChannelCount); // Empty channel infos
ConvFormat: TImageFormat;
begin
if Info.IsFloatingPoint then
- ConvFormat := IffFormat(Info.ChannelCount = 1, ifR32F, ifA32R32G32B32F)
+ begin
+ if Info.ChannelCount = 1 then
+ ConvFormat := ifR32F
+ else if Info.HasAlphaChannel then
+ ConvFormat := ifA32R32G32B32F
+ else
+ ConvFormat := ifR32G32B32F;
+ end
else if Info.HasGrayChannel then
ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16Gray16, ifGray16)
else if Info.RBSwapFormat in GetSupportedFormats then
{
File Notes:
- -- TODOS ----------------------------------------------------
- - nothing now
+ -- 0.77.1 ---------------------------------------------------
+ - 3 channel RGB float images are loaded and saved directly
+ as ifR32G32B32F.
-- 0.26.1 Changes/Bug Fixes ---------------------------------
- PSDs are now saved with RLE compression.
diff --git a/src/lib/vampimg/ImagingRadiance.pas b/src/lib/vampimg/ImagingRadiance.pas
--- /dev/null
@@ -0,0 +1,497 @@
+{
+ 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 contains image format loader/saver for Radiance HDR/RGBE images.}
+unit ImagingRadiance;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ SysUtils, Classes, Imaging, ImagingTypes, ImagingUtility;
+
+type
+ { Radiance is a suite of tools for performing lighting simulation. It's
+ development started in 1985 and it pioneered the concept of
+ high dynamic range imaging. Radiance defined an image format for storing
+ HDR images, now described as RGBE image format. Since it was the first
+ HDR image format, this format is supported by many other software packages.
+
+ Radiance image file consists of three sections: a header, resolution string,
+ followed by the pixel data. Each pixel is stored as 4 bytes, one byte
+ mantissa for each r, g, b and a shared one byte exponent.
+ The pixel data may be stored uncompressed or using run length encoding.
+
+ Imaging translates RGBE pixels to original float values and stores them
+ in ifR32G32B32F data format. It can read both compressed and uncompressed
+ files, and saves files as compressed.}
+ THdrFileFormat = class(TImageFileFormat)
+ protected
+ procedure Define; override;
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ function TestFormat(Handle: TImagingHandle): Boolean; override;
+ end;
+
+implementation
+
+uses
+ Math, ImagingIO;
+
+const
+ SHdrFormatName = 'Radiance HDR/RGBE';
+ SHdrMasks = '*.hdr';
+ HdrSupportedFormats: TImageFormats = [ifR32G32B32F];
+
+type
+ TSignature = array[0..9] of AnsiChar;
+ THdrFormat = (hfRgb, hfXyz);
+
+ THdrHeader = record
+ Format: THdrFormat;
+ Width: Integer;
+ Height: Integer;
+ end;
+
+ TRgbe = packed record
+ R, G, B, E: Byte;
+ end;
+ PRgbe = ^TRgbe;
+ TDynRgbeArray = array of TRgbe;
+
+const
+ RadianceSignature: TSignature = '#?RADIANCE';
+ RgbeSignature: TSignature = '#?RGBE';
+ MaxLineLength = 256;
+ SFmtRgbeRle = '32-bit_rle_rgbe';
+ SFmtXyzeRle = '32-bit_rle_xyze';
+
+resourcestring
+ SErrorBadHeader = 'Bad HDR/RGBE header format.';
+ SWrongScanLineWidth = 'Wrong scanline width.';
+ SXyzNotSupported = 'XYZ color space not supported.';
+
+{ THdrFileFormat }
+
+procedure THdrFileFormat.Define;
+begin
+ inherited;
+ FName := SHdrFormatName;
+ FFeatures := [ffLoad, ffSave];
+ FSupportedFormats := HdrSupportedFormats;
+
+ AddMasks(SHdrMasks);
+end;
+
+function THdrFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ Header: THdrHeader;
+ IO: TIOFunctions;
+
+ function ReadHeader: Boolean;
+ const
+ CommentIds: TAnsiCharSet = ['#', '!'];
+ var
+ Line: AnsiString;
+ HasResolution: Boolean;
+ Count, Idx: Integer;
+ ValStr, NativeLine: string;
+ ValFloat: Double;
+ begin
+ Result := False;
+ HasResolution := False;
+ Count := 0;
+
+ repeat
+ if not ReadLine(IO, Handle, Line) then
+ Exit;
+
+ Inc(Count);
+ if Count > 16 then // Too long header for HDR
+ Exit;
+
+ if Length(Line) = 0 then
+ Continue;
+ if Line[1] in CommentIds then
+ Continue;
+
+ NativeLine := string(Line);
+
+ if StrMaskMatch(NativeLine, 'Format=*') then
+ begin
+ // Data format parsing
+ ValStr := Copy(NativeLine, 8, MaxInt);
+ if ValStr = SFmtRgbeRle then
+ Header.Format := hfRgb
+ else if ValStr = SFmtXyzeRle then
+ Header.Format := hfXyz
+ else
+ Exit;
+ end;
+
+ if StrMaskMatch(NativeLine, 'Gamma=*') then
+ begin
+ ValStr := Copy(NativeLine, 7, MaxInt);
+ if TryStrToFloat(ValStr, ValFloat, GetFormatSettingsForFloats) then
+ FMetadata.SetMetaItem(SMetaGamma, ValFloat);
+ end;
+
+ if StrMaskMatch(NativeLine, 'Exposure=*') then
+ begin
+ ValStr := Copy(NativeLine, 10, MaxInt);
+ if TryStrToFloat(ValStr, ValFloat, GetFormatSettingsForFloats) then
+ FMetadata.SetMetaItem(SMetaExposure, ValFloat);
+ end;
+
+ if StrMaskMatch(NativeLine, '?Y * ?X *') then
+ begin
+ Idx := Pos('X', NativeLine);
+ ValStr := SubString(NativeLine, 4, Idx - 2);
+ if not TryStrToInt(ValStr, Header.Height) then
+ Exit;
+ ValStr := Copy(NativeLine, Idx + 2, MaxInt);
+ if not TryStrToInt(ValStr, Header.Width) then
+ Exit;
+
+ if (NativeLine[1] = '-') then
+ Header.Height := -Header.Height;
+ if (NativeLine[Idx - 1] = '-') then
+ Header.Width := -Header.Width;
+
+ HasResolution := True;
+ end;
+
+ until HasResolution;
+ Result := True;
+ end;
+
+ procedure DecodeRgbe(const Src: TRgbe; Dest: PColor96FPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ var
+ Mult: Single;
+ begin
+ if Src.E > 0 then
+ begin
+ Mult := Math.Ldexp(1, Src.E - 128);
+ Dest.R := Src.R / 255 * Mult;
+ Dest.G := Src.G / 255 * Mult;
+ Dest.B := Src.B / 255 * Mult;
+ end
+ else
+ begin
+ Dest.R := 0;
+ Dest.G := 0;
+ Dest.B := 0;
+ end;
+ end;
+
+ procedure ReadCompressedLine(Width, Y: Integer; var DestBuffer: TDynRgbeArray);
+ var
+ Pos: Integer;
+ I, X, Count: Integer;
+ Code, Value: Byte;
+ LineBuff: TDynByteArray;
+ Rgbe: TRgbe;
+ Ptr: PByte;
+ begin
+ SetLength(LineBuff, Width);
+ IO.Read(Handle, @Rgbe, SizeOf(Rgbe));
+
+ if ((Rgbe.B shl 8) or Rgbe.E) <> Width then
+ RaiseImaging(SWrongScanLineWidth);
+
+ for I := 0 to 3 do
+ begin
+ Pos := 0;
+ while Pos < Width do
+ begin
+ IO.Read(Handle, @Code, SizeOf(Byte));
+ if Code > 128 then
+ begin
+ Count := Code - 128;
+ IO.Read(Handle, @Value, SizeOf(Byte));
+ FillMemoryByte(@LineBuff[Pos], Count, Value);
+ end
+ else
+ begin
+ Count := Code;
+ IO.Read(Handle, @LineBuff[Pos], Count * SizeOf(Byte));
+ end;
+ Inc(Pos, Count);
+ end;
+
+ Ptr := @PByteArray(@DestBuffer[0])[I];
+ for X := 0 to Width - 1 do
+ begin
+ Ptr^ := LineBuff[X];
+ Inc(Ptr, 4);
+ end;
+ end;
+ end;
+
+ procedure ReadPixels(var Image: TImageData);
+ var
+ Y, X, SrcLineLen: Integer;
+ Dest: PColor96FPRec;
+ Compressed: Boolean;
+ Rgbe: TRgbe;
+ Buffer: TDynRgbeArray;
+ begin
+ Dest := Image.Bits;
+ Compressed := not ((Image.Width < 8) or (Image.Width > $7FFFF));
+ SrcLineLen := Image.Width * SizeOf(TRgbe);
+
+ IO.Read(Handle, @Rgbe, SizeOf(Rgbe));
+ IO.Seek(Handle, -SizeOf(Rgbe), smFromCurrent);
+
+ if (Rgbe.R <> 2) or (Rgbe.G <> 2) or ((Rgbe.B and 128) > 0) then
+ Compressed := False;
+
+ SetLength(Buffer, Image.Width);
+
+ for Y := 0 to Image.Height - 1 do
+ begin
+ if Compressed then
+ ReadCompressedLine(Image.Width, Y, Buffer)
+ else
+ IO.Read(Handle, @Buffer[0], SrcLineLen);
+
+ for X := 0 to Image.Width - 1 do
+ begin
+ DecodeRgbe(Buffer[X], Dest);
+ Inc(Dest);
+ end;
+ end;
+ end;
+
+begin
+ IO := GetIO;
+ SetLength(Images, 1);
+
+ // Read header, allocate new image and, then read and convert the pixels
+ if not ReadHeader then
+ RaiseImaging(SErrorBadHeader);
+ if (Header.Format = hfXyz) then
+ RaiseImaging(SXyzNotSupported);
+
+ NewImage(Abs(Header.Width), Abs(Header.Height), ifR32G32B32F, Images[0]);
+ ReadPixels(Images[0]);
+
+ // Flip/mirror the image as needed (height < 0 is default top-down)
+ if Header.Width < 0 then
+ MirrorImage(Images[0]);
+ if Header.Height > 0 then
+ FlipImage(Images[0]);
+
+ Result := True;
+end;
+
+function THdrFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: Integer): Boolean;
+const
+ LineEnd = #$0A;
+ SPrgComment = '#Made with Vampyre Imaging Library';
+ SSizeFmt = '-Y %d +X %d';
+var
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+ IO: TIOFunctions;
+
+ procedure SaveHeader;
+ begin
+ WriteLine(IO, Handle, RadianceSignature, LineEnd);
+ WriteLine(IO, Handle, SPrgComment, LineEnd);
+ WriteLine(IO, Handle, 'FORMAT=' + SFmtRgbeRle, LineEnd + LineEnd);
+ WriteLine(IO, Handle, AnsiString(Format(SSizeFmt, [ImageToSave.Height, ImageToSave.Width])), LineEnd);
+ end;
+
+ procedure EncodeRgbe(const Src: TColor96FPRec; var DestR, DestG, DestB, DestE: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ var
+ V, M: {$IFDEF FPC}Float{$ELSE}Extended{$ENDIF};
+ E: Integer;
+ begin
+ V := Src.R;
+ if (Src.G > V) then
+ V := Src.G;
+ if (Src.B > V) then
+ V := Src.B;
+
+ if V < 1e-32 then
+ begin
+ DestR := 0;
+ DestG := 0;
+ DestB := 0;
+ DestE := 0;
+ end
+ else
+ begin
+ Frexp(V, M, E);
+ V := M * 256.0 / V;
+ DestR := ClampToByte(Round(Src.R * V));
+ DestG := ClampToByte(Round(Src.G * V));
+ DestB := ClampToByte(Round(Src.B * V));
+ DestE := ClampToByte(E + 128);
+ end;
+ end;
+
+ procedure WriteRleLine(const Line: array of Byte; Width: Integer);
+ const
+ MinRunLength = 4;
+ var
+ Cur, BeginRun, RunCount, OldRunCount, NonRunCount: Integer;
+ Buf: array[0..1] of Byte;
+ begin
+ Cur := 0;
+ while Cur < Width do
+ begin
+ BeginRun := Cur;
+ RunCount := 0;
+ OldRunCount := 0;
+ while (RunCount < MinRunLength) and (BeginRun < Width) do
+ begin
+ Inc(BeginRun, RunCount);
+ OldRunCount := RunCount;
+ RunCount := 1;
+ while (BeginRun + RunCount < Width) and (RunCount < 127) and (Line[BeginRun] = Line[BeginRun + RunCount]) do
+ Inc(RunCount);
+ end;
+ if (OldRunCount > 1) and (OldRunCount = BeginRun - Cur) then
+ begin
+ Buf[0] := 128 + OldRunCount;
+ Buf[1] := Line[Cur];
+ IO.Write(Handle, @Buf, 2);
+ Cur := BeginRun;
+ end;
+ while Cur < BeginRun do
+ begin
+ NonRunCount := Min(128, BeginRun - Cur);
+ Buf[0] := NonRunCount;
+ IO.Write(Handle, @Buf, 1);
+ IO.Write(Handle, @Line[Cur], NonRunCount);
+ Inc(Cur, NonRunCount);
+ end;
+ if RunCount >= MinRunLength then
+ begin
+ Buf[0] := 128 + RunCount;
+ Buf[1] := Line[BeginRun];
+ IO.Write(Handle, @Buf, 2);
+ Inc(Cur, RunCount);
+ end;
+ end;
+ end;
+
+ procedure SavePixels;
+ var
+ Y, X, I, Width: Integer;
+ SrcPtr: PColor96FPRecArray;
+ Components: array of array of Byte;
+ StartLine: array[0..3] of Byte;
+ begin
+ Width := ImageToSave.Width;
+ // Save using RLE, each component is compressed separately
+ SetLength(Components, 4, Width);
+
+ for Y := 0 to ImageToSave.Height - 1 do
+ begin
+ SrcPtr := @PColor96FPRecArray(ImageToSave.Bits)[ImageToSave.Width * Y];
+
+ // Identify line as using "new" RLE scheme (separate components)
+ StartLine[0] := 2;
+ StartLine[1] := 2;
+ StartLine[2] := Width shr 8;
+ StartLine[3] := Width and $FF;
+ IO.Write(Handle, @StartLine, SizeOf(StartLine));
+
+ for X := 0 to Width - 1 do
+ begin
+ EncodeRgbe(SrcPtr[X], Components[0, X], Components[1, X],
+ Components[2, X], Components[3, X]);
+ end;
+
+ for I := 0 to 3 do
+ WriteRleLine(Components[I], Width);
+ end;
+ end;
+
+begin
+ Result := False;
+ IO := GetIO;
+ // Makes image to save compatible with Jpeg saving capabilities
+ if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
+ with ImageToSave do
+ try
+ // Save header
+ SaveHeader;
+ // Save uncompressed pixels
+ SavePixels;
+ finally
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end;
+end;
+
+procedure THdrFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+begin
+ ConvertImage(Image, ifR32G32B32F);
+end;
+
+function THdrFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ FileSig: TSignature;
+ ReadCount: Integer;
+begin
+ Result := False;
+ if Handle <> nil then
+ begin
+ ReadCount := GetIO.Read(Handle, @FileSig, SizeOf(FileSig));
+ GetIO.Seek(Handle, -ReadCount, smFromCurrent);
+ Result := (ReadCount = SizeOf(FileSig)) and
+ ((FileSig = RadianceSignature) or CompareMem(@FileSig, @RgbeSignature, 6));
+ end;
+end;
+
+initialization
+ RegisterImageFileFormat(THdrFileFormat);
+
+{
+ File Notes:
+
+ -- 0.77.1 ---------------------------------------------------
+ - Added RLE compression to saving.
+ - Added image saving.
+ - Unit created with initial stuff (loading only).
+
+}
+
+end.
index 5103f78e5e165fc80731a4c950d8a07ceec57e20..66af5f2c8b58b6cfc477f89ab67fbe5ad435a5ee 100644 (file)
{
- $Id: ImagingTarga.pas 139 2008-09-18 02:01:42Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
TTargaFileFormat = class(TImageFileFormat)
protected
FUseRLE: LongBool;
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
- constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
{ Controls that RLE compression is used during saving. Accessible trough
{ TTargaFileFormat class implementation }
-constructor TTargaFileFormat.Create;
+procedure TTargaFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := STargaFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
+ FFeatures := [ffLoad, ffSave];
FSupportedFormats := TargaSupportedFormats;
FUseRLE := TargaDefaultRLE;
index 7de0d120a9ffdff35abaf7702c238de7aec72116..9c5e1f13a0324d7c41a3004e595bb83e6d4177b7 100644 (file)
{
- $Id: ImagingTypes.pas 171 2009-09-02 01:34:19Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
{ Current Major version of Imaging.}
ImagingVersionMajor = 0;
{ Current Minor version of Imaging.}
- ImagingVersionMinor = 26;
+ ImagingVersionMinor = 77;
{ Current patch of Imaging.}
- ImagingVersionPatch = 4;
+ ImagingVersionPatch = 2;
{ Imaging Option Ids whose values can be set/get by SetOption/
GetOption functions.}
raw frames are loaded and sent to user (if you want to animate APNG yourself).
Default value is 1.}
ImagingPNGLoadAnimated = 27;
+ { Sets ZLib compression strategy used when saving PNG files (see deflateInit2()
+ in ZLib for details). Allowed values are: 0 (default), 1 (filtered),
+ 2 (huffman only). Default value is 0.}
+ ImagingPNGZLibStrategy = 28;
{ Specifies whether MNG animation frames are saved with lossy or lossless
compression. Lossless frames are saved as PNG images and lossy frames are
saved as JNG images. Allowed values are 0 (False) and 1 (True).
Default value is 0.}
- ImagingMNGLossyCompression = 28;
+ ImagingMNGLossyCompression = 32;
{ Defines whether alpha channel of lossy compressed MNG frames
(when ImagingMNGLossyCompression is 1) is lossy compressed too.
Allowed values are 0 (False) and 1 (True). Default value is 0.}
- ImagingMNGLossyAlpha = 29;
+ ImagingMNGLossyAlpha = 33;
{ Sets precompression filter used when saving MNG frames as PNG images.
For details look at ImagingPNGPreFilter.}
- ImagingMNGPreFilter = 30;
+ ImagingMNGPreFilter = 34;
{ Sets ZLib compression level used when saving MNG frames as PNG images.
For details look at ImagingPNGCompressLevel.}
- ImagingMNGCompressLevel = 31;
+ ImagingMNGCompressLevel = 35;
{ Specifies compression quality used when saving MNG frames as JNG images.
For details look at ImagingJpegQuality.}
- ImagingMNGQuality = 32;
+ ImagingMNGQuality = 36;
{ Specifies whether images are saved in progressive format when saving MNG
frames as JNG images. For details look at ImagingJpegProgressive.}
- ImagingMNGProgressive = 33;
+ ImagingMNGProgressive = 37;
{ Specifies whether alpha channels of JNG images are lossy compressed.
Allowed values are 0 (False) and 1 (True). Default value is 0.}
{ Specifies whether JNG images are saved in progressive format.
For details look at ImagingJpegProgressive.}
ImagingJNGProgressive = 44;
+
{ Specifies whether PGM files are stored in text or in binary format.
Allowed values are 0 (store as text - very! large files) and 1 (save binary).
Default value is 1.}
ImagingPGMSaveBinary = 50;
+
{ Specifies whether PPM files are stored in text or in binary format.
Allowed values are 0 (store as text - very! large files) and 1 (save binary).
Default value is 1.}
ImagingPPMSaveBinary = 51;
+
{ Boolean option that specifies whether GIF images with more frames
are animated by Imaging (according to frame disposal methods) or just
raw frames are loaded and sent to user (if you want to animate GIF yourself).
<Ord(Low(ImagingFormats.TSamplingFilter)), Ord(High(ImagingFormats.TSamplingFilter))>
and default value is 1 (linear filter).}
ImagingMipMapFilter = 131;
+ { Specifies treshold value used when automatically converting images to
+ ifBinary format. For adaptive tresholding see ImagingBinary.pas unit.
+ Default value is 128 and allowed range is 0..255.}
+ ImagingBinaryTreshold = 132;
{ Returned by GetOption if given Option Id is invalid.}
InvalidOption = -$7FFFFFFF;
TImageFormat = (
ifUnknown = 0,
ifDefault = 1,
- { Indexed formats using palette.}
+ { Indexed formats using palette }
ifIndex8 = 10,
- { Grayscale/Luminance formats.}
+ { Grayscale/Luminance formats }
ifGray8 = 40,
ifA8Gray8 = 41,
ifGray16 = 42,
ifGray32 = 43,
ifGray64 = 44,
ifA16Gray16 = 45,
- { ARGB formats.}
+ { ARGB formats }
ifX5R1G1B1 = 80,
ifR3G3B2 = 81,
ifR5G6B5 = 82,
ifA16R16G16B16 = 91,
ifB16G16R16 = 92,
ifA16B16G16R16 = 93,
- { Floating point formats.}
- ifR32F = 170,
- ifA32R32G32B32F = 171,
- ifA32B32G32R32F = 172,
- ifR16F = 173,
- ifA16R16G16B16F = 174,
- ifA16B16G16R16F = 175,
- { Special formats.}
- ifDXT1 = 220,
- ifDXT3 = 221,
- ifDXT5 = 222,
- ifBTC = 223,
- ifATI1N = 224,
- ifATI2N = 225);
+ { Floating point formats }
+ ifR32F = 160,
+ ifA32R32G32B32F = 161,
+ ifA32B32G32R32F = 162,
+ ifR16F = 163,
+ ifA16R16G16B16F = 164,
+ ifA16B16G16R16F = 165,
+ ifR32G32B32F = 166,
+ ifB32G32R32F = 167,
+ { Special formats }
+ ifDXT1 = 200,
+ ifDXT3 = 201,
+ ifDXT5 = 202,
+ ifBTC = 203,
+ ifATI1N = 204,
+ ifATI2N = 205,
+ ifBinary = 206
+ { Passtrough formats }
+ {ifETC1 = 220,
+ ifETC2RGB = 221,
+ ifETC2RGBA = 222,
+ ifETC2PA = 223,
+ ifDXBC6 = 224,
+ ifDXBC7 = 225}
+ );
{ Color value for 32 bit images.}
TColor32 = LongWord;
TColor64RecArray = array[0..MaxInt div SizeOf(TColor64Rec) - 1] of TColor64Rec;
PColor64RecArray = ^TColor64RecArray;
+ { Color record for 96 bit floating point images, which allows access to
+ individual color channels.}
+ TColor96FPRec = packed record
+ case Integer of
+ 0: (B, G, R: Single);
+ 1: (Channels: array[0..2] of Single);
+ end;
+ PColor96FPRec = ^TColor96FPRec;
+ TColor96FPRecArray = array[0..MaxInt div SizeOf(TColor96FPRec) - 1] of TColor96FPRec;
+ PColor96FPRecArray = ^TColor96FPRecArray;
+
{ Color record for 128 bit floating point images, which allows access to
individual color channels.}
TColorFPRec = packed record
case LongInt of
0: (B, G, R, A: Single);
1: (Channels: array[0..3] of Single);
+ 2: (Color96Rec: TColor96FPRec);
end;
PColorFPRec = ^TColorFPRec;
TColorFPRecArray = array[0..MaxInt div SizeOf(TColorFPRec) - 1] of TColorFPRec;
Size: LongInt; // Size of image bits in Bytes
Bits: Pointer; // Pointer to memory containing image bits
Palette: PPalette32; // Image palette for indexed images
+ Tag: Pointer; // User data
end;
PImageData = ^TImageData;
// format does not exist
IsIndexed: Boolean; // True if image uses palette
IsSpecial: Boolean; // True if image is in special format
+ IsPasstrough: Boolean; // True if image is in passtrough program (Imaging
+ // iself doesn't know how to decode and encode it -
+ // complex texture compressions etc.)
PixelFormat: PPixelFormatInfo; // Pixel format structure
GetPixelsSize: TFormatGetPixelsSizeFunc; // Returns size in bytes of
// Width * Height pixels of image
TResizeFilter = (
rfNearest = 0,
rfBilinear = 1,
- rfBicubic = 2);
+ rfBicubic = 2,
+ rfLanczos = 3);
{ Seek origin mode for IO function Seek.}
TSeekMode = (
smFromCurrent = 1,
smFromEnd = 2);
+ TOpenMode = (
+ omReadOnly = 0, // Opens file for reading only
+ omCreate = 1, // Creates new file (overwriting any existing) and opens it for writing
+ omReadWrite = 2 // Opens for reading and writing. Non existing file is created.
+ );
+
{ IO functions used for reading and writing images from/to input/output.}
- TOpenReadProc = function(Source: PChar): TImagingHandle; cdecl;
- TOpenWriteProc = function(Source: PChar): TImagingHandle; cdecl;
+ TOpenProc = function(Source: PChar; Mode: TOpenMode): TImagingHandle; cdecl;
TCloseProc = procedure(Handle: TImagingHandle); cdecl;
TEofProc = function(Handle: TImagingHandle): Boolean; cdecl;
TSeekProc = function(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode): LongInt; cdecl;
TReadProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
TWriteProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
+{$IFNDEF FPC}
+type
+{$IF CompilerVersion <= 18.5}
+ PtrUInt = LongWord;
+{$ELSE}
+ PtrUInt = NativeUInt;
+{$IFEND}
+{$ENDIF}
+
implementation
{
-- TODOS ----------------------------------------------------
- add lookup tables to pixel formats for fast conversions
+ -- 0.77.1 ---------------------------------------------------
+ - Added "Passtrough" image data formats.
+ - Added Tag to TImageData for storing user data.
+ - Added ImagingPNGZLibStrategy option.
+ - Changed IO functions. Merged open functions to one
+ and added third open mode R/W (for TIFF append etc.).
+ - Added new image data formats and related structures:
+ ifR32G32B32F, ifB32G32G32F.
+
+ -- 0.26.5 Changes/Bug Fixes ---------------------------------
+ - Added ifBinary image format and ImagingBinaryTreshold option.
+ - Lanczos filter added to TResizeFilter enum.
+
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- Added ifATI1N and ifATI2N image data formats.
index e22ef52d859270c82650ddd18d441facafeefe05..c137e1d1386823beaaeefdd0d2aec47e21d5c93e 100644 (file)
{
- $Id: ImagingUtility.pas 175 2009-10-06 11:55:15Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
TDynByteArray = array of Byte;
TDynIntegerArray = array of Integer;
TDynBooleanArray = array of Boolean;
+ TDynStringArray = array of string;
TWordRec = packed record
case Integer of
PInt64RecArray = ^TInt64RecArray;
TFloatHelper = record
- Data1: Int64;
- Data2: Int64;
- end;
+ Data: Int64;
+ case Integer of
+ 0: (Data64: Int64);
+ 1: (Data32: LongWord);
+ end;
PFloatHelper = ^TFloatHelper;
+ TFloatRect = record
+ Left, Top, Right, Bottom: Single;
+ end;
+
TChar2 = array[0..1] of AnsiChar;
TChar3 = array[0..2] of AnsiChar;
TChar4 = array[0..3] of AnsiChar;
TChar8 = array[0..7] of AnsiChar;
TChar16 = array[0..15] of AnsiChar;
+ TAnsiCharSet = set of AnsiChar;
+
+ ENotImplemented = class(Exception)
+ public
+ constructor Create;
+ end;
{ Options for BuildFileList function:
flFullNames - file names in result will have full path names
{ Returns directory where application's exceutable is located without
path delimiter at the end.}
function GetAppDir: string;
-{ Returns True if FileName matches given Mask with optional case sensitivity.
+{ Works like SysUtils.ExtractFileName but supports '/' and '\' dir delimiters
+ at the same time (whereas ExtractFileName supports on default delimiter on current platform).}
+function GetFileName(const FileName: string): string;
+{ Works like SysUtils.ExtractFileDir but supports '/' and '\' dir delimiters
+ at the same time (whereas ExtractFileDir supports on default delimiter on current platform).}
+function GetFileDir(const FileName: string): string;
+{ Returns True if Subject matches given Mask with optional case sensitivity.
Mask can contain ? and * special characters: ? matches
one character, * matches zero or more characters.}
-function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean = False): Boolean;
+function StrMaskMatch(const Subject, Mask: string; CaseSensitive: Boolean = False): Boolean;
{ This function fills Files string list with names of files found
with FindFirst/FindNext functions (See details on Path/Atrr here).
- BuildFileList('c:\*.*', faAnyFile, List, [flRecursive]) returns
{ Fills instance of TStrings with tokens from string S where tokens are separated by
one of Seps characters.}
procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
-{ Returns string representation of integer number (with digit grouping).}
+{ Returns string representation of integer number (with digit grouping).
+ Uses current locale.}
function IntToStrFmt(const I: Int64): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
-{ Returns string representation of float number (with digit grouping).}
+{ Returns string representation of float number (with digit grouping).
+ Uses current locale.}
function FloatToStrFmt(const F: Double; Precision: Integer = 2): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns format settings for parsing floats (dot as decimal separator).
+ Useful when fomatting/parsing floats etc.}
+function GetFormatSettingsForFloats: TFormatSettings;
+{ Returns True if S contains at least one of the substrings in SubStrs array. Case sensitive.}
+function ContainsAnySubStr(const S: string; const SubStrs: array of string): Boolean;
+{ Extracts substring starting at IdxStart ending at IdxEnd.
+ S[IdxEnd] is not included in the result.}
+function SubString(const S: string; IdxStart, IdxEnd: Integer): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Clamps integer value to range <Min, Max>}
function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
function Log2Int(X: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns log base 2 of X.}
function Log2(X: Single): Single;
+{ Returns log base 10 of X.}
+function Log10(X: Single): Single;
{ Returns largest integer <= Val (for 5.9 returns 5).}
function Floor(Value: Single): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns smallest integer >= Val (for 5.1 returns 6).}
@@ -229,6 +259,8 @@ function Iff(Condition: Boolean; const TruePart, FalsePart: Int64): Int64; overl
{ If Condition is True then TruePart is retured, otherwise
FalsePart is returned.}
function IffFloat(Condition: Boolean; TruePart, FalsePart: Single): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Swaps two Boolean values}
+procedure SwapValues(var A, B: Boolean); overload;
{ Swaps two Byte values}
procedure SwapValues(var A, B: Byte); overload;
{ Swaps two Word values}
procedure FillMemoryWord(Data: Pointer; Size: LongInt; Value: Word);
{ Fills given memory with given LongWord value. Size is size of buffer in bytes.}
procedure FillMemoryLongWord(Data: Pointer; Size: LongInt; Value: LongWord);
+{ Fills given memory zeroes.}
+{$EXTERNALSYM ZeroMemory} // Conflicts with WinAPI ZeroMemory in C++ Builder
+procedure ZeroMemory(Data: Pointer; Size: Integer); {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns how many mipmap levels can be created for image of given size.}
function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
{ Scales one rectangle to fit into another. Proportions are preserved so
it could be used for 'Stretch To Fit Window' image drawing for instance.}
function ScaleRectToRect(const SourceRect, TargetRect: TRect): TRect;
+{ Scales given size to fit into max size while keeping the original ascpect ration.
+ Useful for calculating thumbnail dimensions etc.}
+function ScaleSizeToFit(const CurrentSize, MaxSize: TSize): TSize;
+{ Returns width of given rect. Part of RTL in newer Delphi.}
+function RectWidth(const Rect: TRect): Integer;
+{ Returns height of given rect. Part of RTL in newer Delphi.}
+function RectHeight(const Rect: TRect): Integer;
{ Returns True if R1 fits into R2.}
function RectInRect(const R1, R2: TRect): Boolean;
{ Returns True if R1 and R2 intersects.}
function RectIntersects(const R1, R2: TRect): Boolean;
+{ Converts pixel size in micrometers to corrensponding DPI.}
+function PixelSizeToDpi(SizeInMicroMeters: Single): Single;
+{ Converts DPI to corrensponding pixel size in micrometers.}
+function DpiToPixelSize(Dpi: Single): Single;
+
+function FloatRect(ALeft, ATop, ARight, ABottom: Single): TFloatRect;
+function FloatRectWidth(const R: TFloatRect): Single;
+function FloatRectHeight(const R: TFloatRect): Single;
+
{ Formats given message for usage in Exception.Create(..). Use only
in except block - returned message contains message of last raised exception.}
function FormatExceptMsg(const Msg: string; const Args: array of const): string;
implementation
uses
-{$IFDEF MSWINDOWS}
+{$IF Defined(MSWINDOWS)}
Windows;
-{$ENDIF}
-{$IFDEF UNIX}
- {$IFDEF KYLIX}
- Libc;
- {$ELSE}
+{$ELSEIF Defined(FPC)}
Dos, BaseUnix, Unix;
- {$ENDIF}
-{$ENDIF}
+{$ELSEIF Defined(DELPHI)}
+ Posix.SysTime;
+{$IFEND}
+
+var
+ FloatFormatSettings: TFormatSettings;
+
+constructor ENotImplemented.Create;
+begin
+ inherited Create('Not implemented');
+end;
procedure FreeAndNil(var Obj);
var
Result := Exception(ExceptObject);
end;
-{$IFDEF MSWINDOWS}
+{$IF Defined(MSWINDOWS)}
var
PerfFrequency: Int64;
InvPerfFrequency: Single;
QueryPerformanceCounter(Time);
Result := Round(1000000 * InvPerfFrequency * Time);
end;
-{$ENDIF}
-
-{$IFDEF UNIX}
+{$ELSEIF Defined(DELPHI)}
+function GetTimeMicroseconds: Int64;
+var
+ Time: TimeVal;
+begin
+ Posix.SysTime.GetTimeOfDay(Time, nil);
+ Result := Int64(Time.tv_sec) * 1000000 + Time.tv_usec;
+end;
+{$ELSEIF Defined(FPC)}
function GetTimeMicroseconds: Int64;
var
TimeVal: TTimeVal;
begin
- {$IFDEF KYLIX}
- GetTimeOfDay(TimeVal, nil);
- {$ELSE}
fpGetTimeOfDay(@TimeVal, nil);
- {$ENDIF}
Result := Int64(TimeVal.tv_sec) * 1000000 + TimeVal.tv_usec;
end;
-{$ENDIF}
-
-{$IFDEF MSDOS}
-function GetTimeMicroseconds: Int64;
-asm
- XOR EAX, EAX
- CLI
- OUT $43, AL
- MOV EDX, FS:[$46C]
- IN AL, $40
- DB $EB, 0, $EB, 0, $EB, 0
- MOV AH, AL
- IN AL, $40
- DB $EB, 0, $EB, 0, $EB, 0
- XCHG AL, AH
- NEG AX
- MOVZX EDI, AX
- STI
- MOV EBX, $10000
- MOV EAX, EDX
- XOR EDX, EDX
- MUL EBX
- ADD EAX, EDI
- ADC EDX, 0
- PUSH EDX
- PUSH EAX
- MOV ECX, $82BF1000
- MOVZX EAX, WORD PTR FS:[$470]
- MUL ECX
- MOV ECX, EAX
- POP EAX
- POP EDX
- ADD EAX, ECX
- ADC EDX, 0
-end;
-{$ENDIF}
+{$IFEND}
function GetTimeMilliseconds: Int64;
begin
end;
function GetAppExe: string;
-{$IFDEF MSWINDOWS}
+{$IF Defined(MSWINDOWS)}
var
FileName: array[0..MAX_PATH] of Char;
begin
SetString(Result, FileName,
Windows.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
-{$ENDIF}
-{$IFDEF UNIX}
- {$IFDEF KYLIX}
+{$ELSEIF Defined(DELPHI)} // Delphi non Win targets
var
- FileName: array[0..FILENAME_MAX] of Char;
+ FileName: array[0..1024] of Char;
begin
SetString(Result, FileName,
System.GetModuleFileName(MainInstance, FileName, SizeOf(FileName)));
- {$ELSE}
-begin
- Result := FExpand(ParamStr(0));
- {$ENDIF}
-{$ENDIF}
-{$IFDEF MSDOS}
+{$ELSE}
begin
Result := ParamStr(0);
-{$ENDIF}
+{$IFEND}
end;
function GetAppDir: string;
Result := ExtractFileDir(GetAppExe);
end;
-function MatchFileNameMask(const FileName, Mask: string; CaseSensitive: Boolean): Boolean;
+function GetFileName(const FileName: string): string;
+var
+ I: Integer;
+begin
+ I := LastDelimiter('\/' + DriveDelim, FileName);
+ Result := Copy(FileName, I + 1, MaxInt);
+end;
+
+function GetFileDir(const FileName: string): string;
+const
+ Delims = '\/' + DriveDelim;
+var
+ I: Integer;
+begin
+ I := LastDelimiter(Delims, Filename);
+ if (I > 1) and
+ ((FileName[I] = Delims[1]) or (FileName[I] = Delims[2])) and
+ (not IsDelimiter(Delims, FileName, I - 1)) then Dec(I);
+ Result := Copy(FileName, 1, I);
+end;
+
+function StrMaskMatch(const Subject, Mask: string; CaseSensitive: Boolean): Boolean;
var
MaskLen, KeyLen : LongInt;
Exit;
end;
else
- if not CharMatch(Mask[MaskPos], FileName[KeyPos]) then
+ if not CharMatch(Mask[MaskPos], Subject[KeyPos]) then
begin
Result := False;
Exit;
end;
end;
- while (MaskPos <= MaskLen) and (Mask[MaskPos] in ['?', '*']) do
+ while (MaskPos <= MaskLen) and (AnsiChar(Mask[MaskPos]) in ['?', '*']) do
Inc(MaskPos);
if (MaskPos <= MaskLen) or (KeyPos <= KeyLen) then
begin
begin
MaskLen := Length(Mask);
- KeyLen := Length(FileName);
+ KeyLen := Length(Subject);
if MaskLen = 0 then
begin
Result := True;
Result := Format('%.' + IntToStr(Precision) + 'n', [F]);
end;
+function GetFormatSettingsForFloats: TFormatSettings;
+begin
+ Result := FloatFormatSettings;
+end;
+
+function ContainsAnySubStr(const S: string; const SubStrs: array of string): Boolean;
+var
+ I: Integer;
+begin
+ Result := False;
+ for I := 0 to High(SubStrs) do
+ begin
+ Result := Pos(SubStrs[I], S) > 0;
+ if Result then
+ Exit;
+ end;
+end;
+
+function SubString(const S: string; IdxStart, IdxEnd: Integer): string;
+begin
+ Result := Copy(S, IdxStart, IdxEnd - IdxStart);
+end;
+
function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt;
begin
Result := Number;
end;
function Log2(X: Single): Single;
+{$IFDEF USE_ASM}
+asm
+ FLD1
+ FLD X
+ FYL2X
+ FWAIT
+end;
+{$ELSE}
const
Ln2: Single = 0.6931471;
begin
Result := Ln(X) / Ln2;
end;
+{$ENDIF}
+
+function Log10(X: Single): Single;
+{$IFDEF USE_ASM}
+asm
+ FLDLG2
+ FLD X
+ FYL2X
+ FWAIT
+end;
+{$ELSE}
+const
+ Ln10: Single = 2.30258509299405;
+begin
+ Result := Ln(X) / Ln10;
+end;
+{$ENDIF}
function Floor(Value: Single): LongInt;
begin
Result := FalsePart;
end;
+procedure SwapValues(var A, B: Boolean);
+var
+ Tmp: Boolean;
+begin
+ Tmp := A;
+ A := B;
+ B := Tmp;
+end;
+
procedure SwapValues(var A, B: Byte);
var
Tmp: Byte;
end;
{$ENDIF}
+procedure ZeroMemory(Data: Pointer; Size: Integer);
+begin
+ FillMemoryByte(Data, Size, 0);
+end;
+
function GetNumMipMapLevels(Width, Height: LongInt): LongInt;
begin
Result := 0;
end;
end;
+function ScaleSizeToFit(const CurrentSize, MaxSize: Types.TSize): Types.TSize;
+var
+ SR, TR, ScaledRect: TRect;
+begin
+ SR := Types.Rect(0, 0, CurrentSize.CX, CurrentSize.CY);
+ TR := Types.Rect(0, 0, MaxSize.CX, MaxSize.CY);
+ ScaledRect := ScaleRectToRect(SR, TR);
+ Result.CX := ScaledRect.Right - ScaledRect.Left;
+ Result.CY := ScaledRect.Bottom - ScaledRect.Top;
+end;
+
+function RectWidth(const Rect: TRect): Integer;
+begin
+ Result := Rect.Right - Rect.Left;
+end;
+
+function RectHeight(const Rect: TRect): Integer;
+begin
+ Result := Rect.Bottom - Rect.Top;
+end;
+
function RectInRect(const R1, R2: TRect): Boolean;
begin
Result:=
not (R1.Bottom < R2.Top);
end;
+function PixelSizeToDpi(SizeInMicroMeters: Single): Single;
+begin
+ Result := 25400 / SizeInMicroMeters;
+end;
+
+function DpiToPixelSize(Dpi: Single): Single;
+begin
+ Result := 1e03 / (Dpi / 25.4);
+end;
+
+function FloatRect(ALeft, ATop, ARight, ABottom: Single): TFloatRect;
+begin
+ with Result do
+ begin
+ Left := ALeft;
+ Top := ATop;
+ Right := ARight;
+ Bottom := ABottom;
+ end;
+end;
+
+function FloatRectWidth(const R: TFloatRect): Single;
+begin
+ Result := R.Right - R.Left;
+end;
+
+function FloatRectHeight(const R: TFloatRect): Single;
+begin
+ Result := R.Bottom - R.Top;
+end;
+
function FormatExceptMsg(const Msg: string; const Args: array of const): string;
begin
Result := Format(Msg + SLineBreak + 'Message: ' + GetExceptObject.Message, Args);
QueryPerformanceFrequency(PerfFrequency);
InvPerfFrequency := 1.0 / PerfFrequency;
{$ENDIF}
-{$IFDEF MSDOS}
- // reset PIT
- asm
- MOV EAX, $34
- OUT $43, AL
- XOR EAX, EAX
- OUT $40, AL
- OUT $40, AL
- end;
-{$ENDIF}
+
+{$IF Defined(DELPHI)}
+ {$IF CompilerVersion >= 23}
+ FloatFormatSettings := TFormatSettings.Create('en-US');
+ {$ELSE}
+ GetLocaleFormatSettings(1033, FloatFormatSettings);
+ {$IFEND}
+{$ELSE FPC}
+ FloatFormatSettings := DefaultFormatSettings;
+ FloatFormatSettings.DecimalSeparator := '.';
+{$IFEND}
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
+ -- 0.77.1 ----------------------------------------------------
+ - Added GetFileName, GetFileDir, RectWidth, RectHeight function.
+ - Added ScaleSizeToFit function.
+ - Added ZeroMemory and SwapValues for Booleans.
+ - Added Substring function.
+ - Renamed MatchFileNameMask to StrMaskMatch (it's for general use not
+ just filenames).
+ - Delphi XE2 new targets (Win64, OSX32) compatibility changes.
+ - Added GetFormatSettingsForFloats function.
+
+ -- 0.26.5 Changes/Bug Fixes -----------------------------------
+ - Added Log10 function.
+ - Added TFloatRect type and helper functions FloatRect, FloatRectWidth,
+ FloatRectHeight.
+ - Added string function ContainsAnySubStr.
+ - Added functions PixelSizeToDpi, DpiToPixelSize.
+
-- 0.26.1 Changes/Bug Fixes -----------------------------------
- Some formatting changes.
- Changed some string functions to work with localized strings.
index cf743d84c76049b05e626f3050e449ff4b2f7f52..2e10dc2cecc99f87d32def773a3a1cb30413645e 100644 (file)
{
- $Id: ImagingXpm.pas 171 2009-09-02 01:34:19Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
Loading as well as saving is supported now. }
TXPMFileFormat = class(TImageFileFormat)
protected
+ procedure Define; override;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
procedure ConvertToSupported(var Image: TImageData;
const Info: TImageFormatInfo); override;
public
- constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
end;
begin
Result := '';
if FindItem(AKey, Bucket, Index) then
- Result := FBuckets[Bucket].Items[Index].Data;
+ Result := string(FBuckets[Bucket].Items[Index].Data);
end;
procedure TSimpleBucketList.SetData(AKey: TColor32; const AData: string);
Bucket, Index: Integer;
begin
if FindItem(AKey, Bucket, Index) then
- FBuckets[Bucket].Items[Index].Data := AData;
+ FBuckets[Bucket].Items[Index].Data := ShortString(AData);
end;
function TSimpleBucketList.EnumNext(out AData: string): TColor32;
end;
Result := FBuckets[FABucket].Items[FAIndex].Key;
- AData := FBuckets[FABucket].Items[FAIndex].Data;
+ AData := string(FBuckets[FABucket].Items[FAIndex].Data);
Inc(FAIndex);
end;
with Items[Count] do
begin
Key := AKey;
- Data := AData;
+ Data := ShortString(AData);
end;
Inc(Count);
Inc(FItemCount);
TXPMFileFormat implementation
}
-constructor TXPMFileFormat.Create;
+procedure TXPMFileFormat.Define;
begin
- inherited Create;
+ inherited;
FName := SXPMFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
+ FFeatures := [ffLoad, ffSave];
FSupportedFormats := XPMSupportedFormats;
AddMasks(SXPMMasks);
procedure SkipWhiteSpace(var Line: string);
begin
- while (Length(Line) > 0) and (Line[1] in WhiteSpaces) do
+ while (Length(Line) > 0) and (AnsiChar(Line[1]) in WhiteSpaces) do
Delete(Line, 1, 1);
end;
begin
Result := '';
SkipWhiteSpace(Line);
- while (Length(Line) > 0) and not(Line[1] in WhiteSpaces) do
+ while (Length(Line) > 0) and not (AnsiChar(Line[1]) in WhiteSpaces) do
begin
SetLength(Result, Length(Result) + 1);
Result[Length(Result)] := Line[1];
Contents := TStringList.Create;
SetLength(S, GetInputSize(GetIO, Handle));
Read(Handle, @S[1], Length(S));
- Contents.Text := S;
+ Contents.Text := string(S);
// Remove quotes and other stuff
for I := Contents.Count - 1 downto 0 do
begin
index 105f57474d31dcba2eeabd1a00af390bc3616ae3..d16c2ae031bb8a9f3d228ded827fab3abae5fd38 100644 (file)
begin
if (cinfo^.progress <> NIL) then
begin
- cinfo^.progress^.pass_counter := long (iMCU_row);
- cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows);
- cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
+ cinfo^.progress^.pass_counter := long (iMCU_row);
+ cinfo^.progress^.pass_limit := long (cinfo^.total_iMCU_rows);
+ cinfo^.progress^.progress_monitor (j_common_ptr(cinfo));
end;
{ We bypass the main controller and invoke coef controller directly;
all work is being done from the coefficient buffer. }
if (not cinfo^.coef^.compress_data (cinfo, JSAMPIMAGE(NIL))) then
- ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND);
+ ERREXIT(j_common_ptr(cinfo), JERR_CANT_SUSPEND);
end;
cinfo^.master^.finish_pass (cinfo);
end;
index 578706c1b88e9bba27ef54352281e7c487c818bb..09fb8af2044dfb3c9b8dd90b0a3d49c256b2771d 100644 (file)
{ Private subobject }
type
- jTInt32 = 0..Pred(MaxInt div SizeOf(INT32));
- INT32_FIELD = array[jTInt32] of INT32;
+ INT32_FIELD = array[0..MaxInt div SizeOf(INT32) - 1] of INT32;
INT32_FIELD_PTR = ^INT32_FIELD;
type
{METHODDEF}
procedure rgb_ycc_start (cinfo : j_compress_ptr);
const
- FIX_0_29900 = INT32(Round (0.29900 * (1 shl SCALEBITS)) );
- FIX_0_58700 = INT32(Round (0.58700 * (1 shl SCALEBITS)) );
- FIX_0_11400 = INT32(Round (0.11400 * (1 shl SCALEBITS)) );
- FIX_0_16874 = INT32(Round (0.16874 * (1 shl SCALEBITS)) );
- FIX_0_33126 = INT32(Round (0.33126 * (1 shl SCALEBITS)) );
- FIX_0_50000 = INT32(Round (0.50000 * (1 shl SCALEBITS)) );
- FIX_0_41869 = INT32(Round (0.41869 * (1 shl SCALEBITS)) );
- FIX_0_08131 = INT32(Round (0.08131 * (1 shl SCALEBITS)) );
+ FIX_0_29900 = INT32(Round(0.29900 * (1 shl SCALEBITS)));
+ FIX_0_58700 = INT32(Round(0.58700 * (1 shl SCALEBITS)));
+ FIX_0_11400 = INT32(Round(0.11400 * (1 shl SCALEBITS)));
+ FIX_0_16874 = INT32(Round(0.16874 * (1 shl SCALEBITS)));
+ FIX_0_33126 = INT32(Round(0.33126 * (1 shl SCALEBITS)));
+ FIX_0_50000 = INT32(Round(0.50000 * (1 shl SCALEBITS)));
+ FIX_0_41869 = INT32(Round(0.41869 * (1 shl SCALEBITS)));
+ FIX_0_08131 = INT32(Round(0.08131 * (1 shl SCALEBITS)));
var
cconvert : my_cconvert_ptr;
rgb_ycc_tab : INT32_FIELD_PTR;
while (num_rows > 0) do
begin
Dec(num_rows);
- inptr := input_buf^[0];
+ inptr := input_buf[0];
Inc(JSAMPROW_PTR(input_buf));
- outptr := output_buf^[0]^[output_row];
+ outptr := output_buf[0][output_row];
Inc(output_row);
- for col := 0 to pred(num_cols) do
+ for col := 0 to num_cols - 1 do
begin
- r := GETJSAMPLE(inptr^[RGB_RED]);
- g := GETJSAMPLE(inptr^[RGB_GREEN]);
- b := GETJSAMPLE(inptr^[RGB_BLUE]);
+ r := GETJSAMPLE(inptr[RGB_RED]);
+ g := GETJSAMPLE(inptr[RGB_GREEN]);
+ b := GETJSAMPLE(inptr[RGB_BLUE]);
Inc(JSAMPLE_PTR(inptr), RGB_PIXELSIZE);
(* Y *)
- // kylix 3 compiler crashes on this
- {$IF (not Defined(LINUX)) or Defined(FPC)}
- outptr^[col] := JSAMPLE (
- ((ctab^[r+R_Y_OFF] + ctab^[g+G_Y_OFF] + ctab^[b+B_Y_OFF])
- shr SCALEBITS) );
+ // kylix 3 compiler crashes on this
+ // it also crashes Delphi OSX compiler 9 years later :(
+ {$IF not (Defined(DCC) and not Defined(MSWINDOWS))}
+ outptr[col] := JSAMPLE(((ctab[r+R_Y_OFF] + ctab[g+G_Y_OFF] + ctab[b+B_Y_OFF]) shr SCALEBITS));
{$IFEND}
end;
end;
-
end;
index b57c93396a783c33935b9fec339e848f6c002fe8..70cf4785264539fc285018515cece0cb4fb6e1a6 100644 (file)
{!CHANGE: Added this}
{$define Delphi_Stream}
{$Q-}
+{$MINENUMSIZE 4}
+{$ALIGN 8}
index c2202c2e0a44009a5bddea3e2d5d901cb38cac81..b87a3dd8d4d1a85819e8c7e91ca1b3324044afd7 100644 (file)
var
length : INT32;
b : array[0..APPN_DATA_LEN-1] of JOCTET;
- i, numtoread : uint;
+ i, numtoread: uint;
var
datasrc : jpeg_source_mgr_ptr;
next_input_byte : JOCTETptr;
numtoread := uint(length)
else
numtoread := 0;
- for i := 0 to numtoread-1 do
+
+ if numtoread > 0 then
begin
- { Read a byte into b[i]. If must suspend, return FALSE. }
- { make a byte available.
- Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
- but we must reload the local copies after a successful fill. }
- if (bytes_in_buffer = 0) then
+ for i := 0 to numtoread-1 do
begin
- if (not datasrc^.fill_input_buffer(cinfo)) then
+ { Read a byte into b[i]. If must suspend, return FALSE. }
+ { make a byte available.
+ Note we do *not* do INPUT_SYNC before calling fill_input_buffer,
+ but we must reload the local copies after a successful fill. }
+ if (bytes_in_buffer = 0) then
begin
- get_interesting_appn := FALSE;
- exit;
+ if (not datasrc^.fill_input_buffer(cinfo)) then
+ begin
+ get_interesting_appn := FALSE;
+ exit;
+ end;
+ { Reload the local copies }
+ next_input_byte := datasrc^.next_input_byte;
+ bytes_in_buffer := datasrc^.bytes_in_buffer;
end;
- { Reload the local copies }
- next_input_byte := datasrc^.next_input_byte;
- bytes_in_buffer := datasrc^.bytes_in_buffer;
- end;
- Dec( bytes_in_buffer );
+ Dec( bytes_in_buffer );
- b[i] := GETJOCTET(next_input_byte^);
- Inc(next_input_byte);
+ b[i] := GETJOCTET(next_input_byte^);
+ Inc(next_input_byte);
+ end;
end;
Dec(length, numtoread);
index 0a61814e8c93c38b83829386b3459068fde8ac42..11f53fde5e6303c86f1e23e30097dcea509ea1b3 100644 (file)
p1 : int; p2 : int; p3 : int; p4 : int);
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
- str : string);
+ str : AnsiString);
{ Nonfatal errors (we can keep going, but the data is probably corrupt) }
procedure WARNMS(cinfo : j_common_ptr; code : J_MESSAGE_CODE);
p5 : int; p6 : int; p7 : int; p8 : int);
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
- code : J_MESSAGE_CODE; str : string);
+ code : J_MESSAGE_CODE; str : AnsiString);
implementation
end;
procedure ERREXITS(cinfo : j_common_ptr;code : J_MESSAGE_CODE;
- str : string);
+ str : AnsiString);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string[JMSG_STR_PARM_MAX] }
end;
procedure TRACEMSS(cinfo : j_common_ptr; lvl : int;
- code : J_MESSAGE_CODE; str : string);
+ code : J_MESSAGE_CODE; str : AnsiString);
begin
cinfo^.err^.msg_code := ord(code);
cinfo^.err^.msg_parm.s := str; { string JMSG_STR_PARM_MAX }
{METHODDEF}
procedure output_message (cinfo : j_common_ptr);
var
- buffer : string; {[JMSG_LENGTH_MAX];}
+ buffer : AnsiString; {[JMSG_LENGTH_MAX];}
begin
{ Create the message }
cinfo^.err^.format_message (cinfo, buffer);
{METHODDEF}
-procedure format_message (cinfo : j_common_ptr; var buffer : string);
+procedure format_message (cinfo : j_common_ptr; var buffer : AnsiString);
var
err : jpeg_error_mgr_ptr;
msg_code : J_MESSAGE_CODE;
- msgtext : string;
+ msgtext : AnsiString;
isstring : boolean;
begin
err := cinfo^.err;
index 316a9a7a00606e3714d43fc8b73c13eb4b3cadbd..fddf3f5b8a399a1445ea804e932caab5de8da43e 100644 (file)
{$I imjconfig.inc}
-{$IFDEF FPC} { Free Pascal Compiler }
- type
- int = longint;
- uInt = Cardinal; { unsigned int }
- short = Integer;
- ushort = Word;
- long = longint;
-{$ELSE}
-{$IFDEF WIN32}
- { Delphi 2.0 }
- type
- int = Integer;
- uInt = Cardinal;
- short = SmallInt;
- ushort = Word;
- long = longint;
- {$ELSE}
- {$IFDEF VIRTUALPASCAL}
- type
- int = longint;
- uInt = longint; { unsigned int }
- short = system.Integer;
- ushort = system.Word;
- long = longint;
- {$ELSE}
- type
- int = Integer;
- uInt = Word; { unsigned int }
- short = Integer;
- ushort = Word;
- long = longint;
- {$ENDIF}
-{$ENDIF}
-{$ENDIF}
+type
+ int = Integer;
+ uInt = Cardinal;
+ short = SmallInt;
+ ushort = Word;
+ long = LongInt;
+
type
voidp = pointer;
JPEG standard, and the IJG code does not support anything else!
We do not support run-time selection of data precision, sorry. }
+
{$ifdef BITS_IN_JSAMPLE_IS_8} { use 8 or 12 }
const
BITS_IN_JSAMPLE = 8;
{$endif}
-
-
{ Maximum number of components (color channels) allowed in JPEG image.
To meet the letter of the JPEG spec, set this to 255. However, darn
few applications need more than 4 channels (maybe 5 for CMYK + alpha
{ UINT8 must hold at least the values 0..255. }
type
- UINT8 = byte;
+ UINT8 = Byte;
{ UINT16 must hold at least the values 0..65535. }
{ INT16 must hold at least the values -32768..32767. }
- INT16 = int;
+ INT16 = SmallInt;
{ INT32 must hold at least signed 32-bit values. }
- INT32 = longint;
+ INT32 = LongInt;
type
INT32PTR = ^INT32;
index f3f530d00770c497132337cf1a4371334e2178e7..dc35daadecd99b762a06303e8dc0a79a2b7f7b9b 100644 (file)
{ Routine that actually outputs a trace or error message }
output_message : procedure (cinfo : j_common_ptr);
{ Format a message string for the most recent JPEG error or message }
- format_message : procedure (cinfo : j_common_ptr; var buffer : string);
+ format_message : procedure (cinfo : j_common_ptr; var buffer : AnsiString);
{ Reset error state variables at start of a new image }
reset_error_mgr : procedure (cinfo : j_common_ptr);
index 72031aa9d1a87141b3f94086549d096e7afaae1e..05e278d0fd78f5f5faf1dd64892422946f68deb9 100644 (file)
interface
-{ $DEFINE ZLIBEX}
-{ $DEFINE DELPHIZLIB}
-{ $DEFINE ZLIBPAS}
{$DEFINE IMPASZLIB}
+{ $DEFINE ZLIBPAS}
{ $DEFINE FPCPASZLIB}
+{ $DEFINE ZLIBEX}
+{ $DEFINE DELPHIZLIB}
-{ Automatically use FPC's PasZLib when compiling with Lazarus.}
+{ Automatically use FPC's PasZLib when compiling with FPC.}
-{$IFDEF LCL}
+{$IFDEF FPC}
{$UNDEF IMPASZLIB}
{$DEFINE FPCPASZLIB}
{$ENDIF}
uses
-{$IF Defined(ZLIBEX)}
- { Use ZlibEx unit.}
- ZLibEx,
-{$ELSEIF Defined(DELPHIZLIB)}
- { Use ZLib unit shipped with Delphi.}
- ZLib,
-{$ELSEIF Defined(ZLIBPAS)}
- { Pascal interface to ZLib shipped with ZLib C source.}
- zlibpas,
-{$ELSEIF Defined(IMPASZLIB)}
- { Use paszlib modified by me for Delphi and FPC.}
+{$IF Defined(IMPASZLIB)}
+ { Use paszlib modified by me for Delphi and FPC }
imzdeflate, imzinflate, impaszlib,
{$ELSEIF Defined(FPCPASZLIB)}
- { Use FPC's paszlib.}
+ { Use FPC's paszlib }
zbase, paszlib,
+{$ELSEIF Defined(ZLIBPAS)}
+ { Pascal interface to ZLib shipped with ZLib C source }
+ zlibpas,
+{$ELSEIF Defined(ZLIBEX)}
+ { Use ZlibEx unit }
+ ZLibEx,
+{$ELSEIF Defined(DELPHIZLIB)}
+ { Use ZLib unit shipped with Delphi }
+ ZLib,
{$IFEND}
- SysUtils, Classes;
+ ImagingTypes, SysUtils, Classes;
{$IF Defined(IMPASZLIB) or Defined(FPCPASZLIB) or Defined(ZLIBPAS)}
type
TZStreamRec = z_stream;
{$IFEND}
-{$IFDEF ZLIBEX}
+
const
Z_NO_FLUSH = 0;
Z_PARTIAL_FLUSH = 1;
Z_UNKNOWN = 2;
Z_DEFLATED = 8;
-{$ENDIF}
type
{ Abstract ancestor class }
Out: OutBuf = ptr to newly allocated buffer containing decompressed data
OutBytes = number of bytes in OutBuf }
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
- var OutBuf: Pointer; var OutBytes: Integer;
- CompressLevel: Integer = Z_DEFAULT_COMPRESSION);
+ var OutBuf: Pointer; var OutBytes: Integer;
+ CompressLevel: Integer = Z_DEFAULT_COMPRESSION;
+ CompressStrategy: Integer = Z_DEFAULT_STRATEGY);
{ DecompressBuf decompresses data, buffer to buffer, in one call.
In: InBuf = ptr to compressed data
end;
procedure CompressBuf(const InBuf: Pointer; InBytes: Integer;
- var OutBuf: Pointer; var OutBytes: Integer;
- CompressLevel: Integer);
+ var OutBuf: Pointer; var OutBytes: Integer;
+ CompressLevel, CompressStrategy: Integer);
var
strm: TZStreamRec;
P: Pointer;
strm.avail_in := InBytes;
strm.next_out := OutBuf;
strm.avail_out := OutBytes;
- CCheck(deflateInit_(strm, CompressLevel, zlib_version, sizeof(strm)));
+
+ CCheck(deflateInit2(strm, CompressLevel, Z_DEFLATED, MAX_WBITS,
+ DEF_MEM_LEVEL, CompressStrategy));
+
try
while CCheck(deflate(strm, Z_FINISH)) <> Z_STREAM_END do
begin
P := OutBuf;
Inc(OutBytes, 256);
ReallocMem(OutBuf, OutBytes);
- strm.next_out := Pointer(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
+ strm.next_out := Pointer(PtrUInt(OutBuf) + (PtrUInt(strm.next_out) - PtrUInt(P)));
strm.avail_out := 256;
end;
finally
P := OutBuf;
Inc(OutBytes, BufInc);
ReallocMem(OutBuf, OutBytes);
- strm.next_out := Pointer(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P)));
+ strm.next_out := Pointer(PtrUInt(OutBuf) + (PtrUInt(strm.next_out) - PtrUInt(P)));
strm.avail_out := BufInc;
end;
finally