unit GraphicEx; {$TYPEDADDRESS OFF} // The contents of this file are 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/ // // 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. // // The original code is GraphicColor.pas, released November 1, 1999. // // The initial developer of the original code is Dipl. Ing. Mike Lischke (Pleißa, Germany, www.delphi-gems.com), // // Portions created by Dipl. Ing. Mike Lischke are Copyright // (C) 1999-2003 Dipl. Ing. Mike Lischke. All Rights Reserved. //---------------------------------------------------------------------------------------------------------------------- // // GraphicEx - // This unit is an addendum to Graphics.pas, in order to enable your application // to import many common graphic files. // // See help file for a description of supported image types. Additionally, there is a resample routine // (Stretch) based on code from Anders Melander (http://www.melander.dk/delphi/resampler/index.html) // which has been optimized quite a lot to work faster and bug fixed. // // version - 9.9 // // 03-SEP-2000 ml: // EPS with alpha channel, workaround for TIFs with wrong alpha channel indication, // workaround for bad packbits compressed (TIF) images // 28-AUG-2000 ml: // small bugfixes // 27-AUG-2000 ml: // changed all FreeMemory(P) calls back to ... if Assigned(P) then FreeMem(P); ... // 24-AUG-2000 ml: // small bug in LZ77 decoder removed // 18-AUG-2000 ml: // TIF deflate decoding scheme // 15-AUG-2000 ml: // workaround for TIF images without compression, but prediction scheme set (which is not really used in this case) // 12-AUG-2000 ml: // small changes // 16-SEP-2008 sz: // version for D2009 // 28-SEP-2008 sz: // fixed memoryleak in GetGraphicFilter // 02-NOV-2008 sz: // restored PCD format for Delphi 2009 // // // // For older history please look into the help file. // // Note: The library provides usually only load support for the listed image formats but will perhaps be enhanced // in the future to save those types too. It can be compiled with Delphi 4 or newer versions. // //---------------------------------------------------------------------------------------------------------------------- interface {$I GraphicConfiguration.inc} uses Windows, Classes, ExtCtrls, Graphics, SysUtils, JPEG, GraphicCompression, GraphicStrings, GraphicColor; type TCardinalArray = array of Cardinal; TByteArray = array of Byte; TFloatArray = array of Single; TImageOptions = set of ( ioTiled, // image consists of tiles not strips (TIF) ioBigEndian, // byte order in values >= words is reversed (TIF, RLA, SGI) ioMinIsWhite, // minimum value in grayscale palette is white not black (TIF) ioReversed, // bit order in bytes is reveresed (TIF) ioUseGamma // gamma correction is used ); // describes the compression used in the image file TCompressionType = ( ctUnknown, // compression type is unknown ctNone, // no compression at all ctRLE, // run length encoding ctPackedBits, // Macintosh packed bits ctLZW, // Lempel-Zif-Welch ctFax3, // CCITT T.4 (1d), also known as fax group 3 ctFaxRLE, // modified Huffman (CCITT T.4 derivative) ctFax4, // CCITT T.6, also known as fax group 4 ctFaxRLEW, // CCITT T.4 with word alignment ctLZ77, // Hufman inflate/deflate ctJPEG, // TIF JPEG compression (new version) ctOJPEG, // TIF JPEG compression (old version) ctThunderscan, // TIF thunderscan compression ctNext, ctIT8CTPAD, ctIT8LW, ctIT8MP, ctIT8BL, ctPixarFilm, ctPixarLog, ctDCS, ctJBIG, ctPCDHuffmann // PhotoCD Hufman compression ); // properties of a particular image which are set while loading an image or when // they are explicitly requested via ReadImageProperties PImageProperties = ^TImageProperties; TImageProperties = record Version: Cardinal; // TIF, PSP, GIF Options: TImageOptions; // all images Width, // all images Height: Cardinal; // all images ColorScheme: TColorScheme; // all images BitsPerSample, // all Images SamplesPerPixel, // all images BitsPerPixel: Byte; // all images Compression: TCompressionType; // all images FileGamma: Single; // RLA, PNG XResolution, YResolution: Single; // given in dpi (TIF, PCX, PSP) Interlaced, // GIF, PNG HasAlpha: Boolean; // TIF, PNG // informational data, used internally and/or by decoders // TIF FirstIFD, PlanarConfig, // most of this data is needed in the JPG decoder CurrentRow, TileWidth, TileLength, BytesPerLine: Cardinal; RowsPerStrip: TCardinalArray; YCbCrSubSampling, JPEGTables: TByteArray; JPEGColorMode, JPEGTablesMode: Cardinal; CurrentStrip, StripCount, Predictor: Integer; // PCD Overview: Boolean; // true if image is an overview image Rotate: Byte; // describes how the image is rotated (aka landscape vs. portrait image) ImageCount: Word; // number of subimages if this is an overview image // GIF LocalColorTable: Boolean; // image uses an own color palette instead of the global one // RLA BottomUp: Boolean; // images is bottom to top // PSD Channels: Byte; // up to 24 channels per image // PNG FilterMode: Byte; end; // This is the general base class for all image types implemented in GraphicEx. // It contains some generally used class/data. TGraphicExGraphic = class(TBitmap) private FColorManager: TColorManager; FImageProperties: TImageProperties; FBasePosition: Cardinal; // stream start position FStream: TStream; // used for local references of the stream the class is currently loading from FProgressRect: TRect; public constructor Create; override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; class function CanLoad(const FileName: String): Boolean; overload; virtual; class function CanLoad(Stream: TStream): Boolean; overload; virtual; procedure LoadFromResourceName(Instance: THandle; const ResName: String); procedure LoadFromResourceID(Instance: THandle; ResID: Integer); function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; virtual; property ColorManager: TColorManager read FColorManager; property ImageProperties: TImageProperties read FImageProperties write FImageProperties; end; TGraphicExGraphicClass = class of TGraphicExGraphic; {$ifdef SGIGraphic} // *.bw, *.rgb, *.rgba, *.sgi images TSGIGraphic = class(TGraphicExGraphic) private FRowStart, FRowSize: TCardinalArray; // start and length of a line (if compressed) FDecoder: TDecoder; // ...same applies here procedure ReadAndDecode(Red, Green, Blue, Alpha: Pointer; Row, BPC: Cardinal); public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; end; {$endif} {$ifdef AutodeskGraphic} // *.cel, *.pic images TAutodeskGraphic = class(TGraphicExGraphic) public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; end; {$endif} {$ifdef TIFFGraphic} // *.tif, *.tiff images // one entry in a an IFD (image file directory) TIFDEntry = packed record Tag: Word; DataType: Word; DataLength: Cardinal; Offset: Cardinal; end; TTIFFPalette = array[0..787] of Word; TTIFFGraphic = class(TGraphicExGraphic) private FIFD: array of TIFDEntry; // the tags of one image file directory FPalette: TTIFFPalette; FYCbCrPositioning: Cardinal; FYCbCrCoefficients: TFloatArray; function FindTag(Tag: Cardinal; var Index: Cardinal): Boolean; procedure GetValueList(Stream: TStream; Tag: Cardinal; var Values: TByteArray); overload; procedure GetValueList(Stream: TStream; Tag: Cardinal; var Values: TCardinalArray); overload; procedure GetValueList(Stream: TStream; Tag: Cardinal; var Values: TFloatArray); overload; function GetValue(Stream: TStream; Tag: Cardinal; Default: Single = 0): Single; overload; function GetValue(Tag: Cardinal; Default: Cardinal = 0): Cardinal; overload; function GetValue(Tag: Cardinal; var Size: Cardinal; Default: Cardinal = 0): Cardinal; overload; procedure SortIFD; procedure SwapIFD; public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; procedure SaveToStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; end; {$ifdef EPSGraphic} TEPSGraphic = class(TTIFFGraphic) public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; end; {$endif} // EPSGraphic {$endif} // TIFFGraphic {$ifdef TargaGraphic} // *.tga; *.vst; *.icb; *.vda; *.win images TTargaGraphic = class(TGraphicExGraphic) public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; procedure SaveToStream(Stream: TStream); overload; override; procedure SaveToStream(Stream: TStream; Compressed: Boolean); reintroduce; overload; end; {$endif} {$ifdef PCXGraphic} // *.pcx; *.pcc; *.scr images // Note: Due to the badly designed format a PCX/SCR file cannot be part in a larger stream because the position of the // color palette as well as the decoding size can only be determined by the size of the image. // Hence the image must be the only one in the stream or the last one. TPCXGraphic = class(TGraphicExGraphic) public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; end; {$endif} {$ifdef PCDGraphic} // *.pcd images // Note: By default the BASE resolution of a PCD image is loaded with LoadFromStream. TPCDGraphic = class(TGraphicExGraphic) public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; class var DefaultResolution: Integer; // 2 = default; 0: 128 × 192; 1: 256 × 384; 2: 512 × 768; 3: 1024 × 1536; 4: 2048 × 3072; 5: 4096 × 6144 optional end; {$endif} {$ifdef PortableMapGraphic} // *.ppm, *.pgm, *.pbm images TPPMGraphic = class(TGraphicExGraphic) private FBuffer: array[0..4095] of AnsiChar; FIndex: Integer; function CurrentChar: AnsiChar; function GetChar: AnsiChar; function GetNumber: Cardinal; function ReadLine: AnsiString; public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; end; {$endif} {$ifdef CUTGraphic} // *.cut (+ *.pal) images // Note: Also this format should not be used in a stream unless it is the only image or the last one! TCUTGraphic = class(TGraphicExGraphic) private FPaletteFile: String; protected procedure LoadPalette; public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromFile(const FileName: String); override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; property PaletteFile: String read FPaletteFile write FPaletteFile; end; {$endif} {$ifdef GIFGraphic} // *.gif images TGIFGraphic = class(TGraphicExGraphic) private function SkipExtensions: Byte; public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; end; {$endif} {$ifdef RLAGraphic} // *.rla, *.rpf images // implementation based on code from Dipl. Ing. Ingo Neumann (ingo@upstart.de, ingo_n@dialup.nacamar.de) TRLAGraphic = class(TGraphicExGraphic) private procedure SwapHeader(var Header); // start position of the image header in the stream public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; end; {$endif} {$ifdef PhotoshopGraphic} // *.psd, *.pdd images TPSDGraphic = class(TGraphicExGraphic) public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; end; {$endif} {$ifdef PaintshopProGraphic} // *.psp images (file version 3 and 4) TPSPGraphic = class(TGraphicExGraphic) public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; end; {$endif} {$ifdef PortableNetworkGraphic} // *.png images TChunkType = array[0..3] of AnsiChar; // This header is followed by a variable number of data bytes, which are followed by the CRC for this data. // The actual size of this data is given by field length in the chunk header. // CRC is Cardinal (4 byte unsigned integer). TPNGChunkHeader = packed record Length: Cardinal; // size of data (entire chunk excluding itself, CRC and type) case integer of 0: (ChunkType: TChunkType); 1: (Mask: DWORD); end; TPNGGraphic = class(TGraphicExGraphic) private FDecoder: TLZ77Decoder; FIDATSize: Integer; // remaining bytes in the current IDAT chunk FRawBuffer, // buffer to load raw chunk data and to check CRC FCurrentSource: Pointer; // points into FRawBuffer for current position of decoding FHeader: TPNGChunkHeader; // header of the current chunk FCurrentCRC: Cardinal; // running CRC for the current chunk FSourceBPP: Integer; // bits per pixel used in the file FPalette: HPALETTE; // used to hold the palette handle until we can set it finally after the pixel format // has been set too (as this destroys the current palette) FTransparency: TByteArray; // If the image is indexed then this array might contain alpha values (depends on file) // each entry corresponding to the same palette index as the index in this array. // For grayscale and RGB images FTransparentColor contains the (only) transparent // color. FTransparentColor: TColor; // transparent color for gray and RGB FBackgroundColor: TColor; // index or color ref procedure ApplyFilter(Filter: Byte; Line, PrevLine, Target: PByte; BPP, BytesPerRow: Integer); function IsChunk(ChunkType: TChunkType): Boolean; function LoadAndSwapHeader: Cardinal; procedure LoadBackgroundColor(const Description); procedure LoadIDAT(const Description); procedure LoadTransparency(const Description); procedure ReadDataAndCheckCRC; procedure ReadRow(RowBuffer: Pointer; BytesPerRow: Integer); function SetupColorDepth(ColorType, BitDepth: Integer): Integer; public class function CanLoad(Stream: TStream): Boolean; override; procedure LoadFromStream(Stream: TStream); override; function ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; override; property BackgroundColor: TColor read FBackgroundColor; property Transparency: TByteArray read FTransparency; end; {$endif} // PortableNetworkGraphic // ---------- file format management stuff TFormatType = ( ftAnimation, // format contains an animation (like GIF or AVI) ftLayered, // format supports multiple layers (like PSP, PSD) ftMultiImage, // format can contain more than one image (like TIF or GIF) ftRaster, // format is contains raster data (this is mainly used) ftVector // format contains vector data (like DXF or PSP file version 4) ); TFormatTypes = set of TFormatType; TFilterSortType = ( fstNone, // do not sort entries, list them as they are registered fstBoth, // sort entries first by description then by extension fstDescription, // sort entries by description only fstExtension // sort entries by extension only ); TFilterOption = ( foCompact, // use the compact form in filter strings instead listing each extension on a separate line foIncludeAll, // include the 'All image files' filter string foIncludeExtension // add the extension to the description ); TFilterOptions = set of TFilterOption; // The file format list is an alternative to Delphi's own poor implementation which does neither allow to filter // graphic formats nor to build common entries in filter strings nor does it care for duplicate entries or // alphabetic ordering. Additionally, some properties are maintained for each format to do searches, filter partiuclar // formats for a certain case etc. TFileFormatList = class private FClassList, FExtensionList: TList; protected function FindExtension(const Extension: String): Integer; public constructor Create; destructor Destroy; override; function FindGraphicClass(GraphicClass: TGraphicClass): Integer; procedure Clear; function GetDescription(Graphic: TGraphicClass): String; procedure GetExtensionList(List: TStrings); function GetGraphicFilter(Formats: TFormatTypes; SortType: TFilterSortType; Options: TFilterOptions; GraphicClass: TGraphicClass): String; function GraphicFromExtension(S: String): TGraphicClass; function GraphicFromContent(const FileName: String): TGraphicExGraphicClass; overload; function GraphicFromContent(Stream: TStream): TGraphicExGraphicClass; overload; procedure RegisterFileFormat(const Extension, Common, Individual: String; FormatTypes: TFormatTypes; Replace, RegisterDefault: Boolean; GraphicClass: TGraphicClass); procedure UnregisterFileFormat(const Extension: String; GraphicClass: TGraphicClass); end; // resampling support types TResamplingFilter = (sfBox, sfTriangle, sfHermite, sfBell, sfSpline, sfLanczos3, sfMitchell); // Resampling support routines procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter; Radius: Single; Source, Target: TBitmap); overload; procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter; Radius: Single; Source: TBitmap); overload; var FileFormatList: TFileFormatList; //---------------------------------------------------------------------------------------------------------------------- implementation uses Consts, Math, MZLib; type // resampling support types TRGBInt = record R, G, B: Integer; end; PRGBWord = ^TRGBWord; TRGBWord = record R, G, B: Word; end; PRGBAWord = ^TRGBAWord; TRGBAWord = record R, G, B, A: Word; end; PBGR = ^TBGR; TBGR = packed record B, G, R: Byte; end; PBGRA = ^TBGRA; TBGRA = packed record B, G, R, A: Byte; end; PRGB = ^TRGB; TRGB = packed record R, G, B: Byte; end; PRGBA = ^TRGBA; TRGBA = packed record R, G, B, A: Byte; end; PPixelArray = ^TPixelArray; TPixelArray = array[0..0] of TBGR; TFilterFunction = function(Value: Single): Single; // contributor for a Pixel PContributor = ^TContributor; TContributor = record Weight: Integer; // Pixel Weight Pixel: Integer; // Source Pixel end; TContributors = array of TContributor; // list of source pixels contributing to a destination pixel TContributorEntry = record N: Integer; Contributors: TContributors; end; TContributorList = array of TContributorEntry; const DefaultFilterRadius: array[TResamplingFilter] of Single = (0.5, 1, 1, 1.5, 2, 3, 2); threadvar // globally used cache for current image (speeds up resampling about 10%) CurrentLineR: array of Integer; CurrentLineG: array of Integer; CurrentLineB: array of Integer; //---------------------------------------------------------------------------------------------------------------------- procedure GraphicExError(ErrorString: String); overload; begin raise EInvalidGraphic.Create(ErrorString); end; //---------------------------------------------------------------------------------------------------------------------- procedure GraphicExError(ErrorString: String; Args: array of const); overload; begin raise EInvalidGraphic.CreateFmt(ErrorString, Args); end; //---------------------------------------------------------------------------------------------------------------------- // TODO : Pointer arithmetics procedure Upsample(Width, Height, ScaledWidth: Cardinal; Pixels: PByte); // Creates a new image that is a integral size greater than an existing one. var X, Y: Cardinal; P, Q, R: PByte; begin for Y := 0 to Height - 1 do begin P := Pixels + (Height - 1 - Y) * ScaledWidth + (Width - 1); Q := Pixels + ((Height - 1 - Y) shl 1) * ScaledWidth + ((Width - 1) shl 1); Q^ := P^; (Q + 1)^ := P^; for X := 1 to Width - 1 do begin Dec(P); Dec(Q, 2); Q^ := P^; (Q + 1)^ := Byte((Word(P^) + Word((P + 1)^) + 1) shr 1); end; end; for Y := 0 to Height - 2 do begin P := Pixels + (Y shl 1) * ScaledWidth; Q := P + ScaledWidth; R := Q + ScaledWidth; for X := 0 to Width - 2 do begin Q^ := Byte((Word(P^) + Word(R^) + 1) shr 1); (Q + 1)^ := Byte((Word(P^) + Word((P + 2)^) + Word(R^) + Word((R + 2)^) + 2) shr 2); Inc(Q, 2); Inc(P, 2); Inc(R, 2); end; Q^ := Byte((Word(P^) + Word(R^) + 1) shr 1); Inc(P); Inc(Q); Q^ := Byte((Word(P^) + Word(R^) + 1) shr 1); end; P := Pixels + (2 * Height - 2) * ScaledWidth; Q := Pixels + (2 * Height - 1) * ScaledWidth; Move(P^, Q^, 2 * Width); end; //----------------- filter functions for stretching -------------------------------------------------------------------- function HermiteFilter(Value: Single): Single; // f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1 begin if Value < 0 then Value := -Value; if Value < 1 then Result := (2 * Value - 3) * Sqr(Value) + 1 else Result := 0; end; //---------------------------------------------------------------------------------------------------------------------- function BoxFilter(Value: Single): Single; // This filter is also known as 'nearest neighbour' Filter. begin if (Value > -0.5) and (Value <= 0.5) then Result := 1 else Result := 0; end; //---------------------------------------------------------------------------------------------------------------------- function TriangleFilter(Value: Single): Single; // aka 'linear' or 'bilinear' filter begin if Value < 0 then Value := -Value; if Value < 1 then Result := 1 - Value else Result := 0; end; //---------------------------------------------------------------------------------------------------------------------- function BellFilter(Value: Single): Single; begin if Value < 0 then Value := -Value; if Value < 0.5 then Result := 0.75 - Sqr(Value) else if Value < 1.5 then begin Value := Value - 1.5; Result := 0.5 * Sqr(Value); end else Result := 0; end; //---------------------------------------------------------------------------------------------------------------------- function SplineFilter(Value: Single): Single; // B-spline filter var Temp: Single; begin if Value < 0 then Value := -Value; if Value < 1 then begin Temp := Sqr(Value); Result := 0.5 * Temp * Value - Temp + 2 / 3; end else if Value < 2 then begin Value := 2 - Value; Result := Sqr(Value) * Value / 6; end else Result := 0; end; //---------------------------------------------------------------------------------------------------------------------- function Lanczos3Filter(Value: Single): Single; //--------------- local function -------------------------------------------- function SinC(Value: Single): Single; begin if Value <> 0 then begin Value := Value * Pi; Result := Sin(Value) / Value; end else Result := 1; end; //--------------------------------------------------------------------------- begin if Value < 0 then Value := -Value; if Value < 3 then Result := SinC(Value) * SinC(Value / 3) else Result := 0; end; //---------------------------------------------------------------------------------------------------------------------- function MitchellFilter(Value: Single): Single; const B = 1 / 3; C = 1 / 3; var Temp: Single; begin if Value < 0 then Value := -Value; Temp := Sqr(Value); if Value < 1 then begin Value := (((12 - 9 * B - 6 * C) * (Value * Temp)) + ((-18 + 12 * B + 6 * C) * Temp) + (6 - 2 * B)); Result := Value / 6; end else if Value < 2 then begin Value := (((-B - 6 * C) * (Value * Temp)) + ((6 * B + 30 * C) * Temp) + ((-12 * B - 48 * C) * Value) + (8 * B + 24 * C)); Result := Value / 6; end else Result := 0; end; //---------------------------------------------------------------------------------------------------------------------- const FilterList: array[TResamplingFilter] of TFilterFunction = ( BoxFilter, TriangleFilter, HermiteFilter, BellFilter, SplineFilter, Lanczos3Filter, MitchellFilter ); //---------------------------------------------------------------------------------------------------------------------- procedure FillLineChache(N, Delta: Integer; Line: Pointer); var I: Integer; Run: PBGR; begin Run := Line; for I := 0 to N - 1 do begin CurrentLineR[I] := Run.R; CurrentLineG[I] := Run.G; CurrentLineB[I] := Run.B; Inc(PByte(Run), Delta); end; end; //---------------------------------------------------------------------------------------------------------------------- function ApplyContributors(N: Integer; Contributors: TContributors): TBGR; var J: Integer; RGB: TRGBInt; Total, Weight: Integer; Pixel: Cardinal; Contr: ^TContributor; begin RGB.R := 0; RGB.G := 0; RGB.B := 0; Total := 0; Contr := @Contributors[0]; for J := 0 to N - 1 do begin Weight := Contr.Weight; Inc(Total, Weight); Pixel := Contr.Pixel; Inc(RGB.r, CurrentLineR[Pixel] * Weight); Inc(RGB.g, CurrentLineG[Pixel] * Weight); Inc(RGB.b, CurrentLineB[Pixel] * Weight); Inc(Contr); end; if Total = 0 then begin Result.R := ClampByte(RGB.R shr 8); Result.G := ClampByte(RGB.G shr 8); Result.B := ClampByte(RGB.B shr 8); end else begin Result.R := ClampByte(RGB.R div Total); Result.G := ClampByte(RGB.G div Total); Result.B := ClampByte(RGB.B div Total); end; end; //---------------------------------------------------------------------------------------------------------------------- procedure DoStretch(Filter: TFilterFunction; Radius: Single; Source, Target: TBitmap); // This is the actual scaling routine. Target must be allocated already with sufficient size. Source must // contain valid data, Radius must not be 0 and Filter must not be nil. var ScaleX, ScaleY: Single; // Zoom scale factors I, J, K, N: Integer; // Loop variables Center: Single; // Filter calculation variables Width: Single; Weight: Integer; // Filter calculation variables Left, Right: Integer; // Filter calculation variables Work: TBitmap; ContributorList: TContributorList; SourceLine, DestLine: PPixelArray; DestPixel: PBGR; Delta, DestDelta: Integer; SourceHeight, SourceWidth, TargetHeight, TargetWidth: Integer; begin // shortcut variables SourceHeight := Source.Height; SourceWidth := Source.Width; TargetHeight := Target.Height; TargetWidth := Target.Width; if (SourceHeight = 0) or (SourceWidth = 0) or (TargetHeight = 0) or (TargetWidth = 0) then Exit; // create intermediate image to hold horizontal zoom Work := TBitmap.Create; try Work.PixelFormat := pf24Bit; Work.Height := SourceHeight; Work.Width := TargetWidth; if SourceWidth = 1 then ScaleX := TargetWidth / SourceWidth else ScaleX := (TargetWidth - 1) / (SourceWidth - 1); if (SourceHeight = 1) or (TargetHeight = 1) then ScaleY := TargetHeight / SourceHeight else ScaleY := (TargetHeight - 1) / (SourceHeight - 1); // pre-calculate filter contributions for a row SetLength(ContributorList, TargetWidth); // horizontal sub-sampling if ScaleX < 1 then begin // scales from bigger to smaller Width Width := Radius / ScaleX; for I := 0 to TargetWidth - 1 do begin ContributorList[I].N := 0; SetLength(ContributorList[I].Contributors, Trunc(2 * Width + 1)); Center := I / ScaleX; Left := Floor(Center - Width); Right := Ceil(Center + Width); for J := Left to Right do begin Weight := Round(Filter((Center - J) * ScaleX) * ScaleX * 256); if Weight <> 0 then begin if J < 0 then N := -J else if J >= SourceWidth then N := SourceWidth - J + SourceWidth - 1 else N := J; K := ContributorList[I].N; Inc(ContributorList[I].N); ContributorList[I].Contributors[K].Pixel := N; ContributorList[I].Contributors[K].Weight := Weight; end; end; end; end else begin // horizontal super-sampling // scales from smaller to bigger Width for I := 0 to TargetWidth - 1 do begin ContributorList[I].N := 0; SetLength(ContributorList[I].Contributors, Trunc(2 * Radius + 1)); Center := I / ScaleX; Left := Floor(Center - Radius); Right := Ceil(Center + Radius); for J := Left to Right do begin Weight := Round(Filter(Center - J) * 256); if Weight <> 0 then begin if J < 0 then N := -J else if J >= SourceWidth then N := SourceWidth - J + SourceWidth - 1 else N := J; K := ContributorList[I].N; Inc(ContributorList[I].N); ContributorList[I].Contributors[K].Pixel := N; ContributorList[I].Contributors[K].Weight := Weight; end; end; end; end; // now apply filter to sample horizontally from Src to Work SetLength(CurrentLineR, SourceWidth); SetLength(CurrentLineG, SourceWidth); SetLength(CurrentLineB, SourceWidth); for K := 0 to SourceHeight - 1 do begin SourceLine := Source.ScanLine[K]; FillLineChache(SourceWidth, 3, SourceLine); DestPixel := Work.ScanLine[K]; for I := 0 to TargetWidth - 1 do with ContributorList[I] do begin DestPixel^ := ApplyContributors(N, ContributorList[I].Contributors); // move on to next column Inc(DestPixel); end; end; // free the memory allocated for horizontal filter weights, since we need the stucture again for I := 0 to TargetWidth - 1 do ContributorList[I].Contributors := nil; ContributorList := nil; // pre-calculate filter contributions for a column SetLength(ContributorList, TargetHeight); // vertical sub-sampling if ScaleY < 1 then begin // scales from bigger to smaller height Width := Radius / ScaleY; for I := 0 to TargetHeight - 1 do begin ContributorList[I].N := 0; SetLength(ContributorList[I].Contributors, Trunc(2 * Width + 1)); Center := I / ScaleY; Left := Floor(Center - Width); Right := Ceil(Center + Width); for J := Left to Right do begin Weight := Round(Filter((Center - J) * ScaleY) * ScaleY * 256); if Weight <> 0 then begin if J < 0 then N := -J else if J >= SourceHeight then N := SourceHeight - J + SourceHeight - 1 else N := J; K := ContributorList[I].N; Inc(ContributorList[I].N); ContributorList[I].Contributors[K].Pixel := N; ContributorList[I].Contributors[K].Weight := Weight; end; end; end end else begin // vertical super-sampling // scales from smaller to bigger height for I := 0 to TargetHeight - 1 do begin ContributorList[I].N := 0; SetLength(ContributorList[I].Contributors, Trunc(2 * Radius + 1)); Center := I / ScaleY; Left := Floor(Center - Radius); Right := Ceil(Center + Radius); for J := Left to Right do begin Weight := Round(Filter(Center - J) * 256); if Weight <> 0 then begin if J < 0 then N := -J else if J >= SourceHeight then N := SourceHeight - J + SourceHeight - 1 else N := J; K := ContributorList[I].N; Inc(ContributorList[I].N); ContributorList[I].Contributors[K].Pixel := N; ContributorList[I].Contributors[K].Weight := Weight; end; end; end; end; // apply filter to sample vertically from Work to Target SetLength(CurrentLineR, SourceHeight); SetLength(CurrentLineG, SourceHeight); SetLength(CurrentLineB, SourceHeight); SourceLine := Work.ScanLine[0]; Delta := Integer(Work.ScanLine[1]) - Integer(SourceLine); DestLine := Target.ScanLine[0]; DestDelta := Integer(Target.ScanLine[1]) - Integer(DestLine); for K := 0 to TargetWidth - 1 do begin DestPixel := Pointer(DestLine); FillLineChache(SourceHeight, Delta, SourceLine); for I := 0 to TargetHeight - 1 do with ContributorList[I] do begin DestPixel^ := ApplyContributors(N, ContributorList[I].Contributors); Inc(Integer(DestPixel), DestDelta); end; Inc(SourceLine); Inc(DestLine); end; // free the memory allocated for vertical filter weights for I := 0 to TargetHeight - 1 do ContributorList[I].Contributors := nil; // this one is done automatically on exit, but is here for completeness ContributorList := nil; finally Work.Free; CurrentLineR := nil; CurrentLineG := nil; CurrentLineB := nil; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter; Radius: Single; Source, Target: TBitmap); // Scales the source bitmap to the given size (NewWidth, NewHeight) and stores the Result in Target. // Filter describes the filter function to be applied and Radius the size of the filter area. // Is Radius = 0 then the recommended filter area will be used (see DefaultFilterRadius). begin if Radius = 0 then Radius := DefaultFilterRadius[Filter]; Target.Handle := 0; Target.PixelFormat := pf24Bit; Target.Width := NewWidth; Target.Height := NewHeight; Source.PixelFormat := pf24Bit; DoStretch(FilterList[Filter], Radius, Source, Target); end; //---------------------------------------------------------------------------------------------------------------------- procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter; Radius: Single; Source: TBitmap); var Target: TBitmap; begin if Radius = 0 then Radius := DefaultFilterRadius[Filter]; Target := TBitmap.Create; try Target.PixelFormat := pf24Bit; Target.Width := NewWidth; Target.Height := NewHeight; Source.PixelFormat := pf24Bit; DoStretch(FilterList[Filter], Radius, Source, Target); Source.Assign(Target); finally Target.Free; end; end; //----------------- support functions for image loading ---------------------------------------------------------------- procedure SwapShort(P: PWord; Count: Cardinal); // swaps high and low byte of 16 bit values // EAX contains P, EDX contains Count asm @@Loop: MOV CX, [EAX] XCHG CH, CL MOV [EAX], CX ADD EAX, 2 DEC EDX JNZ @@Loop end; //---------------------------------------------------------------------------------------------------------------------- procedure SwapLong(P: PInteger; Count: Cardinal); overload; // swaps high and low bytes of 32 bit values // EAX contains P, EDX contains Count asm @@Loop: MOV ECX, [EAX] BSWAP ECX MOV [EAX], ECX ADD EAX, 4 DEC EDX JNZ @@Loop end; //---------------------------------------------------------------------------------------------------------------------- function SwapLong(Value: Cardinal): Cardinal; overload; // swaps high and low bytes of the given 32 bit value asm BSWAP EAX end; //----------------- various conversion routines ------------------------------------------------------------------------ procedure Depredict1(P: Pointer; Count: Cardinal); // EAX contains P and EDX Count asm @@1: MOV CL, [EAX] ADD [EAX + 1], CL INC EAX DEC EDX JNZ @@1 end; //---------------------------------------------------------------------------------------------------------------------- procedure Depredict3(P: Pointer; Count: Cardinal); // EAX contains P and EDX Count asm MOV ECX, EDX SHL ECX, 1 ADD ECX, EDX // 3 * Count @@1: MOV DL, [EAX] ADD [EAX + 3], DL INC EAX DEC ECX JNZ @@1 end; //---------------------------------------------------------------------------------------------------------------------- procedure Depredict4(P: Pointer; Count: Cardinal); // EAX contains P and EDX Count asm SHL EDX, 2 // 4 * Count @@1: MOV CL, [EAX] ADD [EAX + 4], CL INC EAX DEC EDX JNZ @@1 end; //----------------- TGraphicExGraphic ---------------------------------------------------------------------------------- constructor TGraphicExGraphic.Create; begin inherited; FColorManager := TColorManager.Create; end; //---------------------------------------------------------------------------------------------------------------------- destructor TGraphicExGraphic.Destroy; begin FColorManager.Free; inherited; end; //---------------------------------------------------------------------------------------------------------------------- procedure TGraphicExGraphic.Assign(Source: TPersistent); begin if Source is TGraphicExGraphic then FImageProperties := TGraphicExGraphic(Source).FImageProperties; inherited; end; //---------------------------------------------------------------------------------------------------------------------- class function TGraphicExGraphic.CanLoad(const FileName: String): Boolean; var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try Result := CanLoad(Stream); finally Stream.Free; end; end; //---------------------------------------------------------------------------------------------------------------------- class function TGraphicExGraphic.CanLoad(Stream: TStream): Boolean; // Descentants have to override this method and return True if they consider the data in Stream // as loadable by the particular class. // Note: Make sure the stream position is the same on exit as it was on enter! begin Result := False; end; //---------------------------------------------------------------------------------------------------------------------- procedure TGraphicExGraphic.LoadFromResourceID(Instance: THandle; ResID: Integer); var Stream: TResourceStream; begin Stream := TResourceStream.CreateFromID(Instance, ResID, RT_RCDATA); try LoadFromStream(Stream); finally Stream.Free; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TGraphicExGraphic.LoadFromResourceName(Instance: THandle; const ResName: String); var Stream: TResourceStream; begin Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA); try LoadFromStream(Stream); finally Stream.Free; end; end; //---------------------------------------------------------------------------------------------------------------------- function TGraphicExGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; // Initializes the internal image properties structure. // Descentants must override this method to fill in the actual values. // Result is always False to show there is no image to load. begin Finalize(FImageProperties); ZeroMemory(@FImageProperties, SizeOf(FImageProperties)); FImageProperties.FileGamma := 1; Result := False; end; //----------------- TAutodeskGraphic ----------------------------------------------------------------------------------- {$ifdef AutodeskGraphic} type TAutodeskHeader = packed record Width, Height, XCoord, YCoord: Word; Depth, Compression: Byte; DataSize: Cardinal; Reserved: array[0..15] of Byte; end; //---------------------------------------------------------------------------------------------------------------------- class function TAutodeskGraphic.CanLoad(Stream: TStream): Boolean; var FileID: Word; Header: TAutodeskHeader; LastPosition: Cardinal; begin with Stream do begin Result := (Size - Position) > (SizeOf(FileID) + SizeOf(Header)); if Result then begin LastPosition := Position; Read(FileID, SizeOf(FileID)); Result := FileID = $9119; if Result then begin // read image dimensions Read(Header, SizeOf(Header)); Result := (Header.Depth = 8) and (Header.Compression = 0); end; Position := LastPosition; end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TAutodeskGraphic.LoadFromStream(Stream: TStream); var FileID: Word; FileHeader: TAutodeskHeader; LogPalette: TMaxLogPalette; I: Integer; begin Handle := 0; FBasePosition := Stream.Position; if ReadImageProperties(Stream, 0) then begin with Stream do begin Position := FBasePosition; FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); Read(FileID, 2); // read image dimensions Read(FileHeader, SizeOf(FileHeader)); // read palette entries and create a palette ZeroMemory(@LogPalette, SizeOf(LogPalette)); LogPalette.palVersion := $300; LogPalette.palNumEntries := 256; for I := 0 to 255 do begin Read(LogPalette.palPalEntry[I], 3); LogPalette.palPalEntry[I].peBlue := LogPalette.palPalEntry[I].peBlue shl 2; LogPalette.palPalEntry[I].peGreen := LogPalette.palPalEntry[I].peGreen shl 2; LogPalette.palPalEntry[I].peRed := LogPalette.palPalEntry[I].peRed shl 2; end; // setup bitmap properties PixelFormat := pf8Bit; Palette := CreatePalette(PLogPalette(@LogPalette)^); Width := FileHeader.Width; Height := FileHeader.Height; // finally read image data for I := 0 to Height - 1 do begin Read(Scanline[I]^, FileHeader.Width); Progress(Self, psRunning, MulDiv(I, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; Progress(Self, psEnding, 0, False, FProgressRect, ''); end; end else GraphicExError(gesInvalidImage, ['Autodesk']); end; //---------------------------------------------------------------------------------------------------------------------- function TAutodeskGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var FileID: Word; Header: TAutodeskHeader; begin Result := inherited ReadImageProperties(Stream, ImageIndex); with Stream, FImageProperties do begin Read(FileID, 2); if FileID = $9119 then begin // read image dimensions Read(Header, SizeOf(Header)); ColorScheme := csIndexed; Width := Header.Width; Height := Header.Height; BitsPerSample := 8; SamplesPerPixel := 1; BitsPerPixel := 8; Compression := ctNone; Result := True; end; end; end; {$endif} // AutodeskGraphic //----------------- TSGIGraphic ---------------------------------------------------------------------------------------- {$ifdef SGIGraphic} const SGIMagic = 474; SGI_COMPRESSION_VERBATIM = 0; SGI_COMPRESSION_RLE = 1; type TSGIHeader = packed record Magic: SmallInt; // IRIS image file magic number Storage, // Storage format BPC: Byte; // Number of bytes per pixel channel (1 or 2) Dimension: Word; // Number of dimensions // 1 - one single scanline (and one channel) of length XSize // 2 - two dimensional (one channel) of size XSize x YSize // 3 - three dimensional (ZSize channels) of size XSize x YSize XSize, // width of image YSize, // height of image ZSize: Word; // number of channels/planes in image (3 for RGB, 4 for RGBA etc.) PixMin, // Minimum pixel value PixMax: Cardinal; // Maximum pixel value Dummy: Cardinal; // ignored ImageName: array[0..79] of AnsiChar; ColorMap: Integer; // Colormap ID // 0 - default, almost all images are stored with this flag // 1 - dithered, only one channel of data (pixels are packed), obsolete // 2 - screen (palette) image, obsolete // 3 - no image data, palette only, not displayable Dummy2: array[0..403] of Byte; // ignored end; //---------------------------------------------------------------------------------------------------------------------- class function TSGIGraphic.CanLoad(Stream: TStream): Boolean; // returns True if the data in Stream represents a graphic which can be loaded by this class var Header: TSGIHeader; LastPosition: Cardinal; begin with Stream do begin Result := (Size - Position) > SizeOf(TSGIHeader); if Result then begin LastPosition := Position; ReadBuffer(Header, SizeOf(Header)); // one number as check is too unreliable, hence we take some more fields into the check Result := (Swap(Header.Magic) = SGIMagic) and (Header.BPC in [1, 2]) and (Swap(Header.Dimension) in [1..3]); Position := LastPosition; end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TSGIGraphic.ReadAndDecode(Red, Green, Blue, Alpha: Pointer; Row, BPC: Cardinal); var Count: Cardinal; RawBuffer: Pointer; begin with FStream, FImageProperties do // compressed image? if Assigned(FDecoder) then begin if Assigned(Red) then begin Position := FBasePosition + FRowStart[Row + 0 * Height]; Count := BPC * FRowSize[Row + 0 * Height]; GetMem(RawBuffer, Count); try Read(RawBuffer^, Count); FDecoder.Decode(RawBuffer, Red, Count, Width); finally if Assigned(RawBuffer) then FreeMem(RawBuffer); end; end; if Assigned(Green) then begin Position := FBasePosition + FRowStart[Row + 1 * Height]; Count := BPC * FRowSize[Row + 1 * Height]; GetMem(RawBuffer, Count); try Read(RawBuffer^, Count); FDecoder.Decode(RawBuffer, Green, Count, Width); finally if Assigned(RawBuffer) then FreeMem(RawBuffer); end; end; if Assigned(Blue) then begin Position := FBasePosition + FRowStart[Row + 2 * Height]; Count := BPC * FRowSize[Row + 2 * Height]; GetMem(RawBuffer, Count); try Read(RawBuffer^, Count); FDecoder.Decode(RawBuffer, Blue, Count, Width); finally if Assigned(RawBuffer) then FreeMem(RawBuffer); end; end; if Assigned(Alpha) then begin Position := FBasePosition + FRowStart[Row + 3 * Height]; Count := BPC * FRowSize[Row + 3 * Height]; GetMem(RawBuffer, Count); try Read(RawBuffer^, Count); FDecoder.Decode(RawBuffer, Alpha, Count, Width); finally if Assigned(RawBuffer) then FreeMem(RawBuffer); end; end; end else begin if Assigned(Red) then begin Position := FBasePosition + 512 + (Row * Width); Read(Red^, BPC * Width); end; if Assigned(Green) then begin Position := FBasePosition + 512 + (Row * Width) + (Width * Height); Read(Green^, BPC * Width); end; if Assigned(Blue) then begin Position := FBasePosition + 512 + (Row * Width) + (2 * Width * Height); Read(Blue^, BPC * Width); end; if Assigned(Alpha) then begin Position := FBasePosition + 512 + (Row * Width) + (3 * Width * Height); Read(Alpha^, BPC * Width); end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TSGIGraphic.LoadFromStream(Stream: TStream); var Y: Cardinal; RedBuffer, GreenBuffer, BlueBuffer, AlphaBuffer: Pointer; Header: TSGIHeader; Count: Cardinal; begin // free previous image Handle := 0; // keep stream reference and start position for seek operations FStream := Stream; FBasePosition := Stream.Position; if ReadImageProperties(Stream, 0) then begin with FImageProperties, Stream do begin FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesPreparing); Stream.Position := FBasePosition; // read header again, we need some additional information ReadBuffer(Header, SizeOf(Header)); // SGI images are always stored in big endian style ColorManager.SourceOptions := [coNeedByteSwap]; with Header do ColorMap := SwapLong(ColorMap); if Compression = ctRLE then begin Count := Height * SamplesPerPixel; SetLength(FRowStart, Count); SetLength(FRowSize, Count); // read line starts and sizes from stream Read(FRowStart[0], Count * SizeOf(Cardinal)); SwapLong(@FRowStart[0], Count); Read(FRowSize[0], Count * SizeOf(Cardinal)); SwapLong(@FRowSize[0], Count); FDecoder := TSGIRLEDecoder.Create(BitsPerSample); end else begin FDecoder := nil; end; // set pixel format before size to avoid possibly large conversion operation with ColorManager do begin SourceBitsPerSample := BitsPerSample; TargetBitsPerSample := 8; SourceSamplesPerPixel := SamplesPerPixel; TargetSamplesPerPixel := SamplesPerPixel; SourceColorScheme := ColorScheme; case ColorScheme of csRGBA: TargetColorScheme := csBGRA; csRGB: TargetColorScheme := csBGR; else TargetColorScheme := csIndexed; end; PixelFormat := TargetPixelFormat; end; Self.Width := Width; Self.Height := Height; RedBuffer := nil; GreenBuffer := nil; BlueBuffer := nil; AlphaBuffer := nil; Progress(Self, psEnding, 100, True, FProgressRect, ''); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); try Count := (BitsPerPixel div 8) * Width; // read lines and put them into the bitmap case ColorScheme of csRGBA: begin GetMem(RedBuffer, Count); GetMem(GreenBuffer, Count); GetMem(BlueBuffer, Count); GetMem(AlphaBuffer, Count); for Y := 0 to Height - 1 do begin ReadAndDecode(RedBuffer, GreenBuffer, BlueBuffer, AlphaBuffer, Y, Header.BPC); ColorManager.ConvertRow([RedBuffer, GreenBuffer, BlueBuffer, AlphaBuffer], ScanLine[Height - Y - 1], Width, $FF); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; csRGB: begin GetMem(RedBuffer, Count); GetMem(GreenBuffer, Count); GetMem(BlueBuffer, Count); for Y := 0 to Height - 1 do begin ReadAndDecode(RedBuffer, GreenBuffer, BlueBuffer, nil, Y, Header.BPC); ColorManager.ConvertRow([RedBuffer, GreenBuffer, BlueBuffer], ScanLine[Height - Y - 1], Width, $FF); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; else // any other format is interpreted as being 256 gray scales Palette := ColorManager.CreateGrayscalePalette(False); for Y := 0 to Height - 1 do begin ReadAndDecode(ScanLine[Height - Y - 1], nil, nil, nil, Y, Header.BPC); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; finally Progress(Self, psEnding, 100, True, FProgressRect, ''); if Assigned(RedBuffer) then FreeMem(RedBuffer); if Assigned(GreenBuffer) then FreeMem(GreenBuffer); if Assigned(BlueBuffer) then FreeMem(BlueBuffer); if Assigned(AlphaBuffer) then FreeMem(AlphaBuffer); FDecoder.Free; end; end; end else GraphicExError(gesInvalidImage, ['sgi, bw or rgb(a)']); end; //---------------------------------------------------------------------------------------------------------------------- function TSGIGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var Header: TSGIHeader; begin Result := inherited ReadImageProperties(Stream, ImageIndex); with FImageProperties do begin Stream.ReadBuffer(Header, SizeOf(Header)); if Swap(Header.Magic) = SGIMagic then begin Options := [ioBigEndian]; BitsPerSample := Header.BPC * 8; Width := Swap(Header.XSize); Height := Swap(Header.YSize); SamplesPerPixel := Swap(Header.ZSize); case SamplesPerPixel of 4: ColorScheme := csRGBA; 3: ColorScheme := csRGB; else // all other is considered as being 8 bit gray scale ColorScheme := csIndexed; end; BitsPerPixel := BitsPerSample * SamplesPerPixel; if Header.Storage = SGI_COMPRESSION_RLE then Compression := ctRLE else Compression := ctNone; Result := True; end; end; end; {$endif} // SGIGraphic //----------------- TTIFFGraphic --------------------------------------------------------------------------------------- {$ifdef TIFFGraphic} const // TIFF tags TIFFTAG_SUBFILETYPE = 254; // subfile data descriptor FILETYPE_REDUCEDIMAGE = $1; // reduced resolution version FILETYPE_PAGE = $2; // one page of many FILETYPE_MASK = $4; // transparency mask TIFFTAG_OSUBFILETYPE = 255; // kind of data in subfile (obsolete by revision 5.0) OFILETYPE_IMAGE = 1; // full resolution image data OFILETYPE_REDUCEDIMAGE = 2; // reduced size image data OFILETYPE_PAGE = 3; // one page of many TIFFTAG_IMAGEWIDTH = 256; // image width in pixels TIFFTAG_IMAGELENGTH = 257; // image height in pixels TIFFTAG_BITSPERSAMPLE = 258; // bits per channel (sample) TIFFTAG_COMPRESSION = 259; // data compression technique COMPRESSION_NONE = 1; // dump mode COMPRESSION_CCITTRLE = 2; // CCITT modified Huffman RLE COMPRESSION_CCITTFAX3 = 3; // CCITT Group 3 fax encoding COMPRESSION_CCITTFAX4 = 4; // CCITT Group 4 fax encoding COMPRESSION_LZW = 5; // Lempel-Ziv & Welch COMPRESSION_OJPEG = 6; // 6.0 JPEG (old version) COMPRESSION_JPEG = 7; // JPEG DCT compression (new version) COMPRESSION_ADOBE_DEFLATE = 8; // new id but same as COMPRESSION_DEFLATE COMPRESSION_NEXT = 32766; // next 2-bit RLE COMPRESSION_CCITTRLEW = 32771; // modified Huffman with word alignment COMPRESSION_PACKBITS = 32773; // Macintosh RLE COMPRESSION_THUNDERSCAN = 32809; // ThunderScan RLE // codes 32895-32898 are reserved for ANSI IT8 TIFF/IT COMPRESSION_DCS = 32947; // Kodak DCS encoding COMPRESSION_JBIG = 34661; // ISO JBIG TIFFTAG_PHOTOMETRIC = 262; // photometric interpretation PHOTOMETRIC_MINISWHITE = 0; // min value is white PHOTOMETRIC_MINISBLACK = 1; // min value is black PHOTOMETRIC_RGB = 2; // RGB color model PHOTOMETRIC_PALETTE = 3; // color map indexed PHOTOMETRIC_MASK = 4; // holdout mask PHOTOMETRIC_SEPARATED = 5; // color separations PHOTOMETRIC_YCBCR = 6; // CCIR 601 PHOTOMETRIC_CIELAB = 8; // 1976 CIE L*a*b* TIFFTAG_THRESHHOLDING = 263; // thresholding used on data (obsolete by revision 5.0) THRESHHOLD_BILEVEL = 1; // b&w art scan THRESHHOLD_HALFTONE = 2; // or dithered scan THRESHHOLD_ERRORDIFFUSE = 3; // usually floyd-steinberg TIFFTAG_CELLWIDTH = 264; // dithering matrix width (obsolete by revision 5.0) TIFFTAG_CELLLENGTH = 265; // dithering matrix height (obsolete by revision 5.0) TIFFTAG_FILLORDER = 266; // data order within a Byte FILLORDER_MSB2LSB = 1; // most significant -> least FILLORDER_LSB2MSB = 2; // least significant -> most TIFFTAG_DOCUMENTNAME = 269; // name of doc. image is from TIFFTAG_IMAGEDESCRIPTION = 270; // info about image TIFFTAG_MAKE = 271; // scanner manufacturer name TIFFTAG_MODEL = 272; // scanner model name/number TIFFTAG_STRIPOFFSETS = 273; // Offsets to data strips TIFFTAG_ORIENTATION = 274; // image FOrientation (obsolete by revision 5.0) ORIENTATION_TOPLEFT = 1; // row 0 top, col 0 lhs ORIENTATION_TOPRIGHT = 2; // row 0 top, col 0 rhs ORIENTATION_BOTRIGHT = 3; // row 0 bottom, col 0 rhs ORIENTATION_BOTLEFT = 4; // row 0 bottom, col 0 lhs ORIENTATION_LEFTTOP = 5; // row 0 lhs, col 0 top ORIENTATION_RIGHTTOP = 6; // row 0 rhs, col 0 top ORIENTATION_RIGHTBOT = 7; // row 0 rhs, col 0 bottom ORIENTATION_LEFTBOT = 8; // row 0 lhs, col 0 bottom TIFFTAG_SAMPLESPERPIXEL = 277; // samples per pixel TIFFTAG_ROWSPERSTRIP = 278; // rows per strip of data TIFFTAG_STRIPBYTECOUNTS = 279; // bytes counts for strips TIFFTAG_MINSAMPLEVALUE = 280; // minimum sample value (obsolete by revision 5.0) TIFFTAG_MAXSAMPLEVALUE = 281; // maximum sample value (obsolete by revision 5.0) TIFFTAG_XRESOLUTION = 282; // pixels/resolution in x TIFFTAG_YRESOLUTION = 283; // pixels/resolution in y TIFFTAG_PLANARCONFIG = 284; // storage organization PLANARCONFIG_CONTIG = 1; // single image plane PLANARCONFIG_SEPARATE = 2; // separate planes of data TIFFTAG_PAGENAME = 285; // page name image is from TIFFTAG_XPOSITION = 286; // x page offset of image lhs TIFFTAG_YPOSITION = 287; // y page offset of image lhs TIFFTAG_FREEOFFSETS = 288; // byte offset to free block (obsolete by revision 5.0) TIFFTAG_FREEBYTECOUNTS = 289; // sizes of free blocks (obsolete by revision 5.0) TIFFTAG_GRAYRESPONSEUNIT = 290; // gray scale curve accuracy GRAYRESPONSEUNIT_10S = 1; // tenths of a unit GRAYRESPONSEUNIT_100S = 2; // hundredths of a unit GRAYRESPONSEUNIT_1000S = 3; // thousandths of a unit GRAYRESPONSEUNIT_10000S = 4; // ten-thousandths of a unit GRAYRESPONSEUNIT_100000S = 5; // hundred-thousandths TIFFTAG_GRAYRESPONSECURVE = 291; // gray scale response curve TIFFTAG_GROUP3OPTIONS = 292; // 32 flag bits GROUP3OPT_2DENCODING = $1; // 2-dimensional coding GROUP3OPT_UNCOMPRESSED = $2; // data not compressed GROUP3OPT_FILLBITS = $4; // fill to byte boundary TIFFTAG_GROUP4OPTIONS = 293; // 32 flag bits GROUP4OPT_UNCOMPRESSED = $2; // data not compressed TIFFTAG_RESOLUTIONUNIT = 296; // units of resolutions RESUNIT_NONE = 1; // no meaningful units RESUNIT_INCH = 2; // english RESUNIT_CENTIMETER = 3; // metric TIFFTAG_PAGENUMBER = 297; // page numbers of multi-page TIFFTAG_COLORRESPONSEUNIT = 300; // color curve accuracy COLORRESPONSEUNIT_10S = 1; // tenths of a unit COLORRESPONSEUNIT_100S = 2; // hundredths of a unit COLORRESPONSEUNIT_1000S = 3; // thousandths of a unit COLORRESPONSEUNIT_10000S = 4; // ten-thousandths of a unit COLORRESPONSEUNIT_100000S = 5; // hundred-thousandths TIFFTAG_TRANSFERFUNCTION = 301; // colorimetry info TIFFTAG_SOFTWARE = 305; // name & release TIFFTAG_DATETIME = 306; // creation date and time TIFFTAG_ARTIST = 315; // creator of image TIFFTAG_HOSTCOMPUTER = 316; // machine where created TIFFTAG_PREDICTOR = 317; // prediction scheme w/ LZW PREDICTION_NONE = 1; // no prediction scheme used before coding PREDICTION_HORZ_DIFFERENCING = 2; // horizontal differencing prediction scheme used TIFFTAG_WHITEPOINT = 318; // image white point TIFFTAG_PRIMARYCHROMATICITIES = 319; // primary chromaticities TIFFTAG_COLORMAP = 320; // RGB map for pallette image TIFFTAG_HALFTONEHINTS = 321; // highlight+shadow info TIFFTAG_TILEWIDTH = 322; // rows/data tile TIFFTAG_TILELENGTH = 323; // cols/data tile TIFFTAG_TILEOFFSETS = 324; // offsets to data tiles TIFFTAG_TILEBYTECOUNTS = 325; // Byte counts for tiles TIFFTAG_BADFAXLINES = 326; // lines w/ wrong pixel count TIFFTAG_CLEANFAXDATA = 327; // regenerated line info CLEANFAXDATA_CLEAN = 0; // no errors detected CLEANFAXDATA_REGENERATED = 1; // receiver regenerated lines CLEANFAXDATA_UNCLEAN = 2; // uncorrected errors exist TIFFTAG_CONSECUTIVEBADFAXLINES = 328; // max consecutive bad lines TIFFTAG_SUBIFD = 330; // subimage descriptors TIFFTAG_INKSET = 332; // inks in separated image INKSET_CMYK = 1; // cyan-magenta-yellow-black TIFFTAG_INKNAMES = 333; // ascii names of inks TIFFTAG_DOTRANGE = 336; // 0% and 100% dot codes TIFFTAG_TARGETPRINTER = 337; // separation target TIFFTAG_EXTRASAMPLES = 338; // info about extra samples EXTRASAMPLE_UNSPECIFIED = 0; // unspecified data EXTRASAMPLE_ASSOCALPHA = 1; // associated alpha data EXTRASAMPLE_UNASSALPHA = 2; // unassociated alpha data TIFFTAG_SAMPLEFORMAT = 339; // data sample format SAMPLEFORMAT_UINT = 1; // unsigned integer data SAMPLEFORMAT_INT = 2; // signed integer data SAMPLEFORMAT_IEEEFP = 3; // IEEE floating point data SAMPLEFORMAT_VOID = 4; // untyped data TIFFTAG_SMINSAMPLEVALUE = 340; // variable MinSampleValue TIFFTAG_SMAXSAMPLEVALUE = 341; // variable MaxSampleValue TIFFTAG_JPEGTABLES = 347; // JPEG table stream // Tags 512-521 are obsoleted by Technical Note #2 which specifies a revised JPEG-in-TIFF scheme. TIFFTAG_JPEGPROC = 512; // JPEG processing algorithm JPEGPROC_BASELINE = 1; // baseline sequential JPEGPROC_LOSSLESS = 14; // Huffman coded lossless TIFFTAG_JPEGIFOFFSET = 513; // Pointer to SOI marker TIFFTAG_JPEGIFBYTECOUNT = 514; // JFIF stream length TIFFTAG_JPEGRESTARTINTERVAL = 515; // restart interval length TIFFTAG_JPEGLOSSLESSPREDICTORS = 517; // lossless proc predictor TIFFTAG_JPEGPOINTTRANSFORM = 518; // lossless point transform TIFFTAG_JPEGQTABLES = 519; // Q matrice offsets TIFFTAG_JPEGDCTABLES = 520; // DCT table offsets TIFFTAG_JPEGACTABLES = 521; // AC coefficient offsets TIFFTAG_YCBCRCOEFFICIENTS = 529; // RGB -> YCbCr transform TIFFTAG_YCBCRSUBSAMPLING = 530; // YCbCr subsampling factors TIFFTAG_YCBCRPOSITIONING = 531; // subsample positioning YCBCRPOSITION_CENTERED = 1; // as in PostScript Level 2 YCBCRPOSITION_COSITED = 2; // as in CCIR 601-1 TIFFTAG_REFERENCEBLACKWHITE = 532; // colorimetry info // tags 32952-32956 are private tags registered to Island Graphics TIFFTAG_REFPTS = 32953; // image reference points TIFFTAG_REGIONTACKPOINT = 32954; // region-xform tack point TIFFTAG_REGIONWARPCORNERS = 32955; // warp quadrilateral TIFFTAG_REGIONAFFINE = 32956; // affine transformation mat // tags 32995-32999 are private tags registered to SGI TIFFTAG_MATTEING = 32995; // use ExtraSamples TIFFTAG_DATATYPE = 32996; // use SampleFormat TIFFTAG_IMAGEDEPTH = 32997; // z depth of image TIFFTAG_TILEDEPTH = 32998; // z depth/data tile // tags 33300-33309 are private tags registered to Pixar // // TIFFTAG_PIXAR_IMAGEFULLWIDTH and TIFFTAG_PIXAR_IMAGEFULLLENGTH // are set when an image has been cropped out of a larger image. // They reflect the size of the original uncropped image. // The TIFFTAG_XPOSITION and TIFFTAG_YPOSITION can be used // to determine the position of the smaller image in the larger one. TIFFTAG_PIXAR_IMAGEFULLWIDTH = 33300; // full image size in x TIFFTAG_PIXAR_IMAGEFULLLENGTH = 33301; // full image size in y // tag 33405 is a private tag registered to Eastman Kodak TIFFTAG_WRITERSERIALNUMBER = 33405; // device serial number // tag 33432 is listed in the 6.0 spec w/ unknown ownership TIFFTAG_COPYRIGHT = 33432; // copyright string // 34016-34029 are reserved for ANSI IT8 TIFF/IT YCbCr convert? JPEGCOLORMODE_RAW = $0000; // no conversion (default) JPEGCOLORMODE_RGB = $0001; // do auto conversion TIFFTAG_JPEGTABLESMODE = 65539; // What to put in JPEGTables JPEGTABLESMODE_QUANT = $0001; // include quantization tbls JPEGTABLESMODE_HUFF = $0002; // include Huffman tbls // Note: default is JPEGTABLESMODE_QUANT or JPEGTABLESMODE_HUFF TIFFTAG_FAXFILLFUNC = 65540; // G3/G4 fill function TIFFTAG_PIXARLOGDATAFMT = 65549; // PixarLogCodec I/O data sz PIXARLOGDATAFMT_8BIT = 0; // regular u_char samples PIXARLOGDATAFMT_8BITABGR = 1; // ABGR-order u_chars PIXARLOGDATAFMT_11BITLOG = 2; // 11-bit log-encoded (raw) PIXARLOGDATAFMT_12BITPICIO = 3; // as per PICIO (1.0==2048) PIXARLOGDATAFMT_16BIT = 4; // signed short samples PIXARLOGDATAFMT_FLOAT = 5; // IEEE float samples // 65550-65556 are allocated to Oceana Matrix TIFFTAG_DCSIMAGERTYPE = 65550; // imager model & filter DCSIMAGERMODEL_M3 = 0; // M3 chip (1280 x 1024) DCSIMAGERMODEL_M5 = 1; // M5 chip (1536 x 1024) DCSIMAGERMODEL_M6 = 2; // M6 chip (3072 x 2048) DCSIMAGERFILTER_IR = 0; // infrared filter DCSIMAGERFILTER_MONO = 1; // monochrome filter DCSIMAGERFILTER_CFA = 2; // color filter array DCSIMAGERFILTER_OTHER = 3; // other filter TIFFTAG_DCSINTERPMODE = 65551; // interpolation mode DCSINTERPMODE_NORMAL = $0; // whole image, default DCSINTERPMODE_PREVIEW = $1; // preview of image (384x256) TIFFTAG_DCSBALANCEARRAY = 65552; // color balance values TIFFTAG_DCSCORRECTMATRIX = 65553; // color correction values TIFFTAG_DCSGAMMA = 65554; // gamma value TIFFTAG_DCSTOESHOULDERPTS = 65555; // toe & shoulder points TIFFTAG_DCSCALIBRATIONFD = 65556; // calibration file desc // Note: quality level is on the ZLIB 1-9 scale. Default value is -1 TIFFTAG_ZIPQUALITY = 65557; // compression quality level TIFFTAG_PIXARLOGQUALITY = 65558; // PixarLog uses same scale // TIFF data types TIFF_NOTYPE = 0; // placeholder TIFF_BYTE = 1; // 8-bit unsigned integer TIFF_ASCII = 2; // 8-bit bytes w/ last byte null TIFF_SHORT = 3; // 16-bit unsigned integer TIFF_LONG = 4; // 32-bit unsigned integer TIFF_RATIONAL = 5; // 64-bit unsigned fraction TIFF_SBYTE = 6; // 8-bit signed integer TIFF_UNDEFINED = 7; // 8-bit untyped data TIFF_SSHORT = 8; // 16-bit signed integer TIFF_SLONG = 9; // 32-bit signed integer TIFF_SRATIONAL = 10; // 64-bit signed fraction TIFF_FLOAT = 11; // 32-bit IEEE floating point TIFF_DOUBLE = 12; // 64-bit IEEE floating point TIFF_BIGENDIAN = $4D4D; TIFF_LITTLEENDIAN = $4949; TIFF_VERSION = 42; type TTIFFHeader = packed record ByteOrder: Word; Version: Word; FirstIFD: Cardinal; end; //---------------------------------------------------------------------------------------------------------------------- class function TTIFFGraphic.CanLoad(Stream: TStream): Boolean; var Header: TTIFFHeader; LastPosition: Cardinal; begin with Stream do begin Result := (Size - Position) > SizeOf(Header); if Result then begin LastPosition := Position; Stream.ReadBuffer(Header, SizeOf(Header)); Result := (Header.ByteOrder = TIFF_BIGENDIAN) or (Header.ByteOrder = TIFF_LITTLEENDIAN); if Result then begin if Header.ByteOrder = TIFF_BIGENDIAN then begin Header.Version := Swap(Header.Version); Header.FirstIFD := SwapLong(Header.FirstIFD); end; Result := (Header.Version = TIFF_VERSION) and (Integer(Header.FirstIFD) < (Size - Integer(LastPosition))); end; Position := LastPosition; end; end; end; //---------------------------------------------------------------------------------------------------------------------- function TTIFFGraphic.FindTag(Tag: Cardinal; var Index: Cardinal): Boolean; // looks through the currently loaded IFD for the entry indicated by Tag; // returns True and the index of the entry in Index if the entry is there // otherwise the result is False and Index undefined // Note: The IFD is sorted so we can use a binary search here. var L, H, I, C: Integer; begin Result := False; L := 0; H := High(FIFD); while L <= H do begin I := (L + H) shr 1; C := Integer(FIFD[I].Tag) - Integer(Tag); if C < 0 then L := I + 1 else begin H := I - 1; if C = 0 then begin Result := True; L := I; end; end; end; Index := L; end; //---------------------------------------------------------------------------------------------------------------------- const DataTypeToSize: array[TIFF_NOTYPE..TIFF_SLONG] of Byte = (0, 1, 1, 2, 4, 8, 1, 1, 2, 4); procedure TTIFFGraphic.GetValueList(Stream: TStream; Tag: Cardinal; var Values: TByteArray); // returns the values of the IFD entry indicated by Tag var Index, Value, Shift: Cardinal; I: Integer; begin Values := nil; if FindTag(Tag, Index) and (FIFD[Index].DataLength > 0) then begin // prepare value list SetLength(Values, FIFD[Index].DataLength); // determine whether the data fits into 4 bytes Value := DataTypeToSize[FIFD[Index].DataType] * FIFD[Index].DataLength; // data fits into one cardinal -> extract it if Value <= 4 then begin Shift := DataTypeToSize[FIFD[Index].DataType] * 8; Value := FIFD[Index].Offset; for I := 0 to FIFD[Index].DataLength - 1 do begin case FIFD[Index].DataType of TIFF_BYTE: Values[I] := Byte(Value); TIFF_SHORT, TIFF_SSHORT: // no byte swap needed here because values in the IFD are already swapped // (if necessary at all) Values[I] := Word(Value); TIFF_LONG, TIFF_SLONG: Values[I] := Value; end; Value := Value shr Shift; end; end else begin // data of this tag does not fit into one 32 bits value Stream.Position := FBasePosition + FIFD[Index].Offset; // bytes sized data can be read directly instead of looping through the array if FIFD[Index].DataType in [TIFF_BYTE, TIFF_ASCII, TIFF_SBYTE, TIFF_UNDEFINED] then Stream.Read(Values[0], Value) else begin for I := 0 to High(Values) do begin Stream.Read(Value, DataTypeToSize[FIFD[Index].DataType]); case FIFD[Index].DataType of TIFF_BYTE: Value := Byte(Value); TIFF_SHORT, TIFF_SSHORT: begin if ioBigEndian in FImageProperties.Options then Value := Swap(Word(Value)) else Value := Word(Value); end; TIFF_LONG, TIFF_SLONG: if ioBigEndian in FImageProperties.Options then Value := SwapLong(Value); end; Values[I] := Value; end; end; end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TTIFFGraphic.GetValueList(Stream: TStream; Tag: Cardinal; var Values: TCardinalArray); // returns the values of the IFD entry indicated by Tag var Index, Value, Shift: Cardinal; I: Integer; begin Values := nil; if FindTag(Tag, Index) and (FIFD[Index].DataLength > 0) then begin // prepare value list SetLength(Values, FIFD[Index].DataLength); // determine whether the data fits into 4 bytes Value := DataTypeToSize[FIFD[Index].DataType] * FIFD[Index].DataLength; // data fits into one cardinal -> extract it if Value <= 4 then begin Shift := DataTypeToSize[FIFD[Index].DataType] * 8; Value := FIFD[Index].Offset; for I := 0 to FIFD[Index].DataLength - 1 do begin case FIFD[Index].DataType of TIFF_BYTE, TIFF_ASCII, TIFF_SBYTE, TIFF_UNDEFINED: Values[I] := Byte(Value); TIFF_SHORT, TIFF_SSHORT: // no byte swap needed here because values in the IFD are already swapped // (if necessary at all) Values[I] := Word(Value); TIFF_LONG, TIFF_SLONG: Values[I] := Value; end; Value := Value shr Shift; end; end else begin // data of this tag does not fit into one 32 bits value Stream.Position := FBasePosition + FIFD[Index].Offset; // even bytes sized data must be read by the loop as it is expanded to cardinals for I := 0 to High(Values) do begin Stream.Read(Value, DataTypeToSize[FIFD[Index].DataType]); case FIFD[Index].DataType of TIFF_BYTE: Value := Byte(Value); TIFF_SHORT, TIFF_SSHORT: begin if ioBigEndian in FImageProperties.Options then Value := Swap(Word(Value)) else Value := Word(Value); end; TIFF_LONG, TIFF_SLONG: if ioBigEndian in FImageProperties.Options then Value := SwapLong(Value); end; Values[I] := Value; end; end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TTIFFGraphic.GetValueList(Stream: TStream; Tag: Cardinal; var Values: TFloatArray); // returns the values of the IFD entry indicated by Tag var Index, Shift, IntValue: Cardinal; Value: Single; I: Integer; IntNominator, IntDenominator: Cardinal; FloatNominator, FloatDenominator: Cardinal; begin Values := nil; if FindTag(Tag, Index) and (FIFD[Index].DataLength > 0) then begin // prepare value list SetLength(Values, FIFD[Index].DataLength); // determine whether the data fits into 4 bytes Value := DataTypeToSize[FIFD[Index].DataType] * FIFD[Index].DataLength; // data fits into one cardinal -> extract it if Value <= 4 then begin Shift := DataTypeToSize[FIFD[Index].DataType] * 8; IntValue := FIFD[Index].Offset; for I := 0 to FIFD[Index].DataLength - 1 do begin case FIFD[Index].DataType of TIFF_BYTE, TIFF_ASCII, TIFF_SBYTE, TIFF_UNDEFINED: Values[I] := Byte(IntValue); TIFF_SHORT, TIFF_SSHORT: // no byte swap needed here because values in the IFD are already swapped // (if necessary at all) Values[I] := Word(IntValue); TIFF_LONG, TIFF_SLONG: Values[I] := IntValue; end; IntValue := IntValue shr Shift; end; end else begin // data of this tag does not fit into one 32 bits value Stream.Position := FBasePosition + FIFD[Index].Offset; // even bytes sized data must be read by the loop as it is expanded to Single for I := 0 to High(Values) do begin case FIFD[Index].DataType of TIFF_BYTE: begin Stream.Read(IntValue, DataTypeToSize[FIFD[Index].DataType]); Value := Byte(IntValue); end; TIFF_SHORT, TIFF_SSHORT: begin Stream.Read(IntValue, DataTypeToSize[FIFD[Index].DataType]); if ioBigEndian in FImageProperties.Options then Value := Swap(Word(IntValue)) else Value := Word(IntValue); end; TIFF_LONG, TIFF_SLONG: begin Stream.Read(IntValue, DataTypeToSize[FIFD[Index].DataType]); if ioBigEndian in FImageProperties.Options then Value := SwapLong(IntValue); end; TIFF_RATIONAL, TIFF_SRATIONAL: begin Stream.ReadBuffer(FloatNominator, SizeOf(FloatNominator)); Stream.ReadBuffer(FloatDenominator, SizeOf(FloatDenominator)); if ioBigEndian in FImageProperties.Options then begin FloatNominator := SwapLong(Cardinal(FloatNominator)); FloatDenominator := SwapLong(Cardinal(FloatDenominator)); end; Value := FloatNominator / FloatDenominator; end; TIFF_FLOAT: begin Stream.ReadBuffer(IntNominator, SizeOf(IntNominator)); Stream.ReadBuffer(IntDenominator, SizeOf(IntDenominator)); if ioBigEndian in FImageProperties.Options then begin IntNominator := SwapLong(IntNominator); IntDenominator := SwapLong(IntDenominator); end; Value := IntNominator / IntDenominator; end; end; Values[I] := Value; end; end; end; end; //---------------------------------------------------------------------------------------------------------------------- function TTIFFGraphic.GetValue(Stream: TStream; Tag: Cardinal; Default: Single = 0): Single; // returns the value of the IFD entry indicated by Tag or the default value if the entry is not there var Index: Cardinal; IntNominator, IntDenominator: Cardinal; FloatNominator, FloatDenominator: Cardinal; begin Result := Default; if FindTag(Tag, Index) then begin // if the data length is > 1 then Offset is a real offset into the stream, // otherwise it is the value itself and must be shortend depending on the data type if FIFD[Index].DataLength = 1 then begin case FIFD[Index].DataType of TIFF_BYTE: Result := Byte(FIFD[Index].Offset); TIFF_SHORT, TIFF_SSHORT: Result := Word(FIFD[Index].Offset); TIFF_LONG, TIFF_SLONG: // nothing to do Result := FIFD[Index].Offset; TIFF_RATIONAL, TIFF_SRATIONAL: begin Stream.Position := FBasePosition + FIFD[Index].Offset; Stream.ReadBuffer(FloatNominator, SizeOf(FloatNominator)); Stream.ReadBuffer(FloatDenominator, SizeOf(FloatDenominator)); if ioBigEndian in FImageProperties.Options then begin FloatNominator := SwapLong(Cardinal(FloatNominator)); FloatDenominator := SwapLong(Cardinal(FloatDenominator)); end; Result := FloatNominator / FloatDenominator; end; TIFF_FLOAT: begin Stream.Position := FBasePosition + FIFD[Index].Offset; Stream.ReadBuffer(IntNominator, SizeOf(IntNominator)); Stream.ReadBuffer(IntDenominator, SizeOf(IntDenominator)); if ioBigEndian in FImageProperties.Options then begin IntNominator := SwapLong(IntNominator); IntDenominator := SwapLong(IntDenominator); end; Result := IntNominator / IntDenominator; end; end; end; end; end; //---------------------------------------------------------------------------------------------------------------------- function TTIFFGraphic.GetValue(Tag: Cardinal; Default: Cardinal = 0): Cardinal; // returns the value of the IFD entry indicated by Tag or the default value if the entry is not there var Index: Cardinal; begin if not FindTag(Tag, Index) then Result := Default else begin Result := FIFD[Index].Offset; // if the data length is > 1 then Offset is a real offset into the stream, // otherwise it is the value itself and must be shortend depending on the data type if FIFD[Index].DataLength = 1 then begin case FIFD[Index].DataType of TIFF_BYTE: Result := Byte(Result); TIFF_SHORT, TIFF_SSHORT: Result := Word(Result); TIFF_LONG, TIFF_SLONG: // nothing to do ; else Result := Default; end; end; end; end; //---------------------------------------------------------------------------------------------------------------------- function TTIFFGraphic.GetValue(Tag: Cardinal; var Size: Cardinal; Default: Cardinal): Cardinal; // Returns the value of the IFD entry indicated by Tag or the default value if the entry is not there. // If the tag exists then also the data size is returned. var Index: Cardinal; begin if not FindTag(Tag, Index) then begin Result := Default; Size := 0; end else begin Result := FIFD[Index].Offset; Size := FIFD[Index].DataLength; // if the data length is > 1 then Offset is a real offset into the stream, // otherwise it is the value itself and must be shortend depending on the data type if FIFD[Index].DataLength = 1 then begin case FIFD[Index].DataType of TIFF_BYTE: Result := Byte(Result); TIFF_SHORT, TIFF_SSHORT: Result := Word(Result); TIFF_LONG, TIFF_SLONG: // nothing to do ; else Result := Default; end; end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TTIFFGraphic.SortIFD; // Although all entries in the IFD should be sorted there are still files where this is not the case. // Because the lookup for certain tags in the IFD uses binary search it must be made sure the IFD is // sorted (what we do here). //--------------- local function -------------------------------------------- procedure QuickSort(L, R: Integer); var I, J, M: Integer; T: TIFDEntry; begin repeat I := L; J := R; M := (L + R) shr 1; repeat while FIFD[I].Tag < FIFD[M].Tag do Inc(I); while FIFD[J].Tag > FIFD[M].Tag do Dec(J); if I <= J then begin T := FIFD[I]; FIFD[I] := FIFD[J]; FIFD[J] := T; Inc(I); Dec(J); end; until I > J; if L < J then QuickSort(L, J); L := I; until I >= R; end; //--------------- end local functions --------------------------------------- begin QuickSort(0, High(FIFD)); end; //---------------------------------------------------------------------------------------------------------------------- procedure TTIFFGraphic.SwapIFD; // swap the member fields of all entries of the currently loaded IFD from big endian to little endian var I: Integer; Size: Cardinal; begin for I := 0 to High(FIFD) do with FIFD[I] do begin Tag := Swap(Tag); DataType := Swap(DataType); DataLength := SwapLong(DataLength); // determine whether the data fits into 4 bytes Size := DataTypeToSize[FIFD[I].DataType] * FIFD[I].DataLength; if Size >= 4 then Offset := SwapLong(Offset) else case DataType of TIFF_SHORT, TIFF_SSHORT: if DataLength > 1 then Offset := SwapLong(Offset) else Offset := Swap(Word(Offset)); end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TTIFFGraphic.LoadFromStream(Stream: TStream); var IFDCount: Word; Buffer: Pointer; Run: PByte; Pixels, EncodedData, DataPointerCopy: Pointer; Offsets, ByteCounts: TCardinalArray; ColorMap: Cardinal; StripSize: Cardinal; Decoder: TDecoder; // dynamically assigned handler Deprediction: procedure(P: Pointer; Count: Cardinal); begin Handle := 0; Deprediction := nil; Decoder := nil; // we need to keep the current stream position because all position information // are relative to this one FBasePosition := Stream.Position; if ReadImageProperties(Stream, 0) then begin with FImageProperties do try // tiled images aren't supported if ioTiled in Options then Exit; FProgressRect := Rect(0, 0, 0, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesPreparing); // read data of the first image file directory (IFD) Stream.Position := FBasePosition + FirstIFD; Stream.ReadBuffer(IFDCount, SizeOf(IFDCount)); if ioBigEndian in Options then IFDCount := Swap(IFDCount); SetLength(FIFD, IFDCount); Stream.ReadBuffer(FIFD[0], IFDCount * SizeOf(TIFDEntry)); if ioBigEndian in Options then SwapIFD; SortIFD; // --- read the data of the directory which are needed to actually load the image: // data organization GetValueList(Stream, TIFFTAG_STRIPOFFSETS, Offsets); GetValueList(Stream, TIFFTAG_STRIPBYTECOUNTS, ByteCounts); // retrive additional tile data if necessary if ioTiled in Options then begin GetValueList(Stream, TIFFTAG_TILEOFFSETS, Offsets); GetValueList(Stream, TIFFTAG_TILEBYTECOUNTS, ByteCounts); end; // determine pixelformat and setup color conversion with ColorManager do begin if ioBigEndian in Options then SourceOptions := [coNeedByteSwap] else SourceOptions := []; SourceBitsPerSample := BitsPerSample; if SourceBitsPerSample = 16 then TargetBitsPerSample := 8 else TargetBitsPerSample := SourceBitsPerSample; // the JPEG lib does internally a conversion to RGB if Compression in [ctOJPEG, ctJPEG] then SourceColorScheme := csBGR else SourceColorScheme := ColorScheme; case SourceColorScheme of csRGBA: TargetColorScheme := csBGRA; csRGB: TargetColorScheme := csBGR; csCMY, csCMYK, csCIELab, csYCbCr: TargetColorScheme := csBGR; csIndexed: begin if HasAlpha then SourceColorScheme := csGA; // fake indexed images with alpha (used in EPS) // as being grayscale with alpha TargetColorScheme := csIndexed; end; else TargetColorScheme := SourceColorScheme; end; SourceSamplesPerPixel := SamplesPerPixel; if SourceColorScheme = csCMYK then TargetSamplesPerPixel := 3 else TargetSamplesPerPixel := SamplesPerPixel; if SourceColorScheme = csCIELab then SourceOptions := SourceOptions + [coLabByteRange]; if SourceColorScheme = csGA then PixelFormat := pf8Bit else PixelFormat := TargetPixelFormat; end; // now that the pixel format is set we can also set the (possibly large) image dimensions Self.Width := Width; Self.Height := Height; if (Width = 0) or (Height = 0) then GraphicExError(gesInvalidImage, ['TIF/TIFF']); FProgressRect.Right := Width; if ColorManager.TargetColorScheme in [csIndexed, csG, csGA] then begin // load palette data and build palette if ColorManager.TargetColorScheme = csIndexed then begin ColorMap := GetValue(TIFFTAG_COLORMAP, StripSize, 0); if StripSize > 0 then begin Stream.Position := FBasePosition + ColorMap; // number of palette entries is also given by the color map tag // (3 components each (r,g,b) and two bytes per component) Stream.ReadBuffer(FPalette[0] , 2 * StripSize); Palette := ColorManager.CreateColorPalette([@FPalette[0], @FPalette[StripSize div 3], @FPalette[2 * StripSize div 3]], pfPlane16Triple, StripSize, False); end; end else Palette := ColorManager.CreateGrayScalePalette(ioMinIsWhite in Options); end else if ColorManager.SourceColorScheme = csYCbCr then ColorManager.SetYCbCrParameters(FYCbCrCoefficients, YCbCrSubSampling[0], YCbCrSubSampling[1]); // intermediate buffer for data BytesPerLine := (BitsPerPixel * Width + 7) div 8; // determine prediction scheme if Compression <> ctNone then begin // Prediction without compression makes no sense at all (as it is to improve // compression ratios). Appearently there are image which are uncompressed but still // have a prediction scheme set. Hence we must check for it. case Predictor of PREDICTION_HORZ_DIFFERENCING: // currently only one prediction scheme is defined case SamplesPerPixel of 4: Deprediction := Depredict4; 3: Deprediction := Depredict3; else Deprediction := Depredict1; end; end; end; // create decompressor for the image case Compression of ctNone: ; {$ifdef UseLZW} ctLZW: Decoder := TTIFFLZWDecoder.Create; {$endif} ctPackedBits: Decoder := TPackbitsRLEDecoder.Create; ctFaxRLE, ctFaxRLEW: Decoder := TCCITTMHDecoder.Create(GetValue(TIFFTAG_GROUP3OPTIONS), ioReversed in Options, Compression = ctFaxRLEW, Width); ctFax3: Decoder := TCCITTFax3Decoder.Create(GetValue(TIFFTAG_GROUP3OPTIONS), ioReversed in Options, False, Width); ctJPEG: begin // some extra work is needed for JPEG GetValueList(Stream, TIFFTAG_JPEGTABLES, JPEGTables); Decoder := TTIFFJPEGDecoder.Create(@FImageProperties); end; ctThunderscan: Decoder := TThunderDecoder.Create(Width); ctLZ77: Decoder := TLZ77Decoder.Create(Z_PARTIAL_FLUSH, True); else { COMPRESSION_OJPEG, COMPRESSION_CCITTFAX4 COMPRESSION_NEXT COMPRESSION_IT8CTPAD COMPRESSION_IT8LW COMPRESSION_IT8MP COMPRESSION_IT8BL COMPRESSION_PIXARFILM COMPRESSION_PIXARLOG COMPRESSION_DCS COMPRESSION_JBIG} GraphicExError(gesUnsupportedFeature, [gesCompressionScheme, 'TIF/TIFF']); end; if Assigned(Decoder) then Decoder.DecodeInit; Progress(Self, psEnding, 0, False, FProgressRect, ''); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); // go for each strip in the image (which might contain more than one line) CurrentRow := 0; CurrentStrip := 0; StripCount := Length(Offsets); while CurrentStrip < StripCount do begin Stream.Position := FBasePosition + Offsets[CurrentStrip]; if CurrentStrip < Length(RowsPerStrip) then StripSize := BytesPerLine * RowsPerStrip[CurrentStrip] else StripSize := BytesPerLine * RowsPerStrip[High(RowsPerStrip)]; GetMem(Buffer, StripSize); Run := Buffer; try // decompress strip if necessary if Assigned(Decoder) then begin GetMem(EncodedData, ByteCounts[CurrentStrip]); try DataPointerCopy := EncodedData; Stream.Read(EncodedData^, ByteCounts[CurrentStrip]); // need pointer copies here because they could get modified // while decoding Decoder.Decode(DataPointerCopy, Pointer(Run), ByteCounts[CurrentStrip], StripSize); finally if Assigned(EncodedData) then FreeMem(EncodedData); end; end else begin Stream.Read(Buffer^, StripSize); end; Run := Buffer; // go for each line (row) in the strip while (CurrentRow < Height) and ((integer(Run) - integer(Buffer)) < Integer(StripSize)) do begin Pixels := ScanLine[CurrentRow]; // depredict strip if necessary if Assigned(Deprediction) then Deprediction(Run, Width - 1); // any color conversion comes last ColorManager.ConvertRow([Run], Pixels, Width, $FF); Inc(Run, BytesPerLine); Inc(CurrentRow); Progress(Self, psRunning, MulDiv(CurrentRow, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; finally if Assigned(Buffer) then FreeMem(Buffer); end; Inc(CurrentStrip); end; finally Progress(Self, psEnding, 0, False, FProgressRect, ''); if Assigned(Decoder) then Decoder.DecodeEnd; Decoder.Free; end; end else GraphicExError(gesInvalidImage, ['TIF/TIFF']); end; //---------------------------------------------------------------------------------------------------------------------- procedure TTIFFGraphic.SaveToStream(Stream: TStream); begin end; //---------------------------------------------------------------------------------------------------------------------- function TTIFFGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; // Reads all relevant TIF properties of the image of index ImageIndex (zero based). // Returns True if the image ImageIndex could be read, otherwise False. const PhotometricToColorScheme: array[PHOTOMETRIC_MINISWHITE..PHOTOMETRIC_CIELAB] of TColorScheme = ( csG, csG, csRGBA, csIndexed, csUnknown, csCMYK, csYCbCr, csUnknown, csCIELab ); var IFDCount: Word; ExtraSamples: TCardinalArray; PhotometricInterpretation: Byte; TIFCompression: Word; Index: Cardinal; IFDOffset: Cardinal; Header: TTIFFHeader; LocalBitsPerSample: TCardinalArray; begin // clear image properties Result := inherited ReadImageProperties(Stream, ImageIndex); with FImageProperties do begin // rewind stream to header position Stream.Position := FBasePosition; Stream.ReadBuffer(Header, SizeOf(Header)); if Header.ByteOrder = TIFF_BIGENDIAN then begin Options := Options + [ioBigEndian]; Header.Version := Swap(Header.Version); Header.FirstIFD := SwapLong(Header.FirstIFD); end; Version := Header.Version; FirstIFD := Header.FirstIFD; if Version = TIFF_VERSION then begin IFDOffset := Header.FirstIFD; // advance to next IFD until we have the desired one repeat Stream.Position := FBasePosition + IFDOffset; // number of entries in this directory Stream.ReadBuffer(IFDCount, SizeOf(IFDCount)); if Header.ByteOrder = TIFF_BIGENDIAN then IFDCount := Swap(IFDCount); // if we already have the desired image then get out of here if ImageIndex = 0 then Break; Dec(ImageIndex); // advance to offset for next IFD Stream.Seek(IFDCount * SizeOf(TIFDEntry), soFromCurrent); Stream.ReadBuffer(IFDOffset, SizeOf(IFDOffset)); // no further image available, but the required index is still not found if IFDOffset = 0 then Exit; until False; SetLength(FIFD, IFDCount); Stream.ReadBuffer(FIFD[0], IFDCount * SizeOf(TIFDEntry)); if Header.ByteOrder = TIFF_BIGENDIAN then SwapIFD; SortIFD; Width := GetValue(TIFFTAG_IMAGEWIDTH); Height := GetValue(TIFFTAG_IMAGELENGTH); if (Width = 0) or (Height = 0) then Exit; // data organization GetValueList(Stream, TIFFTAG_ROWSPERSTRIP, RowsPerStrip); // some images rely on the default size ($FFFFFFFF) if only one stripe is in the image, // make sure there's a valid value also in this case if (Length(RowsPerStrip) = 0) or (RowsPerStrip[0] = $FFFFFFFF) then begin SetLength(RowsPerStrip, 1); RowsPerStrip[0] := Height; end; // number of color components per pixel (1 for b&w, 16 and 256 colors, 3 for RGB, 4 for CMYK etc.) SamplesPerPixel := GetValue(TIFFTAG_SAMPLESPERPIXEL, 1); // number of bits per color component GetValueList(Stream, TIFFTAG_BITSPERSAMPLE, LocalBitsPerSample); if Length(LocalBitsPerSample) = 0 then BitsPerSample := 1 else BitsPerSample := LocalBitsPerSample[0]; // determine whether image is tiled and retrive tile data if necessary TileWidth := GetValue(TIFFTAG_TILEWIDTH, 0); TileLength := GetValue(TIFFTAG_TILELENGTH, 0); if (TileWidth > 0) and (TileLength > 0) then Include(Options, ioTiled); // photometric interpretation determines the color space PhotometricInterpretation := GetValue(TIFFTAG_PHOTOMETRIC); // type of extra information for additional samples per pixel GetValueList(Stream, TIFFTAG_EXTRASAMPLES, ExtraSamples); // determine whether extra samples must be considered HasAlpha := Length(ExtraSamples) > 0; // if any of the extra sample contains an invalid value then consider // it as being not existant to avoid wrong interpretation for badly // written images if HasAlpha then begin for Index := 0 to High(ExtraSamples) do if ExtraSamples[Index] > EXTRASAMPLE_UNASSALPHA then begin HasAlpha := False; Break; end; end; // currently all bits per sample values are equal BitsPerPixel := BitsPerSample * SamplesPerPixel; // create decompressor for the image TIFCompression := GetValue(TIFFTAG_COMPRESSION); case TIFCompression of COMPRESSION_NONE: Compression := ctNone; COMPRESSION_LZW: Compression := ctLZW; COMPRESSION_PACKBITS: Compression := ctPackedBits; COMPRESSION_CCITTRLE: Compression := ctFaxRLE; COMPRESSION_CCITTRLEW: Compression := ctFaxRLEW; COMPRESSION_CCITTFAX3: Compression := ctFax3; COMPRESSION_OJPEG: Compression := ctOJPEG; COMPRESSION_JPEG: Compression := ctJPEG; COMPRESSION_CCITTFAX4: Compression := ctFax4; COMPRESSION_NEXT: Compression := ctNext; COMPRESSION_THUNDERSCAN: Compression := ctThunderscan; COMPRESSION_IT8CTPAD: Compression := ctIT8CTPAD; COMPRESSION_IT8LW: Compression := ctIT8LW; COMPRESSION_IT8MP: Compression := ctIT8MP; COMPRESSION_IT8BL: Compression := ctIT8BL; COMPRESSION_PIXARFILM: Compression := ctPixarFilm; COMPRESSION_PIXARLOG: // also a LZ77 clone Compression := ctPixarLog; COMPRESSION_ADOBE_DEFLATE, COMPRESSION_DEFLATE: Compression := ctLZ77; COMPRESSION_DCS: Compression := ctDCS; COMPRESSION_JBIG: Compression := ctJBIG; else Compression := ctUnknown; end; if PhotometricInterpretation in [PHOTOMETRIC_MINISWHITE..PHOTOMETRIC_CIELAB] then begin ColorScheme := PhotometricToColorScheme[PhotometricInterpretation]; if (PhotometricInterpretation = PHOTOMETRIC_RGB) and (SamplesPerPixel < 4) then ColorScheme := csRGB; if PhotometricInterpretation = PHOTOMETRIC_MINISWHITE then Include(Options, ioMinIsWhite); // extra work necessary for YCbCr if PhotometricInterpretation = PHOTOMETRIC_YCBCR then begin if FindTag(TIFFTAG_YCBCRSUBSAMPLING, Index) then GetValueList(Stream, TIFFTAG_YCBCRSUBSAMPLING, YCbCrSubSampling) else begin // initialize default values if nothing is given in the file SetLength(YCbCrSubSampling, 2); YCbCrSubSampling[0] := 2; YCbCrSubSampling[1] := 2; end; if FindTag(TIFFTAG_YCBCRPOSITIONING, Index) then FYCbCrPositioning := GetValue(TIFFTAG_YCBCRPOSITIONING) else FYCbCrPositioning := YCBCRPOSITION_CENTERED; if FindTag(TIFFTAG_YCBCRCOEFFICIENTS, Index) then GetValueList(Stream, TIFFTAG_YCBCRCOEFFICIENTS, FYCbCrCoefficients) else begin // defaults are from CCIR recommendation 601-1 SetLength(FYCbCrCoefficients, 3); FYCbCrCoefficients[0] := 0.299; FYCbCrCoefficients[1] := 0.587; FYCbCrCoefficients[2] := 0.114; end; end; end else ColorScheme := csUnknown; JPEGColorMode := GetValue(TIFFTAG_JPEGCOLORMODE, JPEGCOLORMODE_RAW); JPEGTablesMode := GetValue(TIFFTAG_JPEGTABLESMODE, JPEGTABLESMODE_QUANT or JPEGTABLESMODE_HUFF); PlanarConfig := GetValue(TIFFTAG_PLANARCONFIG); // other image properties XResolution := GetValue(Stream, TIFFTAG_XRESOLUTION); YResolution := GetValue(Stream, TIFFTAG_YRESOLUTION); if GetValue(TIFFTAG_RESOLUTIONUNIT, RESUNIT_INCH) = RESUNIT_CENTIMETER then begin // Resolution is given in centimeters. // Although I personally prefer the metric system over the old english one :-) // I still convert to inches because it is an unwritten rule to give image resolutions in dpi. XResolution := XResolution * 2.54; YResolution := YResolution * 2.54; end; // determine prediction scheme Predictor := GetValue(TIFFTAG_PREDICTOR); // determine fill order in bytes if GetValue(TIFFTAG_FILLORDER, FILLORDER_MSB2LSB) = FILLORDER_LSB2MSB then Include(Options, ioReversed); // finally show that we found and read an image Result := True; end; end; end; //----------------- TEPSGraphic ---------------------------------------------------------------------------------------- {$ifdef EPSGraphic} // Note: This EPS implementation does only read embedded pixel graphics in TIF format (preview). // Credits to: // Olaf Stieleke // Torsten Pohlmeyer // CPS Krohn GmbH // for providing the base information about how to read the preview image. type TEPSHeader = packed record Code: Cardinal; // alway $C6D3D0C5, if not there then this is not an EPS or it is not a binary EPS PSStart, // Offset PostScript-Code PSLen, // length of PostScript-Code MetaPos, // position of a WMF MetaLen, // length of a WMF TiffPos, // position of TIFF (preview images should be either WMF or TIF but not both) TiffLen: Integer; // length of the TIFF Checksum: SmallInt; end; //---------------------------------------------------------------------------------------------------------------------- class function TEPSGraphic.CanLoad(Stream: TStream): Boolean; var Header: TEPSHeader; LastPosition: Cardinal; begin with Stream do begin Result := (Size - Position) > SizeOf(Header); if Result then begin LastPosition := Position; Stream.ReadBuffer(Header, SizeOf(Header)); Result := (Header.Code = $C6D3D0C5) and (Header.TiffPos > Integer(LastPosition) + SizeOf(Header)) and (Header.TiffLen > 0); Position := LastPosition; end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TEPSGraphic.LoadFromStream(Stream: TStream); var Header: TEPSHeader; begin Stream.ReadBuffer(Header, SizeOf(Header)); if Header.Code <> $C6D3D0C5 then GraphicExError(gesInvalidImage, ['EPS']); Stream.Seek(Header.TiffPos - SizeOf(Header), soFromCurrent); inherited; end; //---------------------------------------------------------------------------------------------------------------------- function TEPSGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; begin Result := inherited ReadImageProperties(Stream, ImageIndex); end; {$endif} // EPSGraphic {$endif} // TIFFGraphic //----------------- TTargaGraphic -------------------------------------------------------------------------------------- {$ifdef TargaGraphic} // FILE STRUCTURE FOR THE ORIGINAL TRUEVISION TGA FILE // FIELD 1: NUMBER OF CHARACTERS IN ID FIELD (1 BYTES) // FIELD 2: COLOR MAP TYPE (1 BYTES) // FIELD 3: IMAGE TYPE CODE (1 BYTES) // = 0 NO IMAGE DATA INCLUDED // = 1 UNCOMPRESSED, COLOR-MAPPED IMAGE // = 2 UNCOMPRESSED, TRUE-COLOR IMAGE // = 3 UNCOMPRESSED, BLACK AND WHITE IMAGE (black and white is actually grayscale) // = 9 RUN-LENGTH ENCODED COLOR-MAPPED IMAGE // = 10 RUN-LENGTH ENCODED TRUE-COLOR IMAGE // = 11 RUN-LENGTH ENCODED BLACK AND WHITE IMAGE // FIELD 4: COLOR MAP SPECIFICATION (5 BYTES) // 4.1: COLOR MAP ORIGIN (2 BYTES) // 4.2: COLOR MAP LENGTH (2 BYTES) // 4.3: COLOR MAP ENTRY SIZE (1 BYTES) // FIELD 5:IMAGE SPECIFICATION (10 BYTES) // 5.1: X-ORIGIN OF IMAGE (2 BYTES) // 5.2: Y-ORIGIN OF IMAGE (2 BYTES) // 5.3: WIDTH OF IMAGE (2 BYTES) // 5.4: HEIGHT OF IMAGE (2 BYTES) // 5.5: IMAGE PIXEL SIZE (1 BYTE) // 5.6: IMAGE DESCRIPTOR BYTE (1 BYTE) // bit 0..3: attribute bits per pixel // bit 4..5: image orientation: // 0: bottom left // 1: bottom right // 2: top left // 3: top right // bit 6..7: interleaved flag // 0: two way (even-odd) interleave (e.g. IBM Graphics Card Adapter), obsolete // 1: four way interleave (e.g. AT&T 6300 High Resolution), obsolete // FIELD 6: IMAGE ID FIELD (LENGTH SPECIFIED BY FIELD 1) // FIELD 7: COLOR MAP DATA (BIT WIDTH SPECIFIED BY FIELD 4.3 AND // NUMBER OF COLOR MAP ENTRIES SPECIFIED IN FIELD 4.2) // FIELD 8: IMAGE DATA FIELD (WIDTH AND HEIGHT SPECIFIED IN FIELD 5.3 AND 5.4) const TARGA_NO_COLORMAP = 0; TARGA_COLORMAP = 1; TARGA_EMPTY_IMAGE = 0; TARGA_INDEXED_IMAGE = 1; TARGA_TRUECOLOR_IMAGE = 2; TARGA_BW_IMAGE = 3; TARGA_INDEXED_RLE_IMAGE = 9; TARGA_TRUECOLOR_RLE_IMAGE = 10; TARGA_BW_RLE_IMAGE = 11; type TTargaHeader = packed record IDLength, ColorMapType, ImageType: Byte; ColorMapOrigin, ColorMapSize: Word; ColorMapEntrySize: Byte; XOrigin, YOrigin, Width, Height: Word; PixelSize: Byte; ImageDescriptor: Byte; end; //---------------------------------------------------------------------------------------------------------------------- class function TTargaGraphic.CanLoad(Stream: TStream): Boolean; var Header: TTargaHeader; LastPosition: Cardinal; begin with Stream do begin LastPosition := Position; Result := (Size - Position) > SizeOf(Header); if Result then begin ReadBuffer(Header, SizeOf(Header)); // Targa images are hard to determine because there is no magic id or something like that. // Hence all we can do is to check if all values from the header are within correct limits. Result := (Header.ImageType in [TARGA_EMPTY_IMAGE, TARGA_INDEXED_IMAGE, TARGA_TRUECOLOR_IMAGE, TARGA_BW_IMAGE, TARGA_INDEXED_RLE_IMAGE, TARGA_TRUECOLOR_RLE_IMAGE, TARGA_BW_RLE_IMAGE]) and (Header.ColorMapType in [TARGA_NO_COLORMAP, TARGA_COLORMAP]) and (Header.ColorMapEntrySize in [15, 16, 24, 32]) and (Header.PixelSize in [8, 15, 16, 24, 32]); end; Position := LastPosition; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TTargaGraphic.LoadFromStream(Stream: TStream); var Run, RLEBuffer: PByte; I: Integer; LineSize: Integer; LineBuffer: Pointer; ReadLength: Integer; LogPalette: TMaxLogPalette; Color16: Word; Header: TTargaHeader; FlipV: Boolean; Decoder: TTargaRLEDecoder; begin Handle := 0; FBasePosition := Stream.Position; if ReadImageProperties(Stream, 0) then with Stream, FImageProperties do begin Stream.Position := FBasePosition; FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesPreparing); Stream.Read(Header, SizeOf(Header)); FlipV := (Header.ImageDescriptor and $20) <> 0; Header.ImageDescriptor := Header.ImageDescriptor and $F; // skip image ID Seek(Header.IDLength, soFromCurrent); with ColorManager do begin SourceSamplesPerPixel := SamplesPerPixel; TargetSamplesPerPixel := SamplesPerPixel; SourceColorScheme := ColorScheme; SourceOptions := []; TargetColorScheme := csBGR; SourceBitsPerSample := BitsPerSample; TargetBitsPerSample := BitsPerSample; PixelFormat := TargetPixelFormat; end; if (Header.ColorMapType = TARGA_COLORMAP) or (Header.ImageType in [TARGA_BW_IMAGE, TARGA_BW_RLE_IMAGE]) then begin if Header.ImageType in [TARGA_BW_IMAGE, TARGA_BW_RLE_IMAGE] then Palette := ColorManager.CreateGrayscalePalette(False) else begin LineSize := (Header.ColorMapEntrySize div 8) * Header.ColorMapSize; GetMem(LineBuffer, LineSize); try ReadBuffer(LineBuffer^, LineSize); case Header.ColorMapEntrySize of 32: Palette := ColorManager.CreateColorPalette([LineBuffer], pfInterlaced8Quad, Header.ColorMapSize, True); 24: Palette := ColorManager.CreateColorPalette([LineBuffer], pfInterlaced8Triple, Header.ColorMapSize, True); else with LogPalette do begin // read palette entries and create a palette ZeroMemory(@LogPalette, SizeOf(LogPalette)); palVersion := $300; palNumEntries := Header.ColorMapSize; // 15 and 16 bits per color map entry (handle both like 555 color format // but make 8 bit from 5 bit per color component) for I := 0 to Header.ColorMapSize - 1 do begin Stream.Read(Color16, 2); palPalEntry[I].peBlue := (Color16 and $1F) shl 3; palPalEntry[I].peGreen := (Color16 and $3E0) shr 2; palPalEntry[I].peRed := (Color16 and $7C00) shr 7; end; Palette := CreatePalette(PLogPalette(@LogPalette)^); end; end; finally if Assigned(LineBuffer) then FreeMem(LineBuffer); end; end; end; Self.Width := Header.Width; Self.Height := Header.Height; LineSize := Width * (Header.PixelSize div 8); Progress(Self, psEnding, 0, False, FProgressRect, ''); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); case Header.ImageType of TARGA_EMPTY_IMAGE: // nothing to do here ; TARGA_BW_IMAGE, TARGA_INDEXED_IMAGE, TARGA_TRUECOLOR_IMAGE: begin for I := 0 to Height - 1 do begin if FlipV then LineBuffer := ScanLine[I] else LineBuffer := ScanLine[Header.Height - (I + 1)]; ReadBuffer(LineBuffer^, LineSize); Progress(Self, psRunning, MulDiv(I, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; TARGA_BW_RLE_IMAGE, TARGA_INDEXED_RLE_IMAGE, TARGA_TRUECOLOR_RLE_IMAGE: begin RLEBuffer := nil; Decoder := TTargaRLEDecoder.Create(Header.PixelSize); try GetMem(RLEBuffer, 2 * LineSize); for I := 0 to Height - 1 do begin if FlipV then LineBuffer := ScanLine[I] else LineBuffer := ScanLine[Header.Height - (I + 1)]; ReadLength := Stream.Read(RLEBuffer^, 2 * LineSize); Run := RLEBuffer; Decoder.Decode(Pointer(Run), LineBuffer, 2 * LineSize, Width); Stream.Position := Stream.Position - ReadLength + (Run - RLEBuffer); Progress(Self, psRunning, MulDiv(I, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; finally if Assigned(RLEBuffer) then FreeMem(RLEBuffer); Decoder.Free; end; end; end; Progress(Self, psEnding, 0, False, FProgressRect, ''); end; end; //---------------------------------------------------------------------------------------------------------------------- function TTargaGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var Header: TTargaHeader; begin inherited ReadImageProperties(Stream, ImageIndex); with Stream, FImageProperties do begin ReadBuffer(Header, SizeOf(Header)); Header.ImageDescriptor := Header.ImageDescriptor and $F; Width := Header.Width; Height := Header.Height; BitsPerSample := 8; case Header.PixelSize of 8: begin if Header.ImageType in [TARGA_BW_IMAGE, TARGA_BW_RLE_IMAGE] then ColorScheme := csG else ColorScheme := csIndexed; SamplesPerPixel := 1; end; 15, 16: // actually, 16 bit are meant being 15 bit begin ColorScheme := csRGB; BitsPerSample := 5; SamplesPerPixel := 3; end; 24: begin ColorScheme := csRGB; SamplesPerPixel := 3; end; 32: begin ColorScheme := csRGBA; SamplesPerPixel := 4; end; end; BitsPerPixel := SamplesPerPixel * BitsPerSample; if Header.ImageType in [TARGA_BW_RLE_IMAGE, TARGA_INDEXED_RLE_IMAGE, TARGA_TRUECOLOR_RLE_IMAGE] then Compression := ctRLE else Compression := ctNone; Width := Header.Width; Height := Header.Height; Result := True; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TTargaGraphic.SaveToStream(Stream: TStream); begin SaveToStream(Stream, True); end; //---------------------------------------------------------------------------------------------------------------------- procedure TTargaGraphic.SaveToStream(Stream: TStream; Compressed: Boolean); // The format of the image to be saved depends on the current properties of the bitmap not // on the values which may be set in the header during a former load. var RLEBuffer: Pointer; I: Integer; LineSize: Integer; WriteLength: Cardinal; LogPalette: TMaxLogPalette; BPP: Byte; Header: TTargaHeader; Encoder: TTargaRLEDecoder; begin FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesPreparing); // prepare color depth case PixelFormat of pf1Bit, pf4Bit: // Note: 1 bit and 4 bits per pixel are not supported in the Targa format, an image // with one of these pixel formats is implicitly converted to 256 colors. begin PixelFormat := pf8Bit; BPP := 1; end; pf8Bit: BPP := 1; pf15Bit, pf16Bit: BPP := 2; pf24Bit: BPP := 3; pf32Bit: BPP := 4; else BPP := GetDeviceCaps(Canvas.Handle, BITSPIXEL) div 8; end; if not Empty then begin with Header do begin IDLength := 0; if BPP = 1 then ColorMapType := 1 else ColorMapType := 0; if not Compressed then // can't distinct between a B&W and an color indexed image here, so I use always the latter if BPP = 1 then ImageType := TARGA_INDEXED_IMAGE else ImageType := TARGA_TRUECOLOR_IMAGE else if BPP = 1 then ImageType := TARGA_INDEXED_RLE_IMAGE else ImageType := TARGA_TRUECOLOR_RLE_IMAGE; ColorMapOrigin := 0; // always save entire palette ColorMapSize := 256; // always save complete color information ColorMapEntrySize := 24; XOrigin := 0; YOrigin := 0; Width := Self.Width; Height := Self.Height; PixelSize := 8 * BPP; // if the image is a bottom-up DIB then indicate this in the image descriptor if Cardinal(Scanline[0]) > Cardinal(Scanline[1]) then ImageDescriptor := $20 else ImageDescriptor := 0; end; Stream.Write(Header, SizeOf(Header)); // store color palette if necessary if Header.ColorMapType = 1 then with LogPalette do begin // read palette entries GetPaletteEntries(Palette, 0, 256, palPalEntry); for I := 0 to 255 do begin Stream.Write(palPalEntry[I].peBlue, 1); Stream.Write(palPalEntry[I].peGreen, 1); Stream.Write(palPalEntry[I].peRed, 1); end; end; LineSize := Width * (Header.PixelSize div 8); Progress(Self, psEnding, 0, False, FProgressRect, ''); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); // finally write image data if Compressed then begin RLEBuffer := nil; Encoder := TTargaRLEDecoder.Create(Header.PixelSize); try GetMem(RLEBuffer, 2 * LineSize); for I := 0 to Height - 1 do begin Encoder.Encode(ScanLine[I], RLEBuffer, Width, WriteLength); Stream.WriteBuffer(RLEBuffer^, WriteLength); Progress(Self, psRunning, 0, False, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; finally if Assigned(RLEBuffer) then FreeMem(RLEBuffer); Encoder.Free; end; end else begin for I := 0 to Height - 1 do begin Stream.WriteBuffer(ScanLine[I]^, LineSize); Progress(Self, psRunning, 0, False, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; Progress(Self, psEnding, 0, False, FProgressRect, ''); end; end; {$endif} // TargaGraphic //----------------- TPCXGraphic ---------------------------------------------------------------------------------------- {$ifdef PCXGraphic} type TPCXHeader = record FileID: Byte; // $0A for PCX files, $CD for SCR files Version: Byte; // 0: version 2.5; 2: 2.8 with palette; 3: 2.8 w/o palette; 5: version 3 Encoding: Byte; // 0: uncompressed; 1: RLE encoded BitsPerPixel: Byte; XMin, YMin, XMax, YMax, // coordinates of the corners of the image HRes, // horizontal resolution in dpi VRes: Word; // vertical resolution in dpi ColorMap: array[0..15] of TRGB; // color table Reserved, ColorPlanes: Byte; // color planes (at most 4) BytesPerLine, // number of bytes of one line of one plane PaletteType: Word; // 1: color or b&w; 2: gray scale Fill: array[0..57] of Byte; end; //---------------------------------------------------------------------------------------------------------------------- class function TPCXGraphic.CanLoad(Stream: TStream): Boolean; var Header: TPCXHeader; LastPosition: Cardinal; begin with Stream do begin LastPosition := Position; Result := (Size - Position) > SizeOf(Header); if Result then begin Result := (Header.FileID in [$0A, $0C]) and (Header.Version in [0, 2, 3, 5]) and (Header.Encoding in [0, 1]); ReadBuffer(Header, SizeOf(Header)); end; Position := LastPosition; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TPCXGraphic.LoadFromStream(Stream: TStream); var Header: TPCXHeader; //--------------- local functions ------------------------------------------- procedure MakePalette; var PCXPalette: array[0..255] of TRGB; OldPos: Integer; Marker: Byte; begin if (Header.Version <> 3) or (PixelFormat = pf1Bit) then begin case PixelFormat of pf1Bit: Palette := ColorManager.CreateGrayScalePalette(False); pf4Bit: with Header do begin if paletteType = 2 then Palette := ColorManager.CreateGrayScalePalette(False) else Palette := ColorManager.CreateColorPalette([@ColorMap], pfInterlaced8Triple, 16, False); end; pf8Bit: begin OldPos := Stream.Position; // 256 colors with 3 components plus one marker byte Stream.Position := Stream.Size - 769; Stream.Read(Marker, 1); if Marker <> $0C then begin // palette ID is wrong, perhaps gray scale? if Header.PaletteType = 2 then Palette := ColorManager.CreateGrayScalePalette(False) else ; // ignore palette end else begin Stream.Read(PCXPalette[0], 768); Palette := ColorManager.CreateColorPalette([@PCXPalette], pfInterlaced8Triple, 256, False); end; Stream.Position := OldPos; end; end; end else begin // version 2.8 without palette information, just use the system palette // 256 colors will not be correct with this assignment... Palette := SystemPalette16; end; end; //--------------- end local functions --------------------------------------- var PCXSize, Size: Cardinal; RawBuffer, DecodeBuffer: Pointer; Run: PByte; Plane1, Plane2, Plane3, Plane4: PByte; Value, Mask: Byte; I, J: Integer; Line: PByte; Increment: Cardinal; NewPixelFormat: TPixelFormat; begin Handle := 0; FBasePosition := Stream.Position; if ReadImageProperties(Stream, 0) then begin Stream.Position := FBasePosition; FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesPreparing); Stream.Read(Header, SizeOf(Header)); PCXSize := Stream.Size - Stream.Position; with Header, FImageProperties do begin if not (FileID in [$0A, $CD]) then GraphicExError(gesInvalidImage, ['PCX or SCR']); with ColorManager do begin SourceColorScheme := ColorScheme; SourceBitsPerSample := BitsPerSample; SourceSamplesPerPixel := SamplesPerPixel; if ColorScheme = csIndexed then TargetColorScheme := csIndexed else TargetColorScheme := csBGR; if BitsPerPixel = 2 then TargetBitsPerSample := 4 else TargetBitsPerSample := BitsPerSample; // Note: pixel depths of 2 and 4 bits may not be used with more than one plane // otherwise the image will not show up correctly TargetSamplesPerPixel := SamplesPerPixel; end; NewPixelFormat := ColorManager.TargetPixelFormat; if NewPixelFormat = pfCustom then begin // there can be a special case comprising 4 planes each with 1 bit if (SamplesPerPixel = 4) and (BitsPerPixel = 4) then NewPixelFormat := pf4Bit else GraphicExError(gesInvalidColorFormat, ['PCX']); end; PixelFormat := NewPixelFormat; // 256 colors palette is appended to the actual PCX data if PixelFormat = pf8Bit then Dec(PCXSize, 769); if PixelFormat <> pf24Bit then MakePalette; Self.Width := Width; Self.Height := Height; // adjust alignment of line Increment := SamplesPerPixel * Header.BytesPerLine; // allocate pixel data buffer and decode data if necessary if Compression = ctRLE then begin Size := Increment * Height; GetMem(DecodeBuffer, Size); GetMem(RawBuffer, PCXSize); try Stream.ReadBuffer(RawBuffer^, PCXSize); with TPCXRLEDecoder.Create do try Decode(RawBuffer, DecodeBuffer, PCXSize, Size); finally Free; end; finally if Assigned(RawBuffer) then FreeMem(RawBuffer); end; end else begin GetMem(DecodeBuffer, PCXSize); Stream.ReadBuffer(DecodeBuffer^, PCXSize); end; Progress(Self, psEnding, 0, False, FProgressRect, ''); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); try Run := DecodeBuffer; if (SamplesPerPixel = 4) and (BitsPerPixel = 4) then begin // 4 planes with one bit for I := 0 to Height - 1 do begin Plane1 := Run; Plane2 := @Run[Increment div 4]; Plane3 := @Run[2 * (Increment div 4)]; Plane4 := @Run[3 * (Increment div 4)]; Line := ScanLine[I]; // number of bytes to write Size := (Width * BitsPerPixel + 7) div 8; Mask := 0; while Size > 0 do begin Value := 0; for J := 0 to 1 do asm MOV AL, [Value] MOV EDX, [Plane4] // take the 4 MSBs from the 4 runs and build a nibble SHL BYTE PTR [EDX], 1 // read MSB and prepare next run at the same time RCL AL, 1 // MSB from previous shift is in CF -> move it to AL MOV EDX, [Plane3] // now do the same with the other three runs SHL BYTE PTR [EDX], 1 RCL AL, 1 MOV EDX, [Plane2] SHL BYTE PTR [EDX], 1 RCL AL, 1 MOV EDX, [Plane1] SHL BYTE PTR [EDX], 1 RCL AL, 1 MOV [Value], AL end; Line^ := Value; Inc(Line); Dec(Size); // two runs above (to construct two nibbles -> one byte), now update marker // to know when to switch to next byte in the planes Mask := (Mask + 2) mod 8; if Mask = 0 then begin Inc(Plane1); Inc(Plane2); Inc(Plane3); Inc(Plane4); end; end; Inc(Run, Increment); Progress(Self, psRunning, MulDiv(I, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end else if PixelFormat = pf24Bit then begin // true color for I := 0 to Height - 1 do begin Line := ScanLine[I]; Plane1 := Run; Plane2 := @Run[Increment div 3]; Plane3 := @Run[2 * (Increment div 3)]; ColorManager.ConvertRow([Plane1, Plane2, Plane3], Line, Width, $FF); Inc(Run, Increment); Progress(Self, psRunning, MulDiv(I, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end end else begin // other indexed formats for I := 0 to Height - 1 do begin Line := ScanLine[I]; ColorManager.ConvertRow([Run], Line, Width, $FF); Inc(Run, Increment); Progress(Self, psRunning, MulDiv(I, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; finally if Assigned(DecodeBuffer) then FreeMem(DecodeBuffer); end; Progress(Self, psEnding, 0, False, FProgressRect, ''); end; end; end; //---------------------------------------------------------------------------------------------------------------------- function TPCXGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var Header: TPCXHeader; begin Result := inherited ReadImageProperties(Stream, 0); with Stream do begin ReadBuffer(Header, SizeOf(Header)); with FImageProperties do begin if Header.FileID in [$0A, $CD] then begin Width := Header.XMax - Header.XMin + 1; Height := Header.YMax - Header.YMin + 1; SamplesPerPixel := Header.ColorPlanes; BitsPerSample := Header.BitsPerPixel; BitsPerPixel := BitsPerSample * SamplesPerPixel; if BitsPerPixel <= 8 then ColorScheme := csIndexed else ColorScheme := csRGB; if Header.Encoding = 1 then Compression := ctRLE else Compression := ctNone; XResolution := Header.HRes; YResolution := Header.VRes; Result := True; end; end; end; end; {$endif} // PCXGraphic //----------------- TPCDGraphic ---------------------------------------------------------------------------------------- {$ifdef PCDGraphic} const PCD_BEGIN_BASE16 = 8192; PCD_BEGIN_BASE4 = 47104; PCD_BEGIN_BASE = 196608; PCD_BEGIN_ORIENTATION = 194635; PCD_BEGIN = 2048; PCD_MAGIC = 'PCD_IPI'; //---------------------------------------------------------------------------------------------------------------------- class function TPCDGraphic.CanLoad(Stream: TStream): Boolean; var Header: array of Byte; LastPosition: Cardinal; begin with Stream do begin LastPosition := Position; Result := (Size - Position) > 3 * $800; if Result then begin SetLength(Header, $803); ReadBuffer(Header[0], Length(Header)); Result := (StrLComp(PAnsiChar(@Header[0]), 'PCD_OPA', 7) = 0) or (StrLComp(PAnsiChar(@Header[$800]), 'PCD', 3) = 0); end; Position := LastPosition; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TPCDGraphic.LoadFromStream(Stream: TStream); var C1, C2, YY: PByte; YCbCrData: array[0..2] of PByte; SourceDummy, DestDummy: Pointer; Offset, I, X, Y, ImageIndex, Rows, Columns: Cardinal; ScanLines: array of Pointer; LineBuffer: Pointer; Line, Run: PBGR; Decoder: TPCDDecoder; begin Handle := 0; FBasePosition := Stream.Position; ImageIndex := TPCDGraphic.DefaultResolution; // third image is Base resolution //@@@ SZ if ReadImageProperties(Stream, ImageIndex) then begin with Stream, FImageProperties do begin Position := FBasePosition; FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesPreparing); Columns := 192 shl Min(ImageIndex, 2); Rows := 128 shl Min(ImageIndex, 2); // since row and columns might be swapped because of rotated images // we determine the final dimensions once more Width := 192 shl ImageIndex; Height := 128 shl ImageIndex; ZeroMemory(@YCbCrData, SizeOf(YCbCrData)); try GetMem(YCbCrData[0], Width * Height); GetMem(YCbCrData[1], Width * Height); GetMem(YCbCrData[2], Width * Height); // advance to image data Offset := 96; if Overview then Offset := 5 else if ImageIndex = 1 then Offset := 23 else if ImageIndex = 0 then Offset := 4; Seek(Offset * $800 , soFromCurrent); // color conversion setup with ColorManager do begin SourceColorScheme := csPhotoYCC; SourceBitsPerSample := 8; SourceSamplesPerPixel := 3; TargetColorScheme := csBGR; TargetBitsPerSample := 8; TargetSamplesPerPixel := 3; end; PixelFormat := pf24Bit; // PhotoYCC format uses CCIR Recommendation 709 coefficients and is subsampled // by factor 2 vertically and horizontally ColorManager.SetYCbCrParameters([0.2125, 0.7154, 0.0721], 2, 2); Progress(Self, psEnding, 0, False, FProgressRect, ''); if False then begin // if Overview then ... no info yet about overview image structure end else begin YY := YCbCrData[0]; C1 := YCbCrData[1]; C2 := YCbCrData[2]; I := 0; Progress(Self, psStarting, 0, False, FProgressRect, gesLoadingData); while I < Rows do begin Progress(Self, psRunning, MulDiv(I, 100, Rows), False, FProgressRect, ''); ReadBuffer(YY^, Columns); Inc(YY, Width); ReadBuffer(YY^, Columns); Inc(YY, Width); ReadBuffer(C1^, Columns shr 1); Inc(C1, Width); ReadBuffer(C2^, Columns shr 1); Inc(C2, Width); Inc(I, 2); end; Progress(Self, psEnding, 0, False, FProgressRect, ''); Progress(Self, psStarting, 0, False, FProgressRect, gesUpsampling); // Y stands here for maximum number of upsample calls Y := 5; if ImageIndex >= 3 then begin Inc(Y, 3 * (ImageIndex - 3)); Decoder := TPCDDecoder.Create(Stream); SourceDummy := @YCbCrData; DestDummy := nil; try // recover luminance deltas for 1536 x 1024 image Progress(Self, psRunning, MulDiv(0, 100, Y), False, FProgressRect, ''); Upsample(768, 512, Width, YCbCrData[0]); Progress(Self, psRunning, MulDiv(1, 100, Y), False, FProgressRect, ''); Upsample(384, 256, Width, YCbCrData[1]); Progress(Self, psRunning, MulDiv(2, 100, Y), False, FProgressRect, ''); Upsample(384, 256, Width, YCbCrData[2]); Seek(4 * $800, soFromCurrent); Decoder.Decode(SourceDummy, DestDummy, Width, 1024); if ImageIndex >= 4 then begin // recover luminance deltas for 3072 x 2048 image Progress(Self, psRunning, MulDiv(3, 100, Y), False, FProgressRect, ''); Upsample(1536, 1024, Width, YCbCrData[0]); Progress(Self, psRunning, MulDiv(4, 100, Y), False, FProgressRect, ''); Upsample(768, 512, Width, YCbCrData[1]); Progress(Self, psRunning, MulDiv(5, 100, Y), False, FProgressRect, ''); Upsample(768, 512, Width, YCbCrData[2]); Offset := (Position - Integer(FBasePosition)) div $800 + 12; Seek(FBasePosition + Offset * $800, soFromBeginning); Decoder.Decode(SourceDummy, DestDummy, Width, 2048); if ImageIndex = 5 then begin // recover luminance deltas for 6144 x 4096 image (vaporware) Progress(Self, psRunning, MulDiv(6, 100, Y), False, FProgressRect, ''); Upsample(3072, 2048, Width, YCbCrData[1]); Progress(Self, psRunning, MulDiv(7, 100, Y), False, FProgressRect, ''); Upsample(1536, 1024, Width, YCbCrData[1]); Progress(Self, psRunning, MulDiv(8, 100, Y), False, FProgressRect, ''); Upsample(1536, 1024, Width, YCbCrData[2]); end; end; finally Decoder.Free; end; end; Progress(Self, psRunning, MulDiv(Y - 1, 100, Y), False, FProgressRect, ''); Upsample(Width shr 1, Height shr 1, Width, YCbCrData[1]); Progress(Self, psRunning, MulDiv(Y, 100, Y), False, FProgressRect, ''); Upsample(Width shr 1, Height shr 1, Width, YCbCrData[2]); Progress(Self, psEnding, 0, False, FProgressRect, ''); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); // transfer luminance and chrominance channels YY := YCbCrData[0]; C1 := YCbCrData[1]; C2 := YCbCrData[2]; // For the rotated mode where we need to turn the image by 90°. We can speed up loading // the image by factor 2 by using a local copy of the Scanline pointers. if Rotate in [1, 3] then begin Self.Width := Height; Self.Height := Width; FProgressRect.Right := Height; SetLength(ScanLines, Width); for Y := 0 to Width - 1 do ScanLines[Y] := ScanLine[Y]; GetMem(LineBuffer, 3 * Width); end else begin ScanLines := nil; Self.Width := Width; Self.Height := Height; LineBuffer := nil; end; try case Rotate of 1: // rotate -90° begin for Y := 0 to Height - 1 do begin ColorManager.ConvertRow([YY, C1, C2], LineBuffer, Width, $FF); Inc(YY, Width); Inc(C1, Width); Inc(C2, Width); Run := LineBuffer; for X := 0 to Width - 1 do begin PByte(Line) := @(PByte(ScanLines[Width - X - 1])[Y * 3]); Line^ := Run^; Inc(Run); end; Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; 3: // rotate 90° begin for Y := 0 to Height - 1 do begin ColorManager.ConvertRow([YY, C1, C2], LineBuffer, Width, $FF); Inc(YY, Width); Inc(C1, Width); Inc(C2, Width); Run := LineBuffer; for X := 0 to Width - 1 do begin PByte(Line) := @(PByte(ScanLines[X])[(Height - Y - 1) * 3]); Line^ := Run^; Inc(Run); end; Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; else for Y := 0 to Height - 1 do begin ColorManager.ConvertRow([YY, C1, C2], ScanLine[Y], Width, $FF); Inc(YY, Width); Inc(C1, Width); Inc(C2, Width); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; Progress(Self, psEnding, 0, False, FProgressRect, ''); finally ScanLines := nil; if Assigned(LineBuffer) then FreeMem(LineBuffer); end; end; finally if Assigned(YCbCrData[2]) then FreeMem(YCbCrData[2]); if Assigned(YCbCrData[1]) then FreeMem(YCbCrData[1]); if Assigned(YCbCrData[0]) then FreeMem(YCbCrData[0]); end; end; end; end; //---------------------------------------------------------------------------------------------------------------------- function TPCDGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var Header: array of Byte; Temp: Cardinal; begin if ImageIndex > 5 then ImageIndex := 5; Result := inherited ReadImageProperties(Stream, ImageIndex) and ((Stream.Size - Integer(FBasePosition)) > 3 * $800); with Stream, FImageProperties do begin SetLength(Header, 3 * $800); ReadBuffer(Header[0], Length(Header)); try Overview := StrLComp(PAnsiChar(@Header[0]), 'PCD_OPA', 7) = 0; // determine if image is a PhotoCD image if Overview or (StrLComp(PAnsiChar(@Header[$800]), 'PCD', 3) = 0) then begin Rotate := Header[$0E02] and 3; // image sizes are fixed, depending on the given image index if Overview then ImageIndex := 0; Width := 192 shl ImageIndex; Height := 128 shl ImageIndex; if (Rotate = 1) or (Rotate = 3) then begin Temp := Width; Width := Height; Height := Temp; end; ColorScheme := csPhotoYCC; BitsPerSample := 8; SamplesPerPixel := 3; BitsPerPixel := BitsPerSample * SamplesPerPixel; if ImageIndex > 2 then Compression := ctPCDHuffmann else Compression := ctNone; ImageCount := (Header[10] shl 8) or Header[11]; Result := True; end; finally Header := nil; end; end; end; {$endif} // PCDGraphic //----------------- TPPMGraphic ---------------------------------------------------------------------------------------- {$ifdef PortableMapGraphic} class function TPPMGraphic.CanLoad(Stream: TStream): Boolean; var Buffer: array[0..9] of Byte; LastPosition: Cardinal; begin with Stream do begin LastPosition := Position; Result := (Size - Position) > 10; if Result then begin ReadBuffer(Buffer, SizeOf(Buffer)); Result := (Buffer[0] = ord('P')) and (Buffer[1] in [ord('1')..ord('6')]); end; Position := LastPosition; end; end; //---------------------------------------------------------------------------------------------------------------------- function TPPMGraphic.CurrentChar: AnsiChar; begin if FIndex = SizeOf(FBuffer) then Result := #0 else Result := FBuffer[FIndex]; end; //---------------------------------------------------------------------------------------------------------------------- function TPPMGraphic.GetChar: AnsiChar; // buffered I/O begin if FIndex = SizeOf(FBuffer) then begin if FStream.Position = FStream.Size then GraphicExError(gesStreamReadError, ['PPM']); FIndex := 0; FStream.Read(FBuffer, SizeOf(FBuffer)); end; Result := FBuffer[FIndex]; Inc(FIndex); end; //---------------------------------------------------------------------------------------------------------------------- function TPPMGraphic.GetNumber: Cardinal; // reads the next number from the stream (and skips all characters which are not in 0..9) var Ch: AnsiChar; begin // skip all non-numbers repeat Ch := GetChar; // skip comments if Ch = '#' then begin ReadLine; Ch := GetChar; end; until Ch in ['0'..'9']; // read the number characters and convert meanwhile Result := 0; repeat Result := 10 * Result + Ord(Ch) - $30; Ch := GetChar; until not (Ch in ['0'..'9']); end; //---------------------------------------------------------------------------------------------------------------------- function TPPMGraphic.ReadLine: AnsiString; // reads one text line from stream and skips comments var Ch: AnsiChar; I: Integer; begin Result := ''; repeat Ch := GetChar; if Ch in [#13, #10] then Break else Result := Result + Ch; until False; // eat #13#10 combination if (Ch = #13) and (CurrentChar = #10) then GetChar; // delete comments I := Pos(AnsiString('#'), Result); if I > 0 then Delete(Result, I, MaxInt); end; //---------------------------------------------------------------------------------------------------------------------- procedure TPPMGraphic.LoadFromStream(Stream: TStream); var Buffer: AnsiString; Line24: PBGR; Line8: PByte; X, Y: Integer; Pixel: Byte; begin Handle := 0; FBasePosition := Stream.Position; // copy reference for buffered access FStream := Stream; if ReadImageProperties(Stream, 0) then begin with FImageProperties do begin Stream.Position := FBasePosition; FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); // set index pointer to end of buffer to cause reload FIndex := SizeOf(FBuffer); with Stream do begin Buffer := ReadLine; case StrToInt(String(Buffer[2])) of 1: // PBM ASCII format (black & white) begin PixelFormat := pf1Bit; Self.Width := GetNumber; Self.Height := GetNumber; ColorManager.TargetSamplesPerPixel := 1; ColorManager.TargetBitsPerSample := 1; Palette := ColorManager.CreateGrayScalePalette(True); // read image data for Y := 0 to Height - 1 do begin Line8 := ScanLine[Y]; Pixel := 0; for X := 1 to Width do begin Pixel := (Pixel shl 1) or (GetNumber and 1); if (X mod 8) = 0 then begin Line8^ := Pixel; Inc(Line8); Pixel := 0; end; end; if (Width mod 8) <> 0 then Line8^ := Pixel shl (8 - (Width mod 8)); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; 2: // PGM ASCII form (gray scale) begin PixelFormat := pf8Bit; Self.Width := GetNumber; Self.Height := GetNumber; // skip maximum color value GetNumber; ColorManager.TargetSamplesPerPixel := 1; ColorManager.TargetBitsPerSample := 8; Palette := ColorManager.CreateGrayScalePalette(False); // read image data for Y := 0 to Height - 1 do begin Line8 := ScanLine[Y]; for X := 0 to Width - 1 do begin Line8^ := GetNumber; Inc(Line8); end; Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; 3: // PPM ASCII form (true color) begin PixelFormat := pf24Bit; Self.Width := GetNumber; Self.Height := GetNumber; // skip maximum color value GetNumber; for Y := 0 to Height - 1 do begin Line24 := ScanLine[Y]; for X := 0 to Width - 1 do begin Line24.R := GetNumber; Line24.G := GetNumber; Line24.B := GetNumber; Inc(Line24); end; Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; 4: // PBM binary format (black & white) begin PixelFormat := pf1Bit; Self.Width := GetNumber; Self.Height := GetNumber; ColorManager.TargetSamplesPerPixel := 1; ColorManager.TargetBitsPerSample := 1; Palette := ColorManager.CreateGrayScalePalette(True); // read image data for Y := 0 to Height - 1 do begin Line8 := ScanLine[Y]; for X := 0 to (Width div 8) - 1 do begin Line8^ := Byte(GetChar); Inc(Line8); end; if (Width mod 8) <> 0 then Line8^ := Byte(GetChar); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; 5: // PGM binary form (gray scale) begin PixelFormat := pf8Bit; Self.Width := GetNumber; Self.Height := GetNumber; // skip maximum color value GetNumber; ColorManager.TargetSamplesPerPixel := 1; ColorManager.TargetBitsPerSample := 8; Palette := ColorManager.CreateGrayScalePalette(False); // read image data for Y := 0 to Height - 1 do begin Line8 := ScanLine[Y]; for X := 0 to Width - 1 do begin Line8^ := Byte(GetChar); Inc(Line8); end; Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; 6: // PPM binary form (true color) begin PixelFormat := pf24Bit; Self.Width := GetNumber; Self.Height := GetNumber; // skip maximum color value GetNumber; // Pixel values are store linearly (but RGB instead BGR). // There's one allowed white space which will automatically be skipped by the first // GetChar call below // now read the pixels for Y := 0 to Height - 1 do begin Line24 := ScanLine[Y]; for X := 0 to Width - 1 do begin Line24.R := Byte(GetChar); Line24.G := Byte(GetChar); Line24.B := Byte(GetChar); Inc(Line24); end; Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; end; end; Progress(Self, psEnding, 0, False, FProgressRect, ''); end; end else GraphicExError(gesInvalidImage, ['PBM, PGM or PPM']); end; //---------------------------------------------------------------------------------------------------------------------- function TPPMGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var Buffer: AnsiString; begin Result := inherited ReadImageProperties(Stream, ImageIndex); with Stream, FImageProperties do begin // set index pointer to end of buffer to cause reload FIndex := SizeOf(FBuffer); Buffer := ReadLine; Compression := ctNone; if Buffer[1] = 'P' then begin case StrToInt(String(Buffer[2])) of 1: // PBM ASCII format (black & white) begin Width := GetNumber; Height := GetNumber; SamplesPerPixel := 1; BitsPerSample := 1; ColorScheme := csIndexed; BitsPerPixel := SamplesPerPixel * BitsPerSample; end; 2: // PGM ASCII form (gray scale) begin Width := GetNumber; Height := GetNumber; // skip maximum color value GetNumber; SamplesPerPixel := 1; BitsPerSample := 8; ColorScheme := csIndexed; BitsPerPixel := SamplesPerPixel * BitsPerSample; end; 3: // PPM ASCII form (true color) begin Width := GetNumber; Height := GetNumber; // skip maximum color value GetNumber; SamplesPerPixel := 3; BitsPerSample := 8; ColorScheme := csRGB; BitsPerPixel := SamplesPerPixel * BitsPerSample; end; 4: // PBM binary format (black & white) begin Width := GetNumber; Height := GetNumber; SamplesPerPixel := 1; BitsPerSample := 1; ColorScheme := csIndexed; BitsPerPixel := SamplesPerPixel * BitsPerSample; end; 5: // PGM binary form (gray scale) begin Width := GetNumber; Height := GetNumber; // skip maximum color value GetNumber; SamplesPerPixel := 1; BitsPerSample := 8; ColorScheme := csIndexed; BitsPerPixel := SamplesPerPixel * BitsPerSample; end; 6: // PPM binary form (true color) begin Width := GetNumber; Height := GetNumber; // skip maximum color value GetNumber; SamplesPerPixel := 3; BitsPerSample := 8; ColorScheme := csRGB; BitsPerPixel := SamplesPerPixel * BitsPerSample; end; end; Result := True; end; end; end; {$endif} // PortableMapGraphic //----------------- TCUTGraphic ---------------------------------------------------------------------------------------- {$ifdef CUTGraphic} class function TCUTGraphic.CanLoad(Stream: TStream): Boolean; // Note: cut files cannot be determined from stream because the only information // is width and height of the image at stream/image start which is by no means // enough to identify a cut (or any other) image. begin Result := False; end; //---------------------------------------------------------------------------------------------------------------------- procedure TCUTGraphic.LoadFromFile(const FileName: String); // overridden to extract an implicit palette file name begin FPaletteFile := ChangeFileExt(FileName, '.pal'); inherited; end; //---------------------------------------------------------------------------------------------------------------------- procedure TCUTGraphic.LoadFromStream(Stream: TStream); var Buffer: PByte; Run, Line: Pointer; Decoder: TCUTRLEDecoder; CUTSize: Cardinal; Y: Integer; begin Handle := 0; FBasePosition := Stream.Position; if ReadImageProperties(Stream, 0) then begin with Stream, FImageProperties do begin Position := FBasePosition + 6; FProgressRect := Rect(0, 0, Width, 0); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); PixelFormat := pf8Bit; Self.Width := Width; Self.Height := Height; LoadPalette; CutSize := Stream.Size - Stream.Position; Decoder := TCUTRLEDecoder.Create; Buffer := nil; try GetMem(Buffer, CutSize); Stream.ReadBuffer(Buffer^, CUTSize); Run := Buffer; for Y := 0 to Height - 1 do begin Line := ScanLine[Y]; Decoder.Decode(Run, Line, 0, Width); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; finally Decoder.Free; if Assigned(Buffer) then FreeMem(Buffer); end; Progress(Self, psEnding, 0, False, FProgressRect, ''); end; end; end; //---------------------------------------------------------------------------------------------------------------------- function TCUTGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var Dummy: Word; begin inherited ReadImageProperties(Stream, ImageIndex); with Stream, FImageProperties do begin PixelFormat := pf8Bit; ReadBuffer(Dummy, SizeOf(Dummy)); Width := Dummy; ReadBuffer(Dummy, SizeOf(Dummy)); Height := Dummy; ColorScheme := csIndexed; BitsPerSample := 8; SamplesPerPixel := 1; BitsPerPixel := BitsPerSample * SamplesPerPixel; Compression := ctRLE; Result := True; end; end; //---------------------------------------------------------------------------------------------------------------------- type // the palette file header is actually more complex than the // image file's header, funny... PHaloPaletteHeader = ^THaloPaletteHeader; THaloPaletteHeader = packed record ID: array[0..1] of AnsiChar; // should be 'AH' Version, Size: Word; FileType, SubType: Byte; BrdID, GrMode: Word; MaxIndex, MaxRed, MaxGreen, MaxBlue: Word; // colors = MaxIndex + 1 Signature: array[0..7] of AnsiChar; // 'Dr. Halo' Filler: array[0..11] of Byte; end; //---------------------------------------------------------------------------------------------------------------------- procedure TCUTGraphic.LoadPalette; var Header: PHaloPaletteHeader; LogPalette: TMaxLogPalette; I: Integer; Buffer: array[0..511] of Byte; Run: PWord; begin LogPalette.palVersion := $300; if FileExists(FPaletteFile) then begin with TFileStream.Create(FPaletteFile, fmOpenRead or fmShareDenyNone) do try // quite strange file organization here, we need always to load 512 bytes blocks // and skip occasionally some bytes ReadBuffer(Buffer, SizeOf(Buffer)); Header := @Buffer; LogPalette.palNumEntries := Header.MaxIndex + 1; Run := @Buffer; Inc(PByte(Run), SizeOf(Header^)); for I := 0 to LogPalette.palNumEntries - 1 do begin // load next 512 bytes buffer if necessary if (Integer(Run) - Integer(@Buffer)) > 506 then begin ReadBuffer(Buffer, SizeOf(Buffer)); Run := @Buffer; end; LogPalette.palPalEntry[I].peRed := Run^; Inc(Run); LogPalette.palPalEntry[I].peGreen := Run^; Inc(Run); LogPalette.palPalEntry[I].peBlue := Run^; Inc(Run); end; finally Free; end; end else begin LogPalette.palNumEntries := 256; // no external palette so use gray scale for I := 0 to 255 do begin LogPalette.palPalEntry[I].peBlue := I; LogPalette.palPalEntry[I].peGreen := I; LogPalette.palPalEntry[I].peRed := I; end; end; // finally create palette Palette := CreatePalette(PLogPalette(@LogPalette)^); end; {$endif} // CUTGraphic //----------------- TGIFGraphic ---------------------------------------------------------------------------------------- {$ifdef GIFGraphic} const // logical screen descriptor packed field masks GIF_GLOBALCOLORTABLE = $80; GIF_COLORRESOLUTION = $70; GIF_GLOBALCOLORTABLESORTED = $08; GIF_COLORTABLESIZE = $07; // image flags GIF_LOCALCOLORTABLE = $80; GIF_INTERLACED = $40; GIF_LOCALCOLORTABLESORTED= $20; // block identifiers GIF_PLAINTEXT = $01; GIF_GRAPHICCONTROLEXTENSION = $F9; GIF_COMMENTEXTENSION = $FE; GIF_APPLICATIONEXTENSION = $FF; GIF_IMAGEDESCRIPTOR = Ord(','); GIF_EXTENSIONINTRODUCER = Ord('!'); GIF_TRAILER = Ord(';'); type TGIFHeader = packed record Signature: array[0..2] of AnsiChar; // magic ID 'GIF' Version: array[0..2] of AnsiChar; // '87a' or '89a' end; TLogicalScreenDescriptor = packed record ScreenWidth: Word; ScreenHeight: Word; PackedFields, BackgroundColorIndex, // index into global color table AspectRatio: Byte; // actual ratio = (AspectRatio + 15) / 64 end; TImageDescriptor = packed record //Separator: Byte; // leave that out since we always read one bye ahead Left: Word; // X position of image with respect to logical screen Top: Word; // Y position Width: Word; Height: Word; PackedFields: Byte; end; //---------------------------------------------------------------------------------------------------------------------- class function TGIFGraphic.CanLoad(Stream: TStream): Boolean; var Header: TGIFHeader; LastPosition: Cardinal; begin with Stream do begin LastPosition := Position; Result := (Size - Position) > (SizeOf(TGIFHeader) + SizeOf(TLogicalScreenDescriptor) + SizeOf(TImageDescriptor)); if Result then begin ReadBuffer(Header, SizeOf(Header)); Result := UpperCase(Header.Signature) = 'GIF'; end; Position := LastPosition; end; end; //---------------------------------------------------------------------------------------------------------------------- function TGIFGraphic.SkipExtensions: Byte; // Skips all blocks until an image block has been found in the data stream. // Result is the image block ID if an image block could be found. var Increment: Byte; begin with FStream do begin // iterate through the blocks until first image is found repeat ReadBuffer(Result, 1); if Result = GIF_EXTENSIONINTRODUCER then begin // skip any extension ReadBuffer(Result, 1); case Result of GIF_PLAINTEXT: begin // block size of text grid data ReadBuffer(Increment, 1); Seek(Increment, soFromCurrent); // skip variable lengthed text block repeat // block size ReadBuffer(Increment, 1); if Increment = 0 then Break; Seek(Increment, soFromCurrent); until False; end; GIF_GRAPHICCONTROLEXTENSION: begin // block size ReadBuffer(Increment, 1); // skip block and its terminator Seek(Increment + 1, soFromCurrent); end; GIF_COMMENTEXTENSION: repeat // block size ReadBuffer(Increment, 1); if Increment = 0 then Break; Seek(Increment, soFromCurrent); until False; GIF_APPLICATIONEXTENSION: begin // application id and authentication code plus potential application data repeat ReadBuffer(Increment, 1); if Increment = 0 then Break; Seek(Increment, soFromCurrent); until False; end; end; end; until (Result = GIF_IMAGEDESCRIPTOR) or (Result = GIF_TRAILER); end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TGIFGraphic.LoadFromStream(Stream: TStream); var Header: TGIFHeader; ScreenDescriptor: TLogicalScreenDescriptor; ImageDescriptor: TImageDescriptor; LogPalette: TMaxLogPalette; I: Cardinal; BlockID: Byte; InitCodeSize: Byte; RawData, Run: PByte; TargetBuffer, TargetRun, Line: Pointer; Pass, Increment, Marker: Integer; Decoder: TDecoder; begin // release old image Handle := 0; FBasePosition := Stream.Position; FStream := Stream; if ReadImageProperties(Stream, 0) then begin with Stream, FImageProperties do begin Position := FBasePosition; FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesPreparing); ReadBuffer(Header, SizeOf(Header)); PixelFormat := pf8Bit; // general information ReadBuffer(ScreenDescriptor, SizeOf(ScreenDescriptor)); ZeroMemory(@LogPalette, SizeOf(LogPalette)); LogPalette.palVersion := $300; // read global color table if given if (ScreenDescriptor.PackedFields and GIF_GLOBALCOLORTABLE) <> 0 then begin // the global color table immediately follows the screen descriptor LogPalette.palNumEntries := 2 shl (ScreenDescriptor.PackedFields and GIF_COLORTABLESIZE); for I := 0 to LogPalette.palNumEntries - 1 do begin ReadBuffer(LogPalette.palPalEntry[I].peRed, 1); ReadBuffer(LogPalette.palPalEntry[I].peGreen, 1); ReadBuffer(LogPalette.palPalEntry[I].peBlue, 1); end; // finally create palette Palette := CreatePalette(PLogPalette(@LogPalette)^); end; BlockID := SkipExtensions; Progress(Self, psEnding, 0, False, FProgressRect, ''); // image found? if BlockID = GIF_IMAGEDESCRIPTOR then begin Progress(Self, psStarting, 0, False, FProgressRect, gesLoadingData); ReadBuffer(ImageDescriptor, SizeOf(TImageDescriptor)); Self.Width := Width; Self.Height := Height; // if there is a local color table then override the already set one if (ImageDescriptor.PackedFields and GIF_LOCALCOLORTABLE) <> 0 then begin // the global color table immediately follows the image descriptor LogPalette.palNumEntries := 2 shl (ImageDescriptor.PackedFields and GIF_COLORTABLESIZE); for I := 0 to LogPalette.palNumEntries - 1 do begin ReadBuffer(LogPalette.palPalEntry[I].peRed, 1); ReadBuffer(LogPalette.palPalEntry[I].peGreen, 1); ReadBuffer(LogPalette.palPalEntry[I].peBlue, 1); end; Palette := CreatePalette(PLogPalette(@LogPalette)^); end; ReadBuffer(InitCodeSize, 1); // decompress data in one step // 1) count data Marker := Position; Pass := 0; Increment := 0; repeat if Read(Increment, 1) = 0 then Break; Inc(Pass, Increment); Seek(Increment, soFromCurrent); until Increment = 0; // 2) allocate enough memory GetMem(RawData, Pass); // add one extra line of extra memory for badly coded images GetMem(TargetBuffer, Width * (Height + 1)); try // 3) read and decode data Position := Marker; Increment := 0; Run := RawData; repeat if Read(Increment, 1) = 0 then Break; Read(Run^, Increment); Inc(Run, Increment); until Increment = 0; Decoder := TGIFLZWDecoder.Create(InitCodeSize); try Run := RawData; Decoder.Decode(Pointer(Run), TargetBuffer, Pass, Width * Height); finally Decoder.Free; end; Progress(Self, psEnding, 0, False, FProgressRect, ''); // finally transfer image data Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); if (ImageDescriptor.PackedFields and GIF_INTERLACED) = 0 then begin TargetRun := TargetBuffer; for I := 0 to Height - 1 do begin Line := Scanline[I]; Move(TargetRun^, Line^, Width); Inc(PByte(TargetRun), Width); Progress(Self, psRunning, MulDiv(I, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end else begin TargetRun := TargetBuffer; // interlaced image, need to move in four passes for Pass := 0 to 3 do begin // determine start line and increment of the pass case Pass of 0: begin I := 0; Increment := 8; end; 1: begin I := 4; Increment := 8; end; 2: begin I := 2; Increment := 4; end; else I := 1; Increment := 2; end; while I < Height do begin Line := Scanline[I]; Move(TargetRun^, Line^, Width); Inc(PByte(TargetRun), Width); Inc(I, Increment); if Pass = 3 then begin // progress events only for last (and most expensive) run Progress(Self, psRunning, MulDiv(I, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; end; end; Progress(Self, psEnding, 0, False, FProgressRect, ''); finally if Assigned(TargetBuffer) then FreeMem(TargetBuffer); if Assigned(RawData) then FreeMem(RawData); end; end; end; end else GraphicExError(gesInvalidImage, ['GIF']); end; //---------------------------------------------------------------------------------------------------------------------- function TGIFGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var Header: TGIFHeader; ScreenDescriptor: TLogicalScreenDescriptor; ImageDescriptor: TImageDescriptor; BlockID: Integer; begin Result := inherited ReadImageProperties(Stream, ImageIndex); with Stream, FImageProperties do begin ReadBuffer(Header, SizeOf(Header)); if UpperCase(Header.Signature) = 'GIF' then begin Version := StrToInt(Copy(Header.Version, 1, 2)); ColorScheme := csIndexed; SamplesPerPixel := 1; // might be overwritten BitsPerSample := 8; Compression := ctLZW; // general information ReadBuffer(ScreenDescriptor, SizeOf(ScreenDescriptor)); // skip global color table if given if (ScreenDescriptor.PackedFields and GIF_GLOBALCOLORTABLE) <> 0 then begin BitsPerSample := (ScreenDescriptor.PackedFields and GIF_COLORTABLESIZE) + 1; // the global color table immediately follows the screen descriptor Seek(3 * (1 shl BitsPerSample), soFromCurrent); end; BlockID := SkipExtensions; // image found? if BlockID = GIF_IMAGEDESCRIPTOR then begin ReadBuffer(ImageDescriptor, SizeOf(TImageDescriptor)); Width := ImageDescriptor.Width; if Width = 0 then Width := ScreenDescriptor.ScreenWidth; Height := ImageDescriptor.Height; if Height = 0 then Height := ScreenDescriptor.ScreenHeight; // if there is a local color table then override the already set one LocalColorTable := (ImageDescriptor.PackedFields and GIF_LOCALCOLORTABLE) <> 0; if LocalColorTable then BitsPerSample := (ImageDescriptor.PackedFields and GIF_LOCALCOLORTABLE) + 1; Interlaced := (ImageDescriptor.PackedFields and GIF_INTERLACED) <> 0; end; BitsPerPixel := SamplesPerPixel * BitsPerSample; Result := True; end; end; end; {$endif} // GIFGraphic //----------------- TRLAGraphic ---------------------------------------------------------------------------------------- {$ifdef RLAGraphic} // This implementation is based on code from Dipl. Ing. Ingo Neumann (ingo@upstart.de, ingo_n@dialup.nacamar.de). type TRLAWindow = packed record Left, Right, Bottom, Top: SmallInt; end; TRLAHeader = packed record Window, // overall image size Active_window: TRLAWindow; // size of non-zero portion of image (we use this as actual image size) Frame, // frame number if part of a sequence Storage_type, // type of image channels (0 - integer data, 1 - float data) Num_chan, // samples per pixel (usually 3: r, g, b) Num_matte, // number of matte channels (usually only 1) Num_aux, // number of auxiliary channels, usually 0 Revision: SmallInt; // always $FFFE Gamma: array[0..15] of AnsiChar; // gamma single value used when writing the image Red_pri: array[0..23] of AnsiChar; // used chromaticity for red channel (typical format: "%7.4f %7.4f") Green_pri: array[0..23] of AnsiChar; // used chromaticity for green channel Blue_pri: array[0..23] of AnsiChar;// used chromaticity for blue channel White_pt: array[0..23] of AnsiChar;// used chromaticity for white point Job_num: Integer; // rendering speciifc Name: array[0..127] of AnsiChar; // original file name Desc: array[0..127] of AnsiChar; // a file description ProgramName: array[0..63] of AnsiChar; // name of program which created the image Machine: array[0..31] of AnsiChar; // name of computer on which the image was rendered User: array[0..31] of AnsiChar; // user who ran the creation program of the image Date: array[0..19] of AnsiChar; // creation data of image (ex: Sep 30 12:29 1993) Aspect: array[0..23] of AnsiChar; // aspect format of the file (external resource) Aspect_ratio: array[0..7] of AnsiChar; // float number Width /Height Chan: array[0..31] of AnsiChar; // color space (can be: rgb, xyz, sampled or raw) Field: SmallInt; // 0 - non-field rendered data, 1 - field rendered data Time: array[0..11] of AnsiChar; // time needed to create the image (used when rendering) Filter: array[0..31] of AnsiChar; // filter name to post-process image data Chan_bits, // bits per sample Matte_type, // type of matte channel (see aux_type) Matte_bits, // precision of a pixel's matte channel (1..32) Aux_type, // type of aux channel (0 - integer data; 4 - single (float) data Aux_bits: SmallInt; // bits precision of the pixel's aux channel (1..32 bits) Aux: array[0..31] of AnsiChar; // auxiliary channel as either range or depth Space: array[0..35] of Byte; // unused Next: Integer; // offset for next header if multi-frame image end; //---------------------------------------------------------------------------------------------------------------------- class function TRLAGraphic.CanLoad(Stream: TStream): Boolean; var Header: TRLAHeader; LastPosition: Cardinal; begin with Stream do begin LastPosition := Position; Result := (Size - Position) > SizeOf(Header); if Result then begin ReadBuffer(Header, SizeOf(Header)); Result := (Swap(Word(Header.Revision)) = $FFFE) and ((LowerCase(String(Header.Chan)) = 'rgb') or (LowerCase(String(Header.Chan)) = 'xyz')); end; Position := LastPosition; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TRLAGraphic.LoadFromStream(Stream: TStream); var Offsets: TCardinalArray; RLELength: Word; Line: Pointer; Y: Integer; // RLE buffers RawBuffer, RedBuffer, GreenBuffer, BlueBuffer, AlphaBuffer: Pointer; Decoder: TRLADecoder; begin // free previous image data Handle := 0; FBasePosition := Stream.Position; if ReadImageProperties(Stream, 0) then begin with Stream, FImageProperties do begin FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); with ColorManager do begin SourceSamplesPerPixel := SamplesPerPixel; TargetSamplesPerPixel := SamplesPerPixel; SourceBitsPerSample := BitsPerSample; if BitsPerSample > 8 then TargetBitsPerSample := 8 else TargetBitsPerSample := BitsPerSample; SourceColorScheme := ColorScheme; if ColorScheme = csRGBA then TargetColorScheme := csBGRA else TargetColorScheme := csBGR; PixelFormat := TargetPixelFormat; if FileGamma <> 1 then begin SetGamma(FileGamma); TargetOptions := TargetOptions + [coApplyGamma]; Include(Options, ioUseGamma); end; end; // dimension of image, top might be larger than bottom denoting a bottom up image Self.Width := Width; Self.Height := Height; // each scanline is organized in RLE compressed strips whose location in the stream // is determined by the offsets table SetLength(Offsets, Height); ReadBuffer(Offsets[0], Height * SizeOf(Cardinal)); SwapLong(@Offsets[0], Height); // setup intermediate storage Decoder := TRLADecoder.Create; RawBuffer := nil; RedBuffer := nil; GreenBuffer := nil; BlueBuffer := nil; AlphaBuffer := nil; try GetMem(RedBuffer, Width); GetMem(GreenBuffer, Width); GetMem(BlueBuffer, Width); GetMem(AlphaBuffer, Width); // no go for each scanline for Y := 0 to Height - 1 do begin Stream.Position := FBasePosition + Offsets[Y]; if BottomUp then Line := ScanLine[Integer(Height) - Y - 1] else Line := ScanLine[Y]; // read channel data to decode // red ReadBuffer(RLELength, SizeOf(RLELength)); RLELength := Swap(RLELength); ReallocMem(RawBuffer, RLELength); ReadBuffer(RawBuffer^, RLELength); Decoder.Decode(RawBuffer, RedBuffer, RLELength, Width); // green ReadBuffer(RLELength, SizeOf(RLELength)); RLELength := Swap(RLELength); ReallocMem(RawBuffer, RLELength); ReadBuffer(RawBuffer^, RLELength); Decoder.Decode(RawBuffer, GreenBuffer, RLELength, Width); // blue ReadBuffer(RLELength, SizeOf(RLELength)); RLELength := Swap(RLELength); ReallocMem(RawBuffer, RLELength); ReadBuffer(RawBuffer^, RLELength); Decoder.Decode(RawBuffer, BlueBuffer, RLELength, Width); if ColorManager.TargetColorScheme = csBGR then begin ColorManager.ConvertRow([RedBuffer, GreenBuffer, BlueBuffer], Line, Width, $FF); end else begin // alpha ReadBuffer(RLELength, SizeOf(RLELength)); RLELength := Swap(RLELength); ReallocMem(RawBuffer, RLELength); ReadBuffer(RawBuffer^, RLELength); Decoder.Decode(RawBuffer, AlphaBuffer, RLELength, Width); ColorManager.ConvertRow([RedBuffer, GreenBuffer, BlueBuffer, AlphaBuffer], Line, Width, $FF); end; Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; finally if Assigned(RawBuffer) then FreeMem(RawBuffer); if Assigned(RedBuffer) then FreeMem(RedBuffer); if Assigned(GreenBuffer) then FreeMem(GreenBuffer); if Assigned(BlueBuffer) then FreeMem(BlueBuffer); if Assigned(AlphaBuffer) then FreeMem(AlphaBuffer); Decoder.Free; end; Progress(Self, psEnding, 0, False, FProgressRect, ''); end; end; end; //---------------------------------------------------------------------------------------------------------------------- function TRLAGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var Header: TRLAHeader; begin Result := inherited ReadImageProperties(Stream, ImageIndex); with Stream, FImageProperties do begin ReadBuffer(Header, SizeOf(Header)); // data is always given in big endian order, so swap data which needs this SwapHeader(Header); Options := [ioBigEndian]; SamplesPerPixel := Header.num_chan; if Header.num_matte = 1 then Inc(SamplesPerPixel); BitsPerSample := Header.Chan_bits; BitsPerPixel := SamplesPerPixel * BitsPerSample; if LowerCase(String(Header.Chan)) = 'rgb' then begin if Header.num_matte > 0 then ColorScheme := csRGBA else ColorScheme := csRGB; end else if LowerCase(String(Header.Chan)) = 'xyz' then Exit; try FileGamma := StrToFloat(String(Header.Gamma)); except end; Compression := ctRLE; // dimension of image, top might be larger than bottom denoting a bottom up image Width := Header.Active_window.Right - Header.Active_window.Left + 1; Height := Abs(Header.Active_window.Bottom - Header.Active_window.Top) + 1; BottomUp := (Header.Active_window.Bottom - Header.Active_window.Top) < 0; Result := True; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TRLAGraphic.SwapHeader(var Header); // separate swap method to ease reading the main flow of the LoadFromStream method begin with TRLAHeader(Header) do begin SwapShort(@Window, 4); SwapShort(@Active_window, 4); Frame := Swap(Frame); Storage_type := Swap(Storage_type); Num_chan := Swap(Num_chan); Num_matte := Swap(Num_matte); Num_aux := Swap(Num_aux); Revision := Swap(Revision); Job_num := SwapLong(Job_num); Field := Swap(Field); Chan_bits := Swap(Chan_bits); Matte_type := Swap(Matte_type); Matte_bits := Swap(Matte_bits); Aux_type := Swap(Aux_type); Aux_bits := Swap(Aux_bits); Next := SwapLong(Next); end; end; {$endif} // RLAGraphic //----------------- TPSDGraphic ---------------------------------------------------------------------------------------- {$ifdef PhotoshopGraphic} const // color modes PSD_BITMAP = 0; PSD_GRAYSCALE = 1; PSD_INDEXED = 2; PSD_RGB = 3; PSD_CMYK = 4; PSD_MULTICHANNEL = 7; PSD_DUOTONE = 8; PSD_LAB = 9; PSD_COMPRESSION_NONE = 0; PSD_COMPRESSION_RLE = 1; // RLE compression (same as TIFF packed bits) type TPSDHeader = packed record Signature: array[0..3] of AnsiChar; // always '8BPS' Version: Word; // always 1 Reserved: array[0..5] of Byte; // reserved, always 0 Channels: Word; // 1..24, number of channels in the image (including alpha) Rows, Columns: Cardinal; // 1..30000, size of image Depth: Word; // 1, 8, 16 bits per channel Mode: Word; // color mode (see constants above) end; //---------------------------------------------------------------------------------------------------------------------- class function TPSDGraphic.CanLoad(Stream: TStream): Boolean; var Header: TPSDHeader; LastPosition: Cardinal; begin with Stream do begin LastPosition := Position; Result := (Size - Position) > SizeOf(Header); if Result then begin ReadBuffer(Header, SizeOf(Header)); Result := (UpperCase(String(Header.Signature)) = '8BPS') and (Swap(Header.Version) = 1); end; Position := LastPosition; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TPSDGraphic.LoadFromStream(Stream: TStream); var Header: TPSDHeader; Count: Cardinal; Decoder: TDecoder; RLELength: array of Word; Y: Integer; BPS: Cardinal; // bytes per sample either 1 or 2 for 8 bits per channel and 16 bits per channel respectively ChannelSize: Integer; // size of one channel (taking BPS into account) Increment: Integer; // pointer increment from one line to next // RLE buffers Line, RawBuffer, // all image data compressed Buffer: Pointer; // all iamge data uncompressed Run1, // running pointer in Buffer 1 Run2, // etc. Run3, Run4: PByte; RawPalette: array[0..767] of Byte; begin // free previous image data Handle := 0; FBasePosition := Stream.Position; if ReadImageProperties(Stream, 0) then begin with Stream, FImageProperties do begin Position := FBasePosition; FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesPreparing); ReadBuffer(Header, SizeOf(Header)); // initialize color manager with ColorManager do begin SourceOptions := [coNeedByteSwap]; SourceBitsPerSample := BitsPerSample; if BitsPerSample = 16 then TargetBitsPerSample := 8 else TargetBitsPerSample := BitsPerSample; SourceSamplesPerPixel := SamplesPerPixel; TargetSamplesPerPixel := SamplesPerPixel; // color space SourceColorScheme := ColorScheme; case ColorScheme of csG, csIndexed: TargetColorScheme := ColorScheme; csRGB: TargetColorScheme := csBGR; csRGBA: TargetColorScheme := csBGRA; csCMYK: begin TargetColorScheme := csBGR; TargetSamplesPerPixel := 3; end; csCIELab: begin // PSD uses 0..255 for a and b so we need to convert them to -128..127 SourceOptions := SourceOptions + [coLabByteRange, coLabChromaOffset]; TargetColorScheme := csBGR; end; end; end; PixelFormat := ColorManager.TargetPixelFormat; Self.Width := Width; Self.Height := Height; // size of palette ReadBuffer(Count, SizeOf(Count)); Count := SwapLong(Count); // setup the palette if necessary, color data immediately follows header case ColorScheme of csG: Palette := ColorManager.CreateGrayscalePalette(ioMinIsWhite in Options); csIndexed: begin ReadBuffer(RawPalette, Count); Count := Count div 3; Palette := ColorManager.CreateColorPalette([@RawPalette, @RawPalette[Count], @RawPalette[2 * Count]], pfPlane8Triple, Count, False); end; end; // skip resource and layers section ReadBuffer(Count, SizeOf(Count)); Count := SwapLong(Count); Seek(Count, soFromCurrent); ReadBuffer(Count, SizeOf(Count)); Count := SwapLong(Count); // +2 in order to skip the following compression value Seek(Count + 2, soFromCurrent); // now read out image data RawBuffer := nil; if Compression = ctPackedBits then begin Decoder := TPackbitsRLEDecoder.Create; SetLength(RLELength, Height * Channels); ReadBuffer(RLELength[0], 2 * Length(RLELength)); SwapShort(@RLELength[0], Height * Channels); end else Decoder := nil; Progress(Self, psEnding, 0, False, FProgressRect, ''); try case ColorScheme of csG, csIndexed: begin Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); // very simple format here, we don't need the color conversion manager if Assigned(Decoder) then begin // determine whole compressed size Count := 0; for Y := 0 to Height - 1 do Inc(Count, RLELength[Y]); GetMem(RawBuffer, Count); try ReadBuffer(RawBuffer^, Count); Run1 := RawBuffer; for Y := 0 to Height - 1 do begin Count := RLELength[Y]; Line := ScanLine[Y]; Decoder.Decode(Pointer(Run1), Line, Count, Width); Inc(Run1, Count); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; finally if Assigned(RawBuffer) then FreeMem(RawBuffer); end; end else // uncompressed data for Y := 0 to Height - 1 do begin ReadBuffer(ScanLine[Y]^, Width); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; csRGB, csRGBA, csCMYK, csCIELab: begin Progress(Self, psStarting, 0, False, FProgressRect, gesLoadingData); // Data is organized in planes. This means first all red rows, then // all green and finally all blue rows. BPS := BitsPerSample div 8; ChannelSize := BPS * Width * Height; GetMem(Buffer, Channels * ChannelSize); try // first run: load image data and decompress it if necessary if Assigned(Decoder) then begin // determine whole compressed size Count := 0; for Y := 0 to High(RLELength) do Inc(Count, RLELength[Y]); Count := Count * Cardinal(BPS); GetMem(RawBuffer, Count); try ReadBuffer(RawBuffer^, Count); Decoder.Decode(RawBuffer, Buffer, Count, Channels * ChannelSize); finally if Assigned(RawBuffer) then FreeMem(RawBuffer); end; end else ReadBuffer(Buffer^, Channels * ChannelSize); Progress(Self, psEnding, 0, False, FProgressRect, ''); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); Increment := BPS * Width; // second run: put data into image (convert color space if necessary) case ColorScheme of csRGB: begin Run1 := Buffer; Run2 := Run1; Inc(Run2, ChannelSize); Run3 := Run2; Inc(Run3, ChannelSize); for Y := 0 to Height - 1 do begin ColorManager.ConvertRow([Run1, Run2, Run3], ScanLine[Y], Width, $FF); Inc(Run1, Increment); Inc(Run2, Increment); Inc(Run3, Increment); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; csRGBA: begin Run1 := Buffer; Run2 := Run1; Inc(Run2, ChannelSize); Run3 := Run2; Inc(Run3, ChannelSize); Run4 := Run3; Inc(Run4, ChannelSize); for Y := 0 to Height - 1 do begin ColorManager.ConvertRow([Run1, Run2, Run3, Run4], ScanLine[Y], Width, $FF); Inc(Run1, Increment); Inc(Run2, Increment); Inc(Run3, Increment); Inc(Run4, Increment); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; csCMYK: begin // Photoshop CMYK values are given with 0 for maximum values, but the // (general) CMYK conversion works with 255 as maxium value. Hence we must reverse // all entries in the buffer. Run1 := Buffer; for Y := 1 to 4 * ChannelSize do begin Run1^ := 255 - Run1^; Inc(Run1); end; Run1 := Buffer; Run2 := Run1; Inc(Run2, ChannelSize); Run3 := Run2; Inc(Run3, ChannelSize); Run4 := Run3; Inc(Run4, ChannelSize); for Y := 0 to Height - 1 do begin ColorManager.ConvertRow([Run1, Run2, Run3, Run4], ScanLine[Y], Width, $FF); Inc(Run1, Increment); Inc(Run2, Increment); Inc(Run3, Increment); Inc(Run4, Increment); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; csCIELab: begin Run1 := Buffer; Run2 := Run1; Inc(Run2, ChannelSize); Run3 := Run2; Inc(Run3, ChannelSize); for Y := 0 to Height - 1 do begin ColorManager.ConvertRow([Run1, Run2, Run3], ScanLine[Y], Width, $FF); Inc(Run1, Increment); Inc(Run2, Increment); Inc(Run3, Increment); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; end; finally if Assigned(Buffer) then FreeMem(Buffer); end; end; end; finally Decoder.Free; Progress(Self, psEnding, 0, False, FProgressRect, ''); end; end; end else GraphicExError(gesInvalidImage, ['PSD or PDD']); end; //---------------------------------------------------------------------------------------------------------------------- function TPSDGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var Header: TPSDHeader; Dummy: Word; Count: Cardinal; begin Result := inherited ReadImageProperties(Stream, ImageIndex); with Stream, FImageProperties do begin ReadBuffer(Header, SizeOf(Header)); if Header.Signature = '8BPS' then begin with Header do begin // PSD files are big endian only Channels := Swap(Channels); Rows := SwapLong(Rows); Columns := SwapLong(Columns); Depth := Swap(Depth); Mode := Swap(Mode); end; Options := [ioBigEndian]; // initialize color manager BitsPerSample := Header.Depth; Channels := Header.Channels; // 1..24 channels are supported in PSD files, we can only use 4. // The documentation states that main image data (rgb(a), cmyk etc.) is always // written as first channels in their component order. if Channels > 4 then SamplesPerPixel := 4 else SamplesPerPixel := Channels; BitsPerPixel := SamplesPerPixel * BitsPerSample; // color space case Header.Mode of PSD_DUOTONE, // duo tone should be handled as grayscale PSD_GRAYSCALE: ColorScheme := csG; PSD_BITMAP: // B&W begin ColorScheme := csG; Include(Options, ioMinIsWhite); end; PSD_INDEXED: // 8 bits only are assumed because 16 bit wouldn't make sense here ColorScheme := csIndexed; PSD_MULTICHANNEL, PSD_RGB: if Header.Channels = 3 then ColorScheme := csRGB else ColorScheme := csRGBA; PSD_CMYK: ColorScheme := csCMYK; PSD_LAB: ColorScheme := csCIELab; end; Width := Header.Columns; Height := Header.Rows; // size of palette ReadBuffer(Count, SizeOf(Count)); Count := SwapLong(Count); // skip palette (count is always given, might be 0 however, e.g. for RGB) Seek(Count, soFromCurrent); // skip resource and layers section ReadBuffer(Count, SizeOf(Count)); Count := SwapLong(Count); Seek(Count, soFromCurrent); ReadBuffer(Count, SizeOf(Count)); Count := SwapLong(Count); Seek(Count, soFromCurrent); ReadBuffer(Dummy, SizeOf(Dummy)); if Swap(Dummy) = 1 then Compression := ctPackedBits else Compression := ctNone; Result := True; end; end; end; {$endif} // PhotoshopGraphic //----------------- TPSPGraphic ---------------------------------------------------------------------------------------- {$ifdef PaintshopProGraphic} const // block identifiers PSP_IMAGE_BLOCK = 0; // General Image Attributes Block (main) PSP_CREATOR_BLOCK = 1; // Creator Data Block (main) PSP_COLOR_BLOCK = 2; // Color Palette Block (main and sub) PSP_LAYER_START_BLOCK = 3; // Layer Bank Block (main) PSP_LAYER_BLOCK = 4; // Layer Block (sub) PSP_CHANNEL_BLOCK = 5; // Channel Block (sub) PSP_SELECTION_BLOCK = 6; // Selection Block (main) PSP_ALPHA_BANK_BLOCK = 7; // Alpha Bank Block (main) PSP_ALPHA_CHANNEL_BLOCK = 8; // Alpha Channel Block (sub) PSP_THUMBNAIL_BLOCK = 9; // Thumbnail Block (main) PSP_EXTENDED_DATA_BLOCK = 10; // Extended Data Block (main) PSP_TUBE_BLOCK = 11; // Picture Tube Data Block (main) PSP_ADJUSTMENT_EXTENSION_BLOCK = 12; // Adjustment Layer Extension Block (sub) PSP_VECTOR_EXTENSION_BLOCK = 13; // Vector Layer Extension Block (sub) PSP_SHAPE_BLOCK = 14; // Vector Shape Block (sub) PSP_PAINTSTYLE_BLOCK = 15; // Paint Style Block (sub) PSP_COMPOSITE_IMAGE_BANK_BLOCK = 16; // Composite Image Bank (main) PSP_COMPOSITE_ATTRIBUTES_BLOCK = 17; // Composite Image Attributes (sub) PSP_JPEG_BLOCK = 18; // JPEG Image Block (sub) // bitmap types PSP_DIB_IMAGE = 0; // Layer color bitmap PSP_DIB_TRANS_MASK = 1; // Layer transparency mask bitmap PSP_DIB_USER_MASK = 2; // Layer user mask bitmap PSP_DIB_SELECTION= 3; // Selection mask bitmap PSP_DIB_ALPHA_MASK = 4; // Alpha channel mask bitmap PSP_DIB_THUMBNAIL = 5; // Thumbnail bitmap PSP_DIB_THUMBNAIL_TRANS_MASK = 6; // Thumbnail transparency mask PSP_DIB_ADJUSTMENT_LAYER = 7; // Adjustment layer bitmap PSP_DIB_COMPOSITE = 8; // Composite image bitmap PSP_DIB_COMPOSITE_TRANS_MASK = 9; // Composite image transparency // composite image type PSP_IMAGE_COMPOSITE = 0; // Composite Image PSP_IMAGE_THUMBNAIL = 1; // Thumbnail Image // graphic contents flags PSP_GC_RASTERLAYERS = 1; // At least one raster layer PSP_GC_VectorLayers = 2; // At least one vector layer PSP_GC_ADJUSTMENTLAYERS = 4; // At least one adjustment layer // Additional attributes PSP_GC_THUMBNAIL = $01000000; // Has a thumbnail PSP_GC_THUMBNAILTRANSPARENCY = $02000000; // Thumbnail transp. PSP_GC_COMPOSITE = $04000000; // Has a composite image PSP_GC_COMPOSITETRANSPARENCY = $08000000; // Composite transp. PSP_GC_FLATIMAGE = $10000000; // Just a background PSP_GC_SELECTION = $20000000; // Has a selection PSP_GC_FLOATINGSELECTIONLAYER = $40000000; // Has float. selection PSP_GC_ALPHACHANNELS = $80000000; // Has alpha channel(s) // character style flags PSP_STYLE_ITALIC = 1; // Italic property bit PSP_STYLE_STRUCK = 2; // Strike-out property bit PSP_STYLE_UNDERLINED = 4; // Underlined property bit // layer flags PSP_LAYER_VISIBLEFLAG = 1; // Layer is visible PSP_LAYER_MASKPRESENCEFLAG = 2; // Layer has a mask // Shape property flags PSP_SHAPE_ANTIALIASED = 1; // Shape is anti-aliased PSP_SHAPE_Selected = 2; // Shape is selected PSP_SHAPE_Visible = 4; // Shape is visible // Polyline node type flags PSP_NODE_UNCONSTRAINED = 0; // Default node type PSP_NODE_SMOOTH = 1; // Node is smooth PSP_NODE_SYMMETRIC = 2; // Node is symmetric PSP_NODE_ALIGNED = 4; // Node is aligned PSP_NODE_ACTIVE = 8; // Node is active PSP_NODE_LOCKED = 16; // Node is locked (PSP doc says 0x16 here, but this seems to be a typo) PSP_NODE_SELECTED = 32; // Node is selected (PSP doc says 0x32 here) PSP_NODE_VISIBLE = 64; // Node is visible (PSP doc says 0x64 here) PSP_NODE_CLOSED = 128; // Node is closed (PSP doc says 0x128 here) // Blend modes LAYER_BLEND_NORMAL = 0; LAYER_BLEND_DARKEN = 1; LAYER_BLEND_LIGHTEN = 2; LAYER_BLEND_HUE = 3; LAYER_BLEND_SATURATION = 4; LAYER_BLEND_COLOR = 5; LAYER_BLEND_LUMINOSITY = 6; LAYER_BLEND_MULTIPLY = 7; LAYER_BLEND_SCREEN = 8; LAYER_BLEND_DISSOLVE = 9; LAYER_BLEND_OVERLAY = 10; LAYER_BLEND_HARD_LIGHT = 11; LAYER_BLEND_SOFT_LIGHT = 12; LAYER_BLEND_DIFFERENCE = 130; LAYER_BLEND_DODGE = 14; LAYER_BLEND_BURN = 15; LAYER_BLEND_EXCLUSION = 16; LAYER_BLEND_ADJUST = 255; // Adjustment layer types PSP_ADJUSTMENT_NONE = 0; // Undefined adjustment layer type PSP_ADJUSTMENT_LEVEL = 1; // Level adjustment PSP_ADJUSTMENT_CURVE = 2; // Curve adjustment PSP_ADJUSTMENT_BRIGHTCONTRAST = 3; // Brightness-contrast adjustment PSP_ADJUSTMENT_COLORBAL = 4; // Color balance adjustment PSP_ADJUSTMENT_HSL = 5; // HSL adjustment PSP_ADJUSTMENT_CHANNELMIXER = 6; // Channel mixer adjustment PSP_ADJUSTMENT_INVERT = 7; // Invert adjustment PSP_ADJUSTMENT_THRESHOLD = 8; // Threshold adjustment PSP_ADJUSTMENT_POSTER = 9; // Posterize adjustment // Vector shape types PSP_VST_Unknown = 0; // Undefined vector type PSP_VST_TEXT = 1; // Shape represents lines of text PSP_VST_POLYLINE = 2; // Shape represents a multiple segment line PSP_VST_ELLIPSE = 3; // Shape represents an ellipse (or circle) PSP_VST_POLYGON = 4; // Shape represents a closed polygon // Text element types PSP_TET_UNKNOWN = 0; // Undefined text element type PSP_TET_CHAR = 1; // A single character code PSP_TET_CHARSTYLE = 2; // A character style change PSP_TET_LINESTYLE = 3; // A line style change // Text alignment types PSP_TAT_LEFT = 0; // Left text alignment PSP_TAT_CENTER = 1; // Center text alignment PSP_TAT_RIGHT = 2; // Right text alignment // Paint style types PSP_STYLE_NONE = 0; // Undefined paint style PSP_STYLE_COLOR = 1; // Paint using color (RGB or palette index) PSP_STYLE_GRADIENT = 2; // Paint using gradient // Channel types PSP_CHANNEL_COMPOSITE = 0; // Channel of single channel bitmap PSP_CHANNEL_RED = 1; // Red channel of 24 bit bitmap PSP_CHANNEL_GREEN = 2; // Green channel of 24 bit bitmap PSP_CHANNEL_BLUE = 3; // Blue channel of 24 bit bitmap // Resolution metrics PSP_METRIC_UNDEFINED = 0; // Metric unknown PSP_METRIC_INCH = 1; // Resolution is in inches PSP_METRIC_CM = 2; // Resolution is in centimeters // Compression types PSP_COMP_NONE = 0; // No compression PSP_COMP_RLE = 1; // RLE compression PSP_COMP_LZ77 = 2; // LZ77 compression PSP_COMP_JPEG = 3; // JPEG compression (only used by thumbnail and composite image) // Picture tube placement mode PSP_TPM_Random = 0; // Place tube images in random intervals PSPS_TPM_Constant = 1; // Place tube images in constant intervals // Tube selection mode PSP_TSM_RANDOM =0; // Randomly select the next image in tube to display PSP_TSM_INCREMENTAL = 1; // Select each tube image in turn PSP_TSM_ANGULAR = 2; // Select image based on cursor direction PSP_TSM_PRESSURE = 3; // Select image based on pressure (from pressure-sensitive pad) PSP_TSM_VELOCITY = 4; // Select image based on cursor speed // Extended data field types PSP_XDATA_TRNS_INDEX = 0; // Transparency index field // Creator field types PSP_CRTR_FLD_TITLE = 0; // Image document title field PSP_CRTR_FLD_CRT_DATE = 1; // Creation date field PSP_CRTR_FLD_MOD_DATE = 2; // Modification date field PSP_CRTR_FLD_ARTIST = 3; // Artist name field PSP_CRTR_FLD_CPYRGHT = 4; // Copyright holder name field PSP_CRTR_FLD_DESC = 5; // Image document description field PSP_CRTR_FLD_APP_ID = 6; // Creating app id field PSP_CRTR_FLD_APP_VER = 7; // Creating app version field // Creator application identifier PSP_CREATOR_APP_UNKNOWN = 0; // Creator application unknown PSP_CREATOR_APP_PAINT_SHOP_PRO = 1; // Creator is Paint Shop Pro // Layer types (file version 3) PSP_LAYER_NORMAL = 0; // Normal layer PSP_LAYER_FLOATING_SELECTION = 1; // Floating selection layer // Layer types (file version 4) PSP_LAYER_UNDEFINED = 0; // Undefined layer type PSP_LAYER_RASTER = 1; // Standard raster layer PSP_LAYER_FLOATINGRASTERSELECTION = 2; // Floating selection (raster layer) PSP_LAYER_Vector = 3; // Vector layer PSP_LAYER_ADJUSTMENT = 4; // Adjustment layer MagicID = 'Paint Shop Pro Image File'; type // These block header structures are here for informational purposes only because the data of those // headers is read member by member to generalize code for the different file versions TPSPBlockHeader3 = packed record // block header file version 3 HeaderIdentifier: array[0..3] of AnsiChar; // i.e. "~BK" followed by a zero byte BlockIdentifier: Word; // one of the block identifiers InitialChunkLength, // length of the first sub chunk header or similar TotalBlockLength: Cardinal; // length of this block excluding this header end; TPSPBlockHeader4 = packed record // block header file version 4 HeaderIdentifier: array[0..3] of AnsiChar; // i.e. "~BK" followed by a zero byte BlockIdentifier: Word; // one of the block identifiers TotalBlockLength: Cardinal; // length of this block excluding this header end; TPSPColorPaletteInfoChunk = packed record EntryCount: Cardinal; // number of entries in the palette end; TPSPColorPaletteChunk = array[0..255] of TRGBQuad; // might actually be shorter TPSPChannelInfoChunk = packed record CompressedSize, UncompressedSize: Cardinal; BitmapType, // one of the bitmap types ChannelType: Word; // one of the channel types end; // PSP defines a channel content chunk which is just a bunch of bytes (size is CompressedSize). // There is no sense to define this record type here. TPSPFileHeader = packed record Signature: array[0..31] of AnsiChar; // the string "Paint Shop Pro Image File\n\x1a", padded with zeroes MajorVersion, MinorVersion: Word; end; TPSPImageAttributes = packed record Width, Height: Integer; Resolution: Double; // Number of pixels per metric ResolutionMetric: Byte; // Metric used for resolution (one of the metric constants) Compression, // compression type of image (not thumbnail, it has its own compression) BitDepth, // The bit depth of the color bitmap in each Layer of the image document // (must be 1, 4, 8 or 24). PlaneCount: Word; // Number of planes in each layer of the image document (usually 1) ColorCount: Cardinal; // number of colors in each layer (2^bit depth) GreyscaleFlag: Boolean; // Indicates whether the color bitmap in each layer of image document is a // greyscale (False = not greyscale, True = greyscale). TotalImageSize: Cardinal; // Sum of the sizes of all layer color bitmaps. ActiveLayer: Integer; // Identifies the layer that was active when the image document was saved. LayerCount: Word; // Number of layers in the document. GraphicContents: Cardinal; // A series of flags that helps define the image's graphic contents. end; TPSPLayerInfoChunk = packed record //LayerName: array[0..255] of AnsiChar; // Name of layer (in ASCII text). Has been replaced in version 4 // by a Delphi like short string (length word and variable length string) LayerType: Byte; // Type of layer. ImageRectangle, // Rectangle defining image border. SavedImageRectangle: TRect; // Rectangle within image rectangle that contains "significant" data // (only the contents of this rectangle are saved to the file). LayerOpacity: Byte; // Overall layer opacity. BlendingMode: Byte; // Mode to use when blending layer. Visible: Boolean; // TRUE if layer was visible at time of save, FALSE otherwise. TransparencyProtected: Boolean; // TRUE if transparency is protected. LinkGroupIdentifier: Byte; // Identifies group to which this layer belongs. MaskRectangle, // Rectangle defining user mask border. SavedMaskRectangle: TRect; // Rectangle within mask rectangle that contains "significant" data // (only the contents of this rectangle are saved to the file). MaskLinked: Boolean; // TRUE if mask linked to layer (i.e., mask moves relative to layer) MaskDisabled: Boolean; // TRUE if mask is disabled, FALSE otherwise. InvertMask: Boolean; // TRUE if mask should be inverted when the layer is merged, FALSE otherwise. BlendRangeCount: Word; // Number of valid source-destination field pairs to follow (note, there are // currently always 5 such pairs, but they are not necessarily all valid). SourceBlendRange1, // First source blend range value. DestinationBlendRange1, // First destination blend range value. SourceBlendRange2, DestinationBlendRange2, SourceBlendRange3, DestinationBlendRange3, SourceBlendRange4, DestinationBlendRange4, SourceBlendRange5, DestinationBlendRange5: array[0..3] of Byte; // these fields are obsolete since file version 4 because there's an own chunk for them // BitmapCount: Word; // Number of bitmaps to follow. // ChannelCount: Word; // Number of channels to follow. end; //---------------------------------------------------------------------------------------------------------------------- class function TPSPGraphic.CanLoad(Stream: TStream): Boolean; var Header: TPSPFileHeader; LastPosition: Cardinal; begin with Stream do begin LastPosition := Position; Result := (Size - Position) > SizeOf(Header); if Result then begin ReadBuffer(Header, SizeOf(Header)); Result := (StrLIComp(Header.Signature, MagicID, Length(MagicID)) = 0) and (Header.MajorVersion >= 3); end; Position := LastPosition; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TPSPGraphic.LoadFromStream(Stream: TStream); var Header: TPSPFileHeader; Image: TPSPImageAttributes; // to use the code below for file 3 and 4 I read the parts of the block header // separately instead as a structure HeaderIdentifier: array[0..3] of AnsiChar; // i.e. "~BK" followed by a zero byte BlockIdentifier: Word; // one of the block identifiers InitialChunkLength, // length of the first sub chunk header or similar TotalBlockLength: Cardinal; // length of this block excluding this header LastPosition, ChunkSize: Cardinal; LayerInfo: TPSPLayerInfoChunk; ChannelInfo: TPSPChannelInfoChunk; LayerName: AnsiString; NameLength: Word; NextLayerPosition, NextMainBlock: Integer; // file version 4 specific data BitmapCount, ChannelCount: Word; // load and decoding of image data R, G, B, C: PByte; RedBuffer, GreenBuffer, BlueBuffer, CompBuffer: Pointer; X, Y, Index, RowSize: Integer; // size in bytes of one scanline // other data RawPalette: array[0..4 * 256 - 1] of Byte; //--------------- local functions ------------------------------------------- function ReadBlockHeader: Boolean; // Fills in the block header variables according to the file version. // Returns True if a block header could be read otherwise False (stream end). begin with Stream do begin Result := Position < Size; if Result then begin ReadBuffer(HeaderIdentifier, SizeOf(HeaderIdentifier)); ReadBuffer(BlockIdentifier, SizeOf(BlockIdentifier)); if Header.MajorVersion = 3 then ReadBuffer(InitialChunkLength, SizeOf(InitialChunkLength)); ReadBuffer(TotalBlockLength, SizeOf(TotalBlockLength)); end; end; end; //--------------------------------------------------------------------------- procedure ReadAndDecompress(Target: Pointer); // reads a stream of data from file stream and decompresses it into Target var RawBuffer: Pointer; Decoder: TDecoder; Source: Pointer; begin Decoder := nil; GetMem(RawBuffer, ChannelInfo.CompressedSize); try Stream.ReadBuffer(RawBuffer^, ChannelInfo.CompressedSize); // pointer might be advanced while decoding, so use a copy Source := RawBuffer; case Image.Compression of PSP_COMP_RLE: begin Decoder := TPSPRLEDecoder.Create; Decoder.Decode(Source, Target, ChannelInfo.CompressedSize, ChannelInfo.UncompressedSize); end; PSP_COMP_LZ77: begin Decoder := TLZ77Decoder.Create(Z_FINISH, False); Decoder.DecodeInit; Decoder.Decode(Source, Target, ChannelInfo.CompressedSize, ChannelInfo.UncompressedSize); end; PSP_COMP_JPEG: // here just for completeness, used only in thumbnails and composite images ; end; Decoder.DecodeEnd; finally if Assigned(RawBuffer) then FreeMem(RawBuffer); Decoder.Free; end; end; //--------------------------------------------------------------------------- procedure ReadChannelData; // Reads the actual data of one channel from the current stream position. // Decompression is done by the way. begin with Stream do begin ReadBlockHeader; if Header.MajorVersion > 3 then ReadBuffer(ChunkSize, SizeOf(ChunkSize)); ReadBuffer(ChannelInfo, SizeOf(ChannelInfo)); case ChannelInfo.ChannelType of PSP_CHANNEL_COMPOSITE: // single channel bitmap (indexed or transparency mask) begin GetMem(CompBuffer, ChannelInfo.UncompressedSize); if Image.Compression <> PSP_COMP_NONE then ReadAndDecompress(CompBuffer) else ReadBuffer(CompBuffer^, ChannelInfo.CompressedSize); end; PSP_CHANNEL_RED: // red channel of 24 bit bitmap begin GetMem(RedBuffer, ChannelInfo.UncompressedSize); if Image.Compression <> PSP_COMP_NONE then ReadAndDecompress(RedBuffer) else ReadBuffer(RedBuffer^, ChannelInfo.CompressedSize); end; PSP_CHANNEL_GREEN: begin GetMem(GreenBuffer, ChannelInfo.UncompressedSize); if Image.Compression <> PSP_COMP_NONE then ReadAndDecompress(GreenBuffer) else ReadBuffer(GreenBuffer^, ChannelInfo.CompressedSize); end; PSP_CHANNEL_BLUE: begin GetMem(BlueBuffer, ChannelInfo.UncompressedSize); if Image.Compression <> PSP_COMP_NONE then ReadAndDecompress(BlueBuffer) else ReadBuffer(BlueBuffer^, ChannelInfo.CompressedSize); end; end; end; end; //--------------- end local functions --------------------------------------- begin // free previous image data Handle := 0; FBasePosition := Stream.Position; if ReadImageProperties(Stream, 0) then begin Stream.Position := FBasePosition; RedBuffer := nil; GreenBuffer := nil; BlueBuffer := nil; with Stream, FImageProperties do try FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesPreparing); // Note: To be robust with future PSP images any reader must be able to skip data // which it doesn't know instead of relying on the size of known structures. // Hence there's some extra work needed with the stream (mainly to keep the // current position before a chunk is read and advancing the stream using the // chunk size field). ReadBuffer(Header, SizeOf(Header)); // read general image attribute block ReadBlockHeader; LastPosition := Position; if Version > 3 then ReadBuffer(ChunkSize, SizeOf(ChunkSize)); ReadBuffer(Image, SizeOf(Image)); Position := LastPosition + TotalBlockLength; with ColorManager, Image do begin SourceOptions := []; SourceBitsPerSample := BitsPerSample; TargetBitsPerSample := BitsPerSample; SourceSamplesPerPixel := SamplesPerPixel; TargetSamplesPerPixel := SamplesPerPixel; SourceColorScheme := ColorScheme; if ColorScheme = csRGB then TargetColorScheme := csBGR else TargetColorScheme := ColorScheme; PixelFormat := TargetPixelFormat; end; // set bitmap properties RowSize := 0; // make compiler quiet case BitsPerSample of 1: RowSize := (Image.Width + 7) div 8; 4: RowSize := Image.Width div 2 + 1; 8: RowSize := Image.Width; else GraphicExError(gesInvalidColorFormat, ['PSP']); end; Self.Width := Width; Self.Height := Height; Progress(Self, psEnding, 0, False, FProgressRect, ''); // go through main blocks and read what is needed repeat if not ReadBlockHeader then Break; NextMainBlock := Position + Integer(TotalBlockLength); // no more blocks? if HeaderIdentifier[0] <> '~' then Break; case BlockIdentifier of PSP_COMPOSITE_IMAGE_BANK_BLOCK: begin // composite image block, if present then it must appear before the layer start block // and represents a composition of several layers // do not need to read anything further //Break; end; PSP_LAYER_START_BLOCK: repeat if not ReadBlockHeader then Break; Progress(Self, psStarting, 0, False, FProgressRect, gesLoadingData); // calculate start of next (layer) block in case we need to skip this one NextLayerPosition := Position + Integer(TotalBlockLength); // if all layers have been considered the break loop to continue with other blocks if necessary if BlockIdentifier <> PSP_LAYER_BLOCK then Break; // layer information chunk if Version > 3 then begin LastPosition := Position; ReadBuffer(ChunkSize, SizeOf(ChunkSize)); ReadBuffer(NameLength, SizeOf(NameLength)); SetLength(LayerName, NameLength); if NameLength > 0 then ReadBuffer(LayerName[1], NameLength); ReadBuffer(LayerInfo, SizeOf(LayerInfo)); Position := LastPosition + ChunkSize; // continue only with undefined or raster chunks if not (LayerInfo.LayerType in [PSP_LAYER_UNDEFINED, PSP_LAYER_RASTER]) then begin Position := NextLayerPosition; Continue; end; // in file version 4 there's also an additional bitmap chunk which replaces // two fields formerly located in the LayerInfo chunk LastPosition := Position; ReadBuffer(ChunkSize, SizeOf(ChunkSize)); end else begin SetLength(LayerName, 256); ReadBuffer(LayerName[1], 256); ReadBuffer(LayerInfo, SizeOf(LayerInfo)); // continue only with normal (raster) chunks if LayerInfo.LayerType <> PSP_LAYER_NORMAL then begin Position := NextLayerPosition; Continue; end; end; ReadBuffer(BitmapCount, SizeOf(BitmapCount)); ReadBuffer(ChannelCount, SizeOf(ChannelCount)); // But now we can reliably say whether we have an alpha channel or not. // This kind of information can only be read very late and causes us to // possibly reallocate the entire image (because it is copied by the VCL // when changing the pixel format). // I don't know another way (preferably before the size of the image is set). if ChannelCount > 3 then begin ColorManager.TargetColorScheme := csBGRA; PixelFormat := pf32Bit; end; if Version > 3 then Position := LastPosition + ChunkSize; // allocate memory for all channels and read raw data for X := 0 to ChannelCount - 1 do ReadChannelData; Progress(Self, psEnding, 0, False, FProgressRect, ''); Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); R := RedBuffer; G := GreenBuffer; B := BlueBuffer; C := CompBuffer; with ColorManager do begin if TargetColorScheme in [csIndexed, csG] then begin for Y := 0 to Height - 1 do begin ColorManager.ConvertRow([C], ScanLine[Y], Width, $FF); Inc(C, RowSize); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end else begin for Y := 0 to Height - 1 do begin ColorManager.ConvertRow([R, G, B, C], ScanLine[Y], Width, $FF); Inc(R, RowSize); Inc(G, RowSize); Inc(B, RowSize); Inc(C, RowSize); Progress(Self, psRunning, MulDiv(Y, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; end; Progress(Self, psEnding, 0, False, FProgressRect, ''); // after the raster layer has been read there's no need to loop further Break; until False; // layer loop PSP_COLOR_BLOCK: // color palette block (this is also present for gray scale and b&w images) begin if Version > 3 then ReadBuffer(ChunkSize, SizeOf(ChunkSize)); ReadBuffer(Index, SizeOf(Index)); ReadBuffer(RawPalette, Index * SizeOf(TRGBQuad)); Palette := ColorManager.CreateColorPalette([@RawPalette], pfInterlaced8Quad, Index, True); end; end; // explicitly set stream position to next main block as we might have read a block only partially Position := NextMainBlock; until False; // main block loop finally if Assigned(RedBuffer) then FreeMem(RedBuffer); if Assigned(GreenBuffer) then FreeMem(GreenBuffer); if Assigned(BlueBuffer) then FreeMem(BlueBuffer); end; end else GraphicExError(gesInvalidImage, ['PSP']); end; //---------------------------------------------------------------------------------------------------------------------- function TPSPGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var Header: TPSPFileHeader; Image: TPSPImageAttributes; // to use the code below for file 3 and 4 I read the parts of the block header // separately instead as a structure HeaderIdentifier: array[0..3] of AnsiChar; // i.e. "~BK" followed by a zero byte BlockIdentifier: Word; // one of the block identifiers InitialChunkLength, // length of the first sub chunk header or similar TotalBlockLength: Cardinal; // length of this block excluding this header LastPosition, ChunkSize: Cardinal; //--------------- local functions ------------------------------------------- function ReadBlockHeader: Boolean; // Fills in the block header variables according to the file version. // Returns True if a block header could be read otherwise False (stream end). begin with Stream do begin Result := Position < Size; if Result then begin ReadBuffer(HeaderIdentifier, SizeOf(HeaderIdentifier)); ReadBuffer(BlockIdentifier, SizeOf(BlockIdentifier)); if Header.MajorVersion = 3 then ReadBuffer(InitialChunkLength, SizeOf(InitialChunkLength)); ReadBuffer(TotalBlockLength, SizeOf(TotalBlockLength)); end; end; end; //--------------- end local functions --------------------------------------- begin Result := inherited ReadImageProperties(Stream, ImageIndex); with Stream, FImageProperties do begin ReadBuffer(Header, SizeOf(Header)); if (StrLIComp(Header.Signature, MagicID, Length(MagicID)) = 0) and (Header.MajorVersion >= 3) then begin Version := Header.MajorVersion; // read general image attribute block ReadBlockHeader; LastPosition := Position; if Header.MajorVersion > 3 then ReadBuffer(ChunkSize, SizeOf(ChunkSize)); ReadBuffer(Image, SizeOf(Image)); Position := LastPosition + TotalBlockLength; if Image.BitDepth = 24 then begin BitsPerSample := 8; SamplesPerPixel := 3; ColorScheme := csRGB; // an alpha channel might exist, this is determined by the layer's channel count end else begin BitsPerSample := Image.BitDepth; SamplesPerPixel := 1; if Image.GreyscaleFlag then ColorScheme := csG else ColorScheme := csIndexed; end; BitsPerPixel := BitsPerSample * SamplesPerPixel; Width := Image.Width; Height := Image.Height; case Image.Compression of PSP_COMP_NONE: Compression := ctNone; PSP_COMP_RLE: Compression := ctRLE; PSP_COMP_LZ77: Compression := ctLZ77; PSP_COMP_JPEG: Compression := ctJPEG; else Compression := ctUnknown; end; XResolution := Image.Resolution; if Image.ResolutionMetric = PSP_METRIC_CM then XResolution := XResolution * 2.54; YResolution := XResolution; Result := True; end; end; end; {$endif} // PaintshopProGraphic //----------------- TPNGGraphic ---------------------------------------------------------------------------------------- {$ifdef PortableNetworkGraphic} const PNGMagic: array[0..7] of Byte = (137, 80, 78, 71, 13, 10, 26, 10); // recognized and handled chunk types IHDR: TChunkType = 'IHDR'; IDAT: TChunkType = 'IDAT'; IEND: TChunkType = 'IEND'; PLTE: TChunkType = 'PLTE'; gAMA: TChunkType = 'gAMA'; tRNS: TChunkType = 'tRNS'; bKGD: TChunkType = 'bKGD'; CHUNKMASK = $20; // used to check bit 5 in chunk types type // The following chunks structures are those which appear in the data field of the general chunk structure // given above. // chunk type: 'IHDR' PIHDRChunk = ^TIHDRChunk; TIHDRChunk = packed record Width, Height: Cardinal; BitDepth, // bits per sample (allowed are 1, 2, 4, 8 and 16) ColorType, // combination of: // 1 - palette used // 2 - colors used // 4 - alpha channel used // allowed values are: // 0 - gray scale (allowed bit depths are: 1, 2, 4, 8, 16) // 2 - RGB (8, 16) // 3 - palette (1, 2, 4, 8) // 4 - gray scale with alpha (8, 16) // 6 - RGB with alpha (8, 16) Compression, // 0 - LZ77, others are not yet defined Filter, // filter mode 0 is the only one currently defined Interlaced: Byte; // 0 - not interlaced, 1 - Adam7 interlaced end; //---------------------------------------------------------------------------------------------------------------------- class function TPNGGraphic.CanLoad(Stream: TStream): Boolean; var Magic: array[0..7] of Byte; LastPosition: Cardinal; begin with Stream do begin LastPosition := Position; Result := (Size - Position) > SizeOf(Magic); if Result then begin ReadBuffer(Magic, SizeOf(Magic)); Result := CompareMem(@Magic, @PNGMagic, 8); end; Position := LastPosition; end; end; //---------------------------------------------------------------------------------------------------------------------- function TPNGGraphic.IsChunk(ChunkType: TChunkType): Boolean; // determines, independant of the cruxial 5ths bits in each "letter", whether the // current chunk type in the header is the same as the given chunk type const Mask = not $20202020; begin Result := (FHeader.Mask and Mask) = (PDWORD(@ChunkType)^ and Mask); end; //---------------------------------------------------------------------------------------------------------------------- function TPNGGraphic.LoadAndSwapHeader: Cardinal; // read next chunk header and swap fields to little endian, // returns the intial CRC value for following checks begin FStream.ReadBuffer(FHeader, SizeOf(FHeader)); Result := CRC32(0, @FHeader.ChunkType, 4); FHeader.Length := SwapLong(FHeader.Length); end; //---------------------------------------------------------------------------------------------------------------------- function PaethPredictor(a, b, c: Byte): Byte; var p, pa, pb, pc: Integer; begin // a = left, b = above, c = upper left p := a + b - c; // initial estimate pa := Abs(p - a); // distances to a, b, c pb := Abs(p - b); pc := Abs(p - c); // return nearest of a, b, c, breaking ties in order a, b, c if (pa <= pb) and (pa <= pc) then Result := a else if pb <= pc then Result := b else Result := c; end; //---------------------------------------------------------------------------------------------------------------------- procedure TPNGGraphic.ApplyFilter(Filter: Byte; Line, PrevLine, Target: PByte; BPP, BytesPerRow: Integer); // Applies the filter given in Filter to all bytes in Line (eventually using PrevLine). // Note: The filter type is assumed to be of filter mode 0, as this is the only one currently // defined in PNG. // In opposition to the PNG documentation different identifiers are used here. // Raw refers to the current, not yet decoded value. Decoded refers to the current, already // decoded value (this one is called "raw" in the docs) and Prior is the current value in the // previous line. For the Paeth prediction scheme a fourth pointer is used (PriorDecoded) to describe // the value in the previous line but less the BPP value (Prior[x - BPP]). var I: Integer; Raw, Decoded, Prior, PriorDecoded, TargetRun: PByte; begin case Filter of 0: // no filter, just copy data Move(Line^, Target^, BytesPerRow); 1: // subtraction filter begin Raw := Line; TargetRun := Target; // Transfer BPP bytes without filtering. This mimics the effect of bytes left to the // scanline being zero. Move(Raw^, TargetRun^, BPP); // now do rest of the line Decoded := TargetRun; Inc(Raw, BPP); Inc(TargetRun, BPP); Dec(BytesPerRow, BPP); while BytesPerRow > 0 do begin TargetRun^ := Byte(Raw^ + Decoded^); Inc(Raw); Inc(Decoded); Inc(TargetRun); Dec(BytesPerRow); end; end; 2: // Up filter begin Raw := Line; Prior := PrevLine; TargetRun := Target; while BytesPerRow > 0 do begin TargetRun^ := Byte(Raw^ + Prior^); Inc(Raw); Inc(Prior); Inc(TargetRun); Dec(BytesPerRow); end; end; 3: // average filter begin // first handle BPP virtual pixels to the left Raw := Line; Decoded := Line; Prior := PrevLine; TargetRun := Target; for I := 0 to BPP - 1 do begin TargetRun^ := Byte(Raw^ + Floor(Prior^ / 2)); Inc(Raw); Inc(Prior); Inc(TargetRun); end; Dec(BytesPerRow, BPP); // now do rest of line while BytesPerRow > 0 do begin TargetRun^ := Byte(Raw^ + Floor((Decoded^ + Prior^) / 2)); Inc(Raw); Inc(Decoded); Inc(Prior); Inc(TargetRun); Dec(BytesPerRow); end; end; 4: // paeth prediction begin // again, start with first BPP pixel which would refer to non-existing pixels to the left Raw := Line; Decoded := Target; Prior := PrevLine; PriorDecoded := PrevLine; TargetRun := Target; for I := 0 to BPP - 1 do begin TargetRun^ := Byte(Raw^ + PaethPredictor(0, Prior^, 0)); Inc(Raw); Inc(Prior); Inc(TargetRun); end; Dec(BytesPerRow, BPP); // finally do rest of line while BytesPerRow > 0 do begin TargetRun^ := Byte(Raw^ + PaethPredictor(Decoded^, Prior^, PriorDecoded^)); Inc(Raw); Inc(Decoded); Inc(Prior); Inc(PriorDecoded); Inc(TargetRun); Dec(BytesPerRow); end; end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TPNGGraphic.LoadFromStream(Stream: TStream); var Description: TIHDRChunk; begin // free previous image data Handle := 0; FBasePosition := Stream.Position; FDecoder := nil; FStream := Stream; if ReadImageProperties(Stream, 0) then begin with Stream, FImageProperties do begin Position := FBasePosition + 8; // skip magic FProgressRect := Rect(0, 0, Width, 1); Progress(Self, psStarting, 0, False, FProgressRect, gesPreparing); FPalette := 0; FTransparency := nil; FBackgroundColor := clWhite; FTransparentColor := clNone; // first chunk must be an IHDR chunk FCurrentCRC := LoadAndSwapHeader; FRawBuffer := nil; ColorManager.SourceOptions := [coNeedByteSwap]; try // read IHDR chunk ReadDataAndCheckCRC; Move(FRawBuffer^, Description, SizeOf(Description)); SwapLong(@Description, 2); // currently only one compression type is supported by PNG (LZ77) if Compression = ctLZ77 then begin FDecoder := TLZ77Decoder.Create(Z_PARTIAL_FLUSH, False); FDecoder.DecodeInit; end else GraphicExError(gesUnsupportedFeature, [gesCompressionScheme, 'PNG']); // setup is done, now go for the chunks repeat FCurrentCRC := LoadAndSwapHeader; if IsChunk(IDAT) then begin Progress(Self, psEnding, 0, False, FProgressRect, ''); LoadIDAT(Description); // After reading the image data the next chunk header has already been loaded // so continue with code below instead trying to load a new chunk header. end else if IsChunk(PLTE) then begin // palette chunk if (FHeader.Length mod 3) <> 0 then GraphicExError(gesInvalidPalette, ['PNG']); ReadDataAndCheckCRC; // load palette only if the image is indexed colors if Description.ColorType = 3 then begin // first setup pixel format before actually creating a palette FSourceBPP := SetupColorDepth(Description.ColorType, Description.BitDepth); FPalette := ColorManager.CreateColorPalette([FRawBuffer], pfInterlaced8Triple, FHeader.Length div 3, False); end; Continue; end else if IsChunk(gAMA) then begin ReadDataAndCheckCRC; // the file gamme given here is a scaled cardinal (e.g. 0.45 is expressed as 45000) ColorManager.SetGamma(SwapLong(PCardinal(FRawBuffer)^) / 100000); ColorManager.TargetOptions := ColorManager.TargetOptions + [coApplyGamma]; Include(Options, ioUseGamma); Continue; end else if IsChunk(bKGD) then begin LoadBackgroundColor(Description); Continue; end else if IsChunk(tRNS) then begin LoadTransparency(Description); Continue; end; // Skip unknown or unsupported chunks (+4 because of always present CRC). // IEND will be skipped as well, but this chunk is empty, so the stream will correctly // end on the first byte after the IEND chunk. Seek(FHeader.Length + 4, soFromCurrent); if IsChunk(IEND) then Break; // Note: According to the specs an unknown, but as critical marked chunk is a fatal error. if (Byte(FHeader.ChunkType[0]) and CHUNKMASK) = 0 then GraphicExError(gesUnknownCriticalChunk); until False; finally if Assigned(FDecoder) then begin FDecoder.DecodeEnd; FDecoder.Free; end; if Assigned(FRawBuffer) then FreeMem(FRawBuffer); Progress(Self, psEnding, 0, False, FProgressRect, ''); end; end; end else GraphicExError(gesInvalidImage, ['PNG']); end; //---------------------------------------------------------------------------------------------------------------------- function TPNGGraphic.ReadImageProperties(Stream: TStream; ImageIndex: Cardinal): Boolean; var Magic: array[0..7] of Byte; Description: TIHDRChunk; begin Result := inherited ReadImageProperties(Stream, ImageIndex); FStream := Stream; with Stream, FImageProperties do begin ReadBuffer(Magic, 8); if CompareMem(@Magic, @PNGMagic, 8) then begin // first chunk must be an IHDR chunk FCurrentCRC := LoadAndSwapHeader; if IsChunk(IHDR) then begin Include(Options, ioBigEndian); // read IHDR chunk ReadDataAndCheckCRC; Move(FRawBuffer^, Description, SizeOf(Description)); SwapLong(@Description, 2); if (Description.Width = 0) or (Description.Height = 0) then Exit; Width := Description.Width; Height := Description.Height; if Description.Compression = 0 then Compression := ctLZ77 else Compression := ctUnknown; BitsPerSample := Description.BitDepth; SamplesPerPixel := 1; case Description.ColorType of 0: ColorScheme := csG; 2: begin ColorScheme := csRGB; SamplesPerPixel := 3; end; 3: ColorScheme := csIndexed; 4: ColorScheme := csGA; 6: begin ColorScheme := csRGBA; SamplesPerPixel := 4; end; else ColorScheme := csUnknown; end; BitsPerPixel := SamplesPerPixel * BitsPerSample; FilterMode := Description.Filter; Interlaced := Description.Interlaced <> 0; HasAlpha := ColorScheme in [csGA, csRGBA, csBGRA]; // find gamma repeat FCurrentCRC := LoadAndSwapHeader; if IsChunk(gAMA) then begin ReadDataAndCheckCRC; // the file gamme given here is a scaled cardinal (e.g. 0.45 is expressed as 45000) FileGamma := SwapLong(PCardinal(FRawBuffer)^) / 100000; Break; end; Seek(FHeader.Length + 4, soFromCurrent); if IsChunk(IEND) then Break; until False; Result := True; end; end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TPNGGraphic.LoadBackgroundColor(const Description); // loads the data from the current chunk (must be a bKGD chunk) and fills the bitmpap with that color var Run: PWord; R, G, B: Byte; begin ReadDataAndCheckCRC; with TIHDRChunk(Description) do begin case ColorType of 0, 4: // G(A) begin case BitDepth of 2: FBackgroundColor := MulDiv16(Swap(PWord(FRawBuffer)^), 15, 3); 16: FBackgroundColor := MulDiv16(Swap(PWord(FRawBuffer)^), 255, 65535); else // 1, 4, 8 bits gray scale FBackgroundColor := Byte(Swap(PWord(FRawBuffer)^)); end; end; 2, 6: // RGB(A) begin Run := FRawBuffer; if BitDepth = 16 then begin R := MulDiv16(Swap(Run^), 255, 65535); Inc(Run); G := MulDiv16(Swap(Run^), 255, 65535); Inc(Run); B := MulDiv16(Swap(Run^), 255, 65535); end else begin R := Byte(Swap(Run^)); Inc(Run); G := Byte(Swap(Run^)); Inc(Run); B := Byte(Swap(Run^)); end; FBackgroundColor := RGB(R, G, B); end; else // indexed color scheme (3) FBackgroundColor := PByte(FRawBuffer)^; end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TPNGGraphic.LoadIDAT(const Description); // loads image data from the current position of the stream const // interlace start and offsets RowStart: array[0..6] of Integer = (0, 0, 4, 0, 2, 0, 1); ColumnStart: array[0..6] of Integer = (0, 4, 0, 2, 0, 1, 0); RowIncrement: array[0..6] of Integer = (8, 8, 8, 4, 4, 2, 2); ColumnIncrement: array[0..6] of Integer = (8, 8, 4, 4, 2, 2, 1); PassMask: array[0..6] of Byte = ($80, $08, $88, $22, $AA, $55, $FF); var Row: Integer; TargetBPP: Integer; RowBuffer: array[Boolean] of PAnsiChar; // I use PChar here instead of simple pointer to ease pointer math below EvenRow: Boolean; // distincts between the two rows we need to hold for filtering Pass: Integer; BytesPerRow, InterlaceRowBytes, InterlaceWidth: Integer; begin Progress(Self, psStarting, 0, False, FProgressRect, gesTransfering); RowBuffer[False] := nil; RowBuffer[True] := nil; try // adjust pixel format etc. if not yet done if PixelFormat = pfDevice then FSourceBPP := SetupColorDepth(TIHDRChunk(Description).ColorType, TIHDRChunk(Description).BitDepth); if TIHDRChunk(Description).BitDepth = 16 then TargetBPP := FSourceBPP div 2 else TargetBPP := FSourceBPP; if FPalette <> 0 then Palette := FPalette; // after setting the pixel format we can set the dimensions too without // initiating color conversions Width := TIHDRChunk(Description).Width; Height := TIHDRChunk(Description).Height; // set background and transparency color, these values must be set after the // bitmap is actually valid (although, not filled) Canvas.Lock; try Canvas.Brush.Color := FBackgroundColor; Canvas.FillRect(Rect(0, 0, Width, Height)); finally Canvas.Unlock; end; if FTransparentColor <> clNone then begin TransparentColor := FTransparentColor; Transparent := True; end; // determine maximum number of bytes per row and consider there's one filter byte at the start of each row BytesPerRow := TargetBPP * ((Width * TIHDRChunk(Description).BitDepth + 7) div 8) + 1; RowBuffer[True] := AllocMem(BytesPerRow); RowBuffer[False] := AllocMem(BytesPerRow); // there can be more than one IDAT chunk in the file but then they must directly // follow each other (handled in ReadRow) EvenRow := True; // prepare interlaced images if TIHDRChunk(Description).Interlaced = 1 then begin for Pass := 0 to 6 do begin // prepare next interlace run if Width <= ColumnStart[Pass] then Continue; InterlaceWidth := (Width + ColumnIncrement[Pass] - 1 - ColumnStart[Pass]) div ColumnIncrement[Pass]; InterlaceRowBytes := TargetBPP * ((InterlaceWidth * TIHDRChunk(Description).BitDepth + 7) div 8) + 1; Row := RowStart[Pass]; while Row < Height do begin ReadRow(RowBuffer[EvenRow], InterlaceRowBytes); ApplyFilter(Byte(RowBuffer[EvenRow]^), Pointer(RowBuffer[EvenRow] + 1), Pointer(RowBuffer[not EvenRow] + 1), Pointer(RowBuffer[EvenRow] + 1), FSourceBPP, InterlaceRowBytes - 1); ColorManager.ConvertRow([Pointer(RowBuffer[EvenRow] + 1)], ScanLine[Row], Width, PassMask[Pass]); EvenRow := not EvenRow; // continue with next row in interlaced order Inc(Row, RowIncrement[Pass]); if Pass = 6 then begin // progress event only for last (and most expensive) pass Progress(Self, psRunning, MulDiv(Row, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; end; end else begin for Row := 0 to Height - 1 do begin ReadRow(RowBuffer[EvenRow], BytesPerRow); ApplyFilter(Byte(RowBuffer[EvenRow]^), Pointer(RowBuffer[EvenRow] + 1), Pointer(RowBuffer[not EvenRow] + 1), Pointer(RowBuffer[EvenRow] + 1), FSourceBPP, BytesPerRow - 1); ColorManager.ConvertRow([Pointer(RowBuffer[EvenRow] + 1)], ScanLine[Row], Width, $FF); EvenRow := not EvenRow; Progress(Self, psRunning, MulDiv(Row, 100, Height), True, FProgressRect, ''); OffsetRect(FProgressRect, 0, 1); end; end; // in order to improve safe failness we read all remaining but not read IDAT chunks here while IsChunk(IDAT) do begin ReadDataAndCheckCRC; FCurrentCRC := LoadAndSwapHeader; end; finally if Assigned(RowBuffer[True]) then FreeMem(RowBuffer[True]); if Assigned(RowBuffer[False]) then FreeMem(RowBuffer[False]); end; // ending progress event is issued in main method end; //---------------------------------------------------------------------------------------------------------------------- procedure TPNGGraphic.LoadTransparency(const Description); // reads the data of the current transparency chunk var Run: PWord; R, G, B: Byte; begin ReadDataAndCheckCRC; with TIHDRChunk(Description) do begin case ColorType of 0: // gray begin case BitDepth of 2: R := MulDiv16(Swap(PWord(FRawBuffer)^), 15, 3); 16: R := MulDiv16(Swap(PWord(FRawBuffer)^), 255, 65535); else // 1, 4, 8 bits gray scale R := Byte(Swap(PWord(FRawBuffer)^)); end; FTransparentColor := RGB(R, R, R); end; 2: // RGB begin Run := FRawBuffer; if BitDepth = 16 then begin R := MulDiv16(Swap(Run^), 255, 65535); Inc(Run); G := MulDiv16(Swap(Run^), 255, 65535); Inc(Run); B := MulDiv16(Swap(Run^), 255, 65535); end else begin R := Byte(Swap(Run^)); Inc(Run); G := Byte(Swap(Run^)); Inc(Run); B := Byte(Swap(Run^)); end; FTransparentColor := RGB(R, G, B); end; 4, 6: // formats with full alpha channel, they shouldn't have a transparent color else // Indexed color scheme (3), with at most 256 alpha values (for each palette entry). SetLength(FTransparency, 255); // read the values (at most 256)... Move(FRawBuffer^, FTransparency[0], Max(FHeader.Length, 256)); // ...and set default values (255, fully opaque) for non-supplied values if FHeader.Length < 256 then FillChar(FTransparency[FHeader.Length], 256 - FHeader.Length, $FF); end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TPNGGraphic.ReadDataAndCheckCRC; // Allocates memory in FRawBuffer and reads the next Header.Length bytes from Stream. // Furthermore, the CRC value following the data is read as well and compared with // the CRC value which is calculated here. var FileCRC: Cardinal; begin ReallocMem(FRawBuffer, FHeader.Length); FStream.ReadBuffer(FRawBuffer^, FHeader.Length); FStream.ReadBuffer(FileCRC, SizeOf(FileCRC)); FileCRC := SwapLong(FileCRC); // The type field of a chunk is included in the CRC, this serves as initial value // for the calculation here and is determined in LoadAndSwapHeader. FCurrentCRC := CRC32(FCurrentCRC, FRawBuffer, FHeader.Length); if FCurrentCRC <> FileCRC then GraphicExError(gesInvalidCRC, ['PNG']); end; //---------------------------------------------------------------------------------------------------------------------- procedure TPNGGraphic.ReadRow(RowBuffer: Pointer; BytesPerRow: Integer); // reads and decodes one scanline var LocalBuffer: Pointer; PendingOutput: Integer; begin LocalBuffer := RowBuffer; PendingOutput := BytesPerRow; repeat // read pending chunk data if available input has dropped to zero if FDecoder.AvailableInput = 0 then begin FIDATSize := 0; // read all following chunks until enough data is available or there is no further IDAT chunk while FIDATSize = 0 do begin // finish if the current chunk is not an IDAT chunk if not IsChunk(IDAT) then Exit; ReadDataAndCheckCRC; FCurrentSource := FRawBuffer; FIDATSize := FHeader.Length; // prepare next chunk (plus CRC) FCurrentCRC := LoadAndSwapHeader; end; end; // this decode call will advance Source and Target accordingly FDecoder.Decode(FCurrentSource, LocalBuffer, FIDATSize - (Integer(FCurrentSource) - Integer(FRawBuffer)), PendingOutput); if FDecoder.ZLibResult = Z_STREAM_END then begin if (FDecoder.AvailableOutput <> 0) or (FDecoder.AvailableInput <> 0) then GraphicExError(gesExtraCompressedData, ['PNG']); Break; end; if FDecoder.ZLibResult <> Z_OK then GraphicExError(gesCompression, ['PNG']); PendingOutput := BytesPerRow - (Integer(LocalBuffer) - Integer(RowBuffer)); until PendingOutput = 0; end; //---------------------------------------------------------------------------------------------------------------------- function TPNGGraphic.SetupColorDepth(ColorType, BitDepth: Integer): Integer; begin Result := 0; // determine color scheme and setup related stuff, // Note: The calculated BPP value is always at least 1 even for 1 bits per pixel etc. formats // and used in filter calculation. case ColorType of 0: // gray scale (allowed bit depths are: 1, 2, 4, 8, 16 bits) if BitDepth in [1, 2, 4, 8, 16] then with ColorManager do begin SourceColorScheme := csG; TargetColorScheme := csG; SourceSamplesPerPixel := 1; TargetSamplesPerPixel := 1; SourceBitsPerSample := BitDepth; // 2 bits values are converted to 4 bits values because DIBs don't know the former variant case BitDepth of 2: TargetBitsPerSample := 4; 16: TargetBitsPerSample := 8; else TargetBitsPerSample := BitDepth; end; PixelFormat := TargetPixelFormat; FPalette := CreateGrayscalePalette(False); Result := (BitDepth + 7) div 8; end else GraphicExError(gesInvalidColorFormat, ['PNG']); 2: // RGB if BitDepth in [8, 16] then with ColorManager do begin SourceSamplesPerPixel := 3; TargetSamplesPerPixel := 3; SourceColorScheme := csRGB; TargetColorScheme := csBGR; SourceBitsPerSample := BitDepth; TargetBitsPerSample := 8; PixelFormat := pf24Bit; Result := BitDepth * 3 div 8; end else GraphicExError(gesInvalidColorFormat, ['PNG']); 3: // palette if BitDepth in [1, 2, 4, 8] then with ColorManager do begin SourceColorScheme := csIndexed; TargetColorScheme := csIndexed; SourceSamplesPerPixel := 1; TargetSamplesPerPixel := 1; SourceBitsPerSample := BitDepth; // 2 bits values are converted to 4 bits values because DIBs don't know the former variant if BitDepth = 2 then TargetBitsPerSample := 4 else TargetBitsPerSample := BitDepth; PixelFormat := TargetPixelFormat; Result := 1; end else GraphicExError(gesInvalidColorFormat, ['PNG']); 4: // gray scale with alpha, // For the moment this format is handled without alpha, but might later be converted // to RGBA with gray pixels or use a totally different approach. if BitDepth in [8, 16] then with ColorManager do begin SourceSamplesPerPixel := 1; TargetSamplesPerPixel := 1; SourceBitsPerSample := BitDepth; TargetBitsPerSample := 8; SourceColorScheme := csGA; TargetColorScheme := csIndexed; PixelFormat := pf8Bit; FPalette := CreateGrayScalePalette(False); Result := 2 * BitDepth div 8; end else GraphicExError(gesInvalidColorFormat, ['PNG']); 6: // RGB with alpha (8, 16) if BitDepth in [8, 16] then with ColorManager do begin SourceSamplesPerPixel := 4; TargetSamplesPerPixel := 4; SourceColorScheme := csRGBA; TargetColorScheme := csBGRA; SourceBitsPerSample := BitDepth; TargetBitsPerSample := 8; PixelFormat := pf32Bit; Result := BitDepth * 4 div 8; end else GraphicExError(gesInvalidColorFormat, ['PNG']); else GraphicExError(gesInvalidColorFormat, ['PNG']); end; end; {$endif} // PortableNetworkGraphic //----------------- TFileFormatList ------------------------------------------------------------------------------------ type PClassEntry = ^TClassEntry; TClassEntry = record GraphicClass: TGraphicClass; Description: String; Count: Cardinal; end; PExtensionEntry = ^TExtensionEntry; TExtensionEntry = record Extension, Description: String; FormatTypes: TFormatTypes; ClassReference: PClassEntry; end; constructor TFileFormatList.Create; begin FClassList := TList.Create; FExtensionList := TList.Create; end; //---------------------------------------------------------------------------------------------------------------------- destructor TFileFormatList.Destroy; begin Clear; FClassList.Free; FExtensionList.Free; inherited; end; //---------------------------------------------------------------------------------------------------------------------- procedure TFileFormatList.Clear; var I: Integer; begin for I := 0 to FClassList.Count - 1 do begin TPicture.UnregisterGraphicClass(PClassEntry(FClassList[I]).GraphicClass); Dispose(PClassEntry(FClassList[I])); // need Dispose with type casting to free strings too end; FClassList.Clear; for I := 0 to FExtensionList.Count - 1 do Dispose(PExtensionEntry(FExtensionList[I])); FExtensionList.Clear; end; //---------------------------------------------------------------------------------------------------------------------- function TFileFormatList.FindExtension(const Extension: String): Integer; // Returns the entry which belongs to the given extension string or -1 if there's nothing in the list for this ext. var I: Integer; begin Result := -1; if Extension <> '' then for I := 0 to FExtensionList.Count - 1 do if CompareText(PExtensionEntry(FExtensionList[I]).Extension, Extension) = 0 then begin Result := I; Break; end; end; //---------------------------------------------------------------------------------------------------------------------- function TFileFormatList.FindGraphicClass(GraphicClass: TGraphicClass): Integer; // returns the entry index which belongs to the given graphic class or -1 var I: Integer; begin Result := -1; for I := 0 to FClassList.Count - 1 do if PClassEntry(FClassList[I]).GraphicClass = GraphicClass then begin Result := I; Break; end; end; //---------------------------------------------------------------------------------------------------------------------- function TFileFormatList.GetDescription(Graphic: TGraphicClass): String; // returns the registered description string for the given class var I: Integer; begin Result := ''; I := FindGraphicClass(Graphic); if I > -1 then Result := PClassEntry(FClassList[I]).Description; end; //---------------------------------------------------------------------------------------------------------------------- procedure TFileFormatList.GetExtensionList(List: TStrings); // returns a list of registered extensions (letters only, no *. part) var I: Integer; ExtEntry: PExtensionEntry; begin List.Clear; for I := 0 to FExtensionList.Count - 1 do begin ExtEntry := FExtensionList[I]; List.Add(ExtEntry.Extension); end; end; //---------------------------------------------------------------------------------------------------------------------- function TFileFormatList.GetGraphicFilter(Formats: TFormatTypes; SortType: TFilterSortType; Options: TFilterOptions; GraphicClass: TGraphicClass): String; // Creates a string which can directly be used in an open or save dialog's filter property. // Formats may be used to limit the number of formats to return. // SortType determines how to sort the entries. // Compact determines whether to group extensions (= True) or to put every extension on a separate line. // AllImages finally determines whether to include the 'All image file' entry which includes all allowed extensions // which qualify by the other properties. // Usually all these options determine quite nicely which formats are well suited for a particular task // but sometimes you may find it better to specify a graphic class to limit returned formats further. // In this case set GraphicClass to the particular class otherwise set it nil. var I, J: Integer; DL, EL, All: TStringList; ExtEntry: PExtensionEntry; ClassEntry: PClassEntry; S, DescriptionFormat: String; begin Result := ''; if Formats = [] then Formats := [ftAnimation..ftVector]; DL := TStringList.Create; DL.Sorted := SortType in [fstDescription, fstBoth]; // dl.Duplicates := dupAccept; EL := TStringList.Create; EL.Sorted := SortType in [fstExtension, fstBoth]; // this string list is used to hold the (possibly sorted) list of all allowed extensions All := TStringList.Create; All.Sorted := SortType in [fstExtension, fstBoth]; try // using an adjusted format string makes the code below easier for different options DescriptionFormat := '%s'; if foIncludeExtension in Options then DescriptionFormat := DescriptionFormat + '%s'; if foCompact in Options then begin // all extension for a particular image class on one line for I := 0 to FClassList.Count - 1 do begin ClassEntry := FClassList[I]; if (GraphicClass = nil) or (GraphicClass = ClassEntry.GraphicClass) then begin EL.Clear; // collect allowed extensions for the current graphic class, // this will automatically sort the entries if wanted for J := 0 to FExtensionList.Count - 1 do begin ExtEntry := FExtensionList[J]; if (ExtEntry.ClassReference = ClassEntry) and ((ExtEntry.FormatTypes * Formats) <> []) then EL.Add(ExtEntry.Extension); end; // build the extension list and an description entry if foIncludeAll in Options then All.AddStrings(EL); S := ''; for J := 0 to EL.Count - 1 do S := S + '*.' + EL[J] + '; '; // remove last semicolon and space SetLength(S, Length(S) - 2); if S <> '' then DL.AddObject(ClassEntry.Description, Pointer(StrNew(PChar(S)))); end; end; end else begin // list each extension separately for I := 0 to FExtensionList.Count - 1 do begin ExtEntry := FExtensionList[I]; if ((GraphicClass = nil) or (ExtEntry.ClassReference.GraphicClass = GraphicClass)) and ((ExtEntry.FormatTypes * Formats) <> []) then begin S := ExtEntry.Description; if S = '' then S := ExtEntry.ClassReference.Description; if DL.IndexOf(S) = -1 then //@@@ SZ Patched to avoid Memory Leak DL.AddObject(S, Pointer(StrNew(PChar('*.' + ExtEntry.Extension)))); if foIncludeAll in Options then All.Add(ExtEntry.Extension); end; end; end; // build final filter string out of the collected sub strings if (foIncludeAll in Options) and (All.Count > 0) then begin // first include the general entry if wanted (this entry is never taken into sort order S := ''; for J := 0 to All.Count - 1 do S := S + '*.' + All[J] + '; '; SetLength(S, Length(S) - 2); Result := gesAllImages + '|' + S + '|'; end; for I := 0 to DL.Count - 1 do begin S := PChar(DL.Objects[I]); StrDispose(PChar(DL.Objects[I])); Result := Result + Format(DescriptionFormat, [DL[I], ' (' + S + ')']) + '|' + S + '|'; end; // remove last separator in string if Length(Result) > 0 then SetLength(Result, Length(Result) - 1); finally All.Free; EL.Free; DL.Free; end; end; //---------------------------------------------------------------------------------------------------------------------- function TFileFormatList.GraphicFromExtension(S: String): TGraphicClass; // Returns the class which belongs to the extension given in S or nil if there's non registered. // S may contain a regular file name (also UNC is allowed), a string returned from ExtractFileExt (with period) or just // an extension string. var Index: Integer; begin Result := nil; Index := Pos('.', S); if Index > 0 then Delete(S, 1, Index); Index := FindExtension(S); if Index > -1 then Result := PExtensionEntry(FExtensionList[Index]).ClassReference.GraphicClass; end; //---------------------------------------------------------------------------------------------------------------------- function TFileFormatList.GraphicFromContent(const FileName: String): TGraphicExGraphicClass; // description see other overloaded version var Stream: TFileStream; begin Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); try Result := GraphicFromContent(Stream); finally Stream.Free; end; end; //---------------------------------------------------------------------------------------------------------------------- function TFileFormatList.GraphicFromContent(Stream: TStream): TGraphicExGraphicClass; // Determines the type of image in the stream. This test is only available for TGraphicExGraphic // classes (this excludes TBitmap, TIcon, TMetaFile etc.). // Note: Not all image types can be found using this code because they are not // uniquely identifyable (e.g. Dr. Halo *.cut images). var I: Integer; T: TGraphicExGraphicClass; begin Result := nil; for I := 0 to FClassList.Count - 1 do begin if PClassEntry(FClassList[I]).GraphicClass.InheritsFrom(TGraphicExGraphic) then begin T := TGraphicExGraphicClass(PClassEntry(FClassList[I]).GraphicClass); if T.CanLoad(Stream) then begin Result := T; Break; end; end; end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TFileFormatList.RegisterFileFormat(const Extension, Common, Individual: String; FormatTypes: TFormatTypes; Replace, RegisterDefault: Boolean; GraphicClass: TGraphicClass); // Registers the given graphic class with the passed extension string. If there's already a class registered with this // extension then either the registration of the older entry is replaced by the new one (Replace = True) or an exception // is raised. // This method takes also care to register the new extension with TPicture to make the default handling work too // if RegisterDefault is True. // Further parameters are: // - Extension: the new extension to be registered (not necessarily with only 3 characters, but without a period). // - Common: a description string for all extensions registered with the same class used when several extensions are // listed on one filter line. Pass '' to avoid changing a previously set value if there's one. // - Individual: a description string used when each extension is listed separately. // - FormatTypes: classifies the given file type as being a raster or vector file, with single or multiple images etc. // - GraphicClass: the TGraphic descentant to be used to load and save the particular file. var ExtIndex, ClassIndex: Integer; ExtEntry: PExtensionEntry; ClassEntry, OldReference: PClassEntry; //--------------- local functions ------------------------------------------- procedure UpdateClassEntry; // updates a class entry (creates one if necessary) begin if ClassIndex = -1 then begin New(ClassEntry); ClassEntry.GraphicClass := GraphicClass; ClassEntry.Count := 0; FClassList.Add(ClassEntry); end else ClassEntry := FClassList[ClassIndex]; if Common <> '' then ClassEntry.Description := Common; Inc(ClassEntry.Count); ExtEntry.ClassReference := ClassEntry; end; //--------------- end local functions --------------------------------------- var S: String; begin if Extension <> '' then begin ExtIndex := FindExtension(Extension); ClassIndex := FindGraphicClass(GraphicClass); if ExtIndex = -1 then begin // extension not yet registered New(ExtEntry); ExtEntry.Extension := Extension; ExtEntry.Description := Individual; ExtEntry.FormatTypes := FormatTypes; FExtensionList.Add(ExtEntry); UpdateClassEntry; end else if Replace then begin // replace current extension entry with new one ExtEntry := FExtensionList[ExtIndex]; if ExtEntry.ClassReference.GraphicClass <> GraphicClass then begin // assign existing extension to new graphic class OldReference := ExtEntry.ClassReference; UpdateClassEntry; Dec(OldReference.Count); // remove the graphic class entry if no longer used if OldReference.Count = 0 then FClassList.Remove(OldReference); end; // otherwise do nothing end else GraphicExError(gesRegistration, [Extension]); // finally make TPicture work S := Individual; if S = '' then S := ClassEntry.Description; TPicture.RegisterFileFormat(Extension, S, GraphicClass); end; end; //---------------------------------------------------------------------------------------------------------------------- procedure TFileFormatList.UnregisterFileFormat(const Extension: String; GraphicClass: TGraphicClass); // Removes the entry for the given extension from the internal list. // If Extension is '' then all associations for the given GraphicClass are removed otherwise the class is ignored and // only the one particular extension is removed. // Unregistration from TPicture is done here too, if necessary. var ExtIndex, ClassIndex: Integer; ExtEntry: PExtensionEntry; ClassEntry: PClassEntry; begin ExtIndex := FindExtension(Extension); // make sure we don't try to remove a non-registered extension if (Extension = '') or (ExtIndex > -1) then begin if ExtIndex > -1 then begin // there's an entry for the extension ExtEntry := FExtensionList[ExtIndex]; Dec(ExtEntry.ClassReference.Count); // unregister graphic class too if necessary if ExtEntry.ClassReference.Count = 0 then begin TPicture.UnregisterGraphicClass(ExtEntry.ClassReference.GraphicClass); Dispose(ExtEntry.ClassReference); FClassList.Remove(ExtEntry.ClassReference); end; // finally delete extension entry Dispose(ExtEntry); FExtensionList.Delete(ExtIndex); end else begin // all entries for the given graphic class must be removed ClassIndex := FindGraphicClass(GraphicClass); ClassEntry := FClassList[ClassIndex]; for ExtIndex := FExtensionList.Count - 1 downto 0 do begin if PExtensionEntry(FExtensionList[ExtIndex]).ClassReference.GraphicClass = GraphicClass then begin Dec(ClassEntry.Count); Dispose(PExtensionEntry(FExtensionList[ExtIndex])); FExtensionList.Delete(ExtIndex); // no need to run through further entries if all references are done if ClassEntry.Count = 0 then Break; end; end; Dispose(ClassEntry); FClassList.Delete(ClassIndex); TPicture.UnregisterGraphicClass(GraphicClass); end; end; end; //---------------------------------------------------------------------------------------------------------------------- initialization FileFormatList := TFileFormatList.Create; with FileFormatList do begin // internally register Delphi's "built in" formats, these will not be unregistered on exit and // also not registered with TPicture (because they are already or will soon be) RegisterFileFormat('bmp', gesBitmaps, '', [ftRaster], False, False, TBitmap); RegisterFileFormat('ico', gesIcons, '', [ftRaster], False, False, TIcon); RegisterFileFormat('wmf', gesMetaFiles, '', [ftVector], False, False, TMetafile); RegisterFileFormat('emf', gesMetaFiles, gesEnhancedMetaFiles, [ftVector], False, False, TMetafile); RegisterFileFormat('jfif', gesJPGImages, gesJFIFImages, [ftRaster], False, False, TJPEGImage); RegisterFileFormat('jpg', '', gesJPGImages, [ftRaster], False, False, TJPEGImage); RegisterFileFormat('jpe', '', gesJPEImages, [ftRaster], False, False, TJPEGImage); RegisterFileFormat('jpeg', '', gesJPEGImages, [ftRaster], False, False, TJPEGImage); // register our own formats RegisterFileFormat('rle', gesBitmaps, gesRLEBitmaps, [ftRaster], False, True, TBitmap); RegisterFileFormat('dib', '', gesDIBs, [ftRaster], False, True, TBitmap); {$ifdef TargaGraphic} RegisterFileFormat('win', gesTruevision, '', [ftRaster], False, True, TTargaGraphic); RegisterFileFormat('vst', '', '', [ftRaster], False, True, TTargaGraphic); RegisterFileFormat('vda', '', '', [ftRaster], False, True, TTargaGraphic); RegisterFileFormat('tga', '', '', [ftRaster], False, True, TTargaGraphic); RegisterFileFormat('icb', '', '', [ftRaster], False, True, TTargaGraphic); {$endif} {$ifdef TIFFGraphic} RegisterFileFormat('tiff', gesTIFF, gesMacTIFF, [ftRaster, ftMultiImage], False, True, TTIFFGraphic); RegisterFileFormat('tif', '', gesPCTIF, [ftRaster, ftMultiImage], False, True, TTIFFGraphic); RegisterFileFormat('fax', '', gesGFIFax, [ftRaster, ftMultiImage], False, True, TTIFFGraphic); {$ifdef EPSGraphic} RegisterFileFormat('eps', gesEPS, '', [ftRaster], False, True, TEPSGraphic); {$endif} {$endif} {$ifdef PCXGraphic} RegisterFileFormat('pcx', gesZSoft, '', [ftRaster], False, True, TPCXGraphic); RegisterFileFormat('pcc', '', '', [ftRaster], False, True, TPCXGraphic); RegisterFileFormat('scr', '', gesZSoftWord, [ftRaster], False, True, TPCXGraphic); {$endif} {$ifdef RLAGraphic} RegisterFileFormat('rpf', gesAliasWaveFront, '', [ftRaster], False, True, TRLAGraphic); RegisterFileFormat('rla', '', '', [ftRaster], False, True, TRLAGraphic); {$endif} {$ifdef SGIGraphic} RegisterFileFormat('sgi', gesSGI, gesSGITrueColor, [ftRaster], False, True, TSGIGraphic); RegisterFileFormat('rgba', '', gesSGITrueColorAlpha, [ftRaster], False, True, TSGIGraphic); RegisterFileFormat('rgb', '', gesSGITrueColor, [ftRaster], False, True, TSGIGraphic); RegisterFileFormat('bw', '', gesSGIMono, [ftRaster], False, True, TSGIGraphic); {$endif} {$ifdef PhotoshopGraphic} RegisterFileFormat('psd', gesPhotoshop, '', [ftRaster, ftLayered], False, True, TPSDGraphic); RegisterFileFormat('pdd', '', '', [ftRaster, ftLayered], False, True, TPSDGraphic); {$endif} {$ifdef PortableMapGraphic} RegisterFileFormat('ppm', gesPortable, gesPortablePixel, [ftRaster], False, True, TPPMGraphic); RegisterFileFormat('pgm', '', gesPortableGray, [ftRaster], False, True, TPPMGraphic); RegisterFileFormat('pbm', '', gesPortableMono, [ftRaster], False, True, TPPMGraphic); {$endif} {$ifdef AutodeskGraphic} RegisterFileFormat('cel', gesAutodesk, '', [ftRaster], False, True, TAutodeskGraphic); RegisterFileFormat('pic', gesAutodesk, '', [ftRaster], False, True, TAutodeskGraphic); {$endif} {$ifdef PCDGraphic} TPCDGraphic.DefaultResolution := 2; RegisterFileFormat('pcd', gesKodakPhotoCD, '', [ftRaster], False, True, TPCDGraphic); {$endif} {$ifdef GIFGraphic} RegisterFileFormat('gif', gesCompuserve, '', [ftRaster, ftMultiImage, ftAnimation], False, True, TGIFGraphic); {$endif} {$ifdef CUTGraphic} RegisterFileFormat('cut', gesHalo, '', [ftRaster], False, True, TCUTGraphic); {$endif} {$ifdef PaintshopProGraphic} RegisterFileFormat('psp', gesPaintshopPro, '', [ftRaster, ftVector], False, True, TPSPGraphic); {$endif} {$ifdef PortableNetworkGraphic} RegisterFileFormat('png', gesPortableNetworkGraphic, '', [ftRaster], False, True, TPNGGraphic); {$endif} end; finalization with FileFormatList do begin {$ifdef PaintshopProGraphic} UnregisterFileFormat('', TPSPGraphic); {$endif} {$ifdef PhotoshopGraphic} UnregisterFileFormat('', TPSDGraphic); {$endif} {$ifdef TargaGraphic} UnregisterFileFormat('', TTargaGraphic); {$endif} {$ifdef TIFFGraphic} UnregisterFileFormat('', TTIFFGraphic); {$endif} {$ifdef SGIGraphic} UnregisterFileFormat('', TSGIGraphic); {$endif} {$ifdef PCXGraphic} UnregisterFileFormat('', TPCXGraphic); {$endif} {$ifdef AutodeskGraphic} UnregisterFileFormat('', TAutodeskGraphic); {$endif} {$ifdef PCDGraphic} UnregisterFileFormat('', TPCDGraphic); {$endif} {$ifdef PortableMapGraphic} UnregisterFileFormat('', TPPMGraphic); {$endif} {$ifdef CUTGraphic} UnregisterFileFormat('', TCUTGraphic); {$endif} {$ifdef GIFGraphic} UnregisterFileFormat('', TGIFGraphic); {$endif} {$ifdef RLAGraphic} UnregisterFileFormat('', TRLAGraphic); {$endif} UnregisterFileFormat('rle', TBitmap); UnregisterFileFormat('dib', TBitmap); {$ifdef PortableNetworkGraphic} UnregisterFileFormat('', TPNGGraphic); {$endif} Free; end; end.