From: Ketmar Dark Date: Sat, 23 Apr 2016 08:11:31 +0000 (+0300) Subject: Vampyre Imaging Library updated to latest HEAD X-Git-Url: http://deadsoftware.ru/gitweb?a=commitdiff_plain;h=48fffe15692e9dcd2bdc2ed64f6e998af13211cf;p=d2df-sdl.git Vampyre Imaging Library updated to latest HEAD --- diff --git a/src/lib/vampimg/Imaging.pas b/src/lib/vampimg/Imaging.pas index 22d8cb3..f21fa64 100644 --- a/src/lib/vampimg/Imaging.pas +++ b/src/lib/vampimg/Imaging.pas @@ -1,5 +1,4 @@ { - $Id: Imaging.pas 173 2009-09-04 17:05:52Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -35,13 +34,18 @@ unit Imaging; 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; @@ -157,7 +161,7 @@ function SaveMultiImageToMemory(const Ext: string; Data: Pointer; 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 — 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 — the left @@ -189,12 +193,12 @@ function MapImageToPalette(var Image: TImageData; Pal: PPalette32; { 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 @@ -204,7 +208,7 @@ function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray; 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 @@ -327,8 +355,7 @@ type { 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; @@ -338,15 +365,31 @@ type 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; @@ -356,13 +399,17 @@ type 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); @@ -376,7 +423,7 @@ type 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). @@ -396,7 +443,7 @@ type (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.} @@ -456,14 +503,14 @@ type { 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).} @@ -472,11 +519,97 @@ type 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.} @@ -485,13 +618,15 @@ function ImageToStr(const Image: TImageData): string; 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 @@ -554,16 +694,20 @@ uses {$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'; @@ -608,14 +752,19 @@ resourcestring 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; @@ -633,26 +782,34 @@ type 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 } @@ -674,42 +831,11 @@ procedure InitOptions; forward; { 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 @@ -765,7 +891,13 @@ begin 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; @@ -794,7 +926,7 @@ begin end; InitImage(Image); except - RaiseImaging(SErrorFreeImage, [ImageToStr(Image)]); + raise UpdateExceptMessage(GetExceptObject, SErrorFreeImage, [ImageToStr(Image)]); end; end; @@ -837,35 +969,31 @@ begin 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; @@ -878,23 +1006,19 @@ begin 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; @@ -911,23 +1035,19 @@ begin 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; @@ -1204,7 +1324,7 @@ begin Move(Image.Bits^, Clone.Bits^, Clone.Size); Result := True; except - RaiseImaging(SErrorCloneImage, [ImageToStr(Image)]); + raise UpdateExceptMessage(GetExceptObject, SErrorCloneImage, [ImageToStr(Image)]); end; end; @@ -1315,7 +1435,7 @@ begin Result := True; except - RaiseImaging(SErrorConvertImage, [GetFormatName(DestFormat), ImageToStr(Image)]); + raise UpdateExceptMessage(GetExceptObject, SErrorConvertImage, [GetFormatName(DestFormat), ImageToStr(Image)]); end; end; @@ -1407,7 +1527,7 @@ function ResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt; 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 @@ -1427,7 +1547,7 @@ begin Image := WorkImage; Result := True; except - RaiseImaging(SErrorResizeImage, [ImageToStr(Image)]); + raise UpdateExceptMessage(GetExceptObject, SErrorResizeImage, [ImageToStr(Image)]); end; end; @@ -1703,7 +1823,7 @@ begin FreeImage(CloneARGB); Result := True; except - RaiseImaging(SErrorMapImage, [ImageToStr(Image)]); + raise UpdateExceptMessage(GetExceptObject, SErrorMapImage, [ImageToStr(Image)]); end; end; @@ -1758,8 +1878,8 @@ begin 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); @@ -1782,7 +1902,8 @@ begin Result := True; except - RaiseImaging(SErrorSplitImage, [ImageToStr(Image), ChunkWidth, ChunkHeight]); + raise UpdateExceptMessage(GetExceptObject, SErrorSplitImage, + [ImageToStr(Image), ChunkWidth, ChunkHeight]); end; end; @@ -1861,7 +1982,7 @@ begin end; end; -function RotateImage(var Image: TImageData; Angle: Single): Boolean; +procedure RotateImage(var Image: TImageData; Angle: Single); var OldFmt: TImageFormat; @@ -1886,7 +2007,7 @@ var 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; @@ -1917,7 +2038,7 @@ var 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; @@ -1955,6 +2076,7 @@ var // 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 @@ -1966,9 +2088,10 @@ var 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 @@ -2065,8 +2188,6 @@ var end; begin - Result := False; - if TestImage(Image) then try while Angle >= 360 do @@ -2075,10 +2196,7 @@ begin 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 @@ -2106,9 +2224,8 @@ begin 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; @@ -2285,6 +2402,7 @@ var Info: PImageFormatInfo; WorkImage: TImageData; OldFormat: TImageFormat; + Resampling: TSamplingFilter; begin Result := False; OldFormat := ifUnknown; @@ -2326,13 +2444,21 @@ begin 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 @@ -2610,13 +2736,11 @@ end; { 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; @@ -2630,6 +2754,241 @@ begin 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 @@ -2680,6 +3039,8 @@ begin 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; @@ -2867,11 +3228,18 @@ var 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; @@ -2935,12 +3303,17 @@ end; 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; @@ -2950,9 +3323,14 @@ begin 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; @@ -2990,7 +3368,7 @@ var begin CheckOptionsValidity; Result := False; - if FCanSave then + if CanSave then begin Len := Length(Images); Assert(Len > 0); @@ -2999,7 +3377,7 @@ begin 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; @@ -3017,8 +3395,10 @@ begin end; for I := FFirstIdx to FLastIdx - 1 do + begin if not TestImage(Images[I]) then Exit; + end; end else begin @@ -3090,18 +3470,18 @@ var 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]); @@ -3121,18 +3501,18 @@ var 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]); @@ -3141,6 +3521,7 @@ begin end; except Stream.Position := OldPosition; + FreeImagesInArray(Images); RaiseImaging(SErrorLoadingStream, [@Stream, FExtensions[0]]); end; end; @@ -3152,19 +3533,19 @@ var 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]); @@ -3184,14 +3565,14 @@ var 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 @@ -3211,7 +3592,7 @@ begin 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 @@ -3224,7 +3605,7 @@ begin end; end; except - RaiseImaging(SErrorSavingFile, [FileName, FExtensions[0]]); + raise UpdateExceptMessage(GetExceptObject, SErrorSavingFile, [FileName, FExtensions[0]]); end; end; @@ -3237,12 +3618,12 @@ var 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 @@ -3270,7 +3651,7 @@ begin end; except Stream.Position := OldPosition; - RaiseImaging(SErrorSavingStream, [@Stream, FExtensions[0]]); + raise UpdateExceptMessage(GetExceptObject, SErrorSavingStream, [@Stream, FExtensions[0]]); end; end; @@ -3282,13 +3663,13 @@ var 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 @@ -3316,7 +3697,7 @@ begin IO.Close(Handle); end; except - RaiseImaging(SErrorSavingMemory, [Data, Size, FExtensions[0]]); + raise UpdateExceptMessage(GetExceptObject, SErrorSavingMemory, [Data, Size, FExtensions[0]]); end; end; @@ -3372,7 +3753,7 @@ begin 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; @@ -3384,6 +3765,30 @@ procedure TImageFileFormat.CheckOptionsValidity; 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; @@ -3433,12 +3838,232 @@ begin 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; @@ -3446,9 +4071,11 @@ initialization RegisterOption(ImagingLoadOverrideFormat, @LoadOverrideFormat); RegisterOption(ImagingSaveOverrideFormat, @SaveOverrideFormat); RegisterOption(ImagingMipMapFilter, @MipMapFilter); + RegisterOption(ImagingBinaryTreshold, @BinaryTreshold); finalization FreeOptions; FreeImageFileFormats; + GlobalMetadata.Free; { File Notes: @@ -3456,6 +4083,23 @@ finalization -- 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 diff --git a/src/lib/vampimg/ImagingBitmap.pas b/src/lib/vampimg/ImagingBitmap.pas index 943f476..4c4aac6 100644 --- a/src/lib/vampimg/ImagingBitmap.pas +++ b/src/lib/vampimg/ImagingBitmap.pas @@ -1,5 +1,4 @@ { - $Id: ImagingBitmap.pas 129 2008-08-06 20:01:30Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -26,7 +25,9 @@ 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} @@ -44,6 +45,7 @@ type 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; @@ -51,7 +53,6 @@ type 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 @@ -133,13 +134,11 @@ type { 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; @@ -523,12 +522,12 @@ begin // 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 diff --git a/src/lib/vampimg/ImagingCanvases.pas b/src/lib/vampimg/ImagingCanvases.pas index 0069502..448191c 100644 --- a/src/lib/vampimg/ImagingCanvases.pas +++ b/src/lib/vampimg/ImagingCanvases.pas @@ -1,5 +1,4 @@ { - $Id: ImagingCanvases.pas 174 2009-09-08 09:37:59Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -26,9 +25,7 @@ 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} @@ -645,7 +642,10 @@ begin 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; @@ -1046,14 +1046,14 @@ begin 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; @@ -1414,11 +1414,11 @@ procedure TImagingCanvas.StretchDrawInternal(const SrcRect: TRect; 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; @@ -1900,8 +1900,8 @@ end; 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; @@ -1985,9 +1985,9 @@ begin 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 + @@ -2007,77 +2007,6 @@ begin 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; @@ -2133,9 +2062,14 @@ finalization -- 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. diff --git a/src/lib/vampimg/ImagingClasses.pas b/src/lib/vampimg/ImagingClasses.pas index c00c105..b196fdd 100644 --- a/src/lib/vampimg/ImagingClasses.pas +++ b/src/lib/vampimg/ImagingClasses.pas @@ -1,5 +1,4 @@ { - $Id: ImagingClasses.pas 173 2009-09-04 17:05:52Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -40,29 +39,31 @@ type { 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); @@ -72,9 +73,18 @@ type { 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; @@ -88,21 +98,21 @@ type 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; @@ -116,25 +126,27 @@ type 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. @@ -144,7 +156,9 @@ type { 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.} @@ -161,13 +175,15 @@ type 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 @@ -180,34 +196,36 @@ type 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; @@ -215,29 +233,31 @@ type 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. } @@ -258,9 +278,9 @@ type { 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. @@ -269,15 +289,14 @@ type 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 @@ -303,7 +322,7 @@ begin inherited Destroy; end; -function TBaseImage.GetWidth: LongInt; +function TBaseImage.GetWidth: Integer; begin if Valid then Result := FPData.Width @@ -311,7 +330,7 @@ begin Result := 0; end; -function TBaseImage.GetHeight: LongInt; +function TBaseImage.GetHeight: Integer; begin if Valid then Result := FPData.Height @@ -327,7 +346,7 @@ begin Result := ifUnknown; end; -function TBaseImage.GetScanLine(Index: LongInt): Pointer; +function TBaseImage.GetScanline(Index: Integer): Pointer; var Info: TImageFormatInfo; begin @@ -343,7 +362,15 @@ 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] @@ -351,7 +378,7 @@ begin Result := nil; end; -function TBaseImage.GetSize: LongInt; +function TBaseImage.GetSize: Integer; begin if Valid then Result := FPData.Size @@ -375,7 +402,7 @@ begin Result := nil; end; -function TBaseImage.GetPaletteEntries: LongInt; +function TBaseImage.GetPaletteEntries: Integer; begin Result := GetFormatInfo.PaletteEntries; end; @@ -398,12 +425,17 @@ begin 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; @@ -427,18 +459,45 @@ begin 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 @@ -453,12 +512,15 @@ end; 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 @@ -467,8 +529,8 @@ 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 @@ -532,10 +594,10 @@ end; 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); @@ -544,13 +606,7 @@ end; 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); @@ -580,59 +636,57 @@ procedure TSingleImage.Assign(Source: TPersistent); 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); @@ -651,20 +705,20 @@ begin 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 @@ -689,13 +743,13 @@ 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]); @@ -715,9 +769,9 @@ begin 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 @@ -741,9 +795,9 @@ begin 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 @@ -753,7 +807,7 @@ begin end; end; -procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: LongInt; +procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: Integer; AFormat: TImageFormat); begin if PrepareInsert(Index, 1) then @@ -766,38 +820,62 @@ var 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); @@ -810,35 +888,35 @@ begin 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 @@ -851,9 +929,9 @@ 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 @@ -871,20 +949,25 @@ 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; @@ -937,9 +1020,21 @@ 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. diff --git a/src/lib/vampimg/ImagingColors.pas b/src/lib/vampimg/ImagingColors.pas index 22c1c8f..c7fd428 100644 --- a/src/lib/vampimg/ImagingColors.pas +++ b/src/lib/vampimg/ImagingColors.pas @@ -1,5 +1,4 @@ { - $Id: ImagingColors.pas 173 2009-09-04 17:05:52Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -73,6 +72,8 @@ procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte); { 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 diff --git a/src/lib/vampimg/ImagingComponents.pas b/src/lib/vampimg/ImagingComponents.pas index 3945362..61451fe 100644 --- a/src/lib/vampimg/ImagingComponents.pas +++ b/src/lib/vampimg/ImagingComponents.pas @@ -1,5 +1,4 @@ { - $Id: ImagingComponents.pas 171 2009-09-02 01:34:19Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -36,6 +35,7 @@ interface {$IFDEF LCL} {$DEFINE COMPONENT_SET_LCL} + {$UNDEF COMPONENT_SET_VCL} {$ENDIF} {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)} @@ -336,9 +336,7 @@ implementation 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} @@ -359,7 +357,7 @@ uses {$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'; @@ -509,6 +507,14 @@ var 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 @@ -517,6 +523,7 @@ begin 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) @@ -527,6 +534,7 @@ begin {$ELSE} Imaging.ConvertImage(WorkData, ifA8R8G8B8); {$ENDIF} + end; PF := DataFormatToPixelFormat(WorkData.Format); GetImageFormatInfo(WorkData.Format, Info); @@ -693,9 +701,14 @@ begin 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; @@ -1217,6 +1232,16 @@ finalization -- 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+. diff --git a/src/lib/vampimg/ImagingDds.pas b/src/lib/vampimg/ImagingDds.pas index a2eb09c..9410495 100644 --- a/src/lib/vampimg/ImagingDds.pas +++ b/src/lib/vampimg/ImagingDds.pas @@ -1,5 +1,4 @@ { - $Id: ImagingDds.pas 129 2008-08-06 20:01:30Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -42,7 +41,7 @@ type 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 @@ -51,7 +50,7 @@ type 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; @@ -62,6 +61,8 @@ type 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; @@ -69,7 +70,6 @@ type procedure ConvertToSupported(var Image: TImageData; const Info: TImageFormatInfo); override; public - constructor Create; override; function TestFormat(Handle: TImagingHandle): Boolean; override; procedure CheckOptionsValidity; override; published @@ -94,6 +94,17 @@ type 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 @@ -118,6 +129,8 @@ 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; @@ -206,16 +219,151 @@ type 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; @@ -307,10 +455,12 @@ function TDDSFileFormat.LoadData(Handle: TImagingHandle; 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; @@ -322,6 +472,128 @@ var (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; @@ -329,34 +601,27 @@ begin 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 @@ -367,11 +632,9 @@ 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: @@ -458,7 +721,8 @@ begin 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 @@ -468,6 +732,7 @@ begin if Desc.MipMaps > 1 then begin FLoadedMipMapCount := Desc.MipMaps; + FMetadata.SetMetaItem(SMetaDdsMipMapCount, Desc.MipMaps); ImageCount := Desc.MipMaps; end; @@ -508,12 +773,21 @@ begin // 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 @@ -823,6 +1097,13 @@ initialization -- 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 deleted file mode 100644 index b3752f8..0000000 --- a/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. diff --git a/src/lib/vampimg/ImagingExtras.pas b/src/lib/vampimg/ImagingExtras.pas index 865e81e..d32f0f9 100644 --- a/src/lib/vampimg/ImagingExtras.pas +++ b/src/lib/vampimg/ImagingExtras.pas @@ -1,5 +1,4 @@ { - $Id: ImagingExtras.pas 171 2009-09-02 01:34:19Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -40,20 +39,21 @@ unit ImagingExtras; //{$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} @@ -73,11 +73,20 @@ const 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). @@ -93,7 +102,7 @@ uses ImagingJpeg2000, {$ENDIF} {$IFNDEF DONT_LINK_TIFF} - ImagingTiff, + ImagingLibTiffDelphi, {$ENDIF} {$IFNDEF DONT_LINK_PSD} ImagingPsd, @@ -112,9 +121,16 @@ uses { 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 diff --git a/src/lib/vampimg/ImagingFormats.pas b/src/lib/vampimg/ImagingFormats.pas index 956f491..b42b4ac 100644 --- a/src/lib/vampimg/ImagingFormats.pas +++ b/src/lib/vampimg/ImagingFormats.pas @@ -1,5 +1,4 @@ { - $Id: ImagingFormats.pas 174 2009-09-08 09:37:59Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -123,6 +122,10 @@ procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat, DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32); { Clamps floating point pixel channel values to [0.0, 1.0] range.} procedure ClampFloatPixel(var PixF: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} +{ 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.} @@ -134,18 +137,21 @@ procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height, 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 @@ -153,8 +159,12 @@ procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height, 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 } @@ -761,6 +777,35 @@ var 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; @@ -822,6 +867,93 @@ var 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; @@ -862,6 +994,8 @@ begin Infos[ifR16F] := @R16FInfo; Infos[ifA16R16G16B16F] := @A16R16G16B16FInfo; Infos[ifA16B16G16R16F] := @A16B16G16R16FInfo; + Infos[ifR32G32B32F] := @R32G32B32FInfo; + Infos[ifB32G32R32F] := @B32G32R32FInfo; // special formats Infos[ifDXT1] := @DXT1Info; Infos[ifDXT3] := @DXT3Info; @@ -869,6 +1003,7 @@ begin Infos[ifBTC] := @BTCInfo; Infos[ifATI1N] := @ATI1NInfo; Infos[ifATI2N] := @ATI2NInfo; + Infos[ifBinary] := @BinaryInfo; PFR3G3B2 := PixelFormat(0, 3, 3, 2); PFX5R1G1B1 := PixelFormat(0, 1, 1, 1); @@ -940,12 +1075,12 @@ procedure PFGetARGB(const PF: TPixelFormatInfo; Color: LongWord; var A, R, G, B: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF} begin with PF do - begin - A := (Color and ABitMask shr AShift) * 255 div ARecDiv; - R := (Color and RBitMask shr RShift) * 255 div RRecDiv; - G := (Color and GBitMask shr GShift) * 255 div GRecDiv; - B := (Color and BBitMask shl BShift) * 255 div BRecDiv; - end; + 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; @@ -962,14 +1097,13 @@ end; 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; @@ -1722,32 +1856,22 @@ procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth, 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, @@ -1765,145 +1889,77 @@ begin // 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; @@ -1972,6 +2028,7 @@ begin 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; @@ -1981,14 +2038,14 @@ 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); + 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; @@ -2028,6 +2085,63 @@ begin 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 @@ -2048,49 +2162,64 @@ begin 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; @@ -2125,6 +2254,21 @@ begin 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 @@ -2151,12 +2295,9 @@ const { - 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: @@ -2184,20 +2325,19 @@ const 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; @@ -2205,12 +2345,12 @@ begin 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; @@ -2218,7 +2358,7 @@ begin 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; @@ -2231,11 +2371,11 @@ begin 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; @@ -2245,29 +2385,29 @@ var 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 @@ -2275,10 +2415,10 @@ begin // Float is a normalized Single whose magnitude is less than HalfNormMin. // We convert it to denormalized half. Mantissa := (Mantissa or $00800000) shr (1 - Exp); - // round to nearest + // 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 @@ -2286,12 +2426,12 @@ begin 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 @@ -2299,7 +2439,7 @@ begin 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; @@ -2312,11 +2452,11 @@ begin 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; @@ -2361,11 +2501,11 @@ procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; 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: @@ -2533,18 +2673,21 @@ procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo; 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)^; @@ -2552,7 +2695,8 @@ begin 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; @@ -2566,13 +2710,17 @@ var 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 @@ -2896,6 +3044,7 @@ begin 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 @@ -2910,6 +3059,7 @@ begin Inc(Src, SrcInfo.BytesPerPixel); Inc(Dst, DstInfo.BytesPerPixel); end; + end; end; procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo, @@ -3828,6 +3978,32 @@ begin 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; @@ -3928,6 +4104,11 @@ begin 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 @@ -3938,6 +4119,7 @@ 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; @@ -3951,6 +4133,7 @@ begin 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; @@ -4049,6 +4232,22 @@ begin 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; @@ -4079,10 +4278,10 @@ end; 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 @@ -4121,10 +4320,10 @@ end; 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 @@ -4167,19 +4366,15 @@ end; 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 @@ -4189,25 +4384,28 @@ 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 @@ -4239,6 +4437,18 @@ 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. diff --git a/src/lib/vampimg/ImagingGif.pas b/src/lib/vampimg/ImagingGif.pas index 0f3d9cd..a38e33a 100644 --- a/src/lib/vampimg/ImagingGif.pas +++ b/src/lib/vampimg/ImagingGif.pas @@ -1,5 +1,4 @@ { - $Id: ImagingGif.pas 157 2009-02-15 14:24:58Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -55,6 +54,7 @@ type 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; @@ -62,7 +62,6 @@ type 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; @@ -84,6 +83,7 @@ type const GIFSignature: TChar3 = 'GIF'; GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a'); + GIFDefaultDelay = 65; // Masks for accessing fields in PackedFields of TGIFHeader GIFGlobalColorTable = $80; @@ -111,6 +111,11 @@ const GIFUserInput = $02; GIFDisposalMethod = $1C; +const + // Netscape sub block types + GIFAppLoopExtension = 1; + GIFAppBufferExtension = 2; + type TGIFHeader = packed record // File header part @@ -149,11 +154,6 @@ type 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; @@ -216,13 +216,11 @@ resourcestring 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; @@ -304,7 +302,7 @@ var 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; @@ -735,7 +733,8 @@ var 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 @@ -750,6 +749,9 @@ var // 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 @@ -896,6 +898,7 @@ var 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; @@ -1124,6 +1127,44 @@ var 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 @@ -1136,9 +1177,11 @@ begin // 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 @@ -1147,6 +1190,7 @@ begin // 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)); @@ -1164,7 +1208,7 @@ begin 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 @@ -1186,7 +1230,7 @@ end; function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean; var Header: TGIFHeader; - ReadCount: LongInt; + ReadCount: Integer; begin Result := False; if Handle <> nil then @@ -1208,6 +1252,14 @@ initialization -- 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. diff --git a/src/lib/vampimg/ImagingIO.pas b/src/lib/vampimg/ImagingIO.pas index c26b451..32d2bc2 100644 --- a/src/lib/vampimg/ImagingIO.pas +++ b/src/lib/vampimg/ImagingIO.pas @@ -1,5 +1,4 @@ { - $Id: ImagingIO.pas 100 2007-06-28 21:09:52Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -56,6 +55,12 @@ var 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 @@ -65,7 +70,7 @@ const type { Based on TaaBufferedStream Copyright (c) Julian M Bucknall 1997, 1999 } - TBufferedStream = class(TObject) + TBufferedStream = class private FBuffer: PByteArray; FBufSize: Integer; @@ -338,14 +343,26 @@ end; { 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; @@ -387,12 +404,7 @@ end; { 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; @@ -431,12 +443,7 @@ 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; @@ -513,9 +520,73 @@ begin 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; @@ -523,8 +594,7 @@ initialization OriginalFileIO.Read := FileRead; OriginalFileIO.Write := FileWrite; - StreamIO.OpenRead := StreamOpenRead; - StreamIO.OpenWrite := StreamOpenWrite; + StreamIO.Open := StreamOpen; StreamIO.Close := StreamClose; StreamIO.Eof := StreamEof; StreamIO.Seek := StreamSeek; @@ -532,8 +602,7 @@ initialization StreamIO.Read := StreamRead; StreamIO.Write := StreamWrite; - MemoryIO.OpenRead := MemoryOpenRead; - MemoryIO.OpenWrite := MemoryOpenWrite; + MemoryIO.Open := MemoryOpen; MemoryIO.Close := MemoryClose; MemoryIO.Eof := MemoryEof; MemoryIO.Seek := MemorySeek; @@ -549,6 +618,10 @@ initialization -- 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. diff --git a/src/lib/vampimg/ImagingJpeg.pas b/src/lib/vampimg/ImagingJpeg.pas index f01d183..ef9a5e7 100644 --- a/src/lib/vampimg/ImagingJpeg.pas +++ b/src/lib/vampimg/ImagingJpeg.pas @@ -1,5 +1,4 @@ { - $Id: ImagingJpeg.pas 168 2009-08-22 18:50:21Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -44,12 +43,23 @@ unit ImagingJpeg; { $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 @@ -81,6 +91,7 @@ type 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; @@ -88,7 +99,6 @@ type procedure ConvertToSupported(var Image: TImageData; const Info: TImageFormatInfo); override; public - constructor Create; override; function TestFormat(Handle: TImagingHandle): Boolean; override; procedure CheckOptionsValidity; override; published @@ -147,13 +157,103 @@ var { 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. } + 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); @@ -185,8 +285,8 @@ begin 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; @@ -295,14 +395,16 @@ begin 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); @@ -319,18 +421,12 @@ end; 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 @@ -339,13 +435,10 @@ end; { 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; @@ -371,9 +464,30 @@ var 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; @@ -382,7 +496,19 @@ begin 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; @@ -390,6 +516,7 @@ begin else Exit; end; + NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]); jpeg_start_decompress(@jc.d); GetImageFormatInfo(Format, Info); @@ -397,11 +524,22 @@ begin 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 @@ -410,7 +548,6 @@ begin Inc(Pix); end; end; - {$ENDIF} Inc(Dest, PtrInc * LinesRead); end; @@ -427,6 +564,9 @@ begin end; end; + // Store supported metadata + LoadMetaData; + jpeg_finish_output(@jc.d); jpeg_finish_decompress(@jc.d); Result := True; @@ -448,14 +588,31 @@ var 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); @@ -479,6 +636,9 @@ begin 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 @@ -553,6 +713,18 @@ initialization -- 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 7b2ab93..364cbcf 100644 --- a/src/lib/vampimg/ImagingNetworkGraphics.pas +++ b/src/lib/vampimg/ImagingNetworkGraphics.pas @@ -1,5 +1,4 @@ { - $Id: ImagingNetworkGraphics.pas 171 2009-09-02 01:34:19Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -34,7 +33,7 @@ interface {$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} @@ -54,11 +53,12 @@ type 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 @@ -105,12 +105,11 @@ type 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; @@ -131,12 +130,11 @@ type 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} @@ -156,12 +154,11 @@ type 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} @@ -183,9 +180,10 @@ const 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'; @@ -267,6 +265,14 @@ type 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; @@ -296,6 +302,7 @@ const acTLChunk: TChar4 = 'acTL'; fcTLChunk: TChar4 = 'fcTL'; fdATChunk: TChar4 = 'fdAT'; + pHYsChunk: TChar4 = 'pHYs'; { APNG frame dispose operations.} DisposeOpNone = 0; @@ -314,13 +321,15 @@ const 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; @@ -330,7 +339,7 @@ type IDATMemory: TMemoryStream; JDATMemory: TMemoryStream; JDAAMemory: TMemoryStream; - constructor Create; + constructor Create(AIndex: Integer); destructor Destroy; override; procedure AssignSharedProps(Source: TFrameInfo); end; @@ -338,8 +347,9 @@ type { 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 @@ -348,10 +358,12 @@ type 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.} @@ -372,13 +384,14 @@ type 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} @@ -441,33 +454,6 @@ begin 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 } @@ -486,8 +472,9 @@ end; { TFrameInfo class implementation } -constructor TFrameInfo.Create; +constructor TFrameInfo.Create(AIndex: Integer); begin + Index := AIndex; IDATMemory := TMemoryStream.Create; JDATMemory := TMemoryStream.Create; JDAAMemory := TMemoryStream.Create; @@ -537,6 +524,11 @@ begin GlobalTransparencySize := 0; end; +constructor TNGFileHandler.Create(AFileFormat: TNetworkGraphicsFileFormat); +begin + FileFormat := AFileFormat; +end; + function TNGFileHandler.GetLastFrame: TFrameInfo; var Len: LongInt; @@ -548,13 +540,44 @@ begin 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; @@ -743,6 +766,16 @@ var 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; @@ -777,6 +810,7 @@ begin 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)); @@ -797,6 +831,7 @@ var Data, TotalBuffer, ZeroLine, PrevLine: Pointer; BitCount, TotalSize, TotalPos, BytesPerPixel, I, Pass, SrcDataSize, BytesPerLine, InterlaceLineBytes, InterlaceWidth: LongInt; + Info: TImageFormatInfo; procedure DecodeAdam7; const @@ -882,34 +917,6 @@ var 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; @@ -930,6 +937,14 @@ var 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; @@ -940,8 +955,9 @@ begin 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; @@ -957,9 +973,10 @@ begin 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: @@ -982,13 +999,16 @@ begin 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; @@ -1058,16 +1078,22 @@ begin 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 @@ -1117,7 +1143,7 @@ var 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]; @@ -1243,8 +1269,7 @@ var 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); @@ -1277,14 +1302,17 @@ var 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 @@ -1295,20 +1323,19 @@ var 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 @@ -1316,19 +1343,26 @@ var 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; @@ -1343,9 +1377,9 @@ begin (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 @@ -1442,51 +1476,65 @@ begin 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 @@ -1529,7 +1577,7 @@ var 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 @@ -1649,10 +1698,36 @@ 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 @@ -1704,38 +1779,28 @@ 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 @@ -1811,6 +1876,25 @@ var 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 @@ -1834,6 +1918,8 @@ var WriteChunk(Chunk, Transparency); end; end; + // Write metadata related chunks + WriteGlobalMetaDataChunks(Frame); end; begin @@ -1848,10 +1934,32 @@ 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 @@ -1863,6 +1971,8 @@ begin 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; @@ -1905,16 +2015,7 @@ begin 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; @@ -1946,16 +2047,17 @@ begin 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); @@ -1973,7 +2075,7 @@ var 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 @@ -1989,7 +2091,7 @@ begin 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; @@ -2074,12 +2176,10 @@ end; { 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; @@ -2087,6 +2187,7 @@ begin FLossyCompression := NGDefaultLossyCompression; FQuality := NGDefaultQuality; FProgressive := NGDefaultProgressive; + FZLibStategy := NGDefaultZLibStartegy; end; procedure TNetworkGraphicsFileFormat.CheckOptionsValidity; @@ -2172,11 +2273,11 @@ end; { TPNGFileFormat class implementation } -constructor TPNGFileFormat.Create; +procedure TPNGFileFormat.Define; begin - inherited Create; + inherited; FName := SPNGFormatName; - FIsMultiImageFormat := True; + FFeatures := FFeatures + [ffMultiImage]; FLoadAnimated := PNGDefaultLoadAnimated; AddMasks(SPNGMasks); @@ -2185,6 +2286,7 @@ begin RegisterOption(ImagingPNGPreFilter, @FPreFilter); RegisterOption(ImagingPNGCompressLevel, @FCompressLevel); RegisterOption(ImagingPNGLoadAnimated, @FLoadAnimated); + RegisterOption(ImagingPNGZLibStrategy, @FZLibStategy); end; function TPNGFileFormat.LoadData(Handle: TImagingHandle; @@ -2194,7 +2296,7 @@ var 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 @@ -2208,6 +2310,7 @@ begin 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; @@ -2216,6 +2319,7 @@ begin TAPNGAnimator.Animate(Images, NGFileLoader.acTL, NGFileLoader.Frames); end; finally + NGFileLoader.LoadMetaData; // Store metadata NGFileLoader.Free; end; end; @@ -2235,15 +2339,12 @@ begin 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; @@ -2255,7 +2356,8 @@ begin end else NGFileSaver.FileType := ngPNG; - NGFileSaver.SetFileOptions(Self); + + NGFileSaver.SetFileOptions; with NGFileSaver do try @@ -2322,11 +2424,11 @@ end; { TMNGFileFormat class implementation } -constructor TMNGFileFormat.Create; +procedure TMNGFileFormat.Define; begin - inherited Create; + inherited; FName := SMNGFormatName; - FIsMultiImageFormat := True; + FFeatures := FFeatures + [ffMultiImage]; AddMasks(SMNGMasks); FSignature := MNGSignature; @@ -2346,7 +2448,7 @@ var 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 @@ -2376,6 +2478,7 @@ begin Result := True; end; finally + NGFileLoader.LoadMetaData; // Store metadata NGFileLoader.Free; end; end; @@ -2392,9 +2495,9 @@ begin LargestWidth := 0; LargestHeight := 0; - NGFileSaver := TNGFileSaver.Create; + NGFileSaver := TNGFileSaver.Create(Self); NGFileSaver.FileType := ngMNG; - NGFileSaver.SetFileOptions(Self); + NGFileSaver.SetFileOptions; with NGFileSaver do try @@ -2439,9 +2542,9 @@ end; { TJNGFileFormat class implementation } -constructor TJNGFileFormat.Create; +procedure TJNGFileFormat.Define; begin - inherited Create; + inherited; FName := SJNGFormatName; AddMasks(SJNGMasks); @@ -2453,6 +2556,7 @@ begin RegisterOption(ImagingJNGAlphaCompressLevel, @FCompressLevel); RegisterOption(ImagingJNGQuality, @FQuality); RegisterOption(ImagingJNGProgressive, @FProgressive); + end; function TJNGFileFormat.LoadData(Handle: TImagingHandle; @@ -2461,7 +2565,7 @@ var 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 @@ -2476,6 +2580,7 @@ begin Result := True; end; finally + NGFileLoader.LoadMetaData; // Store metadata NGFileLoader.Free; end; end; @@ -2491,11 +2596,11 @@ begin 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 @@ -2525,6 +2630,23 @@ finalization -- 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. diff --git a/src/lib/vampimg/ImagingOptions.inc b/src/lib/vampimg/ImagingOptions.inc index 85653ad..deb21e4 100644 --- a/src/lib/vampimg/ImagingOptions.inc +++ b/src/lib/vampimg/ImagingOptions.inc @@ -1,5 +1,3 @@ -{ $Id: ImagingOptions.inc 174 2009-09-08 09:37:59Z galfar $ } - { User Options Following defines and options can be changed by user. @@ -17,7 +15,7 @@ { $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. @@ -36,6 +34,7 @@ {$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 @@ -67,20 +66,12 @@ {$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))} @@ -123,37 +114,64 @@ {$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} @@ -167,13 +185,9 @@ { Platform options } -{$IFDEF WIN32} +{$IF Defined(WIN32) or Defined(WIN64)} {$DEFINE MSWINDOWS} -{$ENDIF} - -{$IFDEF DPMI} - {$DEFINE MSDOS} -{$ENDIF} +{$IFEND} {$IFDEF LINUX} {$DEFINE UNIX} @@ -188,7 +202,6 @@ {$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} @@ -198,7 +211,6 @@ {$INLINE ON} // turns inlining on for compilers that support it {$ENDIF} - {$WARNINGS OFF} {$HINTS OFF} {$NOTES OFF} diff --git a/src/lib/vampimg/ImagingPcx.pas b/src/lib/vampimg/ImagingPcx.pas index 257ad76..d278542 100644 --- a/src/lib/vampimg/ImagingPcx.pas +++ b/src/lib/vampimg/ImagingPcx.pas @@ -1,5 +1,4 @@ { - $Id: ImagingPcx.pas 100 2007-06-28 21:09:52Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -44,10 +43,10 @@ type 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; @@ -77,13 +76,11 @@ type { TPCXFileFormat } -constructor TPCXFileFormat.Create; +procedure TPCXFileFormat.Define; begin - inherited Create; + inherited; FName := SPCXFormatName; - FCanLoad := True; - FCanSave := False; - FIsMultiImageFormat := False; + FFeatures := [ffLoad]; AddMasks(SPCXMasks); end; @@ -263,7 +260,7 @@ begin 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 @@ -271,7 +268,7 @@ 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 @@ -306,7 +303,7 @@ 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; diff --git a/src/lib/vampimg/ImagingPortableMaps.pas b/src/lib/vampimg/ImagingPortableMaps.pas index 97e6c4e..89d862d 100644 --- a/src/lib/vampimg/ImagingPortableMaps.pas +++ b/src/lib/vampimg/ImagingPortableMaps.pas @@ -1,5 +1,4 @@ { - $Id: ImagingPortableMaps.pas 163 2009-07-28 21:44:10Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -65,12 +64,13 @@ type 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 @@ -85,32 +85,30 @@ type 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 @@ -120,12 +118,11 @@ type 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 @@ -134,12 +131,11 @@ type 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 @@ -161,7 +157,7 @@ const 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.} @@ -183,13 +179,12 @@ const { 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; @@ -199,7 +194,6 @@ var Dest: PByte; MonoData: Pointer; Info: TImageFormatInfo; - PixelFP: TColorFPRec; LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar; LineEnd, LinePos: LongInt; MapInfo: TPortableMapInfo; @@ -296,7 +290,6 @@ var I: TTupleType; TupleTypeName: string; Scale: Single; - OldSeparator: Char; begin Result := False; with GetIO do @@ -368,10 +361,7 @@ var // 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 @@ -411,6 +401,7 @@ begin LineEnd := 0; LinePos := 0; SetLength(Images, 1); + with GetIO, Images[0] do begin Format := ifUnknown; @@ -425,7 +416,7 @@ begin 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; @@ -482,27 +473,9 @@ begin // 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 @@ -532,8 +505,8 @@ begin 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 @@ -595,8 +568,6 @@ var end; procedure WriteHeader; - var - OldSeparator: Char; begin WriteString('P' + MapInfo.FormatId); if not MapInfo.HasPAMHeader then @@ -608,11 +579,8 @@ var 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 @@ -699,7 +667,7 @@ begin 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 @@ -750,23 +718,7 @@ begin 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; @@ -794,20 +746,20 @@ end; { 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); @@ -853,9 +805,9 @@ end; { TPPMFileFormat } -constructor TPPMFileFormat.Create; +procedure TPPMFileFormat.Define; begin - inherited Create; + inherited; FName := SPPMFormatName; FSupportedFormats := PPMSupportedFormats; AddMasks(SPPMMasks); @@ -901,9 +853,9 @@ end; { TPAMFileFormat } -constructor TPAMFileFormat.Create; +procedure TPAMFileFormat.Define; begin - inherited Create; + inherited; FName := SPAMFormatName; FSupportedFormats := PAMSupportedFormats; AddMasks(SPAMMasks); @@ -943,9 +895,9 @@ end; { TPFMFileFormat } -constructor TPFMFileFormat.Create; +procedure TPFMFileFormat.Define; begin - inherited Create; + inherited; FName := SPFMFormatName; AddMasks(SPFMMasks); FIdNumbers := 'Ff'; @@ -979,7 +931,7 @@ procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData; const Info: TImageFormatInfo); begin if (Info.ChannelCount > 1) or Info.IsIndexed then - ConvertImage(Image, ifA32B32G32R32F) + ConvertImage(Image, ifB32G32R32F) else ConvertImage(Image, ifR32F); end; @@ -997,6 +949,11 @@ initialization -- 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. diff --git a/src/lib/vampimg/ImagingPsd.pas b/src/lib/vampimg/ImagingPsd.pas index a95ce96..cd395ca 100644 --- a/src/lib/vampimg/ImagingPsd.pas +++ b/src/lib/vampimg/ImagingPsd.pas @@ -1,5 +1,4 @@ { - $Id: ImagingPsd.pas 154 2008-12-27 15:41:09Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -46,8 +45,10 @@ type 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; @@ -55,7 +56,6 @@ type 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; @@ -71,7 +71,7 @@ const SPSDMasks = '*.psd,*.pdd'; PSDSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8, ifR8G8B8, ifA8R8G8B8, ifGray16, ifA16Gray16, ifR16G16B16, ifA16R16G16B16, - ifR32F, ifA32R32G32B32F]; + ifR32F, ifR32G32B32F, ifA32R32G32B32F]; PSDDefaultSaveAsLayer = True; const @@ -124,13 +124,11 @@ end; 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); @@ -154,7 +152,6 @@ var 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); @@ -205,6 +202,7 @@ begin // Read PSD header Read(Handle, @Header, SizeOf(Header)); SwapHeader(Header); + // Determine image data format Format := ifUnknown; case Header.Mode of @@ -235,7 +233,12 @@ begin 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; @@ -418,20 +421,6 @@ begin 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); @@ -534,7 +523,7 @@ var 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 @@ -595,9 +584,6 @@ var 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 @@ -692,7 +678,7 @@ begin 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 @@ -753,7 +739,14 @@ var 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 @@ -787,8 +780,9 @@ initialization { 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 new file mode 100644 index 0000000..122e0c2 --- /dev/null +++ b/src/lib/vampimg/ImagingRadiance.pas @@ -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. diff --git a/src/lib/vampimg/ImagingTarga.pas b/src/lib/vampimg/ImagingTarga.pas index 5103f78..66af5f2 100644 --- a/src/lib/vampimg/ImagingTarga.pas +++ b/src/lib/vampimg/ImagingTarga.pas @@ -1,5 +1,4 @@ { - $Id: ImagingTarga.pas 139 2008-09-18 02:01:42Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -43,6 +42,7 @@ type 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; @@ -50,7 +50,6 @@ type 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 @@ -99,13 +98,11 @@ type { 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; diff --git a/src/lib/vampimg/ImagingTypes.pas b/src/lib/vampimg/ImagingTypes.pas index 7de0d12..9c5e1f1 100644 --- a/src/lib/vampimg/ImagingTypes.pas +++ b/src/lib/vampimg/ImagingTypes.pas @@ -1,5 +1,4 @@ { - $Id: ImagingTypes.pas 171 2009-09-02 01:34:19Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -37,9 +36,9 @@ const { 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.} @@ -96,28 +95,32 @@ const 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.} @@ -134,14 +137,17 @@ const { 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). @@ -182,6 +188,10 @@ const 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; @@ -201,16 +211,16 @@ type 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, @@ -225,20 +235,31 @@ type 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; @@ -296,12 +317,24 @@ type 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; @@ -341,6 +374,7 @@ type 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; @@ -400,6 +434,9 @@ type // 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 @@ -427,7 +464,8 @@ type TResizeFilter = ( rfNearest = 0, rfBilinear = 1, - rfBicubic = 2); + rfBicubic = 2, + rfLanczos = 3); { Seek origin mode for IO function Seek.} TSeekMode = ( @@ -435,9 +473,14 @@ type 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; @@ -445,6 +488,15 @@ type 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 { @@ -453,6 +505,19 @@ 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. diff --git a/src/lib/vampimg/ImagingUtility.pas b/src/lib/vampimg/ImagingUtility.pas index e22ef52..c137e1d 100644 --- a/src/lib/vampimg/ImagingUtility.pas +++ b/src/lib/vampimg/ImagingUtility.pas @@ -1,5 +1,4 @@ { - $Id: ImagingUtility.pas 175 2009-10-06 11:55:15Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -59,6 +58,7 @@ type TDynByteArray = array of Byte; TDynIntegerArray = array of Integer; TDynBooleanArray = array of Boolean; + TDynStringArray = array of string; TWordRec = packed record case Integer of @@ -94,16 +94,28 @@ type 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 @@ -136,10 +148,16 @@ function GetAppExe: string; { 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 @@ -161,10 +179,20 @@ function StrTokenEnd(var S: string; Sep: Char): string; { 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 } function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} @@ -187,6 +215,8 @@ function Power(const Base, Exponent: Single): Single; 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} @@ -258,6 +290,9 @@ procedure FillMemoryByte(Data: Pointer; Size: LongInt; Value: Byte); 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; @@ -285,11 +320,27 @@ procedure ClipStretchBounds(var SrcX, SrcY, SrcWidth, SrcHeight, DstX, DstY, { 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; @@ -300,16 +351,21 @@ procedure DebugMsg(const Msg: string; const Args: array of const); 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 @@ -337,7 +393,7 @@ begin Result := Exception(ExceptObject); end; -{$IFDEF MSWINDOWS} +{$IF Defined(MSWINDOWS)} var PerfFrequency: Int64; InvPerfFrequency: Single; @@ -349,56 +405,23 @@ begin 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 @@ -413,29 +436,22 @@ 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; @@ -443,7 +459,28 @@ begin 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; @@ -486,7 +523,7 @@ var Exit; end; else - if not CharMatch(Mask[MaskPos], FileName[KeyPos]) then + if not CharMatch(Mask[MaskPos], Subject[KeyPos]) then begin Result := False; Exit; @@ -499,7 +536,7 @@ var 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 @@ -512,7 +549,7 @@ var begin MaskLen := Length(Mask); - KeyLen := Length(FileName); + KeyLen := Length(Subject); if MaskLen = 0 then begin Result := True; @@ -707,6 +744,29 @@ begin 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; @@ -810,11 +870,36 @@ begin 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 @@ -899,6 +984,15 @@ 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; @@ -1236,6 +1330,11 @@ begin end; {$ENDIF} +procedure ZeroMemory(Data: Pointer; Size: Integer); +begin + FillMemoryByte(Data, Size, 0); +end; + function GetNumMipMapLevels(Width, Height: LongInt): LongInt; begin Result := 0; @@ -1407,6 +1506,27 @@ begin 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:= @@ -1425,6 +1545,37 @@ begin 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); @@ -1455,16 +1606,17 @@ initialization 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: @@ -1472,6 +1624,23 @@ initialization -- 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. diff --git a/src/lib/vampimg/ImagingXpm.pas b/src/lib/vampimg/ImagingXpm.pas index cf743d8..2e10dc2 100644 --- a/src/lib/vampimg/ImagingXpm.pas +++ b/src/lib/vampimg/ImagingXpm.pas @@ -1,5 +1,4 @@ { - $Id: ImagingXpm.pas 171 2009-09-02 01:34:19Z galfar $ Vampyre Imaging Library by Marek Mauder http://imaginglib.sourceforge.net @@ -43,6 +42,7 @@ type 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; @@ -50,7 +50,6 @@ type procedure ConvertToSupported(var Image: TImageData; const Info: TImageFormatInfo); override; public - constructor Create; override; function TestFormat(Handle: TImagingHandle): Boolean; override; end; @@ -121,7 +120,7 @@ var 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); @@ -129,7 +128,7 @@ var 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; @@ -144,7 +143,7 @@ begin end; Result := FBuckets[FABucket].Items[FAIndex].Key; - AData := FBuckets[FABucket].Items[FAIndex].Data; + AData := string(FBuckets[FABucket].Items[FAIndex].Data); Inc(FAIndex); end; @@ -187,7 +186,7 @@ begin with Items[Count] do begin Key := AKey; - Data := AData; + Data := ShortString(AData); end; Inc(Count); Inc(FItemCount); @@ -205,13 +204,11 @@ end; 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); @@ -226,7 +223,7 @@ var 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; @@ -234,7 +231,7 @@ var 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]; @@ -390,7 +387,7 @@ begin 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 diff --git a/src/lib/vampimg/JpegLib/imjcapimin.pas b/src/lib/vampimg/JpegLib/imjcapimin.pas index 105f574..d16c2ae 100644 --- a/src/lib/vampimg/JpegLib/imjcapimin.pas +++ b/src/lib/vampimg/JpegLib/imjcapimin.pas @@ -279,15 +279,15 @@ begin 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; diff --git a/src/lib/vampimg/JpegLib/imjccolor.pas b/src/lib/vampimg/JpegLib/imjccolor.pas index 578706c..09fb8af 100644 --- a/src/lib/vampimg/JpegLib/imjccolor.pas +++ b/src/lib/vampimg/JpegLib/imjccolor.pas @@ -24,8 +24,7 @@ implementation { 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 @@ -94,14 +93,14 @@ const {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; @@ -232,26 +231,24 @@ begin 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; diff --git a/src/lib/vampimg/JpegLib/imjconfig.inc b/src/lib/vampimg/JpegLib/imjconfig.inc index b57c933..70cf478 100644 --- a/src/lib/vampimg/JpegLib/imjconfig.inc +++ b/src/lib/vampimg/JpegLib/imjconfig.inc @@ -121,3 +121,5 @@ {!CHANGE: Added this} {$define Delphi_Stream} {$Q-} +{$MINENUMSIZE 4} +{$ALIGN 8} diff --git a/src/lib/vampimg/JpegLib/imjdmarker.pas b/src/lib/vampimg/JpegLib/imjdmarker.pas index c2202c2..b87a3dd 100644 --- a/src/lib/vampimg/JpegLib/imjdmarker.pas +++ b/src/lib/vampimg/JpegLib/imjdmarker.pas @@ -1631,7 +1631,7 @@ function get_interesting_appn (cinfo : j_decompress_ptr) : boolean; 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; @@ -1692,27 +1692,31 @@ begin 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); diff --git a/src/lib/vampimg/JpegLib/imjerror.pas b/src/lib/vampimg/JpegLib/imjerror.pas index 0a61814..11f53fd 100644 --- a/src/lib/vampimg/JpegLib/imjerror.pas +++ b/src/lib/vampimg/JpegLib/imjerror.pas @@ -42,7 +42,7 @@ procedure ERREXIT4(cinfo : j_common_ptr; code : J_MESSAGE_CODE; 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); @@ -78,7 +78,7 @@ procedure TRACEMS8(cinfo : j_common_ptr; lvl : int; 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 @@ -179,7 +179,7 @@ begin 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] } @@ -286,7 +286,7 @@ begin 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 } @@ -296,7 +296,7 @@ end; {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); @@ -350,11 +350,11 @@ end; {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; diff --git a/src/lib/vampimg/JpegLib/imjmorecfg.pas b/src/lib/vampimg/JpegLib/imjmorecfg.pas index 316a9a7..fddf3f5 100644 --- a/src/lib/vampimg/JpegLib/imjmorecfg.pas +++ b/src/lib/vampimg/JpegLib/imjmorecfg.pas @@ -10,40 +10,13 @@ interface {$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; @@ -58,6 +31,7 @@ type 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; @@ -67,8 +41,6 @@ const {$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 @@ -159,7 +131,7 @@ type { UINT8 must hold at least the values 0..255. } type - UINT8 = byte; + UINT8 = Byte; { UINT16 must hold at least the values 0..65535. } @@ -167,11 +139,11 @@ type { 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; diff --git a/src/lib/vampimg/JpegLib/imjpeglib.pas b/src/lib/vampimg/JpegLib/imjpeglib.pas index f3f530d..dc35daa 100644 --- a/src/lib/vampimg/JpegLib/imjpeglib.pas +++ b/src/lib/vampimg/JpegLib/imjpeglib.pas @@ -722,7 +722,7 @@ type { 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); diff --git a/src/lib/vampimg/ZLib/dzlib.pas b/src/lib/vampimg/ZLib/dzlib.pas index 72031aa..05e278d 100644 --- a/src/lib/vampimg/ZLib/dzlib.pas +++ b/src/lib/vampimg/ZLib/dzlib.pas @@ -45,43 +45,43 @@ unit dzlib; 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; @@ -114,7 +114,6 @@ const Z_UNKNOWN = 2; Z_DEFLATED = 8; -{$ENDIF} type { Abstract ancestor class } @@ -207,8 +206,9 @@ type 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 @@ -265,8 +265,8 @@ begin 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; @@ -283,14 +283,17 @@ begin 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 @@ -334,7 +337,7 @@ begin 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