{ $Id$ } { /*************************************************************************** intfgraphics.pp --------------- ***************************************************************************/ ***************************************************************************** * * * This file is part of the Lazarus Component Library (LCL) * * * * See the file COPYING.modifiedLGPL.txt, included in this distribution, * * for details about the copyright. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** Author: Mattias Gaertner Abstract: Classes and functions for easy handling of raw images (interface images). } unit IntfGraphics; {$mode objfpc}{$H+} interface uses Classes, SysUtils, fpImage, FPReadBMP, BMPComn, FPCAdds, AvgLvlTree, LCLType, LCLProc, GraphType, LCLIntf, FPReadPNG, IcnsTypes; type { TLazIntfImage } { This descendent of TFPCustomImage stores its image data as raw images and is therefore able to directly interchange images with the LCL interfaces. Usage examples: 1. Loading a .xpm file into a TBitmap: var BmpHnd,MaskHnd: HBitmap; Bitmap1: TBitmap; IntfImg1: TLazIntfImage; Reader: TLazReaderXPM; begin // create a bitmap (or use an existing one) Bitmap1:=TBitmap.Create; // create the raw image for the screenformat you want IntfImg1:=TLazIntfImage.Create(0,0,[riqfRGB, riqfAlpha, riqfMask]); // create the XPM reader Reader:=TLazReaderXPM.Create; // load the image IntfImg1.LoadFromFile('filename.xpm',Reader); // create the bitmap handles IntfImg1.CreateBitmap(BmpHnd,MaskHnd); // apply handles to the Bitmap1 Bitmap1.Handle:=BmpHnd; Bitmap1.MaskHandle:=MaskHnd; // clean up Reader.Free; IntfImg1.Free; // do something with the Bitmap1 ... end; 2. Saving a TBitmap to a .xpm file: var BmpHnd,MaskHnd: HBitmap; Bitmap1: TBitmap; IntfImg1: TLazIntfImage; Writer: TLazWriterXPM; begin ... // create the raw image IntfImg1:=TLazIntfImage.Create(0,0,[]); // load the raw image from the bitmap handles IntfImg1.LoadFromBitmap(Bitmap1.Handle,Bitmap1.MaskHandle); // create the XPM writer Writer:=TLazWriterXPM.Create; // save image to file IntfImg1.SaveToFile('filename.xpm',Writer); // clean up Writer.Free; IntfImg1.Free; ... end; } TLazIntfImageGetPixelProc = procedure(x, y: integer; out Color: TFPColor) of object; TLazIntfImageSetPixelProc = procedure(x, y: integer; const Color: TFPColor) of object; TOnReadRawImageBits = procedure(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; var Bits: word); TOnWriteRawImageBits = procedure(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; Bits: word); { TLazIntfImage } TLazIntfImage = class(TFPCustomImage) private FRawImage: TRawImage; FLineStarts: PRawImageLineStarts; FMaskLineStarts: PRawImageLineStarts; FMaskSet: Boolean; // Set when atleast one maskpixel is set FUpdateCount: integer; fCreateAllDataNeeded: boolean; FGetSetColorFunctionsUpdateNeeded: boolean; FReadRawImageBits: TOnReadRawImageBits; FWriteRawImageBits: TOnWriteRawImageBits; FMaskReadRawImageBits: TOnReadRawImageBits; FMaskWriteRawImageBits: TOnWriteRawImageBits; FDataOwner: Boolean; {$ifdef VER2_0} // workaround for IE200310221 on 2.0.4 function GetDataDescription: TRawImageDescription; function GetMaskData: PByte; function GetPixelData: PByte; {$endif} function GetMasked(x, y: integer): Boolean; function GetTColors(x, y: integer): TGraphicsColor; procedure InternalSetSize(AWidth, AHeight: integer); procedure SetMasked(x, y: integer; const AValue: Boolean); procedure SetTColors(x, y: integer; const AValue: TGraphicsColor); protected FGetInternalColorProc: TLazIntfImageGetPixelProc; FSetInternalColorProc: TLazIntfImageSetPixelProc; procedure SetUsePalette (Value: boolean); override; procedure SetInternalColor(x, y: integer; const Value: TFPColor); override; function GetInternalColor(x, y: integer): TFPColor; override; procedure SetInternalPixel (x,y:integer; Value:integer); override; function GetInternalPixel (x,y:integer) : integer; override; procedure FreeData; virtual; procedure SetDataDescription(const ADescription: TRawImageDescription); virtual; procedure ChooseGetSetColorFunctions; virtual; procedure ChooseRawBitsProc(BitsPerPixel: cardinal; ByteOrder: TRawImageByteOrder; BitOrder: TRawImageBitOrder; out ProcReadRawImageBits: TOnReadRawImageBits; out ProcWriteRawImageBits: TOnWriteRawImageBits); // get color functions procedure GetColor_Generic(x, y: integer; out Value: TFPColor); procedure GetColor_RGBA_NoPalette(x, y: integer; out Value: TFPColor); procedure GetColor_RGB_NoPalette(x, y: integer; out Value: TFPColor); procedure GetColor_Gray_NoPalette(x, y: integer; out Value: TFPColor); procedure GetColor_NULL(x, y: integer; out Value: TFPColor); // 32 bpp alpha procedure GetColor_BPP32_A8R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_A8B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_A8G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_A8G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_A8R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_A8B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_B8G8R8A8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_R8G8B8A8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_G8B8R8A8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_G8R8B8A8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_B8R8G8A8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_R8B8G8A8_BIO_TTB(x, y: integer; out Value: TFPColor); // 32 bpp no alpha procedure GetColor_BPP32_X8R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_X8B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_X8G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_X8G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_X8R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_X8B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_B8G8R8X8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_R8G8B8X8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_G8B8R8X8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_G8R8B8X8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_B8R8G8X8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP32_R8B8G8X8_BIO_TTB(x, y: integer; out Value: TFPColor); // 24 bpp procedure GetColor_BPP24_B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP24_R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP24_G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP24_G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP24_B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetColor_BPP24_R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor); procedure GetMask_Generic(x, y: integer; out AValue: Boolean); // set color functions procedure SetColor_Generic(x, y: integer; const Value: TFPColor); procedure SetColor_RGBA_NoPalette(x, y: integer; const Value: TFPColor); procedure SetColor_RGB_NoPalette(x, y: integer; const Value: TFPColor); procedure SetColor_Gray_NoPalette(x, y: integer; const Value: TFPColor); procedure SetColor_NULL(x, y: integer; const Value: TFPColor); // 32 bpp alpha procedure SetColor_BPP32_A8R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_A8B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_A8G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_A8G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_A8R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_A8B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_B8G8R8A8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_R8G8B8A8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_G8B8R8A8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_G8R8B8A8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_B8R8G8A8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_R8B8G8A8_BIO_TTB(x, y: integer; const Value: TFPColor); // 32 bpp no alpha procedure SetColor_BPP32_X8R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_X8B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_X8G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_X8G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_X8R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_X8B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_B8G8R8X8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_R8G8B8X8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_G8B8R8X8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_G8R8B8X8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_B8R8G8X8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP32_R8B8G8X8_BIO_TTB(x, y: integer; const Value: TFPColor); // 24 bpp procedure SetColor_BPP24_B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP24_R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP24_G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP24_G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP24_B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetColor_BPP24_R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor); procedure SetMask_Generic(x, y: integer; const AValue: Boolean); public constructor Create(AWidth, AHeight: integer); override; constructor Create(AWidth, AHeight: integer; AFlags: TRawImageQueryFlags); constructor Create(ARawImage: TRawImage; ADataOwner: Boolean); destructor Destroy; override; procedure BeginUpdate; procedure EndUpdate; procedure SetSize(AWidth, AHeight: integer); override; function CheckDescription(const ADescription: TRawImageDescription; ExceptionOnError: boolean): boolean; virtual; procedure LoadFromDevice(DC: HDC); virtual; procedure LoadFromBitmap(ABitmap, AMaskBitmap: HBitmap; AWidth: integer = -1; AHeight: integer = -1); virtual; procedure CreateBitmaps(out ABitmap, AMask: HBitmap; ASkipMask: boolean = False); virtual; procedure SetRawImage(const ARawImage: TRawImage; ADataOwner: Boolean = True); virtual; procedure GetRawImage(out ARawImage: TRawImage; ATransferOwnership: Boolean = False); virtual; procedure FillPixels(const Color: TFPColor); virtual; procedure CopyPixels(ASource: TFPCustomImage; XDst: Integer = 0; YDst: Integer = 0; AlphaMask: Boolean = False; AlphaTreshold: Word = 0); virtual; procedure AlphaFromMask(AKeepAlpha: Boolean = True); procedure GetXYDataPosition(x, y: integer; out Position: TRawImagePosition); procedure GetXYMaskPosition(x, y: integer; out Position: TRawImagePosition); function GetDataLineStart(y: integer): Pointer;// similar to Delphi TBitmap.ScanLine. Only works with byte aligned lines. procedure CreateData; virtual; function HasTransparency: boolean; virtual; function HasMask: boolean; virtual; public {$ifdef VER2_0} // workaround for IE200310221 on 2.0.4 property PixelData: PByte read GetPixelData; property MaskData: PByte read GetMaskData; property DataDescription: TRawImageDescription read GetDataDescription write SetDataDescription; {$else} property PixelData: PByte read FRawImage.Data; property MaskData: PByte read FRawImage.Mask; property DataDescription: TRawImageDescription read FRawImage.Description write SetDataDescription; {$endif} property TColors[x,y: integer]: TGraphicsColor read GetTColors write SetTColors; property Masked[x,y:integer]: Boolean read GetMasked write SetMasked; end; { TLazIntfImageMask } TLazIntfImageMask = class(TFPCustomImage) private FImage: TLazIntfImage; protected procedure SetInternalColor(x, y: integer; const Value: TFPColor); override; function GetInternalColor(x, y: integer): TFPColor; override; procedure SetInternalPixel (x,y:integer; Value:integer); override; function GetInternalPixel (x,y:integer) : integer; override; public constructor CreateWithImage(TheImage: TLazIntfImage); virtual; property Image: TLazIntfImage read FImage; end; { TLazAVLPalette } { This descendent of TFPPalette uses an AVL tree for speed up. } TLazAVLPalette = class(TFPPalette) protected FAVLPalette: TAvgLvlTree; // tree of PLazAVLPaletteEntry 'color to index' FAVLNodes: PAvgLvlTreeNode;// 'index to node' array procedure SetCount(NewCount: integer); override; procedure SetColor(Index: integer; const NewColor: TFPColor); override; function CompareEntries(Index1, Index2: integer): integer; function CompareColorWithEntries(const AColor: TFPColor; Index: integer): integer; procedure EnlargeData; override; public destructor Destroy; override; function IndexOf(const AColor: TFPColor): integer; override; function Add(const NewColor: TFPColor): integer; override; procedure CheckConsistency; virtual; end; { TArrayNodesTree } PArrayNode = ^TArrayNode; TArrayNode = class public Parent: TArrayNode; Value: integer; Childs: PArrayNode; StartValue: integer; Capacity: integer; Data: Pointer; constructor Create; destructor Destroy; override; procedure DeleteChilds; procedure UnbindFromParent; procedure CreateChildNode(ChildValue: integer); function GetChildNode(ChildValue: integer; CreateIfNotExists: boolean): TArrayNode; procedure Expand(ValueToInclude: integer); function FindPrevSibling: TArrayNode; function FindNextSibling: TArrayNode; function FindNextUTF8: TArrayNode; function FindPrev: TArrayNode; function FindFirstChild: TArrayNode; function FindLastChild: TArrayNode; function FindLastSubChild: TArrayNode; function FindFirstSibling: TArrayNode; function FindLastSibling: TArrayNode; procedure ConsistencyCheck; end; TArrayNodesTree = class public Root: TArrayNode; function FindNode(Path: PInteger; Count: integer): TArrayNode; function FindData(Path: PInteger; Count: integer): Pointer; function SetNode(Path: PInteger; Count: integer; Data: Pointer): TArrayNode; procedure Delete(Node: TArrayNode); procedure Clear; constructor Create; destructor Destroy; override; procedure ConsistencyCheck; end; { ILazImageReader } { Extention to TFPCustomImageReader to initialize a TRawImgeDescription based on the image to be read } ILazImageReader = interface ['{DD8B14DE-4E97-4816-8B40-DD6C4D8CCD1B}'] function GetUpdateDescription: Boolean; procedure SetUpdateDescription(AValue: Boolean); property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription; end; { TLazReaderXPM } { This is a FPImage reader for xpm images. } TLazReaderXPM = class(TFPCustomImageReader, ILazImageReader) private FWidth: Integer; FHeight: Integer; FColorCount: Integer; FCharsPerPixel: Integer; FXHot: Integer; FYHot: Integer; FPixelToColorTree: TArrayNodesTree; FContinue: Boolean; FUpdateDescription: Boolean; // If set, update rawimagedescription function GetUpdateDescription: Boolean; procedure SetUpdateDescription(AValue: Boolean); protected function QueryInterface(const iid: TGuid; out obj): LongInt; stdcall; function _AddRef: LongInt; stdcall; function _Release: LongInt; stdcall; protected procedure ClearPixelToColorTree; procedure InternalRead(Str: TStream; Img: TFPCustomImage); override; function InternalCheck(Str: TStream): boolean; override; public constructor Create; override; destructor Destroy; override; property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription; end; { TLazWriterXPM } { This is a FPImage writer for xpm images. } TLazWriterXPM = class(TFPCustomImageWriter) private FNibblesPerSample: word; FRightShiftSample: cardinal; FContinue: Boolean; procedure SetNibblesPerSample(const AValue: word); protected procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override; public constructor Create; override; property NibblesPerSample: word read FNibblesPerSample write SetNibblesPerSample; end; { TLazReaderBMP } { This is an imroved FPImage reader for bmp images. } //TODO: improved or not, derive from TFPReaderBMP the get RLE support TLazReaderMaskMode = ( lrmmNone, // no mask is generated lrmmAuto, // a mask is generated based on the first pixel read (*) lrmmColor // a mask is generated based on the given color (*) ); // (*) Note: when reading images with an alpha channel and the alpha channel // has no influence on the mask (unless the maskcolor is transparent) TLazReaderDIB = class (TFPCustomImageReader, ILazImageReader) private FImage: TLazIntfImage; FMaskMode: TLazReaderMaskMode; FMaskColor: TFPColor; // color which should be interpreted as masked FMaskIndex: Integer; // for palette based images, index of the color which should be interpreted as masked FReadSize: Integer; // Size (in bytes) of 1 scanline. FBFI: TBitMapInfoHeader; // The header as read from the stream. FPalette: PFPColor; // Buffer with Palette entries. FBitsPerPixel: Integer; // bits per pixel (1, 4, 8, 15, 16, 24, 32) FLineBuf: PByte; // Buffer for 1 scanline. Can be Byte, Word, TColorRGB or TColorRGBA FIsRLE: Boolean; // Is data RLE compressed? FUpdateDescription: Boolean; // If set, update rawimagedescription FContinue: Boolean; // for progress support procedure FreeBufs; // Free (and nil) buffers. function GetUpdateDescription: Boolean; procedure SetUpdateDescription(AValue: Boolean); protected function QueryInterface(const iid: TGuid; out obj): LongInt; stdcall; function _AddRef: LongInt; stdcall; function _Release: LongInt; stdcall; protected // SetupRead will allocate the needed buffers, and read the colormap if needed. procedure SetupRead(nPalette, nRowBits: Integer; ReadPalette, AIsRLE: Boolean); virtual; procedure ReadScanLine(Row: Integer); virtual; procedure WriteScanLine(Row: Cardinal); virtual; // required by TFPCustomImageReader procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override; procedure InternalReadHead; procedure InternalReadBody; function InternalCheck(Stream: TStream) : boolean; override; property ReadSize: Integer read FReadSize; property LineBuf: PByte read FLineBuf; property BFI: TBitMapInfoHeader read FBFI; property IsRLE: Boolean read FIsRLE; public constructor Create; override; destructor Destroy; override; property MaskColor: TFPColor read FMaskColor write FMaskColor; property MaskMode: TLazReaderMaskMode read FMaskMode write FMaskMode; property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription; end; { TLazReaderBMP } TLazReaderBMP = class(TLazReaderDIB) protected function InternalCheck(Stream: TStream) : boolean; override; end; { TLazReaderIconDIB } { This is a FPImage reader for a single DIB from an icon file } TLazReaderIconDIB = class (TLazReaderDIB) protected procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override; end; { TLazReaderPNG } TLazReaderPNG = class(TFPReaderPNG, ILazImageReader) private FAlphaPalette: Boolean; FUpdateDescription: Boolean; function GetUpdateDescription: Boolean; procedure SetUpdateDescription(AValue: Boolean); protected function QueryInterface(const iid: TGuid; out obj): LongInt; stdcall; function _AddRef: LongInt; stdcall; function _Release: LongInt; stdcall; protected procedure DoDecompress; override; procedure HandleAlpha; override; procedure InternalRead(Str:TStream; Img:TFPCustomImage); override; public property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription; end; { TLazReaderIcnsPart } TLazReaderIcnsPart = class(TFPCustomImageReader, ILazImageReader) private FUpdateDescription: Boolean; FPalette: TFPPalette; FImage: TLazIntfImage; FData: PByte; FCalcSize: Integer; FDataSize: Integer; FIconType: TicnsIconType; FIconInfo: TicnsIconInfo; protected function InternalCheck(Str:TStream): boolean; override; procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override; function QueryInterface(const iid: TGuid; out obj): LongInt; stdcall; function _AddRef: LongInt; stdcall; function _Release: LongInt; stdcall; function GetUpdateDescription: Boolean; procedure SetUpdateDescription(AValue: Boolean); procedure SetupRead(AWidth, AHeight, ADepth: Integer; IsMask: Boolean); function Create256ColorPalette: TFPPalette; procedure DoReadRaw; procedure DoReadRLE; procedure DoReadJpeg2000; procedure DoReadMask; public constructor Create; override; destructor Destroy; override; property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription; property IconType: TicnsIconType read FIconType; property DataSize: Integer read FDataSize; end; // extra Rawimage utility functions function QueryDescription(AFlags: TRawImageQueryFlags; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription; procedure QueryDescription(var ADesc: TRawImageDescription; AFlags: TRawImageQueryFlags; AWidth: Integer = -1; AHeight: integer = -1); function GetDescriptionFromDevice(ADC: HDC; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription; function GetDescriptionFromBitmap(ABitmap: HBitmap; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription; function AddAlphaToDescription(var ADesc: TRawImageDescription; APrec: Byte): Boolean; procedure DefaultReaderDescription(AWidth, AHeight: Integer; ADepth: Byte; out ADesc: TRawImageDescription); function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string; procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream; StartSize: integer); function dbgs(const FPColor: TFPColor): string; overload; implementation uses Graphics; type PFPColorBytes = ^TFPColorBytes; TFPColorBytes = record {$ifdef ENDIAN_LITTLE} Rl, Rh, Gl, Gh, Bl, Bh, Al, Ah: Byte; {$else} Rh, Rl, Gh, Gl, Bh, Bl, Ah, Al: Byte; {$endif} end; PFourBytes = ^TFourBytes; TFourBytes = record B0, B1, B2, B3: Byte; end; var IsSpaceChar, IsNumberChar, IsHexNumberChar: array[char] of Boolean; function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string; var NewLength: Integer; ReadLen: Integer; begin if (Str is TMemoryStream) or (Str is TFileStream) or (Str is TStringStream) then begin // read as one block SetLength(Result,Str.Size-Str.Position); if Result<>'' then Str.Read(Result[1],length(Result)); end else begin // read exponential if StartSize=0 then StartSize:=1024; SetLength(Result,StartSize); NewLength:=0; repeat ReadLen:=Str.Read(Result[NewLength+1],length(Result)-NewLength); inc(NewLength,ReadLen); if NewLength0 then DestStream.Write(Buffer[1],NewLength); end; end; function dbgs(const FPColor: TFPColor): string; begin Result:='r='+hexStr(FPColor.Red,4)+',g='+hexStr(FPColor.green,4) +',b='+hexStr(FPColor.blue,4)+',a='+hexStr(FPColor.alpha,4); end; function QueryDescription(AFlags: TRawImageQueryFlags; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription; begin Exclude(AFlags, riqfUpdate); Result.Init; QueryDescription(Result, AFlags, AWidth, AHeight); end; procedure QueryDescription(var ADesc: TRawImageDescription; AFlags: TRawImageQueryFlags; AWidth: Integer = -1; AHeight: integer = -1); begin if RawImage_QueryDescription(AFlags, ADesc) then begin if AWidth <> -1 then ADesc.Width := AWidth; if AHeight <> -1 then ADesc.Height := AHeight; end else begin if not (riqfUpdate in AFlags) then ADesc.Init; end; end; function GetDescriptionFromDevice(ADC: HDC; AWidth, AHeight: integer): TRawImageDescription; begin Result.Init; if not RawImage_DescriptionFromDevice(ADC, Result) then Exit; if AWidth <> -1 then Result.Width := AWidth; if AHeight <> -1 then Result.Height := AHeight; end; function GetDescriptionFromBitmap(ABitmap: HBitmap; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription; begin Result.Init; if not RawImage_DescriptionFromBitmap(ABitmap, Result) then Exit; if AWidth <> -1 then Result.Width := AWidth; if AHeight <> -1 then Result.Height := AHeight; end; function AddAlphaToDescription(var ADesc: TRawImageDescription; APrec: Byte): Boolean; function CreateBitMask(AShift, APrec: Byte): Cardinal; inline; begin Result := ($FFFFFFFF shr (32 - APrec)) shl AShift; end; var Mask: Cardinal; begin Result:=false; if ADesc.AlphaPrec >= APrec then Exit; if ADesc.BitsPerPixel <> 32 then Exit; if ADesc.Depth <> 24 then Exit; Mask := CreateBitMask(ADesc.RedShift, ADesc.RedPrec) or CreateBitMask(ADesc.GreenShift, ADesc.GreenPrec) or CreateBitMask(ADesc.BlueShift, ADesc.BluePrec); if (Mask and $FF = 0) then begin ADesc.AlphaShift := 0; Result := True; end else if (Mask and $FF000000 = 0) then begin ADesc.AlphaShift := 24; Result := True; end; if Result then begin ADesc.AlphaPrec := APrec; ADesc.Depth := 32; end; end; procedure CheckAlphaDescription(AImage: TFPCustomImage); var Desc: TRawImageDescription; begin if not (AImage is TLazIntfImage) then Exit; Desc := TLazIntfImage(AImage).DataDescription; if Desc.AlphaPrec >= 8 then Exit; if not AddAlphaToDescription(Desc, 8) then begin Desc.Init_BPP32_B8G8R8A8_BIO_TTB(Desc.Width, Desc.Height); // copy mask description with TLazIntfImage(AImage).DataDescription do begin Desc.MaskBitsPerPixel := MaskBitsPerPixel; Desc.MaskShift := MaskShift; Desc.MaskLineEnd := MaskLineEnd; Desc.MaskBitOrder := MaskBitOrder; end; end; TLazIntfImage(AImage).DataDescription := Desc; end; procedure DefaultReaderDescription(AWidth, AHeight: Integer; ADepth: Byte; out ADesc: TRawImageDescription); begin // Default description, assume 24bit for palettebased // Maybe when RawImage palette is supported, other descriptions need to be adjusted. ADesc.Init_BPP24_B8G8R8_M1_BIO_TTB(AWidth, AHeight); case ADepth of 1: begin ADesc.Depth := 1; ADesc.BitsPerPixel := 1; ADesc.Format := ricfGray; ADesc.LineEnd := rileWordBoundary; ADesc.RedPrec := 1; ADesc.RedShift := 0; ADesc.GreenPrec := 1; ADesc.GreenShift := 0; ADesc.BluePrec := 1; ADesc.BlueShift := 0; end; 2..4: begin // ADesc.Depth := 4; // ADesc.BitsPerPixel := 4; end; 5..8: begin // ADesc.Depth := 8; // ADesc.BitsPerPixel := 8; end; 9..15: begin ADesc.Depth := 15; ADesc.BitsPerPixel := 16; ADesc.RedPrec := 5; ADesc.RedShift := 10; ADesc.GreenPrec := 5; ADesc.GreenShift := 5; ADesc.BluePrec := 5; ADesc.BlueShift := 0; end; 16: begin ADesc.Depth := 16; ADesc.BitsPerPixel := 16; ADesc.RedPrec := 5; ADesc.RedShift := 10; ADesc.GreenPrec := 6; ADesc.GreenShift := 5; ADesc.BluePrec := 5; ADesc.BlueShift := 0; end; 17..24: begin // already default end; else ADesc.Depth := 32; ADesc.BitsPerPixel := 32; ADesc.AlphaPrec := 8; ADesc.AlphaShift := 24; end; end; procedure ReadRawImageBits_1_2_4_BIO(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; var Bits: word); var P: PByte; PrecMask: Cardinal; OneByte: Byte; begin PrecMask:=(Cardinal(1) shl Prec)-1; P:=@(TheData[Position.Byte]); OneByte:=P^; Bits:=Word(cardinal(OneByte shr (Shift+Position.Bit)) and PrecMask); if Prec<16 then begin // add missing bits Bits:=(Bits shl (16-Prec)); Bits:=Bits or MissingBits[Prec,Bits shr 13]; end; end; procedure ReadRawImageBits_1_2_4_BNIO(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; var Bits: word); var P: PByte; PrecMask: Cardinal; OneByte: Byte; begin PrecMask:=(Cardinal(1) shl Prec)-1; P:=@(TheData[Position.Byte]); OneByte:=P^; Bits:=Word(cardinal(OneByte shr (Shift+7-Position.Bit)) and PrecMask); if Prec<16 then begin // add missing bits Bits:=(Bits shl (16-Prec)); Bits:=Bits or MissingBits[Prec,Bits shr 13]; end; end; procedure ReadRawImageBits_8(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; var Bits: word); var P: PByte; PrecMask: Cardinal; OneByte: Byte; begin PrecMask:=(Cardinal(1) shl Prec)-1; P:=@(TheData[Position.Byte]); OneByte:=P^; Bits:=Word(cardinal(OneByte shr Shift) and PrecMask); if Prec<16 then begin // add missing bits Bits:=(Bits shl (16-Prec)); Bits:=Bits or MissingBits[Prec,Bits shr 13]; end; end; procedure ReadRawImageBits_16(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; var Bits: word); var P: PByte; PrecMask: Cardinal; TwoBytes: Word; begin PrecMask:=(Cardinal(1) shl Prec)-1; P:=@(TheData[Position.Byte]); TwoBytes:=PWord(P)^; Bits:=Word(cardinal(TwoBytes shr Shift) and PrecMask); if Prec<16 then begin // add missing bits Bits:=(Bits shl (16-Prec)); Bits:=Bits or MissingBits[Prec,Bits shr 13]; end; end; procedure ReadRawImageBits_ReversedBytes_16(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; var Bits: word); var P: PByte; PrecMask: Cardinal; TwoBytes: Word; begin PrecMask:=(Cardinal(1) shl Prec)-1; P:=@(TheData[Position.Byte]); TwoBytes:=PWord(P)^; TwoBytes:=(TwoBytes shr 8) or ((TwoBytes and $ff) shl 8); // switch byte order Bits:=Word(cardinal(TwoBytes shr Shift) and PrecMask); if Prec<16 then begin // add missing bits Bits:=(Bits shl (16-Prec)); Bits:=Bits or MissingBits[Prec,Bits shr 13]; end; end; procedure ReadRawImageBits_24(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; var Bits: word); var P: PByte; PrecMask: Cardinal; FourBytes: Cardinal; begin PrecMask:=(Cardinal(1) shl Prec)-1; P:=@(TheData[Position.Byte]); {$ifdef Endian_Little} FourBytes:=DWord(PWord(P)^) or (DWord((P+2)^) shl 16); {$else} FourBytes:=(DWord(PWord(P)^) shl 8) or DWord(P^); {$endif} Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask); if Prec<16 then begin // add missing bits Bits:=(Bits shl (16-Prec)); Bits:=Bits or MissingBits[Prec,Bits shr 13]; end; end; procedure ReadRawImageBits_ReversedBytes_24(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; var Bits: word); var P: PByte; PrecMask: Cardinal; FourBytes: Cardinal; begin PrecMask:=(Cardinal(1) shl Prec)-1; P:=@(TheData[Position.Byte]); {$ifdef Endian_Little} FourBytes:=(DWord(PWord(P)^) shl 8) or DWord(P^); {$else} FourBytes:=DWord(PWord(P)^) or (DWord((P+2)^) shl 16); {$endif} Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask); if Prec<16 then begin // add missing bits Bits:=(Bits shl (16-Prec)); Bits:=Bits or MissingBits[Prec,Bits shr 13]; end; end; procedure ReadRawImageBits_32(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; var Bits: word); var P: PByte; PrecMask: Cardinal; FourBytes: Cardinal; begin PrecMask:=(Cardinal(1) shl Prec)-1; P:=@(TheData[Position.Byte]); FourBytes:=PDWord(P)^; Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask); if Prec<16 then begin // add missing bits Bits:=(Bits shl (16-Prec)); Bits:=Bits or MissingBits[Prec,Bits shr 13]; end; end; procedure ReadRawImageBits_ReversedBytes_32(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; var Bits: word); var P: PByte; PrecMask: Cardinal; FourBytes: Cardinal; begin PrecMask:=(Cardinal(1) shl Prec)-1; P:=@(TheData[Position.Byte]); FourBytes:=PDWord(P)^; // switch byte order FourBytes:=(FourBytes shr 24) or ((FourBytes shr 8) and $FF00) or ((FourBytes and $ff00) shl 8) or ((FourBytes and $ff) shl 24); Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask); if Prec<16 then begin // add missing bits Bits:=(Bits shl (16-Prec)); Bits:=Bits or MissingBits[Prec,Bits shr 13]; end; end; procedure WriteRawImageBits_1_2_4_BIO(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; Bits: word); var P: PByte; PrecMask: Cardinal; OneByte: Byte; ShiftLeft: Integer; begin P:=@(TheData[Position.Byte]); PrecMask:=(Cardinal(1) shl Prec)-1; Bits:=Bits shr (16-Prec); OneByte:=P^; ShiftLeft:=Shift+Position.Bit; PrecMask:=not (PrecMask shl ShiftLeft); OneByte:=OneByte and PrecMask; // clear old OneByte:=OneByte or (Bits shl ShiftLeft); // set new P^:=OneByte; end; procedure WriteRawImageBits_1_2_4_BNIO(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; Bits: word); var P: PByte; PrecMask: Cardinal; OneByte: Byte; ShiftLeft: Integer; begin P:=@(TheData[Position.Byte]); PrecMask:=(Cardinal(1) shl Prec)-1; Bits:=Bits shr (16-Prec); OneByte:=P^; ShiftLeft:=Shift+7-Position.Bit; PrecMask:=not (PrecMask shl ShiftLeft); OneByte:=OneByte and PrecMask; // clear old OneByte:=OneByte or (Bits shl ShiftLeft); // set new P^:=OneByte; end; procedure WriteRawImageBits_8(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; Bits: word); var P: PByte; PrecMask: Cardinal; OneByte: Byte; begin P:=@(TheData[Position.Byte]); PrecMask:=(Cardinal(1) shl Prec)-1; Bits:=Bits shr (16-Prec); OneByte:=P^; PrecMask:=not (PrecMask shl Shift); OneByte:=OneByte and PrecMask; // clear old OneByte:=OneByte or (Bits shl Shift); // set new P^:=OneByte; end; procedure WriteRawImageBits_16(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; Bits: word); var P: PByte; PrecMask: Cardinal; TwoBytes: Word; begin P:=@(TheData[Position.Byte]); PrecMask:=(Cardinal(1) shl Prec)-1; Bits:=Bits shr (16-Prec); TwoBytes:=PWord(P)^; PrecMask:=not (PrecMask shl Shift); TwoBytes:=TwoBytes and PrecMask; // clear old TwoBytes:=TwoBytes or (Bits shl Shift); // set new PWord(P)^:=TwoBytes; end; procedure WriteRawImageBits_ReversedBytes_16(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; Bits: word); var P: PByte; PrecMask: Cardinal; TwoBytes: Word; begin P:=@(TheData[Position.Byte]); PrecMask:=(Cardinal(1) shl Prec)-1; Bits:=Bits shr (16-Prec); TwoBytes:=PWord(P)^; TwoBytes:=(TwoBytes shr 8) or ((TwoBytes and $ff) shl 8); // switch byte order PrecMask:=not (PrecMask shl Shift); TwoBytes:=TwoBytes and PrecMask; // clear old TwoBytes:=TwoBytes or (Bits shl Shift); // set new TwoBytes:=(TwoBytes shr 8) or ((TwoBytes and $ff) shl 8); // switch byte order PWord(P)^:=TwoBytes; end; procedure WriteRawImageBits_24(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; Bits: word); var P: PByte; PrecMask: Cardinal; FourBytes: Cardinal; begin P:=@(TheData[Position.Byte]); PrecMask:=(Cardinal(1) shl Prec)-1; Bits:=Bits shr (16-Prec); {$ifdef Endian_Little} FourBytes:=DWord(PWord(P)^) or (DWord(P[2]) shl 16); {$else} FourBytes:=(DWord(PWord(P)^) shl 8) or DWord(P^); {$endif} PrecMask:=not (PrecMask shl Shift); FourBytes:=FourBytes and PrecMask; // clear old FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new {$ifdef Endian_little} PWord(P)^ := Word(FourBytes); P[2] := Byte(FourBytes shr 16); {$else} PWord(P)^ := Word(FourBytes shr 8); P[2] := Byte(FourBytes); {$endif} end; procedure WriteRawImageBits_ReversedBytes_24(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; Bits: word); var P: PByte; PrecMask: Cardinal; FourBytes: Cardinal; begin P:=@(TheData[Position.Byte]); PrecMask:=(Cardinal(1) shl Prec)-1; Bits:=Bits shr (16-Prec); {$ifdef Endian_Little} FourBytes:=(DWord(PWord(P)^) shl 8) or DWord(P^); {$else} FourBytes:=DWord(PWord(P)^) or (DWord((P+2)^) shl 16); {$endif} PrecMask:=not (PrecMask shl Shift); FourBytes:=FourBytes and PrecMask; // clear old FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new {$ifdef Endian_little} PWord(P)^ := Word(FourBytes shr 8); P^ := Byte(FourBytes); {$else} PWord(P)^ := Word(FourBytes); (P+2)^ := Byte(FourBytes shr 16); {$endif} end; procedure WriteRawImageBits_32(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; Bits: word); var P: PByte; PrecMask: Cardinal; FourBytes: Cardinal; begin P:=@(TheData[Position.Byte]); PrecMask:=(Cardinal(1) shl Prec)-1; Bits:=Bits shr (16-Prec); FourBytes:=PDWord(P)^; PrecMask:=not (PrecMask shl Shift); FourBytes:=FourBytes and PrecMask; // clear old FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new PDWord(P)^:=FourBytes; end; procedure WriteRawImageBits_ReversedBytes_32(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; Bits: word); var P: PByte; PrecMask: Cardinal; FourBytes: Cardinal; begin P:=@(TheData[Position.Byte]); PrecMask:=(Cardinal(1) shl Prec)-1; Bits:=Bits shr (16-Prec); FourBytes:=PDWord(P)^; // switch byte order FourBytes:=(FourBytes shr 24) or ((FourBytes shr 8) and $FF00) or ((FourBytes and $ff00) shl 8) or ((FourBytes and $ff) shl 24); PrecMask:=not (PrecMask shl Shift); FourBytes:=FourBytes and PrecMask; // clear old FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new // switch byte order FourBytes:=(FourBytes shr 24) or ((FourBytes shr 8) and $FF00) or ((FourBytes and $ff00) shl 8) or ((FourBytes and $ff) shl 24); PDWord(P)^:=FourBytes; end; procedure ReadRawImageBits_NULL(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; var Bits: word); begin Bits:=0; if Prec<16 then begin // add missing bits Bits:=(Bits shl (16-Prec)); Bits:=Bits or MissingBits[Prec,Bits shr 13]; end; end; procedure WriteRawImageBits_NULL(TheData: PByte; const Position: TRawImagePosition; Prec, Shift: cardinal; Bits: word); begin end; { TLazIntfImage } procedure TLazIntfImage.SetDataDescription(const ADescription: TRawImageDescription); begin if CompareMem(@FRawImage.Description, @ADescription, SizeOf(TRawImageDescription)) then Exit; CheckDescription(ADescription, True); BeginUpdate; try FreeData; FRawImage.Description := ADescription; ChooseGetSetColorFunctions; InternalSetSize(ADescription.Width, ADescription.Height); CreateData; finally EndUpdate; end; end; procedure TLazIntfImage.ChooseRawBitsProc(BitsPerPixel: cardinal; ByteOrder: TRawImageByteOrder; BitOrder: TRawImageBitOrder; out ProcReadRawImageBits: TOnReadRawImageBits; out ProcWriteRawImageBits: TOnWriteRawImageBits); begin case BitsPerPixel of 1,2,4: begin if BitOrder = riboBitsInOrder then begin ProcReadRawImageBits := @ReadRawImageBits_1_2_4_BIO; ProcWriteRawImageBits := @WriteRawImageBits_1_2_4_BIO; end else begin ProcReadRawImageBits := @ReadRawImageBits_1_2_4_BNIO; ProcWriteRawImageBits := @WriteRawImageBits_1_2_4_BNIO; end; end; 8: begin ProcReadRawImageBits := @ReadRawImageBits_8; ProcWriteRawImageBits := @WriteRawImageBits_8; end; 16: begin if DefaultByteOrder=ByteOrder then begin ProcReadRawImageBits := @ReadRawImageBits_16; ProcWriteRawImageBits := @WriteRawImageBits_16; end else begin ProcReadRawImageBits := @ReadRawImageBits_ReversedBytes_16; ProcWriteRawImageBits := @WriteRawImageBits_ReversedBytes_16; end; end; 24: begin if DefaultByteOrder=ByteOrder then begin ProcReadRawImageBits := @ReadRawImageBits_24; ProcWriteRawImageBits := @WriteRawImageBits_24; end else begin ProcReadRawImageBits := @ReadRawImageBits_ReversedBytes_24; ProcWriteRawImageBits := @WriteRawImageBits_ReversedBytes_24; end; end; 32: begin if DefaultByteOrder=ByteOrder then begin ProcReadRawImageBits := @ReadRawImageBits_32; ProcWriteRawImageBits := @WriteRawImageBits_32; end else begin ProcReadRawImageBits := @ReadRawImageBits_ReversedBytes_32; ProcWriteRawImageBits := @WriteRawImageBits_ReversedBytes_32; end; end; else DebugLn('WARNING: TLazIntfImage.ChooseRawBitsProc Unsupported BitsPerPixel=',dbgs(BitsPerPixel)); ProcReadRawImageBits := @ReadRawImageBits_NULL; ProcWriteRawImageBits := @WriteRawImageBits_NULL; end; end; procedure TLazIntfImage.ChooseGetSetColorFunctions; function ChooseRGBA_32Bpp: Boolean; var Positions: Byte; begin Result := False; with FRawImage.Description do begin if Depth <> 32 then Exit; if BitsPerPixel <> 32 then Exit; if LineOrder <> riloTopToBottom then Exit; if AlphaPrec <> 8 then Exit; if RedPrec <> 8 then Exit; if GreenPrec <> 8 then Exit; if BluePrec <> 8 then Exit; if AlphaShift and 7 <> 0 then Exit; if RedShift and 7 <> 0 then Exit; if GreenShift and 7 <> 0 then Exit; if BlueShift and 7 <> 0 then Exit; Positions := (((AlphaShift shr 3) and 3) shl 6 or ((RedShift shr 3) and 3) shl 4 or ((GreenShift shr 3) and 3) shl 2 or ((BlueShift shr 3) and 3)) and $FF; if ByteOrder = riboMSBFirst then Positions := not Positions; // reverse positions end; // the locations of A,R,G,B are now coded in 2 bits each: AARRBBGG // the 2-bit value (0..3) represents the location of the channel, // counting from left case Positions of {AARRGGBB} %00011011: begin FGetInternalColorProc := @GetColor_BPP32_A8R8G8B8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_A8R8G8B8_BIO_TTB; end; {AARRGGBB} %00111001: begin FGetInternalColorProc := @GetColor_BPP32_A8B8G8R8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_A8B8G8R8_BIO_TTB; end; {AARRGGBB} %00100111: begin FGetInternalColorProc := @GetColor_BPP32_A8G8R8B8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_A8G8R8B8_BIO_TTB; end; {AARRGGBB} %00110110: begin FGetInternalColorProc := @GetColor_BPP32_A8G8B8R8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_A8G8B8R8_BIO_TTB; end; {AARRGGBB} %00011110: begin FGetInternalColorProc := @GetColor_BPP32_A8R8B8G8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_A8R8B8G8_BIO_TTB; end; {AARRGGBB} %00101101: begin FGetInternalColorProc := @GetColor_BPP32_A8B8R8G8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_A8B8R8G8_BIO_TTB; end; {AARRGGBB} %11100100: begin FGetInternalColorProc := @GetColor_BPP32_B8G8R8A8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_B8G8R8A8_BIO_TTB; end; {AARRGGBB} %11000110: begin FGetInternalColorProc := @GetColor_BPP32_R8G8B8A8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_R8G8B8A8_BIO_TTB; end; {AARRGGBB} %11100001: begin FGetInternalColorProc := @GetColor_BPP32_G8B8R8A8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_G8B8R8A8_BIO_TTB; end; {AARRGGBB} %11010010: begin FGetInternalColorProc := @GetColor_BPP32_G8R8B8A8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_G8R8B8A8_BIO_TTB; end; {AARRGGBB} %11011000: begin FGetInternalColorProc := @GetColor_BPP32_B8R8G8A8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_B8R8G8A8_BIO_TTB; end; {AARRGGBB} %11001001: begin FGetInternalColorProc := @GetColor_BPP32_R8B8G8A8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_R8B8G8A8_BIO_TTB; end; else Exit; end; Result := True; end; function ChooseRGB_32Bpp: Boolean; var Positions: Byte; begin Result := False; with FRawImage.Description do begin if Depth <> 24 then Exit; if BitsPerPixel <> 32 then Exit; if LineOrder <> riloTopToBottom then Exit; if RedPrec <> 8 then Exit; if GreenPrec <> 8 then Exit; if BluePrec <> 8 then Exit; if RedShift and 7 <> 0 then Exit; if GreenShift and 7 <> 0 then Exit; if BlueShift and 7 <> 0 then Exit; Positions := (((RedShift shr 3) and 3) shl 4 or ((GreenShift shr 3) and 3) shl 2 or ((BlueShift shr 3) and 3)) and $FF; if ByteOrder = riboMSBFirst then Positions := not Positions and %00111111; // reverse positions end; // the locations of R,G,B are now coded in 2 bits each: xxRRBBGG // the 2-bit value (0..3) represents the location of the channel, // counting from left case Positions of {xxRRGGBB} %00011011: begin FGetInternalColorProc := @GetColor_BPP32_X8R8G8B8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_X8R8G8B8_BIO_TTB; end; {xxRRGGBB} %00111001: begin FGetInternalColorProc := @GetColor_BPP32_X8B8G8R8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_X8B8G8R8_BIO_TTB; end; {xxRRGGBB} %00100111: begin FGetInternalColorProc := @GetColor_BPP32_X8G8R8B8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_X8G8R8B8_BIO_TTB; end; {xxRRGGBB} %00110110: begin FGetInternalColorProc := @GetColor_BPP32_X8G8B8R8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_X8G8B8R8_BIO_TTB; end; {xxRRGGBB} %00011110: begin FGetInternalColorProc := @GetColor_BPP32_X8R8B8G8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_X8R8B8G8_BIO_TTB; end; {xxRRGGBB} %00101101: begin FGetInternalColorProc := @GetColor_BPP32_X8B8R8G8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_X8B8R8G8_BIO_TTB; end; {xxRRGGBB} %00100100: begin FGetInternalColorProc := @GetColor_BPP32_B8G8R8X8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_B8G8R8X8_BIO_TTB; end; {xxRRGGBB} %00000110: begin FGetInternalColorProc := @GetColor_BPP32_R8G8B8X8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_R8G8B8X8_BIO_TTB; end; {xxRRGGBB} %00100001: begin FGetInternalColorProc := @GetColor_BPP32_G8B8R8X8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_G8B8R8X8_BIO_TTB; end; {xxRRGGBB} %00010010: begin FGetInternalColorProc := @GetColor_BPP32_G8R8B8X8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_G8R8B8X8_BIO_TTB; end; {xxRRGGBB} %00011000: begin FGetInternalColorProc := @GetColor_BPP32_B8R8G8X8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_B8R8G8X8_BIO_TTB; end; {xxRRGGBB} %00001001: begin FGetInternalColorProc := @GetColor_BPP32_R8B8G8X8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP32_R8B8G8X8_BIO_TTB; end; else Exit; end; Result := True; end; function ChooseRGB_24Bpp: Boolean; var Positions: Byte; begin Result := False; with FRawImage.Description do begin if Depth <> 24 then Exit; if BitsPerPixel <> 24 then Exit; if LineOrder <> riloTopToBottom then Exit; if RedPrec <> 8 then Exit; if GreenPrec <> 8 then Exit; if BluePrec <> 8 then Exit; if RedShift and 7 <> 0 then Exit; if GreenShift and 7 <> 0 then Exit; if BlueShift and 7 <> 0 then Exit; if ByteOrder = riboMSBFirst then Positions := ((2-((RedShift shr 3) and 3)) shl 4 or (2-((GreenShift shr 3) and 3)) shl 2 or (2-((BlueShift shr 3) and 3))) and $FF else Positions := (((RedShift shr 3) and 3) shl 4 or ((GreenShift shr 3) and 3) shl 2 or ((BlueShift shr 3) and 3)) and $FF; end; // the locations of R,G,B are now coded in 2 bits each: xxRRBBGG // the 2-bit value (0..3) represents the location of the channel, // counting from left case Positions of {xxRRGGBB} %00100100: begin FGetInternalColorProc := @GetColor_BPP24_B8G8R8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP24_B8G8R8_BIO_TTB; end; {xxRRGGBB} %00000110: begin FGetInternalColorProc := @GetColor_BPP24_R8G8B8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP24_R8G8B8_BIO_TTB; end; {xxRRGGBB} %00100001: begin FGetInternalColorProc := @GetColor_BPP24_G8B8R8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP24_G8B8R8_BIO_TTB; end; {xxRRGGBB} %00010010: begin FGetInternalColorProc := @GetColor_BPP24_G8R8B8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP24_G8R8B8_BIO_TTB; end; {xxRRGGBB} %00011000: begin FGetInternalColorProc := @GetColor_BPP24_B8R8G8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP24_B8R8G8_BIO_TTB; end; {xxRRGGBB} %00001001: begin FGetInternalColorProc := @GetColor_BPP24_R8B8G8_BIO_TTB; FSetInternalColorProc := @SetColor_BPP24_R8B8G8_BIO_TTB; end; else Exit; end; Result := True; end; procedure ChooseRGBAFunctions; begin with FRawImage.Description do begin ChooseRawBitsProc(BitsPerPixel, ByteOrder, BitOrder, FReadRawImageBits, FWriteRawImageBits); if AlphaPrec > 0 then begin FGetInternalColorProc := @GetColor_RGBA_NoPalette; FSetInternalColorProc := @SetColor_RGBA_NoPalette; end else begin FGetInternalColorProc := @GetColor_RGB_NoPalette; FSetInternalColorProc := @SetColor_RGB_NoPalette; end; end; end; begin // Default: use the generic functions, that can handle all kinds of RawImages FGetInternalColorProc := @GetColor_Generic; FSetInternalColorProc := @SetColor_Generic; if FUpdateCount > 0 then begin FGetSetColorFunctionsUpdateNeeded := true; Exit; end; FGetSetColorFunctionsUpdateNeeded := false; with FRawImage.Description do begin if MaskBitsPerPixel > 0 then ChooseRawBitsProc(MaskBitsPerPixel, ByteOrder, MaskBitOrder, FMaskReadRawImageBits, FMaskWriteRawImageBits); if PaletteColorCount = 0 then begin case Format of ricfRGBA: begin if not (ChooseRGBA_32Bpp or ChooseRGB_32Bpp or ChooseRGB_24Bpp) then ChooseRGBAFunctions; end; ricfGray: begin ChooseRawBitsProc(BitsPerPixel, ByteOrder, BitOrder, FReadRawImageBits, FWriteRawImageBits); FGetInternalColorProc := @GetColor_Gray_NoPalette; FSetInternalColorProc := @SetColor_Gray_NoPalette; end; end; end else begin // palette // ToDo DebugLn('WARNING: TLazIntfImage.ChooseGetSetColorFunctions Palette is unsupported'); end; end; end; procedure TLazIntfImage.GetColor_Generic(x, y: integer; out Value: TFPColor); var Position: TRawImagePosition; begin GetXYDataPosition(x,y,Position); if FRawImage.Description.PaletteColorCount = 0 then begin FRawimage.ReadChannels(Position, Value.Red, Value.Green, Value.Blue, Value.Alpha); end else begin // ToDo: read index, then palette Value.Red:=0; Value.Green:=0; Value.Blue:=0; Value.Alpha:=0; end; end; procedure TLazIntfImage.GetMask_Generic(x, y: integer; out AValue: Boolean); var Position: TRawImagePosition; begin if FRawImage.Description.MaskBitsPerPixel = 0 then begin Avalue := False; end else begin GetXYMaskPosition(x,y,Position); FRawimage.ReadMask(Position, AValue); end; end; procedure TLazIntfImage.SetColor_Generic(x, y: integer; const Value: TFPColor); var Position: TRawImagePosition; begin GetXYDataPosition(x,y,Position); if FRawImage.Description.PaletteColorCount = 0 then begin FRawImage.WriteChannels(Position, Value.Red, Value.Green, Value.Blue, Value.Alpha); end else begin // ToDo: Palette end; end; procedure TLazIntfImage.SetMask_Generic(x, y: integer; const AValue: Boolean); var Position: TRawImagePosition; begin if FRawImage.Description.MaskBitsPerPixel = 0 then Exit; GetXYMaskPosition(x,y,Position); FRawImage.WriteMask(Position, AValue); end; procedure TLazIntfImage.GetColor_RGBA_NoPalette(x, y: integer; out Value: TFPColor); var Position: TRawImagePosition; begin GetXYDataPosition(x,y,Position); with FRawImage.Description do begin FReadRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red); FReadRawImageBits(FRawImage.Data, Position, GreenPrec, GreenShift, Value.Green); FReadRawImageBits(FRawImage.Data, Position, BluePrec, BlueShift, Value.Blue); FReadRawImageBits(FRawImage.Data, Position, AlphaPrec, AlphaShift, Value.Alpha); end; end; procedure TLazIntfImage.GetColor_RGB_NoPalette(x, y: integer; out Value: TFPColor); var Position: TRawImagePosition; begin GetXYDataPosition(x,y,Position); with FRawImage.Description do begin FReadRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red); FReadRawImageBits(FRawImage.Data, Position, GreenPrec, GreenShift, Value.Green); FReadRawImageBits(FRawImage.Data, Position, BluePrec, BlueShift, Value.Blue); end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_Gray_NoPalette(x, y: integer; out Value: TFPColor); var Position: TRawImagePosition; begin GetXYDataPosition(x,y,Position); with FRawImage.Description do FReadRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red); Value.Green := Value.Red; Value.Blue := Value.Red; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_A8B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor); var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Ah := B0; VBytes.Al := B0; VBytes.Bh := B1; VBytes.Bl := B1; VBytes.Rh := B2; VBytes.Rl := B2; VBytes.Gh := B3; VBytes.Gl := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_A8B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor); var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Ah := B0; VBytes.Al := B0; VBytes.Bh := B1; VBytes.Bl := B1; VBytes.Rh := B2; VBytes.Rl := B2; VBytes.Gh := B3; VBytes.Gl := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_A8G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor); var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Ah := B0; VBytes.Al := B0; VBytes.Gh := B1; VBytes.Gl := B1; VBytes.Bh := B2; VBytes.Bl := B2; VBytes.Rh := B3; VBytes.Rl := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_A8G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor); var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Ah := B0; VBytes.Al := B0; VBytes.Gh := B1; VBytes.Gl := B1; VBytes.Rh := B2; VBytes.Rl := B2; VBytes.Bh := B3; VBytes.Bl := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_A8R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor); var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Ah := B0; VBytes.Al := B0; VBytes.Rh := B1; VBytes.Rl := B1; VBytes.Bh := B2; VBytes.Bl := B2; VBytes.Gh := B3; VBytes.Gl := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_A8R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Ah := B0; VBytes.Al := B0; VBytes.Rh := B1; VBytes.Rl := B1; VBytes.Gh := B2; VBytes.Gl := B2; VBytes.Bh := B3; VBytes.Bl := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_B8G8R8A8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Bh := B0; VBytes.Bl := B0; VBytes.Gh := B1; VBytes.Gl := B1; VBytes.Rh := B2; VBytes.Rl := B2; VBytes.Ah := B3; VBytes.Al := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_B8R8G8A8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Bh := B0; VBytes.Bl := B0; VBytes.Rh := B1; VBytes.Rl := B1; VBytes.Gh := B2; VBytes.Gl := B2; VBytes.Ah := B3; VBytes.Al := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_G8B8R8A8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Gh := B0; VBytes.Gl := B0; VBytes.Bh := B1; VBytes.Bl := B1; VBytes.Rh := B2; VBytes.Rl := B2; VBytes.Ah := B3; VBytes.Al := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_G8R8B8A8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Gh := B0; VBytes.Gl := B0; VBytes.Rh := B1; VBytes.Rl := B1; VBytes.Bh := B2; VBytes.Bl := B2; VBytes.Ah := B3; VBytes.Al := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_R8B8G8A8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Rh := B0; VBytes.Rl := B0; VBytes.Bh := B1; VBytes.Bl := B1; VBytes.Gh := B2; VBytes.Gl := B2; VBytes.Ah := B3; VBytes.Al := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_R8G8B8A8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Rh := B0; VBytes.Rl := B0; VBytes.Gh := B1; VBytes.Gl := B1; VBytes.Bh := B2; VBytes.Bl := B2; VBytes.Ah := B3; VBytes.Al := B3; end; end; procedure TLazIntfImage.GetColor_BPP32_X8B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Bh := B1; VBytes.Bl := B1; VBytes.Rh := B2; VBytes.Rl := B2; VBytes.Gh := B3; VBytes.Gl := B3; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_X8B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Bh := B1; VBytes.Bl := B1; VBytes.Rh := B2; VBytes.Rl := B2; VBytes.Gh := B3; VBytes.Gl := B3; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_X8G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Gh := B1; VBytes.Gl := B1; VBytes.Bh := B2; VBytes.Bl := B2; VBytes.Rh := B3; VBytes.Rl := B3; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_X8G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Gh := B1; VBytes.Gl := B1; VBytes.Rh := B2; VBytes.Rl := B2; VBytes.Bh := B3; VBytes.Bl := B3; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_X8R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Rh := B1; VBytes.Rl := B1; VBytes.Bh := B2; VBytes.Bl := B2; VBytes.Gh := B3; VBytes.Gl := B3; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_X8R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Rh := B1; VBytes.Rl := B1; VBytes.Gh := B2; VBytes.Gl := B2; VBytes.Bh := B3; VBytes.Bl := B3; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_B8G8R8X8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Bh := B0; VBytes.Bl := B0; VBytes.Gh := B1; VBytes.Gl := B1; VBytes.Rh := B2; VBytes.Rl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_B8R8G8X8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Bh := B0; VBytes.Bl := B0; VBytes.Rh := B1; VBytes.Rl := B1; VBytes.Gh := B2; VBytes.Gl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_G8B8R8X8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Gh := B0; VBytes.Gl := B0; VBytes.Bh := B1; VBytes.Bl := B1; VBytes.Rh := B2; VBytes.Rl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_G8R8B8X8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Gh := B0; VBytes.Gl := B0; VBytes.Rh := B1; VBytes.Rl := B1; VBytes.Bh := B2; VBytes.Bl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_R8B8G8X8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Rh := B0; VBytes.Rl := B0; VBytes.Bh := B1; VBytes.Bl := B1; VBytes.Gh := B2; VBytes.Gl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP32_R8G8B8X8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin VBytes.Rh := B0; VBytes.Rl := B0; VBytes.Gh := B1; VBytes.Gl := B1; VBytes.Bh := B2; VBytes.Bl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP24_B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=24 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin VBytes.Bh := B0; VBytes.Bl := B0; VBytes.Gh := B1; VBytes.Gl := B1; VBytes.Rh := B2; VBytes.Rl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP24_B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=24 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin VBytes.Bh := B0; VBytes.Bl := B0; VBytes.Rh := B1; VBytes.Rl := B1; VBytes.Gh := B2; VBytes.Gl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP24_G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=24 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin VBytes.Gh := B0; VBytes.Gl := B0; VBytes.Bh := B1; VBytes.Bl := B1; VBytes.Rh := B2; VBytes.Rl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP24_G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=24 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin VBytes.Gh := B0; VBytes.Gl := B0; VBytes.Rh := B1; VBytes.Rl := B1; VBytes.Bh := B2; VBytes.Bl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP24_R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=24 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin VBytes.Rh := B0; VBytes.Rl := B0; VBytes.Bh := B1; VBytes.Bl := B1; VBytes.Gh := B2; VBytes.Gl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_BPP24_R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=24 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin VBytes.Rh := B0; VBytes.Rl := B0; VBytes.Gh := B1; VBytes.Gl := B1; VBytes.Bh := B2; VBytes.Bl := B2; end; // no alpha -> set opaque Value.Alpha:=high(Value.Alpha); end; procedure TLazIntfImage.GetColor_NULL(x, y: integer; out Value: TFPColor); //var // Position: TRawImagePosition; begin // GetXYDataPosition(x,y,Position); Value.Red:=0; Value.Green:=0; Value.Blue:=0; Value.Alpha:=0; end; procedure TLazIntfImage.SetColor_RGBA_NoPalette(x, y: integer; const Value: TFPColor); var Position: TRawImagePosition; begin GetXYDataPosition(x,y,Position); with FRawImage.Description do begin FWriteRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red); FWriteRawImageBits(FRawImage.Data, Position, GreenPrec, GreenShift, Value.Green); FWriteRawImageBits(FRawImage.Data, Position, BluePrec, BlueShift, Value.Blue); FWriteRawImageBits(FRawImage.Data, Position, AlphaPrec, AlphaShift, Value.Alpha) end; end; procedure TLazIntfImage.SetColor_RGB_NoPalette(x, y: integer; const Value: TFPColor); var Position: TRawImagePosition; begin GetXYDataPosition(x,y,Position); with FRawImage.Description do begin FWriteRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red); FWriteRawImageBits(FRawImage.Data, Position, GreenPrec, GreenShift, Value.Green); FWriteRawImageBits(FRawImage.Data, Position, BluePrec, BlueShift, Value.Blue); end; // no alpha -> ignore end; procedure TLazIntfImage.SetColor_Gray_NoPalette(x, y: integer; const Value: TFPColor); var Position: TRawImagePosition; begin GetXYDataPosition(x,y,Position); with FRawImage.Description do FWriteRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red); end; procedure TLazIntfImage.SetColor_NULL(x, y: integer; const Value: TFPColor); begin // NULL, not implemented end; procedure TLazIntfImage.SetColor_BPP32_A8R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Ah; B1 := VBytes.Rh; B2 := VBytes.Gh; B3 := VBytes.Bh; end; end; procedure TLazIntfImage.SetColor_BPP32_A8B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Ah; B1 := VBytes.Bh; B2 := VBytes.Gh; B3 := VBytes.Rh; end; end; procedure TLazIntfImage.SetColor_BPP32_A8B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Ah; B1 := VBytes.Bh; B2 := VBytes.Rh; B3 := VBytes.Gh; end; end; procedure TLazIntfImage.SetColor_BPP32_A8G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Ah; B1 := VBytes.Gh; B2 := VBytes.Bh; B3 := VBytes.Rh; end; end; procedure TLazIntfImage.SetColor_BPP32_A8G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Ah; B1 := VBytes.Gh; B2 := VBytes.Rh; B3 := VBytes.Bh; end; end; procedure TLazIntfImage.SetColor_BPP32_A8R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Ah; B1 := VBytes.Rh; B2 := VBytes.Bh; B3 := VBytes.Gh; end; end; procedure TLazIntfImage.SetColor_BPP32_B8G8R8A8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Bh; B1 := VBytes.Gh; B2 := VBytes.Rh; B3 := VBytes.Ah; end; end; procedure TLazIntfImage.SetColor_BPP32_B8R8G8A8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Bh; B1 := VBytes.Rh; B2 := VBytes.Gh; B3 := VBytes.Ah; end; end; procedure TLazIntfImage.SetColor_BPP32_G8B8R8A8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Gh; B1 := VBytes.Bh; B2 := VBytes.Rh; B3 := VBytes.Ah; end; end; procedure TLazIntfImage.SetColor_BPP32_G8R8B8A8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Gh; B1 := VBytes.Rh; B2 := VBytes.Bh; B3 := VBytes.Ah; end; end; procedure TLazIntfImage.SetColor_BPP32_R8B8G8A8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Rh; B1 := VBytes.Bh; B2 := VBytes.Gh; B3 := VBytes.Ah; end; end; procedure TLazIntfImage.SetColor_BPP32_R8G8B8A8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Rh; B1 := VBytes.Gh; B2 := VBytes.Bh; B3 := VBytes.Ah; end; end; procedure TLazIntfImage.SetColor_BPP32_X8R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B1 := VBytes.Rh; B2 := VBytes.Gh; B3 := VBytes.Bh; end; end; procedure TLazIntfImage.SetColor_BPP32_X8B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B1 := VBytes.Bh; B2 := VBytes.Gh; B3 := VBytes.Rh; end; end; procedure TLazIntfImage.SetColor_BPP32_X8B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B1 := VBytes.Bh; B2 := VBytes.Rh; B3 := VBytes.Gh; end; end; procedure TLazIntfImage.SetColor_BPP32_X8G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B1 := VBytes.Gh; B2 := VBytes.Bh; B3 := VBytes.Rh; end; end; procedure TLazIntfImage.SetColor_BPP32_X8G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B1 := VBytes.Gh; B2 := VBytes.Rh; B3 := VBytes.Bh; end; end; procedure TLazIntfImage.SetColor_BPP32_X8R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B1 := VBytes.Rh; B2 := VBytes.Bh; B3 := VBytes.Gh; end; end; procedure TLazIntfImage.SetColor_BPP32_B8G8R8X8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Bh; B1 := VBytes.Gh; B2 := VBytes.Rh; end; end; procedure TLazIntfImage.SetColor_BPP32_B8R8G8X8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Bh; B1 := VBytes.Rh; B2 := VBytes.Gh; end; end; procedure TLazIntfImage.SetColor_BPP32_G8B8R8X8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Gh; B1 := VBytes.Bh; B2 := VBytes.Rh; end; end; procedure TLazIntfImage.SetColor_BPP32_G8R8B8X8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Gh; B1 := VBytes.Rh; B2 := VBytes.Bh; end; end; procedure TLazIntfImage.SetColor_BPP32_R8B8G8X8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Rh; B1 := VBytes.Bh; B2 := VBytes.Gh; end; end; procedure TLazIntfImage.SetColor_BPP32_R8G8B8X8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do begin B0 := VBytes.Rh; B1 := VBytes.Gh; B2 := VBytes.Bh; end; end; procedure TLazIntfImage.SetColor_BPP24_B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin B0 := VBytes.Bh; B1 := VBytes.Gh; B2 := VBytes.Rh; end; end; procedure TLazIntfImage.SetColor_BPP24_B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin B0 := VBytes.Bh; B1 := VBytes.Rh; B2 := VBytes.Gh; end; end; procedure TLazIntfImage.SetColor_BPP24_G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin B0 := VBytes.Gh; B1 := VBytes.Bh; B2 := VBytes.Rh; end; end; procedure TLazIntfImage.SetColor_BPP24_G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin B0 := VBytes.Gh; B1 := VBytes.Rh; B2 := VBytes.Bh; end; end; procedure TLazIntfImage.SetColor_BPP24_R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin B0 := VBytes.Rh; B1 := VBytes.Bh; B2 := VBytes.Gh; end; end; procedure TLazIntfImage.SetColor_BPP24_R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor); // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom // BitsPerPixel=32 var VBytes: TFPColorBytes absolute Value; begin with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do begin B0 := VBytes.Rh; B1 := VBytes.Gh; B2 := VBytes.Bh; end; end; function TLazIntfImage.GetTColors(x, y: integer): TGraphicsColor; begin Result:=FPColorToTColor(Colors[x,y]); end; procedure TLazIntfImage.SetTColors(x, y: integer; const AValue: TGraphicsColor); begin Colors[x,y]:=TColorToFPColor(AValue); end; procedure TLazIntfImage.SetUsePalette(Value: boolean); begin inherited // we can SetUsePalette(False); // Can't handle palettes at the moment end; procedure TLazIntfImage.SetInternalColor(x, y: integer; const Value: TFPColor); begin {if (x=0) and (y=0) then begin // a common bug in the readers is that Alpha is reversed DebugLn('TLazIntfImage.SetInternalColor ',x,',',y,' ',Value.Red,',',Value.Green,',',Value.Blue,',',Value.Alpha); if Value.Alpha<>alphaOpaque then RaiseGDBException(''); end;} FSetInternalColorProc(x,y,Value); {if y=Height-1 then DebugLn(['TLazIntfImage.SetInternalColor x=',x,' y=',y,' ',dbgs(Value),' ',dbgs(GetInternalColor(x,y))]);} end; function TLazIntfImage.GetInternalColor(x, y: integer): TFPColor; begin FGetInternalColorProc(x,y,Result); end; procedure TLazIntfImage.SetInternalPixel(x, y: integer; Value: integer); begin if Palette = nil then Exit; if FRawImage.Description.PaletteColorCount = 0 then begin // Non palettebased image so set the color SetInternalColor(x, y, Palette.Color[Value]); end else begin // TODO: Setting of palette colors end; end; procedure TLazIntfImage.SetMasked(x, y: integer; const AValue: Boolean); begin // CheckIndex(x,y); SetMask_Generic(x, y, AValue); FMaskSet := FMaskSet or AValue; end; function TLazIntfImage.GetInternalPixel(x, y: integer): integer; begin if Palette = nil then Exit(0); if FRawImage.Description.PaletteColorCount = 0 then begin // Non palettebased image so lookup the color Result := Palette.IndexOf(GetInternalColor(x, y)); end else begin // TODO: Setting of palette colors Result := 0; end; end; function TLazIntfImage.GetMasked(x, y: integer): Boolean; begin // CheckIndex (x,y); GetMask_Generic(x, y, Result); end; {$ifdef VER2_0} function TLazIntfImage.GetDataDescription: TRawImageDescription; begin Result := FRawImage.Description; end; function TLazIntfImage.GetMaskData: PByte; begin Result := FRawImage.Mask; end; function TLazIntfImage.GetPixelData: PByte; begin Result := FRawImage.Data; end; {$endif} procedure TLazIntfImage.FreeData; begin if FDataOwner then ReallocMem(FRawImage.Data, 0) else FRawImage.Data := nil; FRawImage.DataSize := 0; if FLineStarts <> nil then Dispose(FLineStarts); FLineStarts := nil; if FDataOwner then ReallocMem(FRawImage.Mask, 0) else FRawImage.Mask := nil; FRawImage.MaskSize := 0; if FMaskLineStarts <> nil then Dispose(FMaskLineStarts); FMaskLineStarts := nil; FMaskSet := False; if FDataOwner then ReallocMem(FRawImage.Palette, 0) else FRawImage.Palette := nil; FRawImage.PaletteSize := 0; // old RawImage data has been cleared/destroyed => so new data must be owned by us FDataOwner := True; end; procedure TLazIntfImage.CreateData; begin if FUpdateCount > 0 then begin FCreateAllDataNeeded := True; Exit; end; FCreateAllDataNeeded := False; FreeData; New(FLineStarts); FLineStarts^.Init(Width, Height, FRawImage.Description.BitsPerPixel, FRawImage.Description.LineEnd, FRawImage.Description.LineOrder); New(FMaskLineStarts); FMaskLineStarts^.Init(Width, Height, FRawImage.Description.MaskBitsPerPixel, FRawImage.Description.MaskLineEnd, FRawImage.Description.LineOrder); FRawImage.CreateData(False); end; function TLazIntfImage.HasTransparency: boolean; begin Result := FMaskSet or FRawImage.IsTransparent(True); end; function TLazIntfImage.HasMask: boolean; begin Result := FMaskSet; end; constructor TLazIntfImage.Create(AWidth, AHeight: integer); begin Create(AWidth, AHeight, []); end; constructor TLazIntfImage.Create(AWidth, AHeight: integer; AFlags: TRawImageQueryFlags); begin FDataOwner := True; FGetInternalColorProc := @GetColor_NULL; FSetInternalColorProc := @SetColor_NULL; inherited Create(AWidth, AHeight); if AFlags <> [] then begin QueryDescription(FRawImage.Description, AFlags, AWidth, AHeight); ChooseGetSetColorFunctions; end; end; constructor TLazIntfImage.Create(ARawImage: TRawImage; ADataOwner: Boolean); var Desc: TRawImageDescription absolute ARawImage.Description; begin BeginUpdate; FRawImage := ARawImage; Create(Desc.Width, Desc.Height, []); FDataOwner := ADataOwner; FCreateAllDataNeeded := False; EndUpdate; New(FLineStarts); FLineStarts^.Init(Width, Height, Desc.BitsPerPixel, Desc.LineEnd, Desc.LineOrder); New(FMaskLineStarts); FMaskLineStarts^.Init(Width, Height, Desc.MaskBitsPerPixel, Desc.MaskLineEnd, Desc.LineOrder); ChooseGetSetColorFunctions; end; destructor TLazIntfImage.Destroy; begin FreeData; inherited Destroy; end; procedure TLazIntfImage.AlphaFromMask(AKeepAlpha: Boolean); var x, y, xStop, yStop: Integer; Color: TFPColor; begin if FRawImage.Mask = nil then Exit; if FRawImage.MaskSize = 0 then Exit; xStop := Width - 1; yStop := Height - 1; if AKeepAlpha then begin for y:=0 to yStop do for x:=0 to xStop do begin if not Masked[x,y] then Continue; Color := Colors[x,y]; Color.alpha := Low(Color.alpha); Colors[x,y] := Color; end; end else begin for y:=0 to yStop do for x:=0 to xStop do begin Color := Colors[x,y]; if Masked[x,y] then Color.alpha := Low(Color.alpha) else Color.alpha := High(Color.alpha); Colors[x,y] := Color; end; end; end; procedure TLazIntfImage.BeginUpdate; begin Inc(FUpdateCount); end; procedure TLazIntfImage.EndUpdate; begin if FUpdateCount = 0 then Exit; Dec(FUpdateCount); if FUpdateCount > 0 then Exit; if FCreateAllDataNeeded then CreateData; if FGetSetColorFunctionsUpdateNeeded then ChooseGetSetColorFunctions; end; procedure TLazIntfImage.InternalSetSize(AWidth, AHeight: integer); procedure Error; begin raise FPImageException.Create('Invalid Size'); end; begin if (AWidth = Width) and (AHeight = Height) then exit; if (AWidth<0) or (AHeight<0) then Error; inherited SetSize(AWidth, AHeight); FRawImage.Description.Width := Width; FRawImage.Description.Height := Height; end; procedure TLazIntfImage.SetSize(AWidth, AHeight: integer); begin InternalSetSize(AWidth, AHeight); CreateData; end; function TLazIntfImage.CheckDescription( const ADescription: TRawImageDescription; ExceptionOnError: boolean ): boolean; procedure DoError(const Msg: string); begin if ExceptionOnError then Raise FPImageException.Create(Msg); DebugLn('TLazIntfImage.CheckDescription: ',Msg); end; begin Result:=false; // check format if (not (ADescription.Format in [low(TRawImageColorFormat)..high(TRawImageColorFormat)])) then begin DoError('Invalid Raw Image Description Format'); exit; end; Result:=true; end; procedure TLazIntfImage.GetXYDataPosition(x, y: integer; out Position: TRawImagePosition); begin Position := FLineStarts^.GetPosition(x, y); end; procedure TLazIntfImage.GetXYMaskPosition(x, y: integer; out Position: TRawImagePosition); begin Position := FMaskLineStarts^.GetPosition(x, y); end; function TLazIntfImage.GetDataLineStart(y: integer): Pointer; begin if FRawimage.Description.LineOrder = riloBottomToTop then y:=Height-y; Result := FRawImage.Data+FLineStarts^.Positions[y].Byte; end; procedure TLazIntfImage.LoadFromDevice(DC: HDC); var R: TRect; RawImage: TRawImage; DeviceSize: TPoint; begin GetDeviceSize(DC, DeviceSize); R := Rect(0,0,DeviceSize.X,DeviceSize.Y); if not RawImage_FromDevice(RawImage, DC, R) then raise FPImageException.Create('Failed to get raw image from device'); SetRawImage(RawImage); end; procedure TLazIntfImage.LoadFromBitmap(ABitmap, AMaskBitmap: HBitmap; AWidth: integer; AHeight: integer); var R: TRect; RawImage: TRawImage; Desc: TRawImageDescription; begin if not RawImage_DescriptionFromBitmap(ABitmap, Desc) then raise FPImageException.Create('Failed to get raw image description from bitmap'); if AWidth < 0 then AWidth := Desc.Width; if AHeight < 0 then AHeight := Desc.Height; R := Rect(0, 0, AWidth, AHeight); if not RawImage_FromBitmap(RawImage, ABitmap, AMaskBitmap, @R) then raise FPImageException.Create('Failed to get raw image from bitmap'); SetRawImage(RawImage); end; procedure TLazIntfImage.CreateBitmaps(out ABitmap, AMask: HBitmap; ASkipMask: boolean); begin if not RawImage_CreateBitmaps(FRawImage, ABitmap, AMask, ASkipMask) then raise FPImageException.Create('Failed to create handles'); end; procedure TLazIntfImage.SetRawImage(const ARawImage: TRawImage; ADataOwner: Boolean); var Desc: TRawImageDescription absolute ARawImage.Description; begin if FRawImage.IsEqual(ARawImage) then Exit; BeginUpdate; try FreeData; FRawImage := ARawImage; FDataOwner := ADataOwner; SetSize(Desc.Width, Desc.Height); FCreateAllDataNeeded := False; New(FLineStarts); FLineStarts^.Init(Width, Height, Desc.BitsPerPixel, Desc.LineEnd, Desc.LineOrder); New(FMaskLineStarts); FMaskLineStarts^.Init(Width, Height, Desc.MaskBitsPerPixel, Desc.MaskLineEnd, Desc.LineOrder); ChooseGetSetColorFunctions; finally EndUpdate; end; end; procedure TLazIntfImage.GetRawImage(out ARawImage: TRawImage; ATransferOwnership: Boolean); begin ARawImage := FRawImage; if ATransferOwnership then FDataOwner := False; end; procedure TLazIntfImage.FillPixels(const Color: TFPColor); var ColorChar: char; ColorWord: Word; Cnt: Integer; i: Integer; ColorDWord: Cardinal; y: Integer; x: Integer; begin if (Width=0) or (Height=0) or (FRawImage.Data=nil) then exit; case FRawImage.Description.BitsPerPixel of 8: begin SetInternalColor(0,0,Color); ColorChar:=Char(FRawImage.Data[0]); FillChar(FRawImage.Data^,FRawImage.DataSize,ColorChar); end; 16: begin SetInternalColor(0,0,Color); ColorWord:=PWord(FRawImage.Data)[0]; Cnt:=FRawImage.DataSize div 2; for i:=0 to Cnt-1 do PWord(FRawImage.Data)[i]:=ColorWord; end; 32: begin SetInternalColor(0,0,Color); ColorDWord:=PDWord(FRawImage.Data)[0]; Cnt:=FRawImage.DataSize div 4; for i:=0 to Cnt-1 do PDWord(FRawImage.Data)[i]:=ColorDWord; end; else for y:=0 to Height-1 do for x:=0 to Width-1 do SetInternalColor(x,y,Color); end; // ToDo: mask end; procedure TLazIntfImage.CopyPixels(ASource: TFPCustomImage; XDst, YDst: Integer; AlphaMask: Boolean; AlphaTreshold: Word); var SrcImg: TLazIntfImage absolute ASource; SrcHasMask, DstHasMask: Boolean; x, y, xStop, yStop: Integer; c: TFPColor; begin { if (Src.Width<>Width) or (Src.Height<>Height) then SetSize(Src.Width,Src.Height); } if (ASource is TLazIntfImage) and FRawImage.Description.IsEqual(SrcImg.FRawImage.Description) and (XDst = 0) and (YDst = 0) then begin // same description -> copy if FRawImage.Data <> nil then System.Move(SrcImg.FRawImage.Data^,FRawImage.Data^,FRawImage.DataSize); if FRawImage.Mask <> nil then System.Move(SrcImg.FRawImage.Mask^,FRawImage.Mask^,FRawImage.MaskSize); Exit; end; // copy pixels xStop := ASource.Width; if Width - XDst < xStop then xStop := Width - XDst; yStop := ASource.Height; if Height - YDst < yStop then yStop := Height - YDst; Dec(xStop); Dec(yStop); if ASource is TLazIntfImage then SrcHasMask := SrcImg.FRawImage.Description.MaskBitsPerPixel > 0 else SrcHasMask := False; DstHasMask := FRawImage.Description.MaskBitsPerPixel > 0; if DstHasMask and (ASource is TLazIntfImage) then begin for y:=0 to yStop do for x:=0 to xStop do Masked[x+XDst,y+YDst] := SrcHasMask and SrcImg.Masked[x,y]; end; for y:=0 to yStop do for x:=0 to xStop do begin c := ASource.Colors[x,y]; if not DstHasMask and SrcHasMask and (c.alpha = $FFFF) then // copy mask to alpha channel if SrcImg.Masked[x,y] then c.alpha := 0; Colors[x+XDst,y+YDst] := c; if AlphaMask and (c.alpha < AlphaTreshold) then Masked[x+XDst,y+YDst] := True; end; end; { TLazReaderXPM } type TXPMPixelToColorEntry = record Color: TFPColor; end; PXPMPixelToColorEntry = ^TXPMPixelToColorEntry; procedure TLazReaderXPM.ClearPixelToColorTree; var Entry: PXPMPixelToColorEntry; ArrNode: TArrayNode; begin if FPixelToColorTree<>nil then begin ArrNode:=FPixelToColorTree.Root; while ArrNode<>nil do begin Entry:=PXPMPixelToColorEntry(ArrNode.Data); if Entry<>nil then begin //DebugLn('TLazReaderXPM.ClearPixelToColorTree A ',DbgS(ArrNode),' ',DbgS(Entry)); Dispose(Entry); end; ArrNode:=ArrNode.FindNextUTF8; end; FPixelToColorTree.Free; FPixelToColorTree:=nil; end; end; procedure TLazReaderXPM.InternalRead(Str: TStream; Img: TFPCustomImage); type TSrcLine = record StartPos: integer; EndPos: integer; end; var SrcPos: integer; Src: String; SrcLen: Integer; CurLineNumber, LastLineStart: integer; HasAlpha: Boolean; procedure RaiseXPMReadError(const Msg: string; ReadPos: integer); var CurColumn: Integer; begin CurColumn:=ReadPos-LastLineStart+1; raise Exception.Create(Msg +' in xpm stream at line '+IntToStr(CurLineNumber) +' column '+IntToStr(CurColumn)); end; // read next string constant "" and skip comments function ReadNextLine(var Line: TSrcLine; ExceptionOnNotFound: Boolean): boolean; begin while SrcPos<=SrcLen do begin case Src[SrcPos] of #10,#13: begin // count linenumbers for nicer error output inc(SrcPos); inc(CurLineNumber); if (SrcPos<=SrcLen) and (Src[SrcPos] in [#10,#13]) and (Src[SrcPos]<>Src[SrcPos-1]) then inc(SrcPos); LastLineStart:=SrcPos; end; '/': begin if (SrcPos skip comment inc(SrcPos,2); while (SrcPos'\') then begin // string end found Line.EndPos:=SrcPos; //DebugLn(' ',copy(Src,Line.StartPos-1,Line.EndPos-Line.StartPos+2)); inc(SrcPos); Result:=true; exit; end; inc(SrcPos); end; end; else inc(SrcPos); end; end; Result:=false; if ExceptionOnNotFound then Raise Exception.Create('Unexpected end of xpm stream'); end; function ReadNumber(var ReadPos: integer; ExceptionOnNotFound: Boolean): integer; begin // skip spaces while IsSpaceChar[Src[ReadPos]] do inc(ReadPos); // read number Result:=0; if IsNumberChar[Src[ReadPos]] then begin repeat Result:=Result*10+ord(Src[ReadPos])-Ord('0'); inc(ReadPos); until not IsNumberChar[Src[ReadPos]]; end else if ExceptionOnNotFound then RaiseXPMReadError('number expected',ReadPos); end; procedure ReadHeader; var FirstLine: TSrcLine; begin ReadNextLine(FirstLine,true); FWidth:=ReadNumber(FirstLine.StartPos,true); FHeight:=ReadNumber(FirstLine.StartPos,true); FColorCount:=ReadNumber(FirstLine.StartPos,true); FCharsPerPixel:=ReadNumber(FirstLine.StartPos,true); fXHot:=ReadNumber(FirstLine.StartPos,false); fYHot:=ReadNumber(FirstLine.StartPos,fXHot<>0); //DebugLn('ReadHeader A Width=',FWidth,' Height=',FHeight,' ColorCount=',FColorCount,' CharsPerPixel=',FCharsPerPixel); // ToDo: parse XPMExt tag end; function HexToColor(HexStart, HexEnd: integer): TFPColor; procedure ReadHexNumber(var StartPos: integer; Len: integer; var Number: word); var c: Char; i: Integer; begin Number:=0; for i:=1 to 4 do begin Number:=Number shl 4; if i<=Len then begin c:=Src[StartPos]; case c of '0'..'9': inc(Number,ord(c)-ord('0')); 'A'..'F': inc(Number,ord(c)-ord('A')+10); 'a'..'f': inc(Number,ord(c)-ord('a')+10); end; inc(StartPos); end; end; // fill missing bits case Len of 1: Number:=Number or (Number shr 4) or (Number shr 8) or (Number shr 12); 2: Number:=Number or (Number shr 8); 3: Number:=Number or (Number shr 12); end; end; var HexLen: Integer; SampleLen: Integer; SampleStart: Integer; begin HexLen:=HexEnd-HexStart; case HexLen of 3: SampleLen:=1; 6: SampleLen:=2; 9: SampleLen:=3; 12:SampleLen:=4; else RaiseXPMReadError('hexnumber expected',HexStart); end; SampleStart:=HexStart; ReadHexNumber(SampleStart,SampleLen,Result.Red); ReadHexNumber(SampleStart,SampleLen,Result.Green); ReadHexNumber(SampleStart,SampleLen,Result.Blue); Result.Alpha:=alphaOpaque; end; function TextToColor(TextStart, TextEnd: integer): TFPColor; var s: String; begin s := lowercase(copy(Src,TextStart,TextEnd-TextStart)); if s = 'transparent' then Result := FPImage.colTransparent else if s = 'none' then Result := FPImage.colTransparent else if s = 'black' then result := FPImage.colBlack else if s = 'blue' then Result := FPImage.colBlue else if s = 'green' then Result := FPImage.colGreen else if s = 'cyan' then Result := FPImage.colCyan else if s = 'red' then Result := FPImage.colRed else if s = 'magenta' then Result := FPImage.colMagenta else if s = 'yellow' then Result := FPImage.colYellow else if s = 'white' then Result := FPImage.colWhite else if s = 'gray' then Result := FPImage.colGray else if s = 'lightgray' then Result := FPImage.colLtGray else if (s = 'darkgray') or (s='grey') then Result := FPImage.colDKGray else if s = 'darkblue' then Result := FPImage.colDkBlue else if s = 'darkgreen' then Result := FPImage.colDkGreen else if s = 'darkcyan' then Result := FPImage.colDkCyan else if s = 'darkred' then Result := FPImage.colDkRed else if s = 'darkmagenta' then Result := FPImage.colDkMagenta else if s = 'darkyellow' then Result := FPImage.colDkYellow else if s = 'maroon' then Result := FPImage.colMaroon else if s = 'lightgreen' then Result := FPImage.colLtGreen else if s = 'olive' then Result := FPImage.colOlive else if s = 'navy' then Result := FPImage.colNavy else if s = 'purple' then Result := FPImage.colPurple else if s = 'teal' then Result := FPImage.colTeal else if s = 'silver' then Result := FPImage.colSilver else if s = 'lime' then Result := FPImage.colLime else if s = 'fuchsia' then Result := FPImage.colFuchsia else if s = 'aqua' then Result := FPImage.colAqua else Result := FPImage.colTransparent; end; procedure AddColor(PixelStart: integer; const AColor: TFPColor; IntArray: PInteger); var NewEntry: PXPMPixelToColorEntry; i: Integer; begin {DebugLn('TLazReaderXPM.InternalRead.AddColor A "',DbgStr(copy(Src,PixelStart,FCharsPerPixel)),'"=', DbgS(AColor.Red),',', DbgS(AColor.Green),',', DbgS(AColor.Blue),',', DbgS(AColor.Alpha));} New(NewEntry); NewEntry^.Color:=AColor; // add entry to Array Tree if FPixelToColorTree=nil then FPixelToColorTree:=TArrayNodesTree.Create; for i:=0 to FCharsPerPixel-1 do IntArray[i]:=ord(Src[PixelStart+i]); FPixelToColorTree.SetNode(IntArray,FCharsPerPixel,NewEntry); //if FPixelToColorTree.FindData(IntArray,FCharsPerPixel)<>NewEntry then RaiseGDBException(''); end; procedure ReadPalette(IntArray: PInteger); var i: Integer; Line: TSrcLine; ReadPos: Integer; ColorStart: Integer; ColorEnd: Integer; NewColor: TFPColor; PixelStart: Integer; begin for i:=1 to FColorCount do begin ReadNextLine(Line,true); ReadPos:=Line.StartPos; // read pixel string PixelStart:=ReadPos; inc(ReadPos,FCharsPerPixel); // skip spaces while IsSpaceChar[Src[ReadPos]] do inc(ReadPos); // read 'c' (sometimes the 'c' is an 's') if not (Src[ReadPos] in ['c','s']) then RaiseXPMReadError('"c" expected',ReadPos); inc(ReadPos); // skip spaces while IsSpaceChar[Src[ReadPos]] do inc(ReadPos); // read color string ColorStart:=ReadPos; if Src[ReadPos]='#' then begin inc(ColorStart); // read as hexnumber repeat inc(ReadPos); until not (IsHexNumberChar[Src[ReadPos]]); ColorEnd:=ReadPos; NewColor:=HexToColor(ColorStart,ColorEnd); end else begin // read as text repeat inc(ReadPos); until not (Src[ReadPos] in ['A'..'Z','a'..'z']); ColorEnd:=ReadPos; NewColor:=TextToColor(ColorStart,ColorEnd); end; AddColor(PixelStart,NewColor,IntArray); HasAlpha := HasAlpha or (NewColor.alpha <> alphaOpaque); end; end; procedure ReadPixels(IntArray: PInteger); var y: Integer; Line: TSrcLine; ReadPos: Integer; x: Integer; i: Integer; CurColor: TFPColor; CurEntry: PXPMPixelToColorEntry; begin Img.SetSize(FWidth, FHeight); for y := 0 to FHeight - 1 do begin if not FContinue then Exit; ReadNextLine(Line,true); ReadPos:=Line.StartPos; if Line.EndPos-Line.StartPosnil then CurColor:=CurEntry^.Color else RaiseXPMReadError('invalid color',ReadPos-FCharsPerPixel); {if CurEntry2<>CurEntry then begin DebugLn('x=',x,' y=',y,' Pixel=',Entry^.Pixel, ' RefPixel=',CurEntry^.Pixel, ' Color=', DbgS(CurColor.Red),',', DbgS(CurColor.Green),',', DbgS(CurColor.Blue),',', DbgS(CurColor.Alpha)); DebugLn('Entry2: Pixel=',CurEntry2^.Pixel, ' RefPixel=',CurEntry2^.Pixel, ' Color=', DbgS(CurEntry2^.Color.Red),',', DbgS(CurEntry2^.Color.Green),',', DbgS(CurEntry2^.Color.Blue),',', DbgS(CurEntry2^.Color.Alpha)); end;} {DebugLn('x=',x,' y=',y,' Pixel=',Entry^.Pixel, ' RefPixel=',PXPMPixelToColorEntry(Node.Data)^.Pixel, ' Color=', DbgS(CurColor.Red),',', DbgS(CurColor.Green),',', DbgS(CurColor.Blue),',', DbgS(CurColor.Alpha));} Img.Colors[x,y]:=CurColor; end; Progress(psRunning, trunc(100.0 * (Y + 1) / FHeight), False, Rect(0, 0, FWidth - 1, y), 'reading XPM pixels', FContinue); end; end; var IntArray: array of Integer; Desc: TRawImageDescription; begin FContinue := True; Progress(psStarting, 0, False, Rect(0,0,0,0), '', FContinue); ClearPixelToColorTree; Src:=ReadCompleteStreamToString(Str,1024); SrcLen:=length(Src); SrcPos:=1; CurLineNumber:=1; LastLineStart:=1; ReadHeader; SetLength(IntArray, FCharsPerPixel+1); HasAlpha := False; ReadPalette(@IntArray[0]); if FUpdateDescription and (theImage is TLazIntfImage) then begin if HasAlpha then DefaultReaderDescription(FWidth, FHeight, 32, Desc) else DefaultReaderDescription(FWidth, FHeight, 24, Desc); // MWE: keep mask ? // if FMaskMode = lrmmNone // then Desc.MaskBitsPerPixel := 0; TLazIntfImage(theImage).DataDescription := Desc; end else begin if HasAlpha then CheckAlphaDescription(TheImage); end; //FPixelToColorTree.ConsistencyCheck; ReadPixels(@IntArray[0]); Progress(psEnding, 100, false, Rect(0,0,0,0), '', FContinue); end; function TLazReaderXPM.QueryInterface(const iid: TGuid; out obj): longint; stdcall; begin if GetInterface(iid, obj) then Result := S_OK else Result := E_NOINTERFACE; end; procedure TLazReaderXPM.SetUpdateDescription(AValue: Boolean); begin FUpdateDescription := AValue; end; function TLazReaderXPM._AddRef: LongInt; stdcall; begin Result := -1; end; function TLazReaderXPM._Release: LongInt; stdcall; begin Result := -1; end; function TLazReaderXPM.InternalCheck(Str: TStream): boolean; var s : string[9]; l : integer; begin try l := str.Read (s[1],9); s[0] := char(l); if l <> 9 then result := False else result := (s = '/* XPM */'); except result := false; end; end; constructor TLazReaderXPM.Create; begin inherited Create; end; destructor TLazReaderXPM.Destroy; begin ClearPixelToColorTree; inherited Destroy; end; function TLazReaderXPM.GetUpdateDescription: Boolean; begin Result := FUpdateDescription; end; { TLazAVLPalette } type TLazAVLPaletteEntry = record Palette: TLazAVLPalette; Index: integer; end; PLazAVLPaletteEntry = ^TLazAVLPaletteEntry; function CompareLazAVLPaletteEntries(Entry1, Entry2: PLazAVLPaletteEntry): integer; begin Result := Entry1^.Palette.CompareEntries(Entry1^.Index, Entry2^.Index); end; function ComparePFPColorAndLazAVLPalEntry(PColor: PFPColor; Entry: PLazAVLPaletteEntry): integer; begin Result := Entry^.Palette.CompareColorWithEntries(PColor^, Entry^.Index); end; procedure TLazAVLPalette.SetCount(NewCount: integer); var NewAVLPalEntry: PLazAVLPaletteEntry; AVLNode: TAvgLvlTreeNode; CurAVLPalEntry: PLazAVLPaletteEntry; Index: Integer; begin if FCount=NewCount then exit; // remove unused colors from 'color to index' tree if FAVLPalette<>nil then begin for Index:=FCount-1 downto NewCount do begin AVLNode:=FAVLNodes[Index]; CurAVLPalEntry:=PLazAVLPaletteEntry(AVLNode.Data); FAVLPalette.Delete(AVLNode); FAVLNodes[Index]:=nil; Dispose(CurAVLPalEntry); end; end; inherited SetCount(NewCount); // create tree if not already done if (FAVLPalette=nil) and (FCount>0) then FAVLPalette:=TAvgLvlTree.Create(TListSortCompare(@CompareLazAVLPaletteEntries)); if FAVLPalette=nil then exit; // add new colors to 'color to index' tree and 'index to node' array while FAVLPalette.Count0 then FreeMem(FAVLNodes); inherited Destroy; end; function TLazAVLPalette.IndexOf(const AColor: TFPColor): integer; var Node: TAvgLvlTreeNode; begin if FAVLPalette<>nil then Node:=FAVLPalette.FindKey(@AColor,TListSortCompare(@ComparePFPColorAndLazAVLPalEntry)) else Node:=nil; if Node<>nil then Result:=PLazAVLPaletteEntry(Node.Data)^.Index else Result:=Add(AColor); end; function TLazAVLPalette.Add(const NewColor: TFPColor): integer; begin Result:=FCount; if FCount=FCapacity then EnlargeData; SetCount(FCount+1); SetColor(Result,NewColor); end; function TLazAVLPalette.CompareEntries(Index1, Index2: integer): integer; begin Result:=CompareColors(FData^[Index1],FData^[Index2]); end; function TLazAVLPalette.CompareColorWithEntries(const AColor: TFPColor; Index: integer): integer; begin Result:=CompareColors(AColor,FData^[Index]); end; procedure TLazAVLPalette.EnlargeData; var NewCapacity: Integer; begin if FCapacity<16 then NewCapacity:=32 else if FCapacity<64 then NewCapacity:=128 else NewCapacity:=FCapacity*2; ReallocMem(FData,SizeOf(TFPColor)*NewCapacity); ReallocMem(FAVLNodes,SizeOf(Pointer)*NewCapacity); FCapacity:=NewCapacity; end; procedure TLazAVLPalette.CheckConsistency; var Node: TAvgLvlTreeNode; Entry: PLazAVLPaletteEntry; i: Integer; begin if FAVLPalette<>nil then begin if FAVLPalette.ConsistencyCheck<>0 then RaiseGDBException('TLazAVLPalette.ConsistencyCheck'); if FAVLPalette.Count<>FCount then RaiseGDBException('TLazAVLPalette.ConsistencyCheck'); end; if FAVLNodes<>nil then begin for i:=0 to FCapacity-1 do begin Node:=FAVLNodes[i]; if i>=FCount then begin continue; end; if Node=nil then RaiseGDBException('TLazAVLPalette.ConsistencyCheck'); Entry:=PLazAVLPaletteEntry(Node.Data); if Entry=nil then RaiseGDBException('TLazAVLPalette.ConsistencyCheck'); if Entry^.Index<>i then RaiseGDBException('TLazAVLPalette.ConsistencyCheck'); if Entry^.Palette<>Self then RaiseGDBException('TLazAVLPalette.ConsistencyCheck'); end; end; end; { TLazWriterXPM } const DefXPMPalChars = '.,-*abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ' +'0123456789@#;:=+%$()[]'; procedure TLazWriterXPM.SetNibblesPerSample(const AValue: word); begin if FNibblesPerSample=AValue then exit; FNibblesPerSample:=AValue; if FNibblesPerSample>4 then FNibblesPerSample:=4; FRightShiftSample:=(4-FNibblesPerSample)*4; end; procedure TLazWriterXPM.InternalWrite(Str: TStream; Img: TFPCustomImage); var Palette: TLazAVLPalette; PixelStrings: ^AnsiString; ColorStrings: ^AnsiString; CharsPerPixel: Integer; LineEnd: string; function GetColor(x,y: integer): TFPColor; begin Result:=Img.Colors[x,y]; if (Result.Alpha>=(alphaOpaque shr 1)) then Result.Alpha:=alphaOpaque else Result:=colTransparent; Result.Red:=Result.Red shr FRightShiftSample; Result.Green:=Result.Green shr FRightShiftSample; Result.Blue:=Result.Blue shr FRightShiftSample; end; function SampleToHex(Sample: word): string; begin Result:=HexStr(Sample,FNibblesPerSample); end; procedure BuildPalette; var x: Integer; y: Integer; PixelStringsSize: Integer; i: Integer; Rest: Integer; c: char; CharPos: Integer; ColorStringsSize: Integer; Color: TFPColor; begin // create Palette Palette:=TLazAVLPalette.Create(0); for y:=0 to Img.Height-1 do for x:=0 to Img.Width-1 do Palette.IndexOf(GetColor(x,y)); // calclulate CharsPerPixel CharsPerPixel:=0; i:=Palette.Count; while i>0 do begin i:=i div length(DefXPMPalChars); inc(CharsPerPixel); end; // create pixel strings PixelStringsSize:=SizeOf(Pointer)*Palette.Count; ReAllocMem(PixelStrings,PixelStringsSize); FillChar(PixelStrings^,PixelStringsSize,0); for i:=0 to Palette.Count-1 do begin SetLength(PixelStrings[i],CharsPerPixel); Rest:=i; for CharPos:=CharsPerPixel downto 1 do begin c:=DefXPMPalChars[(Rest mod length(DefXPMPalChars))+1]; PixelStrings[i][CharPos]:=c; Rest:=Rest div length(DefXPMPalChars); end; end; // create color strings ColorStringsSize:=SizeOf(Pointer)*Palette.Count; ReAllocMem(ColorStrings,ColorStringsSize); FillChar(ColorStrings^,ColorStringsSize,0); for i:=0 to Palette.Count-1 do begin Color:=Palette[i]; if Color.Alpha=0 then begin ColorStrings[i]:='None'; end else begin ColorStrings[i]:='#'+SampleToHex(Color.Red)+SampleToHex(Color.Green) +SampleToHex(Color.Blue); end; end; end; procedure WriteString(const s: string); begin Str.Write(s[1],length(s)); end; procedure WriteHeader; var s: String; begin s:='/* XPM */'+LineEnd; s:=s+'static char *graphic[] = {'+LineEnd; s:=s+'"'+IntToStr(Img.Width)+' '+IntToStr(Img.Height) +' '+IntToStr(Palette.Count)+' '+IntToStr(CharsPerPixel)+'"'; if Palette.Count>0 then s:=s+','; s:=s+LineEnd; WriteString(s); end; procedure WritePalette; var s: string; SrcPos: Integer; procedure WriteToSrc(const AddString: string); var i: Integer; begin for i:=1 to length(AddString) do begin s[SrcPos]:=AddString[i]; inc(SrcPos); end; end; var PaletteLineLen: Integer; i: Integer; SrcLen: Integer; begin // calculate needed memory PaletteLineLen:=length('"')+CharsPerPixel+length(' c ')+length('",'+LineEnd); SrcLen:=0; for i:=0 to Palette.Count-1 do begin inc(SrcLen,PaletteLineLen); inc(SrcLen,length(ColorStrings[i])); end; // build palette source SetLength(s,SrcLen); SrcPos:=1; for i:=0 to Palette.Count-1 do begin WriteToSrc('"'); WriteToSrc(PixelStrings[i]); WriteToSrc(' c '); WriteToSrc(ColorStrings[i]); WriteToSrc('",'); WriteToSrc(LineEnd); end; if SrcPos<>length(s)+1 then RaiseGDBException('TLazWriterXPM.InternalWrite consistency ERROR SrcPos<>length(s)'); WriteString(s); end; procedure WritePixels; var s: string; SrcPos: Integer; procedure WriteToSrc(const AddString: string); var i: Integer; begin for i:=1 to length(AddString) do begin s[SrcPos]:=AddString[i]; inc(SrcPos); end; end; var y: Integer; x: Integer; i: Integer; SrcLenPerLine: Integer; SrcLen: Integer; begin // calculate needed memory SrcLenPerLine:=length('"')+CharsPerPixel*Img.Width+length('",')+length(LineEnd); SrcLen:=Img.Height*SrcLenPerLine; // build palette source SetLength(s,SrcLen); SrcPos:=1; for y:=0 to Img.Height-1 do begin WriteToSrc('"'); for x:=0 to Img.Width-1 do begin i := Palette.IndexOf(GetColor(x,y)); WriteToSrc(PixelStrings[i]); end; Progress(psRunning, trunc(100.0 * ((y + 1) / Img.Height)), False, Rect(0,0,Img.Width-1,y), 'writing XPM pixels', FContinue); if ylength(s)+1 then RaiseGDBException('TLazWriterXPM.InternalWrite consistency ERROR SrcPos<>length(s)'); WriteString(s); end; var i: Integer; begin FContinue := True; Progress(psStarting, 0, False, Rect(0,0,0,0), '', FContinue); Palette:=nil; PixelStrings:=nil; ColorStrings:=nil; LineEnd:=#10; try BuildPalette; WriteHeader; WritePalette; WritePixels; finally if PixelStrings<>nil then begin for i:=0 to Palette.Count-1 do begin PixelStrings[i]:=''; ColorStrings[i]:=''; end; ReAllocMem(PixelStrings,0); ReAllocMem(ColorStrings,0); end; Palette.Free; end; Progress(psEnding, 100, false, Rect(0,0,0,0), '', FContinue); end; constructor TLazWriterXPM.Create; begin inherited Create; FNibblesPerSample:=2; FRightShiftSample:=8; end; { TArrayNode } constructor TArrayNode.Create; begin //DebugLn('TArrayNode.Create ',Capacity,' Self=',DbgS(Self)); end; destructor TArrayNode.Destroy; begin DeleteChilds; UnbindFromParent; inherited Destroy; end; procedure TArrayNode.DeleteChilds; var i: Integer; begin if Childs<>nil then begin for i:=0 to Capacity-1 do Childs[i].Free; FreeMem(Childs); Childs:=nil; Capacity:=0; end; end; procedure TArrayNode.UnbindFromParent; begin if Parent<>nil then begin Parent.Childs[Value-Parent.StartValue]:=nil; Parent:=nil; end; end; procedure TArrayNode.CreateChildNode(ChildValue: integer); var NewNode: TArrayNode; Index: Integer; begin NewNode:=TArrayNode.Create; NewNode.Value:=ChildValue; NewNode.Parent:=Self; Index:=ChildValue-StartValue; Childs[Index]:=NewNode; end; function TArrayNode.GetChildNode(ChildValue: integer; CreateIfNotExists: boolean ): TArrayNode; var Index: Integer; begin Result:=nil; Index:=ChildValue-StartValue; if (Index<0) or (Index>=Capacity) then begin // out of range if not CreateIfNotExists then exit; Expand(ChildValue); Index:=ChildValue-StartValue; end; Result:=Childs[Index]; if (Result=nil) and CreateIfNotExists then begin CreateChildNode(ChildValue); Result:=Childs[Index]; end; end; procedure TArrayNode.Expand(ValueToInclude: integer); var Index: Integer; NewChilds: PArrayNode; NewSize: Integer; i: Integer; NewStartValue: Integer; NewCapacity: Integer; OldSize: Integer; begin //DebugLn('TArrayNode.Expand A ',ValueToInclude,' Capacity=',Capacity,' StartValue=',StartValue); if Childs=nil then begin NewStartValue:=ValueToInclude; NewCapacity:=4; end else begin Index:=ValueToInclude-StartValue; if (Index>=0) and (IndexValueToInclude then begin inc(NewCapacity,NewStartValue-ValueToInclude); NewStartValue:=ValueToInclude; end else begin Index:=ValueToInclude-NewStartValue; if Index>=NewCapacity then NewCapacity:=Index+1; end; // make NewCapacity a power of 2 for i:=1 to 30 do begin if (1 shl i)>=NewCapacity then begin NewCapacity:=1 shl i; break; end; end; end; NewSize:=SizeOf(Pointer)*NewCapacity; GetMem(NewChilds,NewSize); FillChar(NewChilds^,NewSize,0); if Childs<>nil then begin OldSize:=SizeOf(Pointer)*Capacity; System.Move(Childs^,NewChilds[StartValue-NewStartValue],OldSize); FreeMem(Childs); end; Childs:=NewChilds; StartValue:=NewStartValue; Capacity:=NewCapacity; end; function TArrayNode.FindPrevSibling: TArrayNode; var i: Integer; begin Result:=nil; if Parent=nil then exit; i:=Value-Parent.StartValue-1; while (i>=0) do begin if Parent.Childs[i]<>nil then begin Result:=Parent.Childs[i]; exit; end; dec(i); end; end; function TArrayNode.FindNextSibling: TArrayNode; var i: Integer; begin Result:=nil; if Parent=nil then exit; i:=Value-Parent.StartValue+1; while (inil then begin Result:=Parent.Childs[i]; exit; end; inc(i); end; end; function TArrayNode.FindNextUTF8: TArrayNode; var SiblingNode: TArrayNode; begin Result:=FindFirstChild; if Result<>nil then exit; SiblingNode:=Self; while SiblingNode<>nil do begin Result:=SiblingNode.FindNextSibling; if Result<>nil then exit; SiblingNode:=SiblingNode.Parent; end; end; function TArrayNode.FindPrev: TArrayNode; begin Result:=FindPrevSibling; if Result=nil then begin Result:=Parent; exit; end; Result:=Result.FindLastSubChild; end; function TArrayNode.FindFirstChild: TArrayNode; var i: Integer; begin Result:=nil; if Capacity=0 then exit; i:=0; while inil then begin Result:=Childs[i]; exit; end; inc(i); end; end; function TArrayNode.FindLastChild: TArrayNode; var i: Integer; begin Result:=nil; if Capacity=0 then exit; i:=Capacity-1; while i>=0 do begin if Childs[i]<>nil then begin Result:=Childs[i]; exit; end; dec(i); end; end; function TArrayNode.FindLastSubChild: TArrayNode; var ANode: TArrayNode; begin ANode:=Self; while ANode<>nil do begin Result:=ANode; ANode:=ANode.FindLastChild; end; end; function TArrayNode.FindFirstSibling: TArrayNode; begin if Parent=nil then Result:=nil else Result:=Parent.FindFirstChild; end; function TArrayNode.FindLastSibling: TArrayNode; begin if Parent=nil then Result:=nil else Result:=Parent.FindLastChild; end; procedure TArrayNode.ConsistencyCheck; procedure R(const Msg: string); begin RaiseGDBException(Msg); end; var i: Integer; ChildNode: TArrayNode; begin if Childs<>nil then begin if Capacity<=0 then R('Capacity too small'); for i:=0 to Capacity-1 do begin ChildNode:=Childs[i]; if ChildNode<>nil then begin if ChildNode.Value<>i+StartValue then R('Value wrong'); if ChildNode.Parent<>Self then R('Parent wrong'); ChildNode.ConsistencyCheck; end; end; end else begin if Capacity<>0 then R('Capacity wrong'); end; end; { TArrayNodesTree } function TArrayNodesTree.FindNode(Path: PInteger; Count: integer ): TArrayNode; var i: Integer; begin Result:=Root; i:=0; while (Result<>nil) and (inil then Result:=ANode.Data else Result:=nil; end; function TArrayNodesTree.SetNode(Path: PInteger; Count: integer; Data: Pointer): TArrayNode; var i: Integer; begin if Root=nil then Root:=TArrayNode.Create; Result:=Root; for i:=0 to Count-1 do begin //DebugLn('TArrayNodesTree.SetNode A ',DbgS(Result)); Result:=Result.GetChildNode(Path[i],true); end; Result.Data:=Data; end; procedure TArrayNodesTree.Delete(Node: TArrayNode); begin if Node=nil then exit; if Node=Root then Root:=nil; Node.Free; end; procedure TArrayNodesTree.Clear; begin Delete(Root); end; constructor TArrayNodesTree.Create; begin end; destructor TArrayNodesTree.Destroy; begin Clear; inherited Destroy; end; procedure TArrayNodesTree.ConsistencyCheck; begin if Root<>nil then Root.ConsistencyCheck; end; { TLazReaderDIB_ } function TLazReaderBMP.InternalCheck(Stream: TStream): boolean; var BFH: TBitMapFileHeader; begin stream.Read(BFH, SizeOf(BFH)); with BFH do Result := (LEtoN(bfType) = BMmagic); // Just check magic number end; { TLazReaderDIB } function BmpRGBAToFPColor(const RGBA: TColorRGBA): TFPcolor; begin Result.Red := (RGBA.R shl 8) or RGBA.R; Result.Green := (RGBA.G shl 8) or RGBA.G; Result.Blue := (RGBA.B shl 8) or RGBA.B; Result.Alpha := (RGBA.A shl 8) or RGBA.A; end; function BmpRGBToFPColor(const RGBA: TColorRGBA): TFPcolor; begin Result.Red := (RGBA.R shl 8) or RGBA.R; Result.Green := (RGBA.G shl 8) or RGBA.G; Result.Blue := (RGBA.B shl 8) or RGBA.B; Result.Alpha := AlphaOpaque; end; function BmpRGBToFPColor(const RGB: TColorRGB) : TFPColor; begin Result.Red := (RGB.R shl 8) + RGB.R; Result.Green := (RGB.G shl 8) + RGB.G; Result.Blue := (RGB.B shl 8) + RGB.B; Result.Alpha := AlphaOpaque; end; function Bmp16BitToFPColor(Const RGB: Word): TFPColor; var V1, V2: Cardinal; begin { // 5 bit for red -> 16 bit for TFPColor Result.Red:=(RGB shr 11) and $1f; Result.Red:=(Result.Red shl 11) or MissingBits[5,Result.Red shr 2]; // 6 bit for green -> 16 bit for TFPColor Result.Green:=(RGB shr 5) and $3f; Result.Green:=(Result.Green shl 10) or MissingBits[6,Result.Green shr 3]; // 5 bit for blue -> 16 bit for TFPColor Result.Blue:=RGB and $1f; Result.Blue := (Result.Blue shl 11) or MissingBits[5, Result.Blue shr 2]; } // 5 bit for red -> 16 bit for TFPColor V1 := RGB and $F800; // 15..11 V2 := V1; V1 := V1 shr 5; // 10..6 V2 := V2 or V1; V1 := V1 shr 5; // 5..1 V2 := V2 or V1; V1 := V1 shr 5; // 0 Result.Red := Word(V2 or V1); // 6 bit for green -> 16 bit for TFPColor V1 := (RGB shl 5) and $FC00; // 15..10 V2 := V1; V1 := V1 shr 6; // 9..4 V2 := V2 or V1; V1 := V1 shr 6; // 4..0 Result.Green := Word(V2 or V1); // 5 bit for blue -> 16 bit for TFPColor V1 := (RGB shl 11) and $F800; // 15..11 V2 := V1; V1 := V1 shr 5; V2 := V2 or V1; // 10..6 V1 := V1 shr 5; V2 := V2 or V1; // 5..1 V1 := V1 shr 5; Result.Blue := Word(V2 or V1); // 0 // opaque, no mask Result.Alpha := AlphaOpaque; end; function Bmp15BitToFPColor(const RGB: Word): TFPColor; var V1, V2: Cardinal; begin // 5 bit for red -> 16 bit for TFPColor V1 := (RGB shl 1) and $F800; // 15..11 V2 := V1; V1 := V1 shr 5; // 10..6 V2 := V2 or V1; V1 := V1 shr 5; // 5..1 V2 := V2 or V1; V1 := V1 shr 5; // 0 Result.Red := Word(V2 or V1); // 5 bit for red -> 16 bit for TFPColor V1 := (RGB shl 6) and $F800; // 15..11 V2 := V1; V1 := V1 shr 5; // 10..6 V2 := V2 or V1; V1 := V1 shr 5; // 5..1 V2 := V2 or V1; V1 := V1 shr 5; // 0 Result.Green := Word(V2 or V1); // 5 bit for blue -> 16 bit for TFPColor V1 := (RGB shl 11) and $F800; // 15..11 V2 := V1; V1 := V1 shr 5; V2 := V2 or V1; // 10..6 V1 := V1 shr 5; V2 := V2 or V1; // 5..1 V1 := V1 shr 5; Result.Blue := Word(V2 or V1); // 0 // opaque, no mask Result.Alpha:=alphaOpaque; end; procedure TLazReaderDIB.FreeBufs; begin FreeMem(FLineBuf); FLineBuf := nil; FreeMem(FPalette); FPalette := nil; end; function TLazReaderDIB.GetUpdateDescription: Boolean; begin Result := FUpdateDescription; end; procedure TLazReaderDIB.SetupRead(nPalette, nRowBits: Integer; ReadPalette, AIsRLE: Boolean); var ColInfo: array of TColorRGBA; i: Integer; begin FIsRLE := AIsRLE; if nPalette > 0 then begin GetMem(FPalette, nPalette*SizeOf(TFPColor)); SetLength(ColInfo, nPalette); if ReadPalette then begin if (BFI.biClrUsed > 0) and (BFI.biClrUsed <= Cardinal(nPalette)) // prevent buffer overflow then TheStream.Read(ColInfo[0], BFI.biClrUsed * SizeOf(ColInfo[0])) else TheStream.Read(ColInfo[0], nPalette * SizeOf(ColInfo[0])); for i := 0 to nPalette-1 do FPalette[i] := BmpRGBToFPColor(ColInfo[i]); end; end else begin { Skip palette } if BFI.biClrUsed > 0 then TheStream.Position := TheStream.Position + TStreamSeekType(BFI.biClrUsed*SizeOf(TColorRGBA)); end; FReadSize := ((nRowBits + 31) div 32) shl 2; GetMem(FLineBuf, FReadSize); end; procedure TLazReaderDIB.ReadScanLine(Row: Integer); //{$IFDEF FPC_BIG_ENDIAN} //var // n: Integer; //{$ENDIF} var d: array[0..1] of Byte; Offset: Integer; begin // Add here support for compressed lines. The 'readsize' is the same in the end. // MWE: Note: when doing so, keep in mind that the bufer is expected to be in Little Endian. // for better performance, the conversion is done when writeing the buffer. if IsRLE then begin Offset := 0; while True do begin TheStream.Read(d[0], 2); if d[0] > 0 then begin while d[0] > 0 do begin LineBuf[Offset] := d[1]; Inc(Offset); Dec(d[0]); end; end else case d[1] of 0, 1: break; // End of scanline or end of bitmap 2: raise FPImageException.Create('RLE code #2 is not supported'); else begin TheStream.Read(LineBuf[Offset], d[1]); Inc(Offset, d[1]); if Odd(d[1]) then TheStream.Read(d[1], 1); // Jump to even file position end; end; end; end else TheStream.Read(LineBuf[0], ReadSize); (* {$ifdef FPC_BIG_ENDIAN} if (FBitsPerPixel = 15) or (FBitsPerPixel = 16) then begin for n := 0 to (ReadSize div 2) - 1 do PWord(LineBuf)[n] := LEtoN(PWord(LineBuf)[n]); end; {$ENDIF} *) end; procedure TLazReaderDIB.SetUpdateDescription(AValue: Boolean); begin FUpdateDescription := AValue; end; procedure TLazReaderDIB.WriteScanLine(Row: Cardinal); // using cardinals generates compacter code var Column: Cardinal; Color: TFPColor; Index: Byte; begin if FMaskMode = lrmmNone then begin case FBitsPerPixel of 1 : for Column := 0 to TheImage.Width - 1 do TheImage.colors[Column,Row] := FPalette[Ord(LineBuf[Column div 8] and ($80 shr (Column and 7)) <> 0)]; 4 : for Column := 0 to TheImage.Width - 1 do TheImage.colors[Column,Row] := FPalette[(LineBuf[Column div 2] shr (((not Column) and 1)*4)) and $0f]; 8 : for Column := 0 to TheImage.Width - 1 do TheImage.colors[Column,Row] := FPalette[LineBuf[Column]]; 15: for Column := 0 to TheImage.Width - 1 do TheImage.colors[Column,Row] := Bmp15BitToFPColor({$ifdef FPC_BIG_ENDIAN}LeToN{$endif}(PWord(LineBuf)[Column])); 16: for Column := 0 to TheImage.Width - 1 do TheImage.colors[Column,Row] := Bmp16BitToFPColor({$ifdef FPC_BIG_ENDIAN}LeToN{$endif}(PWord(LineBuf)[Column])); 24: for Column := 0 to TheImage.Width - 1 do TheImage.colors[Column,Row] := BmpRGBToFPColor(PColorRGB(LineBuf)[Column]); 32: for Column := 0 to TheImage.Width - 1 do TheImage.colors[Column,Row] := BmpRGBAToFPColor(PColorRGBA(LineBuf)[Column]); end; end else begin case FBitsPerPixel of 1 : for Column := 0 to TheImage.Width - 1 do begin Index := Ord(LineBuf[Column div 8] and ($80 shr (Column and 7)) <> 0); FImage.colors[Column,Row] := FPalette[Index]; FImage.Masked[Column,Row] := Index = FMaskIndex; end; 4 : for Column := 0 to TheImage.Width - 1 do begin Index := (LineBuf[Column div 2] shr (((not Column) and 1)*4)) and $0f; FImage.colors[Column,Row] := FPalette[Index]; FImage.Masked[Column,Row] := Index = FMaskIndex; end; 8 : for Column := 0 to TheImage.Width - 1 do begin Index := LineBuf[Column]; FImage.colors[Column,Row] := FPalette[Index]; FImage.Masked[Column,Row] := Index = FMaskIndex; end; 15: for Column := 0 to TheImage.Width - 1 do begin Color := Bmp15BitToFPColor({$ifdef FPC_BIG_ENDIAN}LeToN{$endif}(PWord(LineBuf)[Column])); FImage.colors[Column,Row] := Color; FImage.Masked[Column,Row] := Color = FMaskColor; end; 16: for Column := 0 to TheImage.Width - 1 do begin Color := Bmp16BitToFPColor({$ifdef FPC_BIG_ENDIAN}LeToN{$endif}(PWord(LineBuf)[Column])); FImage.colors[Column,Row] := Color; FImage.Masked[Column,Row] := Color = FMaskColor; end; 24: for Column := 0 to TheImage.Width - 1 do begin Color := BmpRGBToFPColor(PColorRGB(LineBuf)[Column]); FImage.colors[Column,Row] := Color; FImage.Masked[Column,Row] := Color = FMaskColor; end; 32: for Column := 0 to TheImage.Width - 1 do begin Color := BmpRGBAToFPColor(PColorRGBA(LineBuf)[Column]); FImage.colors[Column,Row] := Color; FImage.Masked[Column,Row] := Color = FMaskColor; end; end; end; end; function TLazReaderDIB._AddRef: LongInt; stdcall; begin Result := -1; end; function TLazReaderDIB._Release: LongInt; stdcall; begin Result := -1; end; procedure TLazReaderDIB.InternalRead(Stream: TStream; Img: TFPCustomImage); var Desc: TRawImageDescription; begin FContinue := True; Progress(psStarting, 0, False, Rect(0,0,0,0), '', FContinue); FImage := TheImage as TLazIntfImage; InternalReadHead; if FUpdateDescription then begin DefaultReaderDescription(FBFI.biWidth, FBFI.biHeight, FBFI.biBitCount, Desc); // if FMaskMode = lrmmNone // then Desc.MaskBitsPerPixel := 0; FImage.DataDescription := Desc; end; InternalReadBody; Progress(psEnding, 100, false, Rect(0,0,0,0), '', FContinue); end; procedure TLazReaderDIB.InternalReadHead; begin TheStream.Read(FBFI,SizeOf(FBFI)); {$IFDEF FPC_BIG_ENDIAN} FBFI.biSize := LEtoN(FBFI.biSize ); FBFI.biWidth := LEtoN(FBFI.biWidth ); FBFI.biHeight := LEtoN(FBFI.biHeight ); FBFI.biPlanes := LEtoN(FBFI.biPlanes ); FBFI.biBitCount := LEtoN(FBFI.biBitCount ); FBFI.biCompression := LEtoN(FBFI.biCompression ); FBFI.biSizeImage := LEtoN(FBFI.biSizeImage ); FBFI.biXPelsPerMeter := LEtoN(FBFI.biXPelsPerMeter); FBFI.biYPelsPerMeter := LEtoN(FBFI.biYPelsPerMeter); FBFI.biClrUsed := LEtoN(FBFI.biClrUsed ); FBFI.biClrImportant := LEtoN(FBFI.biClrImportant ); {$ENDIF} end; function TLazReaderDIB.QueryInterface(const iid: TGuid; out obj): LongInt; stdcall; begin if GetInterface(iid, obj) then Result := S_OK else Result := E_NOINTERFACE; end; procedure TLazReaderDIB.InternalReadBody; type TPixelMasks = packed record R, G, B: LongWord; end; const SWrongCombination = 'Bitmap with wrong combination of bit count (%d) and compression (%d)'; SUnsupportedPixelMask = 'Bitmap with non-standard pixel masks not supported'; procedure SaveTransparentColor; begin //DebugLn('SaveTransparentColor ',dbgs(UseLeftBottomAsTransparent),' ',dbgs(FBitsPerPixel)); if FMaskMode <> lrmmAuto then Exit; // define transparent color: 1-8 use palette, 15-24 use fixed color FMaskIndex := -1; case FBitsPerPixel of 1 : FMaskIndex := (LineBuf[0] shr 7) and 1; 4 : FMaskIndex := (LineBuf[0] shr 4) and $f; 8 : FMaskIndex := LineBuf[0]; 15: FMaskColor := Bmp15BitToFPColor({$ifdef FPC_BIG_ENDIAN}LeToN{$endif}(PWord(LineBuf)[0])); 16: FMaskColor := Bmp16BitToFPColor({$ifdef FPC_BIG_ENDIAN}LeToN{$endif}(PWord(LineBuf)[0])); 24: FMaskColor := BmpRGBToFPColor(PColorRGB(LineBuf)[0]); 32: FMaskCOlor := BmpRGBAToFPColor(PColorRGBA(LineBuf)[0]); end; if FMaskIndex <> -1 then FMaskColor := FPalette[FMaskIndex]; end; procedure UpdateProgress(Row: Integer); inline; begin Progress(psRunning, trunc(100.0 * ((TheImage.Height - Row) / TheImage.Height)), False, Rect(0, 0, TheImage.Width - 1, TheImage.Height - 1 - Row), 'reading BMP pixels', FContinue); end; var PixelMasks: TPixelMasks; Row : Cardinal; begin { This will move past any junk after the BFI header } TheStream.Position := TheStream.Position + TStreamSeekType(BFI.biSize-SizeOf(BFI)); TheImage.SetSize(BFI.biWidth, Abs(BFI.biHeight)); // Note for Abs - height can be negative if bitmap data is not stored upside-down FBitsPerPixel := BFI.biBitCount; case BFI.biBitCount of 1: begin { Monochrome } if BFI.biCompression <> BI_RGB then raise FPImageException.CreateFmt(SWrongCombination, [BFI.biBitCount, BFI.biCompression]); SetupRead(2, TheImage.Width, True, False); end; 4: begin case BFI.biCompression of BI_RGB: SetupRead(16, TheImage.Width * 4, True, False); BI_RLE4: SetupRead(16, TheImage.Width * 4, True, True); else raise FPImageException.CreateFmt(SWrongCombination, [BFI.biBitCount, BFI.biCompression]); end; end; 8: begin case BFI.biCompression of BI_RGB: SetupRead(256, TheImage.Width * 8, True, False); BI_RLE8: SetupRead(256, TheImage.Width * 8, True, True); else raise FPImageException.CreateFmt(SWrongCombination, [BFI.biBitCount, BFI.biCompression]); end; end; 16: begin case BFI.biCompression of BI_RGB: // 5-5-5 FBitsPerPixel := 15; BI_BITFIELDS: begin // 5-5-5 or 5-6-5 THeStream.Read(PixelMasks, SizeOf(PixelMasks)); {$IFDEF FPC_BIG_ENDIAN} PixelMasks.R := LEtoN(PixelMasks.R); PixelMasks.G := LEtoN(PixelMasks.G); PixelMasks.B := LEtoN(PixelMasks.B); {$ENDIF} if (PixelMasks.R = $7C00) and // 5 red (PixelMasks.G = $03E0) and // 5 green (PixelMasks.B = $001F) then // 5 blue FBitsPerPixel := 15 else if (PixelMasks.R = $F800) and // 5 red (PixelMasks.G = $07E0) and // 6 green (PixelMasks.B = $001F) then // 5 blue FBitsPerPixel := 16 else raise FPImageException.Create(SUnsupportedPixelMask); end; else raise FPImageException.CreateFmt(SWrongCombination, [BFI.biBitCount, BFI.biCompression]); end; SetupRead(0, TheImage.Width * 16, True, False); end; 24: begin case BFI.biCompression of BI_RGB: ; BI_BITFIELDS: begin // actually not a valid value TheStream.Read(PixelMasks, SizeOf(PixelMasks)); {$IFDEF FPC_BIG_ENDIAN} PixelMasks.R := LEtoN(PixelMasks.R); PixelMasks.G := LEtoN(PixelMasks.G); PixelMasks.B := LEtoN(PixelMasks.B); {$ENDIF} if (PixelMasks.R <> $FF0000) or // 8 red (PixelMasks.G <> $00FF00) or // 8 green (PixelMasks.B <> $0000FF) then // 8 blue raise FPImageException.Create(SUnsupportedPixelMask); end; else raise FPImageException.CreateFmt(SWrongCombination, [BFI.biBitCount, BFI.biCompression]); end; SetupRead(0, TheImage.Width * 24, True, False); end; 32: begin case BFI.biCompression of BI_RGB: ; BI_BITFIELDS: begin TheStream.Read(PixelMasks, SizeOf(PixelMasks)); {$IFDEF FPC_BIG_ENDIAN} PixelMasks.R := LEtoN(PixelMasks.R); PixelMasks.G := LEtoN(PixelMasks.G); PixelMasks.B := LEtoN(PixelMasks.B); {$ENDIF} if (PixelMasks.R <> $00FF0000) or // 8 red (PixelMasks.G <> $0000FF00) or // 8 green (PixelMasks.B <> $000000FF) then // 8 blue raise FPImageException.Create(SUnsupportedPixelMask); end; else raise FPImageException.CreateFmt(SWrongCombination, [BFI.biBitCount, BFI.biCompression]); end; // force alpha description CheckAlphaDescription(TheImage); SetupRead(0, TheImage.Width * 32, True, False); end; else raise FPImageException.CreateFmt('Wrong bitmap bit count: %d', [BFI.biBitCount]); end; if (TheImage.Height = 0) or (TheImage.Width = 0) then begin FreeBufs; Exit; end; try if not FContinue then Exit; Row := TheImage.Height - 1; ReadScanLine(Row); SaveTransparentColor; if BFI.biHeight > 0 then WriteScanLine(Row) // upside-down else WriteScanLine(TheImage.Height - 1 - Row); UpdateProgress(Row); while Row > 0 do begin if not FContinue then Exit; Dec(Row); ReadScanLine(Row); // Scanline in LineBuf with Size ReadSize. if BFI.biHeight > 0 then WriteScanLine(Row) // upside-down else WriteScanLine(TheImage.Height - 1 - Row); UpdateProgress(Row); end; finally FreeBufs; end; end; function TLazReaderDIB.InternalCheck(Stream: TStream): boolean; begin Result := True; end; constructor TLazReaderDIB.Create; begin inherited Create; FMaskColor := colTransparent; FContinue := True; end; destructor TLazReaderDIB.Destroy; begin FreeBufs; inherited Destroy; end; { TLazIntfImageMask } procedure TLazIntfImageMask.SetInternalColor(x, y: integer; const Value: TFPColor); begin FImage.Masked[x, y] := Value.red < $8000; end; function TLazIntfImageMask.GetInternalColor(x, y: integer): TFPColor; begin if FImage.Masked[x, y] then Result := FPImage.colWhite else Result := FPImage.colBlack; end; procedure TLazIntfImageMask.SetInternalPixel(x, y: integer; Value: integer); begin FImage.Masked[x, y] := Value <> 0; end; function TLazIntfImageMask.GetInternalPixel(x, y: integer): integer; begin Result := Ord(FImage.Masked[x, y]); end; constructor TLazIntfImageMask.CreateWithImage(TheImage: TLazIntfImage); begin FImage:=TheImage; inherited Create(FImage.Width,FImage.Height); end; { TLazReaderIconDIB } procedure TLazReaderIconDIB.InternalRead(Stream: TStream; Img: TFPCustomImage); var Desc: TRawImageDescription; Row, Column: Integer; NewColor: TFPColor; BufPtr: PByte; MaskBit: Byte; begin FImage := TheImage as TLazIntfImage; InternalReadHead; // Height field is doubled, to (sort of) accomodate mask // MWE: it shoud be safer to verify the division agains the dirinfo.height // anyway I haven't encountered an icon in the wild which doesn't have a mask FBFI.biHeight := FBFI.biHeight div 2; if FUpdateDescription then begin DefaultReaderDescription(FBFI.biWidth, FBFI.biHeight, FBFI.biBitCount, Desc); // if FMaskMode = lrmmNone // then Desc.MaskBitsPerPixel := 0; FImage.DataDescription := Desc; end else Desc := FImage.DataDescription; InternalReadBody; { Now read standard bitmap } // Mask immediately follows unless bitmap was 32 bit - monchrome bitmap with no header // MWE: Correction, it seems that even 32bit icons can have a mask following // if BFI.biBitCount >= 32 then Exit; FReadSize := ((Desc.Width + 31) div 32) shl 2; SetupRead(2, Desc.Width, False, False); try for Row := Desc.Height - 1 downto 0 do begin ReadScanLine(Row); // Scanline in LineBuf with Size ReadSize. BufPtr := LineBuf; MaskBit := $80; for Column:=0 to Desc.Width - 1 do begin if BufPtr^ and MaskBit = 0 then begin // opaque FImage.Masked[Column, Row] := False; end else begin // transparent FImage.Masked[Column, Row] := True; // add alpha when source wasn't 32bit if (Desc.AlphaPrec <> 0) and (Desc.Depth < 32) then begin NewColor := FImage.Colors[Column, Row]; NewColor.Alpha := alphaTransparent; FImage.Colors[Column, Row] := NewColor; end; end; if MaskBit = 1 then begin MaskBit := $80; Inc(BufPtr); end else begin MaskBit := MaskBit shr 1; end; end; end; finally FreeBufs; end; end; { TLazReaderPNG } procedure TLazReaderPNG.DoDecompress; var Desc: TRawImageDescription; IsAlpha, IsGray: Boolean; begin if FUpdateDescription and (theImage is TLazIntfImage) then begin // init some default IsGray := Header.ColorType and 3 = 0; // Paul: if we have a mask in the description then we need to set it manually // by Masked[x, y] := Color.Alpha = AlphaTransparent, but to do that we must // read format ourself. fpReaders set alpha instead - they dont have Masked[]. // So if we want true description with mask we must teach our SetInternalColor // method to handle Alpha if mask needed (or do it any other way). In other words // this is now unimplemented and we'll get randomly masked image. // As a temporary solution I'm enable alpha description if transparent color // is present. This is indicated by UseTransparent property. // When we will handle Mask in SetInternalColor please remove UseTransparent // from the IsAlpha assignment. IsAlpha := (Header.ColorType and 4 <> 0) or FAlphaPalette or UseTransparent; if not IsAlpha and UseTransparent then Desc.Init_BPP32_B8G8R8A8_M1_BIO_TTB(Header.Width, Header.height) else Desc.Init_BPP32_B8G8R8A8_BIO_TTB(Header.Width, Header.height); if IsGray then Desc.Format := ricfGray; if not IsAlpha then Desc.AlphaPrec := 0; // check palette if (Header.ColorType and 1 <> 0) then begin // todo: palette end else begin // no palette, adjust description if IsGray then Desc.Depth := Header.BitDepth else if IsAlpha then Desc.Depth := 4 * Header.BitDepth else Desc.Depth := 3 * Header.BitDepth; case Header.BitDepth of 1,2,4: begin // only gray Desc.BitsPerPixel := Header.BitDepth; Desc.RedPrec := Header.BitDepth; Desc.RedShift := 0; end; 8: begin // no change end; 16: begin Desc.BitsPerPixel := Desc.Depth; Desc.RedPrec := 16; Desc.RedShift := Desc.RedShift * 2; Desc.GreenPrec := 16; Desc.GreenShift := Desc.GreenShift * 2; Desc.BluePrec := 16; Desc.BlueShift := Desc.BlueShift * 2; Desc.AlphaPrec := Desc.AlphaPrec * 2; // might be zero Desc.AlphaShift := Desc.AlphaShift * 2; end; end; end; TLazIntfImage(theImage).DataDescription := Desc; end; inherited DoDecompress; end; function TLazReaderPNG.GetUpdateDescription: Boolean; begin Result := FUpdateDescription; end; procedure TLazReaderPNG.HandleAlpha; begin inherited HandleAlpha; FAlphaPalette := Header.ColorType = 3; end; procedure TLazReaderPNG.InternalRead(Str: TStream; Img: TFPCustomImage); begin FAlphaPalette := False; inherited InternalRead(Str, Img); end; function TLazReaderPNG.QueryInterface(const iid: TGuid; out obj): LongInt; stdcall; begin if GetInterface(iid, obj) then Result := S_OK else Result := E_NOINTERFACE; end; procedure TLazReaderPNG.SetUpdateDescription(AValue: Boolean); begin FUpdateDescription := AValue; end; function TLazReaderPNG._AddRef: LongInt; stdcall; begin Result := -1; end; function TLazReaderPNG._Release: LongInt; stdcall; begin Result := -1; end; { TLazReaderIcnsPart } function TLazReaderIcnsPart.InternalCheck(Str: TStream): boolean; begin // todo: write check code Result := True; end; procedure TLazReaderIcnsPart.InternalRead(Stream: TStream; Img: TFPCustomImage); var Desc: TRawImageDescription; Element: TIconFamilyElement; IsMask: Boolean; begin FImage := TheImage as TLazIntfImage; Stream.Read(Element, SizeOf(Element)); Element.elementSize := BEtoN(Element.elementSize); FIconType := GetIcnsIconType(Element.elementType); FIconInfo := icnsIconTypeInfo[FIconType]; IsMask := FIconType in icnsMaskTypes; if UpdateDescription then begin if IsMask then begin if FIconInfo.Depth = 1 then DefaultReaderDescription(FIconInfo.Width, FIconInfo.Height, FIconInfo.Depth, Desc) else DefaultReaderDescription(FIconInfo.Width, FIconInfo.Height, 32, Desc); end else DefaultReaderDescription(FIconInfo.Width, FIconInfo.Height, FIconInfo.Depth, Desc); if (Desc.BitsPerPixel = 32) then Desc.MaskBitsPerPixel := 0; FImage.DataDescription := Desc; end else Desc := FImage.DataDescription; SetupRead(FIconInfo.Width, FIconInfo.Height, FIconInfo.Depth, IsMask); FDataSize := Element.elementSize - SizeOf(Element); GetMem(FData, FDataSize); try Stream.Read(FData^, FDataSize); if FIconType in icnsWithAlpha then DoReadJpeg2000 else if IsMask then DoReadMask else if FIconType in icnsRGB then DoReadRLE else DoReadRaw; finally FreeMem(FData); FData := nil; end; end; function TLazReaderIcnsPart.QueryInterface(const iid: TGuid; out obj): LongInt; stdcall; begin if GetInterface(iid, obj) then Result := S_OK else Result := E_NOINTERFACE; end; function TLazReaderIcnsPart._AddRef: LongInt; stdcall; begin Result := -1; end; function TLazReaderIcnsPart._Release: LongInt; stdcall; begin Result := -1; end; function TLazReaderIcnsPart.GetUpdateDescription: Boolean; begin Result := FUpdateDescription; end; procedure TLazReaderIcnsPart.SetUpdateDescription(AValue: Boolean); begin FUpdateDescription := AValue; end; procedure TLazReaderIcnsPart.SetupRead(AWidth, AHeight, ADepth: Integer; IsMask: Boolean); begin if FData <> nil then FreeMem(FData); FreeAndNil(FPalette); if not IsMask then case ADepth of 4: FPalette := CreateVGAPalette; 8: FPalette := Create256ColorPalette; end; FCalcSize := ((AWidth * AHeight * ADepth) shr 3); TheImage.SetSize(AWidth, AHeight); end; procedure TLazReaderIcnsPart.DoReadRaw; var Row, Column: Integer; shift: byte; b: PByte; begin // only 4 and 8 are stored as raw image format case FIconInfo.Depth of 4 : begin b := FData; shift := 4; for Row := 0 to FIconInfo.Height - 1 do for Column := 0 to FIconInfo.Width - 1 do begin FImage.colors[Column, Row] := FPalette[(b^ shr shift) mod 16]; if shift = 0 then begin shift := 4; inc(b); end else shift := 0; end; end; 8 : begin b := FData; for Row := 0 to FIconInfo.Height - 1 do for Column := 0 to FIconInfo.Width - 1 do begin FImage.colors[Column, Row] := FPalette[b^]; inc(b); end; end; end; end; procedure TLazReaderIcnsPart.DoReadRLE; var ADecompData: PDWord; ARGBAData: PRGBAQuad; Component, Shift: Byte; PixelCount, j, l: Integer; RepeatValue: DWord; SourcePtr: PByte; DestPtr: PDWord; begin // only 24 bit RGB is RLE encoded the same way as TIFF or TGA RLE // data is encoded channel by channel: // high bit = 0 => length = low 0..6 bits + 1; read length times next value // high bit = 1 => length = value - 125 ; read one value and repeat length times ADecompData := AllocMem(FCalcSize); DestPtr := ADecompData; if FIconType = iitThumbnail32BitData then SourcePtr := @FData[4] else SourcePtr := FData; PixelCount := FIconInfo.Height * FIconInfo.Width; for Component := 0 to 2 do begin DestPtr := ADecompData; Shift := (2 - Component) * 8; while DestPtr - ADecompData < PixelCount do begin l := SourcePtr^; inc(SourcePtr); if (l and $80) = 0 then // high bit = 0 begin for j := 0 to l do begin DestPtr^ := DestPtr^ or (DWord(SourcePtr^) shl Shift); inc(SourcePtr); inc(DestPtr); end; end else begin // high bit = 1 l := l - 126; RepeatValue := DWord(SourcePtr^) shl Shift; inc(SourcePtr); for j := 0 to l do begin DestPtr^ := DestPtr^ or RepeatValue; inc(DestPtr); end; end; end; end; ARGBAData := PRGBAQuad(ADecompData); for l := 0 to FIconInfo.Height - 1 do for j := 0 to FIconInfo.Width - 1 do begin FImage.Colors[j, l] := FPColor(ARGBAData^.Red shl 8 or ARGBAData^.Red, ARGBAData^.Green shl 8 or ARGBAData^.Green, ARGBAData^.Blue shl 8 or ARGBAData^.Blue, alphaOpaque); inc(ARGBAData); end; FreeMem(ADecompData); end; procedure TLazReaderIcnsPart.DoReadJpeg2000; begin // TODO: according to some research in the web we need to read jpeg 2000 data end; procedure TLazReaderIcnsPart.DoReadMask; var Row, Column: Integer; shift: byte; b: PByte; begin case FIconInfo.Depth of 1: begin // actually here is stored 2 1-bit images, but we will get only first shift := 7; b := FData; for Row := 0 to FIconInfo.Height - 1 do begin for Column := 0 to FIconInfo.Width - 1 do begin FImage.colors[Column, Row] := FPColor(0, 0, 0); FImage.Masked[Column, Row] := (b^ shr shift) mod 2 = 0; if shift = 0 then begin shift := 7; inc(b); end else dec(shift); end; end; end; 8: begin b := FData; for Row := 0 to FIconInfo.Height - 1 do for Column := 0 to FIconInfo.Width - 1 do begin FImage.colors[Column, Row] := FPColor(0, 0, 0, (b^ shl 8) or b^); inc(b); end; end; end; end; function TLazReaderIcnsPart.Create256ColorPalette: TFPPalette; const CHANNELVAL: array[0..15] of Word = ( $FFFF, $CCCC, $9999, $6666, $3333, $0000, $EEEE, $DDDD, $BBBB, $AAAA, $8888, $7777, $5555, $4444, $2222, $1111 ); var rIdx, gIdx, bIdx: byte; PalIdx: Byte; begin Result := TFPPalette.Create(256); PalIdx := 0; for rIdx := 0 to 5 do begin for gIdx := 0 to 5 do begin for bIdx := 0 to 5 do begin Result[PalIdx] := FPColor(CHANNELVAL[rIdx], CHANNELVAL[gIdx], CHANNELVAL[bIdx]); Inc(PalIdx); end; end; end; for rIdx := 6 to 15 do begin Result[PalIdx] := FPColor(CHANNELVAL[rIdx], 0, 0); Inc(PalIdx); end; for gIdx := 6 to 15 do begin Result[PalIdx] := FPColor(0, CHANNELVAL[gIdx], 0); Inc(PalIdx); end; for bIdx := 6 to 15 do begin Result[PalIdx] := FPColor(0, 0, CHANNELVAL[bIdx]); Inc(PalIdx); end; for rIdx := 6 to 15 do begin Result[PalIdx] := FPColor(CHANNELVAL[rIdx], CHANNELVAL[rIdx], CHANNELVAL[rIdx]); Inc(PalIdx); end; Result[PalIdx] := FPColor(0, 0, 0); end; constructor TLazReaderIcnsPart.Create; begin inherited Create; FData := nil; FPalette := nil; FCalcSize := 0; FIconType := iitNone; end; destructor TLazReaderIcnsPart.Destroy; begin FPalette.Free; FreeMem(FData); inherited Destroy; end; //------------------------------------------------------------------------------ procedure InternalInit; var c: Char; begin for c:=Low(char) to High(char) do begin IsSpaceChar[c]:=c in [' ',#9,#10,#13]; IsNumberChar[c]:=c in ['0'..'9']; IsHexNumberChar[c]:=c in ['0'..'9','A'..'F','a'..'f']; end; end; initialization InternalInit; end.