1 {  $Id: intfgraphics.pas 60390 2019-02-09 08:49:38Z mattias $  }
2 {
3  /***************************************************************************
4                               intfgraphics.pp
5                               ---------------
6 
7  ***************************************************************************/
8 
9  *****************************************************************************
10   This file is part of the Lazarus Component Library (LCL)
11 
12   See the file COPYING.modifiedLGPL.txt, included in this distribution,
13   for details about the license.
14  *****************************************************************************
15 
16   Author: Mattias Gaertner
17 
18   Abstract:
19     Classes and functions for easy handling of raw images (interface images).
20 }
21 unit IntfGraphics;
22 
23 {$mode objfpc}{$H+}
24 
25 interface
26 
27 uses
28   // RTL + FCL
29   Classes, SysUtils, Math, fpImage,
30   FPReadBMP, FPWriteBMP, BMPComn,
31   FPReadPNG, FPWritePNG,
32   {$IFNDEF DisableLCLTIFF}
33   FPReadTiff, FPWriteTiff, FPTiffCmn,
34   {$ENDIF}
35   Laz_AVL_Tree,
36   // LazUtils
37   FPCAdds, LazLoggerBase, LazTracer,
38   // LCL
39   LCLType, LCLversion, GraphType, IcnsTypes;
40 
41 type
42   { TLazIntfImage }
43   { This descendent of TFPCustomImage stores its image data as raw images and
44     is therefore able to directly interchange images with the LCL interfaces.
45 
46     Usage examples:
47 
48     1. Loading a .xpm file into a TBitmap:
49 
50       var
51         BmpHnd,MaskHnd: HBitmap;
52         Bitmap1: TBitmap;
53         IntfImg1: TLazIntfImage;
54         Reader: TLazReaderXPM;
55       begin
56         // create a bitmap (or use an existing one)
57         Bitmap1:=TBitmap.Create;
58         // create the raw image for the screenformat you want
59         IntfImg1:=TLazIntfImage.Create(0,0,[riqfRGB, riqfAlpha, riqfMask]);
60         // create the XPM reader
61         Reader:=TLazReaderXPM.Create;
62         // load the image
63         IntfImg1.LoadFromFile('filename.xpm',Reader);
64         // create the bitmap handles
65         IntfImg1.CreateBitmap(BmpHnd,MaskHnd);
66         // apply handles to the Bitmap1
67         Bitmap1.Handle:=BmpHnd;
68         Bitmap1.MaskHandle:=MaskHnd;
69         // clean up
70         Reader.Free;
71         IntfImg1.Free;
72         // do something with the Bitmap1
73         ...
74       end;
75 
76 
77     2. Saving a TBitmap to a .xpm file:
78 
79       var
80         BmpHnd,MaskHnd: HBitmap;
81         Bitmap1: TBitmap;
82         IntfImg1: TLazIntfImage;
83         Writer: TLazWriterXPM;
84       begin
85         ...
86         // create the raw image
87         IntfImg1:=TLazIntfImage.Create(0,0,[]);
88         // load the raw image from the bitmap handles
89         IntfImg1.LoadFromBitmap(Bitmap1.Handle,Bitmap1.MaskHandle);
90         // create the XPM writer
91         Writer:=TLazWriterXPM.Create;
92         // save image to file
93         IntfImg1.SaveToFile('filename.xpm',Writer);
94         // clean up
95         Writer.Free;
96         IntfImg1.Free;
97         ...
98       end;
99     }
100 
101   TLazIntfImageGetPixelProc = procedure(x, y: integer; out Color: TFPColor) of object;
102   TLazIntfImageSetPixelProc = procedure(x, y: integer; const Color: TFPColor) of object;
103 
104   TOnReadRawImageBits = procedure(TheData: PByte;
105     const Position: TRawImagePosition;
106     Prec, Shift: cardinal; var Bits: word);
107 
108   TOnWriteRawImageBits = procedure(TheData: PByte;
109     const Position: TRawImagePosition;
110     Prec, Shift: cardinal; Bits: word);
111 
112 
113   { TLazIntfImage }
114 
115   TLazIntfImage = class(TFPCustomImage)
116   private
117     FRawImage: TRawImage;
118     FLineStarts: PRawImageLineStarts;
119     FMaskLineStarts: PRawImageLineStarts;
120     FMaskSet: Boolean; // Set when at least one maskpixel is set
121     FUpdateCount: integer;
122     fCreateAllDataNeeded: boolean;
123     FGetSetColorFunctionsUpdateNeeded: boolean;
124     FReadRawImageBits: TOnReadRawImageBits;
125     FWriteRawImageBits: TOnWriteRawImageBits;
126     FMaskReadRawImageBits: TOnReadRawImageBits;
127     FMaskWriteRawImageBits: TOnWriteRawImageBits;
128     FDataOwner: Boolean;
GetMaskednull129     function GetMasked(x, y: integer): Boolean;
GetTColorsnull130     function GetTColors(x, y: integer): TGraphicsColor;
131 
132     procedure InternalSetSize(AWidth, AHeight: integer);
133 
134     procedure SetMasked(x, y: integer; const AValue: Boolean);
135     procedure SetTColors(x, y: integer; const AValue: TGraphicsColor);
136   protected
137     FGetInternalColorProc: TLazIntfImageGetPixelProc;
138     FSetInternalColorProc: TLazIntfImageSetPixelProc;
139     procedure SetUsePalette (Value: boolean); override;
140     procedure SetInternalColor(x, y: integer; const Value: TFPColor); override;
GetInternalColornull141     function  GetInternalColor(x, y: integer): TFPColor; override;
142     procedure SetInternalPixel (x,y:integer; Value:integer); override;
GetInternalPixelnull143     function  GetInternalPixel (x,y:integer) : integer; override;
144     procedure FreeData; virtual;
145     procedure SetDataDescription(const ADescription: TRawImageDescription); virtual;
146     procedure ChooseGetSetColorFunctions; virtual;
147     procedure ChooseRawBitsProc(BitsPerPixel: cardinal;
148                                 ByteOrder: TRawImageByteOrder;
149                                 BitOrder: TRawImageBitOrder;
150                                 out ProcReadRawImageBits: TOnReadRawImageBits;
151                                 out ProcWriteRawImageBits: TOnWriteRawImageBits);
152     // get color functions
153     procedure GetColor_Generic(x, y: integer; out Value: TFPColor);
154     procedure GetColor_RGBA_NoPalette(x, y: integer; out Value: TFPColor);
155     procedure GetColor_RGB_NoPalette(x, y: integer; out Value: TFPColor);
156     procedure GetColor_Gray_NoPalette(x, y: integer; out Value: TFPColor);
157     procedure GetColor_GrayAlpha_NoPalette(x, y: integer; out Value: TFPColor);
158     procedure GetColor_NULL(x, y: integer; out Value: TFPColor);
159     // 32 bpp alpha
160     procedure GetColor_BPP32_A8R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
161     procedure GetColor_BPP32_A8B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
162     procedure GetColor_BPP32_A8G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
163     procedure GetColor_BPP32_A8G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
164     procedure GetColor_BPP32_A8R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
165     procedure GetColor_BPP32_A8B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
166     procedure GetColor_BPP32_B8G8R8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
167     procedure GetColor_BPP32_R8G8B8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
168     procedure GetColor_BPP32_G8B8R8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
169     procedure GetColor_BPP32_G8R8B8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
170     procedure GetColor_BPP32_B8R8G8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
171     procedure GetColor_BPP32_R8B8G8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
172     // 32 bpp no alpha
173     procedure GetColor_BPP32_X8R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
174     procedure GetColor_BPP32_X8B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
175     procedure GetColor_BPP32_X8G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
176     procedure GetColor_BPP32_X8G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
177     procedure GetColor_BPP32_X8R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
178     procedure GetColor_BPP32_X8B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
179     procedure GetColor_BPP32_B8G8R8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
180     procedure GetColor_BPP32_R8G8B8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
181     procedure GetColor_BPP32_G8B8R8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
182     procedure GetColor_BPP32_G8R8B8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
183     procedure GetColor_BPP32_B8R8G8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
184     procedure GetColor_BPP32_R8B8G8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
185     // 24 bpp
186     procedure GetColor_BPP24_B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
187     procedure GetColor_BPP24_R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
188     procedure GetColor_BPP24_G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
189     procedure GetColor_BPP24_G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
190     procedure GetColor_BPP24_B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
191     procedure GetColor_BPP24_R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
192 
193     procedure GetMask_Generic(x, y: integer; out AValue: Boolean);
194 
195     // set color functions
196     procedure SetColor_Generic(x, y: integer; const Value: TFPColor);
197     procedure SetColor_RGBA_NoPalette(x, y: integer; const Value: TFPColor);
198     procedure SetColor_RGB_NoPalette(x, y: integer; const Value: TFPColor);
199     procedure SetColor_Gray_NoPalette(x, y: integer; const Value: TFPColor);
200     procedure SetColor_GrayAlpha_NoPalette(x, y: integer; const Value: TFPColor);
201     procedure SetColor_NULL(x, y: integer; const Value: TFPColor);
202     // 32 bpp alpha
203     procedure SetColor_BPP32_A8R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
204     procedure SetColor_BPP32_A8B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
205     procedure SetColor_BPP32_A8G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
206     procedure SetColor_BPP32_A8G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
207     procedure SetColor_BPP32_A8R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
208     procedure SetColor_BPP32_A8B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
209     procedure SetColor_BPP32_B8G8R8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
210     procedure SetColor_BPP32_R8G8B8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
211     procedure SetColor_BPP32_G8B8R8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
212     procedure SetColor_BPP32_G8R8B8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
213     procedure SetColor_BPP32_B8R8G8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
214     procedure SetColor_BPP32_R8B8G8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
215     // 32 bpp no alpha
216     procedure SetColor_BPP32_X8R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
217     procedure SetColor_BPP32_X8B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
218     procedure SetColor_BPP32_X8G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
219     procedure SetColor_BPP32_X8G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
220     procedure SetColor_BPP32_X8R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
221     procedure SetColor_BPP32_X8B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
222     procedure SetColor_BPP32_B8G8R8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
223     procedure SetColor_BPP32_R8G8B8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
224     procedure SetColor_BPP32_G8B8R8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
225     procedure SetColor_BPP32_G8R8B8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
226     procedure SetColor_BPP32_B8R8G8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
227     procedure SetColor_BPP32_R8B8G8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
228     // 24 bpp
229     procedure SetColor_BPP24_B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
230     procedure SetColor_BPP24_R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
231     procedure SetColor_BPP24_G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
232     procedure SetColor_BPP24_G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
233     procedure SetColor_BPP24_B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
234     procedure SetColor_BPP24_R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
235 
236     procedure SetMask_Generic(x, y: integer; const AValue: Boolean);
237   public
238     constructor Create(AWidth, AHeight: integer); override;
239     constructor Create(AWidth, AHeight: integer; AFlags: TRawImageQueryFlags);
240     constructor Create(ARawImage: TRawImage; ADataOwner: Boolean);
241     constructor CreateCompatible(IntfImg: TLazIntfImage; AWidth, AHeight: integer);
242     destructor Destroy; override;
243     procedure Assign(Source: TPersistent); override;
244     procedure BeginUpdate;
245     procedure EndUpdate;
246     procedure SetSize(AWidth, AHeight: integer); override;
CheckDescriptionnull247     function CheckDescription(const ADescription: TRawImageDescription;
248                               ExceptionOnError: boolean): boolean; virtual;
249     procedure LoadFromDevice(DC: HDC); virtual;
250     procedure LoadFromBitmap(ABitmap, AMaskBitmap: HBitmap; AWidth: integer = -1; AHeight: integer = -1); virtual;
251     procedure CreateBitmaps(out ABitmap, AMask: HBitmap; ASkipMask: boolean = False); virtual;
252     procedure SetRawImage(const ARawImage: TRawImage; ADataOwner: Boolean = True); virtual;
253     procedure GetRawImage(out ARawImage: TRawImage; ATransferOwnership: Boolean = False); virtual;
254     procedure FillPixels(const Color: TFPColor); virtual;
255     procedure CopyPixels(ASource: TFPCustomImage; XDst: Integer = 0; YDst: Integer = 0;
256                          AlphaMask: Boolean = False; AlphaTreshold: Word = 0); virtual;
257     procedure AlphaBlend(ASource, ASourceAlpha: TLazIntfImage; const ADestX, ADestY: Integer);
258     procedure AlphaFromMask(AKeepAlpha: Boolean = True);
259     procedure Mask(const AColor: TFPColor; AKeepOldMask: Boolean = False);
260     procedure GetXYDataPosition(x, y: integer; out Position: TRawImagePosition);
261     procedure GetXYMaskPosition(x, y: integer; out Position: TRawImagePosition);
GetDataLineStartnull262     function  GetDataLineStart(y: integer): Pointer;// similar to Delphi TBitmap.ScanLine. Only works with lines aligned to whole bytes.
263     procedure CreateData; virtual;
HasTransparencynull264     function  HasTransparency: boolean; virtual;
HasMasknull265     function  HasMask: boolean; virtual;
266     procedure SetDataDescriptionKeepData(const ADescription: TRawImageDescription);
267   public
268     property PixelData: PByte read FRawImage.Data;
269     property MaskData: PByte read FRawImage.Mask;
270     property DataDescription: TRawImageDescription read FRawImage.Description
271                                                    write SetDataDescription;
272     property TColors[x,y: integer]: TGraphicsColor read GetTColors write SetTColors;
273     property Masked[x,y:integer]: Boolean read GetMasked write SetMasked;
274   end;
275 
276 
277   { TLazIntfImageMask }
278 
279   TLazIntfImageMask = class(TFPCustomImage)
280   private
281     FImage: TLazIntfImage;
282   protected
283     procedure SetInternalColor(x, y: integer; const Value: TFPColor); override;
GetInternalColornull284     function GetInternalColor(x, y: integer): TFPColor; override;
285     procedure SetInternalPixel (x,y:integer; Value:integer); override;
GetInternalPixelnull286     function GetInternalPixel (x,y:integer) : integer; override;
287   public
288     constructor CreateWithImage(TheImage: TLazIntfImage); virtual;
289     property Image: TLazIntfImage read FImage;
290   end;
291 
292 
293   { TLazAVLPalette }
294   { This descendent of TFPPalette uses an AVL tree for speed up. }
295 
296   TLazAVLPalette = class(TFPPalette)
297   protected
298     FAVLPalette: TAvlTree; // tree of PLazAVLPaletteEntry 'color to index'
299     FAVLNodes: PAvlTreeNode;// 'index to node' array
300     procedure SetCount(NewCount: integer); override;
301     procedure SetColor(Index: integer; const NewColor: TFPColor); override;
CompareEntriesnull302     function CompareEntries(Index1, Index2: integer): integer;
CompareColorWithEntriesnull303     function CompareColorWithEntries(const AColor: TFPColor;
304                                      Index: integer): integer;
305     procedure EnlargeData; override;
306   public
307     destructor Destroy; override;
IndexOfnull308     function IndexOf(const AColor: TFPColor): integer; override;
Addnull309     function Add(const NewColor: TFPColor): integer; override;
310     procedure CheckConsistency; virtual;
311   end;
312 
313 
314   { TArrayNodesTree }
315 
316   PArrayNode = ^TArrayNode;
317   TArrayNode = class
318   public
319     Parent: TArrayNode;
320     Value: integer;
321     Children: PArrayNode;
322     StartValue: integer;
323     Capacity: integer;
324     Data: Pointer;
325     constructor Create;
326     destructor Destroy; override;
327     procedure DeleteChilds;
328     procedure UnbindFromParent;
329     procedure CreateChildNode(ChildValue: integer);
GetChildNodenull330     function GetChildNode(ChildValue: integer;
331                           CreateIfNotExists: boolean): TArrayNode;
332     procedure Expand(ValueToInclude: integer);
FindPrevSiblingnull333     function FindPrevSibling: TArrayNode;
FindNextSiblingnull334     function FindNextSibling: TArrayNode;
FindNextUTF8null335     function FindNextUTF8: TArrayNode;
FindPrevnull336     function FindPrev: TArrayNode;
FindFirstChildnull337     function FindFirstChild: TArrayNode;
FindLastChildnull338     function FindLastChild: TArrayNode;
FindLastSubChildnull339     function FindLastSubChild: TArrayNode;
FindFirstSiblingnull340     function FindFirstSibling: TArrayNode;
FindLastSiblingnull341     function FindLastSibling: TArrayNode;
342     procedure ConsistencyCheck;
343   end;
344 
345   TArrayNodesTree = class
346   public
347     Root: TArrayNode;
FindNodenull348     function FindNode(Path: PInteger; Count: integer): TArrayNode;
FindDatanull349     function FindData(Path: PInteger; Count: integer): Pointer;
SetNodenull350     function SetNode(Path: PInteger; Count: integer;
351                      Data: Pointer): TArrayNode;
352     procedure Delete(Node: TArrayNode);
353     procedure Clear;
354     constructor Create;
355     destructor Destroy; override;
356     procedure ConsistencyCheck;
357   end;
358 
359 
360   { ILazImageReader }
361   { Extension to TFPCustomImageReader to initialize a TRawImgeDescription based
362     on the image to be read
363   }
364 
365   ILazImageReader = interface
366     ['{DD8B14DE-4E97-4816-8B40-DD6C4D8CCD1B}']
GetUpdateDescriptionnull367     function GetUpdateDescription: Boolean;
368     procedure SetUpdateDescription(AValue: Boolean);
369 
370     property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription;
371   end;
372 
373   { ILazImageWriter }
374   { Extension to TFPCustomImageWriter to initialize the writer based
375     on the intfimage data. To be able to write different formats, the writer
376     should initialize itself
377   }
378   ILazImageWriter = interface
379     ['{DFE8D2A0-E318-45CE-87DE-9C6F1F1928E5}']
380     procedure Initialize(AImage: TLazIntfImage);
381     procedure Finalize;
382   end;
383 
384 
385   { TLazReaderXPM }
386   { This is a FPImage reader for xpm images. }
387 
388   TLazReaderXPM = class(TFPCustomImageReader, ILazImageReader)
389   private
390     FWidth: Integer;
391     FHeight: Integer;
392     FColorCount: Integer;
393     FCharsPerPixel: Integer;
394     FXHot: Integer;
395     FYHot: Integer;
396     FPixelToColorTree: TArrayNodesTree;
397     FContinue: Boolean;
398     FUpdateDescription: Boolean; // If set, update rawimagedescription
399   public
GetUpdateDescriptionnull400     function  GetUpdateDescription: Boolean;
401     procedure SetUpdateDescription(AValue: Boolean);
QueryInterfacenull402     function QueryInterface(constref iid: TGuid; out obj): LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
_AddRefnull403     function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
_Releasenull404     function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
405   protected
406     procedure ClearPixelToColorTree;
407     procedure InternalRead(Str: TStream; Img: TFPCustomImage); override;
InternalChecknull408     function  InternalCheck(Str: TStream): boolean; override;
409   public
410     constructor Create; override;
411     destructor Destroy; override;
412     property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription;
413   end;
414 
415 
416   { TLazWriterXPM }
417   { This is a FPImage writer for xpm images. }
418 
419   TLazWriterXPM = class(TFPCustomImageWriter)
420   private
421     FNibblesPerSample: word;
422     FRightShiftSample: cardinal;
423     FContinue: Boolean;
424     procedure SetNibblesPerSample(const AValue: word);
425   protected
426     procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override;
427   public
428     constructor Create; override;
429     property NibblesPerSample: word read FNibblesPerSample
430                                     write SetNibblesPerSample;
431   end;
432 
433 
434   { TLazReaderDIB }
435   { This is an imroved FPImage reader for dib images. }
436 
437   TLazReaderMaskMode = (
438     lrmmNone,  // no mask is generated
439     lrmmAuto,  // a mask is generated based on the first pixel read (*)
440     lrmmColor  // a mask is generated based on the given color (*)
441   );
442   // (*) Note: when reading images with an alpha channel and the alpha channel
443   //           has no influence on the mask (unless the maskcolor is transparent)
444 
445   TLazReaderDIBEncoding = (
446     lrdeRGB,
447     lrdeRLE,
448     lrdeBitfield,
449     lrdeJpeg,     // for completion, don't know if they exist
450     lrdePng,      // for completion, don't know if they exist
451     lrdeHuffman   // for completion, don't know if they exist
452   );
453 
454   TLazReaderDIBInfo = record
455     Width: Cardinal;
456     Height: Cardinal;
457     BitCount: Byte;
458     Encoding: TLazReaderDIBEncoding;
459     PaletteCount: Word;
460     UpsideDown: Boolean;
461     PixelMasks: packed record
462       R, G, B, A: LongWord;
463     end;
464     MaskShift: record
465       R, G, B, A: Byte;
466     end;
467     MaskSize: record
468       R, G, B, A: Byte;
469     end;
470   end;
471 
472   { TLazReaderDIB }
473 
474   TLazReaderDIB = class (TFPCustomImageReader, ILazImageReader)
475   private
476     FImage: TLazIntfImage;
477 
478     FMaskMode: TLazReaderMaskMode;
479     FMaskColor: TFPColor; // color which should be interpreted as masked
480     FMaskIndex: Integer;  // for palette based images, index of the color which should be interpreted as masked
481 
482     FReadSize: Integer;          // Size (in bytes) of 1 scanline.
483     FDIBinfo: TLazReaderDIBInfo; // Info about the bitmap as read from the stream
484     FPalette: array of TFPColor; // Buffer with Palette entries.
485     FLineBuf: PByte;             // Buffer for 1 scanline. Can be Byte, Word, TColorRGB or TColorRGBA
486     FUpdateDescription: Boolean; // If set, update rawimagedescription
487     FContinue: Boolean;          // for progress support
488     FIgnoreAlpha: Boolean;       // if alpha-channel is declared but does not exists (all values = 0)
489 
490     function BitfieldsToFPColor(const AColor: Cardinal): TFPcolor;
491     function RGBToFPColor(const AColor: TColorRGBA): TFPcolor;
492     function RGBToFPColor(const AColor: TColorRGB): TFPcolor;
493     function RGBToFPColor(const AColor: Word): TFPcolor;
494 
495   public
496     function  GetUpdateDescription: Boolean;
497     procedure SetUpdateDescription(AValue: Boolean);
498     function QueryInterface(constref iid: TGuid; out obj): LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
499     function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
500     function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
501   protected
502     procedure InitLineBuf;
503     procedure FreeLineBuf;
504 
505 
506     procedure ReadScanLine(Row: Integer); virtual;
507     procedure WriteScanLine(Row: Cardinal); virtual;
508     // required by TFPCustomImageReader
509     procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
510     procedure InternalReadHead; virtual;
511     procedure InternalReadBody; virtual;
512     function  InternalCheck(Stream: TStream) : boolean; override;
513 
514     property ReadSize: Integer read FReadSize;
515     property LineBuf: PByte read FLineBuf;
516     property Info: TLazReaderDIBInfo read FDIBInfo;
517   public
518     constructor Create; override;
519     destructor Destroy; override;
520     property MaskColor: TFPColor read FMaskColor write FMaskColor;
521     property MaskMode: TLazReaderMaskMode read FMaskMode write FMaskMode;
522     property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription;
523   end;
524 
525   { TLazReaderBMP }
526 
527   TLazReaderBMP = class(TLazReaderDIB)
528   private
529     FDataOffset: Int64; // some bitmaps can specify the data offset
530   protected
531     function  InternalCheck(Stream: TStream) : boolean; override;
532     procedure InternalReadHead; override;
533   end;
534 
535   { TLazWriterBMP }
536 
537   TLazWriterBMP = class(TFPWriterBMP, ILazImageWriter)
538   public
539     function QueryInterface(constref iid: TGuid; out obj): LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
540     function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
541     function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
542   public
543     procedure Initialize(AImage: TLazIntfImage);
544     procedure Finalize;
545   end;
546 
547 
548   { TLazReaderIconDIB }
549   { This is a FPImage reader for a single DIB from an icon file }
550   TLazReaderIconDIB = class (TLazReaderDIB)
551   protected
552     procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
553   end;
554 
555 
556 
557   { TLazReaderPNG }
558 
559   TLazReaderPNG = class(TFPReaderPNG, ILazImageReader)
560   private
561     FAlphaPalette: Boolean;
562     FUpdateDescription: Boolean;
563   public
564     function  GetUpdateDescription: Boolean;
565     procedure SetUpdateDescription(AValue: Boolean);
566     function QueryInterface(constref iid: TGuid; out obj): LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
567     function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
568     function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
569   protected
570     procedure DoDecompress; override;
571     procedure HandleAlpha; override;
572     procedure InternalRead(Str:TStream; Img:TFPCustomImage); override;
573   public
574     property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription;
575   end;
576 
577   { TLazWriterPNG }
578 
579   TLazWriterPNG = class(TFPWriterPNG, ILazImageWriter)
580   public
581     function QueryInterface(constref iid: TGuid; out obj): LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
582     function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
583     function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
584   public
585     procedure Initialize(AImage: TLazIntfImage);
586     procedure Finalize;
587   end;
588 
589 {$IFNDEF DisableLCLTIFF}
590 
591   { TLazReaderTiff }
592 
593 const
594   LazTiffExtraPrefix = 'LazTiff';
595   LazTiffHostComputer = LazTiffExtraPrefix + 'HostComputer';
596   LazTiffMake = LazTiffExtraPrefix + 'Make';
597   LazTiffModel = LazTiffExtraPrefix + 'Model';
598   LazTiffSoftware = LazTiffExtraPrefix + 'Software';
599 
600 type
601   {$IF FPC_FULLVERSION<20601}
602   {$DEFINE OldTiffCreateImageHook}
603   {$ENDIF}
604 
605   TLazReaderTiff = class(TFPReaderTiff, ILazImageReader)
606   private
607     FUpdateDescription: Boolean;
608     {$IFDEF OldTiffCreateImageHook}
609     // the OnCreateImage event is "abused" to update the description after the
610     // format and before the image is read
611     FOrgEvent: TTiffCreateCompatibleImgEvent;
612     procedure CreateImageHook(Sender: TFPReaderTiff; var NewImage: TFPCustomImage);
613     procedure DoCreateImage(ImgFileDir: TTiffIDF);
614     {$ELSE}
615   protected
616     procedure DoCreateImage(ImgFileDir: TTiffIFD); override;
617     {$ENDIF}
618   public
619     function  GetUpdateDescription: Boolean;
620     procedure SetUpdateDescription(AValue: Boolean);
621     function QueryInterface(constref iid: TGuid; out obj): LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
622     function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
623     function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
624   protected
625     procedure InternalRead(Str:TStream; Img:TFPCustomImage); override;
626   public
627     property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription;
628   end;
629 
630   { TLazWriterTiff }
631 
632   TLazWriterTiff = class(TFPWriterTiff, ILazImageWriter)
633   public
634     function QueryInterface(constref iid: TGuid; out obj): LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
635     function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
636     function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
637   protected
638     procedure InternalWrite(Stream: TStream; Img: TFPCustomImage); override;
639   public
640     procedure Initialize(AImage: TLazIntfImage);
641     procedure Finalize;
642   end;
643 
644 {$ENDIF} //DisableLCLTIFF
645 
646   { TLazReaderIcnsPart }
647 
648   TLazReaderIcnsPart = class(TFPCustomImageReader, ILazImageReader)
649   private
650     FUpdateDescription: Boolean;
651     FPalette: TFPPalette;
652     FImage: TLazIntfImage;
653     FData: PByte;
654     FCalcSize: Integer;
655     FDataSize: Integer;
656     FIconType: TicnsIconType;
657     FIconInfo: TicnsIconInfo;
658   protected
659     function  InternalCheck(Str:TStream): boolean; override;
660     procedure InternalRead(Stream: TStream; Img: TFPCustomImage); override;
661     procedure SetupRead(AWidth, AHeight, ADepth: Integer; IsMask: Boolean);
662     function Create256ColorPalette: TFPPalette;
663     procedure DoReadRaw;
664     procedure DoReadRLE;
665     procedure DoReadJpeg2000;
666     procedure DoReadMask;
667   public
668     function GetUpdateDescription: Boolean;
669     procedure SetUpdateDescription(AValue: Boolean);
670     function QueryInterface(constref iid: TGuid; out obj): LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
671     function _AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
672     function _Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
673   public
674     constructor Create; override;
675     destructor Destroy; override;
676     property UpdateDescription: Boolean read GetUpdateDescription write SetUpdateDescription;
677     property IconType: TicnsIconType read FIconType;
678     property DataSize: Integer read FDataSize;
679   end;
680 
681 // extra Rawimage utility functions
682 
683 function QueryDescription(AFlags: TRawImageQueryFlags; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription;
684 procedure QueryDescription(var ADesc: TRawImageDescription; AFlags: TRawImageQueryFlags; AWidth: Integer = -1; AHeight: integer = -1);
685 function GetDescriptionFromDevice(ADC: HDC; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription;
686 function GetDescriptionFromBitmap(ABitmap: HBitmap; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription;
687 function AddAlphaToDescription(var ADesc: TRawImageDescription; APrec: Byte): Boolean;
688 
689 
690 procedure DefaultReaderDescription(AWidth, AHeight: Integer; ADepth: Byte; out ADesc: TRawImageDescription);
691 
692 
693 function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string;
694 procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
695                                      StartSize: integer);
696 
697 function dbgs(const FPColor: TFPColor): string; overload;
698 
699 implementation
700 
701 uses
702   Graphics, LCLIntf;
703 
704 type
705   PFPColorBytes = ^TFPColorBytes;
706   TFPColorBytes = record
707     {$ifdef ENDIAN_LITTLE}
708     Rl, Rh, Gl, Gh, Bl, Bh, Al, Ah: Byte;
709     {$else}
710     Rh, Rl, Gh, Gl, Bh, Bl, Ah, Al: Byte;
711     {$endif}
712   end;
713 
714   PFourBytes = ^TFourBytes;
715   TFourBytes = record
716     B0, B1, B2, B3: Byte;
717   end;
718 
719 
720 var
721   IsSpaceChar, IsNumberChar, IsHexNumberChar: array[char] of Boolean;
722 
723 function ReadCompleteStreamToString(Str: TStream; StartSize: integer): string;
724 var
725   NewLength: Integer;
726   ReadLen: Integer;
727 begin
728   if (Str is TMemoryStream) or (Str is TFileStream) or (Str is TStringStream)
729   then begin
730     // read as one block
731     SetLength(Result,Str.Size-Str.Position);
732     if Result<>'' then
733       Str.Read(Result[1],length(Result));
734   end else begin
735     // read exponential
736     if StartSize=0 then StartSize:=1024;
737     SetLength(Result,StartSize);
738     NewLength:=0;
739     repeat
740       ReadLen:=Str.Read(Result[NewLength+1],length(Result)-NewLength);
741       inc(NewLength,ReadLen);
742       if NewLength<length(Result) then break;
743       SetLength(Result,length(Result)*2);
744     until false;
745     SetLength(Result,NewLength);
746   end;
747 end;
748 
749 procedure ReadCompleteStreamToStream(SrcStream, DestStream: TStream;
750                                      StartSize: integer);
751 var
752   NewLength: Integer;
753   ReadLen: Integer;
754   Buffer: string;
755 begin
756   if (SrcStream is TMemoryStream) or (SrcStream is TFileStream)
757   or (SrcStream is TStringStream)
758   then begin
759     // read as one block
760     if DestStream is TMemoryStream then
761       TMemoryStream(DestStream).SetSize(DestStream.Size
762                                         +(SrcStream.Size-SrcStream.Position));
763     DestStream.CopyFrom(SrcStream,SrcStream.Size-SrcStream.Position);
764   end else begin
765     // read exponential
766     if StartSize<=0 then StartSize:=1024;
767     SetLength(Buffer,StartSize);
768     NewLength:=0;
769     repeat
770       ReadLen:=SrcStream.Read(Buffer[NewLength+1],length(Buffer)-NewLength);
771       inc(NewLength,ReadLen);
772       if NewLength<length(Buffer) then break;
773       SetLength(Buffer,length(Buffer)*2);
774     until false;
775     if NewLength>0 then
776       DestStream.Write(Buffer[1],NewLength);
777   end;
778 end;
779 
780 function dbgs(const FPColor: TFPColor): string;
781 begin
782   Result:='r='+hexStr(FPColor.Red,4)+',g='+hexStr(FPColor.green,4)
783         +',b='+hexStr(FPColor.blue,4)+',a='+hexStr(FPColor.alpha,4);
784 end;
785 
786 function QueryDescription(AFlags: TRawImageQueryFlags; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription;
787 begin
788   Exclude(AFlags, riqfUpdate);
789   Result{%H-}.Init;
790   QueryDescription(Result, AFlags, AWidth, AHeight);
791 end;
792 
793 procedure QueryDescription(var ADesc: TRawImageDescription; AFlags: TRawImageQueryFlags; AWidth: Integer = -1; AHeight: integer = -1);
794 begin
795   if RawImage_QueryDescription(AFlags, ADesc)
796   then begin
797     if AWidth <> -1 then ADesc.Width := AWidth;
798     if AHeight <> -1 then ADesc.Height := AHeight;
799   end
800   else begin
801     if not (riqfUpdate in AFlags) then ADesc.Init;
802   end;
803 end;
804 
805 function GetDescriptionFromDevice(ADC: HDC; AWidth, AHeight: integer): TRawImageDescription;
806 begin
807   Result{%H-}.Init;
808   if not RawImage_DescriptionFromDevice(ADC, Result) then Exit;
809   if AWidth <> -1 then Result.Width := AWidth;
810   if AHeight <> -1 then Result.Height := AHeight;
811 end;
812 
813 function GetDescriptionFromBitmap(ABitmap: HBitmap; AWidth: Integer = -1; AHeight: integer = -1): TRawImageDescription;
814 begin
815   Result{%H-}.Init;
816   if not RawImage_DescriptionFromBitmap(ABitmap, Result) then Exit;
817   if AWidth <> -1 then Result.Width := AWidth;
818   if AHeight <> -1 then Result.Height := AHeight;
819 end;
820 
821 function AddAlphaToDescription(var ADesc: TRawImageDescription; APrec: Byte): Boolean;
822   function CreateBitMask(AShift, APrec: Byte): Cardinal; inline;
823   begin
824     Result := ($FFFFFFFF shr (32 - APrec)) shl AShift;
825   end;
826 var
827   Mask: Cardinal;
828 begin
829   Result:=false;
830   if ADesc.AlphaPrec >= APrec then Exit;
831   if ADesc.BitsPerPixel <> 32 then Exit;
832   if ADesc.Depth <> 24 then Exit;
833 
834   Mask := CreateBitMask(ADesc.RedShift, ADesc.RedPrec)
835        or CreateBitMask(ADesc.GreenShift, ADesc.GreenPrec)
836        or CreateBitMask(ADesc.BlueShift, ADesc.BluePrec);
837 
838   if (Mask and $FF = 0)
839   then begin
840     ADesc.AlphaShift := 0;
841     Result := True;
842   end
843   else
844     if (Mask and $FF000000 = 0)
845     then begin
846       ADesc.AlphaShift := 24;
847       Result := True;
848     end;
849   if Result
850   then begin
851     ADesc.AlphaPrec := APrec;
852     ADesc.Depth := 32;
853   end;
854 end;
855 
856 procedure CheckAlphaDescription(AImage: TFPCustomImage);
857 var
858   Desc: TRawImageDescription;
859 begin
860   if not (AImage is TLazIntfImage) then Exit;
861 
862   Desc := TLazIntfImage(AImage).DataDescription;
863   if Desc.AlphaPrec >= 8 then Exit;
864 
865   if not AddAlphaToDescription(Desc, 8)
866   then begin
867     Desc.Init_BPP32_B8G8R8A8_BIO_TTB(Desc.Width, Desc.Height);
868     // copy mask description
869     with TLazIntfImage(AImage).DataDescription do
870     begin
871       Desc.MaskBitsPerPixel := MaskBitsPerPixel;
872       Desc.MaskShift := MaskShift;
873       Desc.MaskLineEnd := MaskLineEnd;
874       Desc.MaskBitOrder := MaskBitOrder;
875     end;
876   end;
877 
878   TLazIntfImage(AImage).DataDescription := Desc;
879 end;
880 
881 procedure DefaultReaderDescription(AWidth, AHeight: Integer; ADepth: Byte; out ADesc: TRawImageDescription);
882 begin
883   // Default description, assume 24bit for palettebased
884   // Maybe when RawImage palette is supported, other descriptions need to be adjusted.
885 
886   ADesc.Init_BPP24_B8G8R8_M1_BIO_TTB(AWidth, AHeight);
887 
888   case ADepth of
889     1: begin
890       ADesc.Depth := 1;
891       ADesc.BitsPerPixel := 1;
892       ADesc.Format := ricfGray;
893       ADesc.LineEnd := rileWordBoundary;
894       ADesc.RedPrec := 1;
895       ADesc.RedShift := 0;
896       ADesc.GreenPrec := 1;
897       ADesc.GreenShift := 0;
898       ADesc.BluePrec := 1;
899       ADesc.BlueShift := 0;
900     end;
901     2..4: begin
902 //      ADesc.Depth := 4;
903 //      ADesc.BitsPerPixel := 4;
904     end;
905     5..8: begin
906 //      ADesc.Depth := 8;
907 //      ADesc.BitsPerPixel := 8;
908     end;
909     9..15: begin
910       ADesc.Depth := 15;
911       ADesc.BitsPerPixel := 16;
912       ADesc.RedPrec := 5;
913       ADesc.RedShift := 10;
914       ADesc.GreenPrec := 5;
915       ADesc.GreenShift := 5;
916       ADesc.BluePrec := 5;
917       ADesc.BlueShift := 0;
918     end;
919     16: begin
920       ADesc.Depth := 16;
921       ADesc.BitsPerPixel := 16;
922       ADesc.RedPrec := 5;
923       ADesc.RedShift := 10;
924       ADesc.GreenPrec := 6;
925       ADesc.GreenShift := 5;
926       ADesc.BluePrec := 5;
927       ADesc.BlueShift := 0;
928     end;
929     17..24: begin
930       // already default
931     end;
932   else
933     ADesc.Depth := 32;
934     ADesc.BitsPerPixel := 32;
935     ADesc.AlphaPrec := 8;
936     ADesc.AlphaShift := 24;
937   end;
938 end;
939 
940 // ReadRawImageBits_* routines are called multiple times, once for each channel
941 // Therefore Shift means the Shift in the raw image of the channel
942 // TheData points to beginning of the image data
943 // Position is the position in bytes to the start of the pixel in TheData
944 // Prec is the precision of the channel
945 // Bits is the value of the channel, which is the output
946 
947 
948 procedure ReadRawImageBits_1_2_4_BIO(TheData: PByte;
949   const Position: TRawImagePosition;
950   Prec, Shift: cardinal;
951   var Bits: word);
952 var
953   P: PByte;
954   PrecMask: Cardinal;
955   OneByte: Byte;
956 begin
957   PrecMask:=(Cardinal(1) shl Prec)-1;
958   P:=@(TheData[Position.Byte]);
959 
960   OneByte:=P^;
961   Bits:=Word(cardinal(OneByte shr (Shift+Position.Bit)) and PrecMask);
962 
963   if Prec<16 then begin
964     // add missing bits
965     Bits:=(Bits shl (16-Prec));
966     Bits:=Bits or MissingBits[Prec,Bits shr 13];
967   end;
968 end;
969 
970 procedure ReadRawImageBits_1_2_4_BNIO(TheData: PByte;
971   const Position: TRawImagePosition;
972   Prec, Shift: cardinal;
973   var Bits: word);
974 var
975   P: PByte;
976   PrecMask: Cardinal;
977   OneByte: Byte;
978 begin
979   PrecMask:=(Cardinal(1) shl Prec)-1;
980   P:=@(TheData[Position.Byte]);
981 
982   OneByte:=P^;
983   Bits:=Word(cardinal(OneByte shr (Shift+7-Position.Bit)) and PrecMask);
984 
985   if Prec<16 then begin
986     // add missing bits
987     Bits:=(Bits shl (16-Prec));
988     Bits:=Bits or MissingBits[Prec,Bits shr 13];
989   end;
990 end;
991 
992 procedure ReadRawImageBits_8(TheData: PByte;
993   const Position: TRawImagePosition;
994   Prec, Shift: cardinal;
995   var Bits: word);
996 var
997   P: PByte;
998   PrecMask: Cardinal;
999   OneByte: Byte;
1000 begin
1001   PrecMask:=(Cardinal(1) shl Prec)-1;
1002   P:=@(TheData[Position.Byte]);
1003 
1004   OneByte:=P^;
1005   Bits:=Word(cardinal(OneByte shr Shift) and PrecMask);
1006 
1007   if Prec<16 then begin
1008     // add missing bits
1009     Bits:=(Bits shl (16-Prec));
1010     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1011   end;
1012 end;
1013 
1014 procedure ReadRawImageBits_16(TheData: PByte;
1015   const Position: TRawImagePosition;
1016   Prec, Shift: cardinal;
1017   var Bits: word);
1018 var
1019   P: PByte;
1020   PrecMask: Cardinal;
1021   TwoBytes: Word;
1022 begin
1023   PrecMask:=(Cardinal(1) shl Prec)-1;
1024   P:=@(TheData[Position.Byte]);
1025 
1026   TwoBytes:=PWord(P)^;
1027   Bits:=Word(cardinal(TwoBytes shr Shift) and PrecMask);
1028 
1029   if Prec<16 then begin
1030     // add missing bits
1031     Bits:=(Bits shl (16-Prec));
1032     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1033   end;
1034 end;
1035 
1036 procedure ReadRawImageBits_ReversedBytes_16(TheData: PByte;
1037   const Position: TRawImagePosition;
1038   Prec, Shift: cardinal;
1039   var Bits: word);
1040 var
1041   P: PByte;
1042   PrecMask: Cardinal;
1043   TwoBytes: Word;
1044 begin
1045   PrecMask:=(Cardinal(1) shl Prec)-1;
1046   P:=@(TheData[Position.Byte]);
1047 
1048   TwoBytes:=PWord(P)^;
1049   TwoBytes:=(TwoBytes shr 8) or ((TwoBytes and $ff) shl 8); // switch byte order
1050   Bits:=Word(cardinal(TwoBytes shr Shift) and PrecMask);
1051 
1052   if Prec<16 then begin
1053     // add missing bits
1054     Bits:=(Bits shl (16-Prec));
1055     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1056   end;
1057 end;
1058 
1059 procedure ReadRawImageBits_24(TheData: PByte;
1060   const Position: TRawImagePosition;
1061   Prec, Shift: cardinal;
1062   var Bits: word);
1063 var
1064   P: PByte;
1065   PrecMask: Cardinal;
1066   FourBytes: Cardinal;
1067 begin
1068   PrecMask:=(Cardinal(1) shl Prec)-1;
1069   P:=@(TheData[Position.Byte]);
1070 
1071   {$ifdef Endian_Little}
1072   FourBytes:=DWord(PWord(P)^) or (DWord((P+2)^) shl 16);
1073   {$else}
1074   FourBytes:=(DWord(PWord(P)^) shl 8) or DWord((P+2)^);
1075   {$endif}
1076   Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask);
1077 
1078   if Prec<16 then begin
1079     // add missing bits
1080     Bits:=(Bits shl (16-Prec));
1081     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1082   end;
1083 end;
1084 
1085 procedure ReadRawImageBits_ReversedBytes_24(TheData: PByte;
1086   const Position: TRawImagePosition;
1087   Prec, Shift: cardinal;
1088   var Bits: word);
1089 var
1090   P: PByte;
1091   PrecMask: Cardinal;
1092   FourBytes: Cardinal;
1093 begin
1094   PrecMask:=(Cardinal(1) shl Prec)-1;
1095   P:=@(TheData[Position.Byte]);
1096 
1097   {$ifdef Endian_Little}
1098   FourBytes:=(DWord(PWord(P)^) shl 8) or DWord((P+2)^);
1099   {$else}
1100   FourBytes:=DWord(PWord(P)^) or (DWord((P+2)^) shl 16);
1101   {$endif}
1102 
1103   Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask);
1104 
1105   if Prec<16 then begin
1106     // add missing bits
1107     Bits:=(Bits shl (16-Prec));
1108     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1109   end;
1110 end;
1111 
1112 procedure ReadRawImageBits_32(TheData: PByte;
1113   const Position: TRawImagePosition;
1114   Prec, Shift: cardinal;
1115   var Bits: word);
1116 var
1117   P: PByte;
1118   PrecMask: Cardinal;
1119   FourBytes: Cardinal;
1120 begin
1121   PrecMask:=(Cardinal(1) shl Prec)-1;
1122   P:=@(TheData[Position.Byte]);
1123 
1124   FourBytes:=PDWord(P)^;
1125   Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask);
1126 
1127   if Prec<16 then begin
1128     // add missing bits
1129     Bits:=(Bits shl (16-Prec));
1130     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1131   end;
1132 end;
1133 
1134 procedure ReadRawImageBits_ReversedBytes_32(TheData: PByte;
1135   const Position: TRawImagePosition;
1136   Prec, Shift: cardinal;
1137   var Bits: word);
1138 var
1139   P: PByte;
1140   PrecMask: Cardinal;
1141   FourBytes: Cardinal;
1142 begin
1143   PrecMask:=(Cardinal(1) shl Prec)-1;
1144   P:=@(TheData[Position.Byte]);
1145 
1146   FourBytes:=PDWord(P)^;
1147 
1148   // switch byte order
1149   FourBytes:=(FourBytes shr 24) or ((FourBytes shr 8) and $FF00)
1150              or ((FourBytes and $ff00) shl 8) or ((FourBytes and $ff) shl 24);
1151 
1152   Bits:=Word(cardinal(FourBytes shr Shift) and PrecMask);
1153 
1154   if Prec<16 then begin
1155     // add missing bits
1156     Bits:=(Bits shl (16-Prec));
1157     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1158   end;
1159 end;
1160 
1161 procedure ReadRawImageBits_48(TheData: PByte;
1162   const Position: TRawImagePosition;
1163   Prec, Shift: cardinal;
1164   var Bits: word);
1165 var
1166   P: PByte;
1167   PrecMask: Cardinal;
1168   EightBytes: QWord;
1169 begin
1170   PrecMask:=(Cardinal(1) shl Prec)-1;
1171   P:=@(TheData[Position.Byte]);
1172 
1173   {$ifdef Endian_Little}
1174   EightBytes:=QWord(PDWord(P)^) or (QWord(PWord(P+4)^) shl 32);
1175   {$else}
1176   EightBytes:=(QWord(PDWord(P)^) shl 16) or QWord(PWord(P+4)^);
1177   {$endif}
1178   Bits:=Word(cardinal(EightBytes shr Shift) and PrecMask);
1179 
1180   if Prec<16 then begin
1181     // add missing bits
1182     Bits:=(Bits shl (16-Prec));
1183     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1184   end;
1185 end;
1186 
1187 procedure ReadRawImageBits_ReversedBytes_48(TheData: PByte;
1188   const Position: TRawImagePosition;
1189   Prec, Shift: cardinal;
1190   var Bits: word);
1191 var
1192   P: PByte;
1193   PrecMask: Cardinal;
1194   EightBytes: QWord;
1195 begin
1196   PrecMask:=(Cardinal(1) shl Prec)-1;
1197   P:=@(TheData[Position.Byte]);
1198 
1199   {$ifdef Endian_Little}
1200   EightBytes:=(QWord(PDWord(P)^) shl 16) or QWord(PWord(P+4)^);
1201   {$else}
1202   EightBytes:=QWord(PDWord(P)^) or (QWord(PWord(P+4)^) shl 32);
1203   {$endif}
1204   Bits:=Word(cardinal(EightBytes shr Shift) and PrecMask);
1205 
1206   if Prec<16 then begin
1207     // add missing bits
1208     Bits:=(Bits shl (16-Prec));
1209     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1210   end;
1211 end;
1212 
1213 procedure ReadRawImageBits_64(TheData: PByte;
1214   const Position: TRawImagePosition;
1215   Prec, Shift: cardinal;
1216   var Bits: word);
1217 var
1218   P: PByte;
1219   PrecMask: Cardinal;
1220   EightBytes: QWord;
1221 begin
1222   PrecMask:=(Cardinal(1) shl Prec)-1;
1223   P:=@(TheData[Position.Byte]);
1224 
1225   EightBytes:=PQWord(P)^;
1226   Bits:=Word(Cardinal(EightBytes shr Shift) and PrecMask);
1227 
1228   if Prec<16 then begin
1229     // add missing bits
1230     Bits:=(Bits shl (16-Prec));
1231     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1232   end;
1233 end;
1234 
1235 procedure ReadRawImageBits_ReversedBytes_64(TheData: PByte;
1236   const Position: TRawImagePosition;
1237   Prec, Shift: cardinal;
1238   var Bits: word);
1239 var
1240   P: PByte;
1241   PrecMask: Cardinal;
1242   EightBytes: QWord;
1243 begin
1244   PrecMask:=(Cardinal(1) shl Prec)-1;
1245   P:=@(TheData[Position.Byte]);
1246 
1247   EightBytes:=PQWord(P)^;
1248 
1249   // switch byte order
1250   EightBytes:=swapendian(EightBytes);
1251 
1252   Bits:=Word(Cardinal(EightBytes shr Shift) and PrecMask);
1253 
1254   if Prec<16 then begin
1255     // add missing bits
1256     Bits:=(Bits shl (16-Prec));
1257     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1258   end;
1259 end;
1260 
1261 procedure WriteRawImageBits_1_2_4_BIO(TheData: PByte;
1262   const Position: TRawImagePosition;
1263   Prec, Shift: cardinal; Bits: word);
1264 var
1265   P: PByte;
1266   PrecMask: Cardinal;
1267   OneByte: Byte;
1268   ShiftLeft: Integer;
1269 begin
1270   P:=@(TheData[Position.Byte]);
1271   PrecMask:=(Cardinal(1) shl Prec)-1;
1272   Bits:=Bits shr (16-Prec);
1273 
1274   OneByte:=P^;
1275   ShiftLeft:=Shift+Position.Bit;
1276   PrecMask:=not (PrecMask shl ShiftLeft);
1277   OneByte:=OneByte and PrecMask; // clear old
1278   OneByte:=OneByte or (Bits shl ShiftLeft); // set new
1279   P^:=OneByte;
1280 end;
1281 
1282 procedure WriteRawImageBits_1_2_4_BNIO(TheData: PByte;
1283   const Position: TRawImagePosition;
1284   Prec, Shift: cardinal; Bits: word);
1285 var
1286   P: PByte;
1287   PrecMask: Cardinal;
1288   OneByte: Byte;
1289   ShiftLeft: Integer;
1290 begin
1291   P:=@(TheData[Position.Byte]);
1292   PrecMask:=(Cardinal(1) shl Prec)-1;
1293   Bits:=Bits shr (16-Prec);
1294 
1295   OneByte:=P^;
1296   ShiftLeft:=Shift+7-Position.Bit;
1297   PrecMask:=not (PrecMask shl ShiftLeft);
1298   OneByte:=OneByte and PrecMask; // clear old
1299   OneByte:=OneByte or (Bits shl ShiftLeft); // set new
1300   P^:=OneByte;
1301 end;
1302 
1303 procedure WriteRawImageBits_8(TheData: PByte;
1304   const Position: TRawImagePosition;
1305   Prec, Shift: cardinal; Bits: word);
1306 var
1307   P: PByte;
1308   PrecMask: Cardinal;
1309   OneByte: Byte;
1310 begin
1311   P:=@(TheData[Position.Byte]);
1312   PrecMask:=(Cardinal(1) shl Prec)-1;
1313   Bits:=Bits shr (16-Prec);
1314 
1315   OneByte:=P^;
1316   PrecMask:=not (PrecMask shl Shift);
1317   OneByte:=OneByte and PrecMask; // clear old
1318   OneByte:=OneByte or (Bits shl Shift); // set new
1319   P^:=OneByte;
1320 end;
1321 
1322 procedure WriteRawImageBits_16(TheData: PByte;
1323   const Position: TRawImagePosition;
1324   Prec, Shift: cardinal; Bits: word);
1325 var
1326   P: PByte;
1327   PrecMask: Cardinal;
1328   TwoBytes: Word;
1329 begin
1330   P:=@(TheData[Position.Byte]);
1331   PrecMask:=(Cardinal(1) shl Prec)-1;
1332   Bits:=Bits shr (16-Prec);
1333 
1334   TwoBytes:=PWord(P)^;
1335   PrecMask:=not (PrecMask shl Shift);
1336   TwoBytes:=TwoBytes and PrecMask; // clear old
1337   TwoBytes:=TwoBytes or (Bits shl Shift); // set new
1338   PWord(P)^:=TwoBytes;
1339 end;
1340 
1341 procedure WriteRawImageBits_ReversedBytes_16(TheData: PByte;
1342   const Position: TRawImagePosition;
1343   Prec, Shift: cardinal; Bits: word);
1344 var
1345   P: PByte;
1346   PrecMask: Cardinal;
1347   TwoBytes: Word;
1348 begin
1349   P:=@(TheData[Position.Byte]);
1350   PrecMask:=(Cardinal(1) shl Prec)-1;
1351   Bits:=Bits shr (16-Prec);
1352 
1353   TwoBytes:=PWord(P)^;
1354   TwoBytes:=(TwoBytes shr 8) or ((TwoBytes and $ff) shl 8); // switch byte order
1355   PrecMask:=not (PrecMask shl Shift);
1356   TwoBytes:=TwoBytes and PrecMask; // clear old
1357   TwoBytes:=TwoBytes or (Bits shl Shift); // set new
1358   TwoBytes:=(TwoBytes shr 8) or ((TwoBytes and $ff) shl 8); // switch byte order
1359   PWord(P)^:=TwoBytes;
1360 end;
1361 
1362 procedure WriteRawImageBits_24(TheData: PByte;
1363   const Position: TRawImagePosition;
1364   Prec, Shift: cardinal; Bits: word);
1365 var
1366   P: PByte;
1367   PrecMask: Cardinal;
1368   FourBytes: Cardinal;
1369 begin
1370   P:=@(TheData[Position.Byte]);
1371   PrecMask:=(Cardinal(1) shl Prec)-1;
1372   Bits:=Bits shr (16-Prec);
1373 
1374 {$ifdef Endian_Little}
1375   FourBytes:=DWord(PWord(P)^) or (DWord((P+2)^) shl 16);
1376 {$else}
1377   FourBytes:=(DWord(PWord(P)^) shl 8) or DWord((P+2)^);
1378 {$endif}
1379 
1380   PrecMask:=not (PrecMask shl Shift);
1381   FourBytes:=FourBytes and PrecMask; // clear old
1382   FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new
1383 
1384 {$ifdef Endian_little}
1385   PWord(P)^ := Word(FourBytes);
1386   P[2] := Byte(FourBytes shr 16);
1387 {$else}
1388   PWord(P)^ := Word(FourBytes shr 8);
1389   P[2] := Byte(FourBytes);
1390 {$endif}
1391 end;
1392 
1393 procedure WriteRawImageBits_ReversedBytes_24(TheData: PByte;
1394   const Position: TRawImagePosition;
1395   Prec, Shift: cardinal; Bits: word);
1396 var
1397   P: PByte;
1398   PrecMask: Cardinal;
1399   FourBytes: Cardinal;
1400 begin
1401   P:=@(TheData[Position.Byte]);
1402   PrecMask:=(Cardinal(1) shl Prec)-1;
1403   Bits:=Bits shr (16-Prec);
1404 
1405 {$ifdef Endian_Little}
1406   FourBytes:=(DWord(PWord(P)^) shl 8) or DWord(P^);
1407 {$else}
1408   FourBytes:=DWord(PWord(P)^) or (DWord((P+2)^) shl 16);
1409 {$endif}
1410 
1411   PrecMask:=not (PrecMask shl Shift);
1412   FourBytes:=FourBytes and PrecMask; // clear old
1413   FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new
1414 
1415 {$ifdef Endian_little}
1416   PWord(P)^ := Word(FourBytes shr 8);
1417   P^ := Byte(FourBytes);
1418 {$else}
1419   PWord(P)^ := Word(FourBytes);
1420   (P+2)^ := Byte(FourBytes shr 16);
1421 {$endif}
1422 end;
1423 
1424 procedure WriteRawImageBits_32(TheData: PByte;
1425   const Position: TRawImagePosition;
1426   Prec, Shift: cardinal; Bits: word);
1427 var
1428   P: PByte;
1429   PrecMask: Cardinal;
1430   FourBytes: Cardinal;
1431 begin
1432   if Prec=16
1433   then begin
1434     // fast update
1435     P:=@(TheData[Position.Byte]);
1436     inc(P,2-Shift shr 3);
1437     PWORD(P)^:=Bits;
1438     Exit;
1439   end;
1440 
1441   P:=@(TheData[Position.Byte]);
1442   PrecMask:=(Cardinal(1) shl Prec)-1;
1443   Bits:=Bits shr (16-Prec);
1444 
1445   FourBytes:=PDWord(P)^;
1446   PrecMask:=not (PrecMask shl Shift);
1447   FourBytes:=FourBytes and PrecMask; // clear old
1448   FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new
1449   PDWord(P)^:=FourBytes;
1450 end;
1451 
1452 procedure WriteRawImageBits_ReversedBytes_32(TheData: PByte;
1453   const Position: TRawImagePosition;
1454   Prec, Shift: cardinal; Bits: word);
1455 var
1456   P: PByte;
1457   PrecMask: Cardinal;
1458   FourBytes: Cardinal;
1459 begin
1460   P:=@(TheData[Position.Byte]);
1461   PrecMask:=(Cardinal(1) shl Prec)-1;
1462   Bits:=Bits shr (16-Prec);
1463 
1464   FourBytes:=PDWord(P)^;
1465 
1466   // switch byte order
1467   FourBytes:=(FourBytes shr 24) or ((FourBytes shr 8) and $FF00)
1468              or ((FourBytes and $ff00) shl 8) or ((FourBytes and $ff) shl 24);
1469 
1470   PrecMask:=not (PrecMask shl Shift);
1471   FourBytes:=FourBytes and PrecMask; // clear old
1472   FourBytes:=FourBytes or cardinal(Bits shl Shift); // set new
1473 
1474   // switch byte order
1475   FourBytes:=(FourBytes shr 24) or ((FourBytes shr 8) and $FF00)
1476              or ((FourBytes and $ff00) shl 8) or ((FourBytes and $ff) shl 24);
1477   PDWord(P)^:=FourBytes;
1478 end;
1479 
1480 procedure WriteRawImageBits_48(TheData: PByte;
1481   const Position: TRawImagePosition;
1482   Prec, Shift: cardinal; Bits: word);
1483 var
1484   P: PByte;
1485   PrecMask: QWord;
1486   EightBytes: QWord;
1487 begin
1488   P:=@(TheData[Position.Byte]);
1489   PrecMask:=(QWord(1) shl Prec)-1;
1490   Bits:=Bits shr (16-Prec);
1491 
1492 {$ifdef Endian_Little}
1493   EightBytes:=QWord(PDWord(P)^) or (QWord(PWord(P+4)^) shl 32);
1494 {$else}
1495   EightBytes:=(QWord(PDWord(P)^) shl 16) or QWord(PWord(P+4)^);
1496 {$endif}
1497 
1498   PrecMask:=not (PrecMask shl Shift);
1499   EightBytes:=EightBytes and PrecMask; // clear old
1500   EightBytes:=EightBytes or QWord(Bits) shl Shift; // set new
1501 
1502 {$ifdef Endian_little}
1503   PDWord(P)^ := DWord(EightBytes);
1504   PWord(P+4)^ := Word(EightBytes shr 32);
1505 {$else}
1506   PDWord(P)^ := DWord(EightBytes shr 16);
1507   PWord(P+4)^ := Word(EightBytes);
1508 {$endif}
1509 end;
1510 
1511 procedure WriteRawImageBits_ReversedBytes_48(TheData: PByte;
1512   const Position: TRawImagePosition;
1513   Prec, Shift: cardinal; Bits: word);
1514 var
1515   P: PByte;
1516   PrecMask: QWord;
1517   EightBytes: QWord;
1518 begin
1519   P:=@(TheData[Position.Byte]);
1520   PrecMask:=(QWord(1) shl Prec)-1;
1521   Bits:=Bits shr (16-Prec);
1522 
1523 {$ifdef Endian_Little}
1524   EightBytes:=(QWord(PDWord(P)^) shl 16) or QWord(PWord(P+4)^);
1525 {$else}
1526   EightBytes:=QWord(PDWord(P)^) or (QWord(PWord(P+4)^) shl 32);
1527 {$endif}
1528 
1529   PrecMask:=not (PrecMask shl Shift);
1530   EightBytes:=EightBytes and PrecMask; // clear old
1531   EightBytes:=EightBytes or QWord(Bits) shl Shift; // set new
1532 
1533 {$ifdef Endian_little}
1534   PDWord(P)^ := DWord(EightBytes shr 16);
1535   PWord(P+4)^ := Word(EightBytes);
1536 {$else}
1537   PDWord(P)^ := DWord(EightBytes);
1538   PWord(P+4)^ := Word(EightBytes shr 32);
1539 {$endif}
1540 end;
1541 
1542 procedure WriteRawImageBits_64(TheData: PByte;
1543   const Position: TRawImagePosition;
1544   Prec, Shift: cardinal; Bits: word);
1545 var
1546   P: PByte;
1547   PrecMask: QWord;
1548   EightBytes: QWord;
1549 begin
1550   P:=@(TheData[Position.Byte]);
1551   PrecMask:=(Qword(1) shl Prec)-1;
1552   Bits:=Bits shr (16-Prec);
1553 
1554   EightBytes:=PQWord(P)^;
1555   PrecMask:=not (PrecMask shl Shift);
1556   EightBytes:=EightBytes and PrecMask; // clear old
1557   EightBytes:=EightBytes or QWord(Bits) shl Shift; // set new
1558   PQWord(P)^:=EightBytes;
1559 end;
1560 
1561 procedure WriteRawImageBits_ReversedBytes_64(TheData: PByte;
1562   const Position: TRawImagePosition;
1563   Prec, Shift: cardinal; Bits: word);
1564 var
1565   P: PByte;
1566   PrecMask: QWord;
1567   EightBytes: QWord;
1568 begin
1569   P:=@(TheData[Position.Byte]);
1570   PrecMask:=(QWord(1) shl Prec)-1;
1571   Bits:=Bits shr (16-Prec);
1572 
1573   EightBytes:=PQWord(P)^;
1574 
1575   // switch byte order
1576   EightBytes:=swapendian(EightBytes);
1577 
1578   PrecMask:=not (PrecMask shl Shift);
1579   EightBytes:=EightBytes and PrecMask; // clear old
1580   EightBytes:=EightBytes or QWord(Bits) shl Shift; // set new
1581 
1582   // switch byte order
1583   EightBytes:=swapendian(EightBytes);
1584   PQWord(P)^:=EightBytes;
1585 end;
1586 
1587 
1588 procedure ReadRawImageBits_NULL(TheData: PByte;
1589   const Position: TRawImagePosition;
1590   Prec, Shift: cardinal;
1591   var Bits: word);
1592 begin
1593   Bits:=0;
1594 
1595   if Prec<16 then begin
1596     // add missing bits
1597     Bits:=(Bits shl (16-Prec));
1598     Bits:=Bits or MissingBits[Prec,Bits shr 13];
1599   end;
1600 end;
1601 
1602 procedure WriteRawImageBits_NULL(TheData: PByte;
1603   const Position: TRawImagePosition;
1604   Prec, Shift: cardinal; Bits: word);
1605 begin
1606 end;
1607 
1608 { TLazIntfImage }
1609 
1610 procedure TLazIntfImage.SetDataDescription(const ADescription: TRawImageDescription);
1611 begin
1612   if CompareMem(@FRawImage.Description, @ADescription, SizeOf(TRawImageDescription))
1613   then Exit;
1614 
1615   CheckDescription(ADescription, True);
1616   BeginUpdate;
1617   try
1618     FreeData;
1619     FRawImage.Description := ADescription;
1620     ChooseGetSetColorFunctions;
1621     InternalSetSize(ADescription.Width, ADescription.Height);
1622     CreateData;
1623   finally
1624     EndUpdate;
1625   end;
1626 end;
1627 
1628 procedure TLazIntfImage.ChooseRawBitsProc(BitsPerPixel: cardinal;
1629   ByteOrder: TRawImageByteOrder; BitOrder: TRawImageBitOrder;
1630   out ProcReadRawImageBits: TOnReadRawImageBits;
1631   out ProcWriteRawImageBits: TOnWriteRawImageBits);
1632 begin
1633   case BitsPerPixel of
1634 
1635   1,2,4:
1636   begin
1637     if BitOrder = riboBitsInOrder then
1638     begin
1639       ProcReadRawImageBits  := @ReadRawImageBits_1_2_4_BIO;
1640       ProcWriteRawImageBits := @WriteRawImageBits_1_2_4_BIO;
1641     end else begin
1642       ProcReadRawImageBits  := @ReadRawImageBits_1_2_4_BNIO;
1643       ProcWriteRawImageBits := @WriteRawImageBits_1_2_4_BNIO;
1644     end;
1645   end;
1646 
1647   8:
1648   begin
1649     ProcReadRawImageBits  := @ReadRawImageBits_8;
1650     ProcWriteRawImageBits := @WriteRawImageBits_8;
1651   end;
1652 
1653   16:
1654   begin
1655     if DefaultByteOrder=ByteOrder then begin
1656       ProcReadRawImageBits  := @ReadRawImageBits_16;
1657       ProcWriteRawImageBits := @WriteRawImageBits_16;
1658     end else begin
1659       ProcReadRawImageBits  := @ReadRawImageBits_ReversedBytes_16;
1660       ProcWriteRawImageBits := @WriteRawImageBits_ReversedBytes_16;
1661     end;
1662   end;
1663 
1664   24:
1665   begin
1666     if DefaultByteOrder=ByteOrder then begin
1667       ProcReadRawImageBits  := @ReadRawImageBits_24;
1668       ProcWriteRawImageBits := @WriteRawImageBits_24;
1669     end else begin
1670       ProcReadRawImageBits  := @ReadRawImageBits_ReversedBytes_24;
1671       ProcWriteRawImageBits := @WriteRawImageBits_ReversedBytes_24;
1672     end;
1673   end;
1674 
1675   32:
1676   begin
1677     if DefaultByteOrder=ByteOrder then begin
1678       ProcReadRawImageBits  := @ReadRawImageBits_32;
1679       ProcWriteRawImageBits := @WriteRawImageBits_32;
1680     end else begin
1681       ProcReadRawImageBits  := @ReadRawImageBits_ReversedBytes_32;
1682       ProcWriteRawImageBits := @WriteRawImageBits_ReversedBytes_32;
1683     end;
1684   end;
1685 
1686   48:
1687   begin
1688     if DefaultByteOrder=ByteOrder then begin
1689       ProcReadRawImageBits  := @ReadRawImageBits_48;
1690       ProcWriteRawImageBits := @WriteRawImageBits_48;
1691     end else begin
1692       ProcReadRawImageBits  := @ReadRawImageBits_ReversedBytes_48;
1693       ProcWriteRawImageBits := @WriteRawImageBits_ReversedBytes_48;
1694     end;
1695   end;
1696 
1697   64:
1698   begin
1699     if DefaultByteOrder=ByteOrder then begin
1700       ProcReadRawImageBits  := @ReadRawImageBits_64;
1701       ProcWriteRawImageBits := @WriteRawImageBits_64;
1702     end else begin
1703       ProcReadRawImageBits  := @ReadRawImageBits_ReversedBytes_64;
1704       ProcWriteRawImageBits := @WriteRawImageBits_ReversedBytes_64;
1705     end;
1706   end;
1707 
1708   else
1709     {$IFNDEF DisableChecks}
1710     DebugLn('WARNING: TLazIntfImage.ChooseRawBitsProc Unsupported BitsPerPixel=',dbgs(BitsPerPixel));
1711     {$ENDIF}
1712     ProcReadRawImageBits  := @ReadRawImageBits_NULL;
1713     ProcWriteRawImageBits := @WriteRawImageBits_NULL;
1714   end;
1715 end;
1716 
1717 procedure TLazIntfImage.ChooseGetSetColorFunctions;
1718 
1719   function ChooseRGBA_32Bpp: Boolean;
1720   var
1721     Positions: Byte;
1722   begin
1723     Result := False;
1724     with FRawImage.Description do
1725     begin
1726       if Depth <> 32 then Exit;
1727       if BitsPerPixel <> 32 then Exit;
1728       if LineOrder <> riloTopToBottom then Exit;
1729       if AlphaPrec <> 8 then Exit;
1730       if RedPrec <> 8 then Exit;
1731       if GreenPrec <> 8 then Exit;
1732       if BluePrec <> 8 then Exit;
1733       if AlphaShift and 7 <> 0 then Exit;
1734       if RedShift and 7 <> 0 then Exit;
1735       if GreenShift and 7 <> 0 then Exit;
1736       if BlueShift and 7 <> 0 then Exit;
1737 
1738       Positions := (((AlphaShift shr 3) and 3) shl 6
1739                 or ((RedShift shr 3) and 3) shl 4
1740                 or ((GreenShift shr 3) and 3) shl 2
1741                 or ((BlueShift shr 3) and 3)) and $FF;
1742 
1743       if ByteOrder = riboMSBFirst
1744       then Positions := not Positions; // reverse positions
1745     end;
1746 
1747     // the locations of A,R,G,B are now coded in 2 bits each: AARRGGBB
1748     // the 2-bit value (0..3) represents the location of the channel,
1749     // counting from left
1750     case Positions of
1751       {AARRGGBB}
1752       %00011011: begin
1753         FGetInternalColorProc := @GetColor_BPP32_A8R8G8B8_BIO_TTB;
1754         FSetInternalColorProc := @SetColor_BPP32_A8R8G8B8_BIO_TTB;
1755       end;
1756       {AARRGGBB}
1757       %00111001: begin
1758         FGetInternalColorProc := @GetColor_BPP32_A8B8G8R8_BIO_TTB;
1759         FSetInternalColorProc := @SetColor_BPP32_A8B8G8R8_BIO_TTB;
1760       end;
1761       {AARRGGBB}
1762       %00100111: begin
1763         FGetInternalColorProc := @GetColor_BPP32_A8G8R8B8_BIO_TTB;
1764         FSetInternalColorProc := @SetColor_BPP32_A8G8R8B8_BIO_TTB;
1765       end;
1766       {AARRGGBB}
1767       %00110110: begin
1768         FGetInternalColorProc := @GetColor_BPP32_A8G8B8R8_BIO_TTB;
1769         FSetInternalColorProc := @SetColor_BPP32_A8G8B8R8_BIO_TTB;
1770       end;
1771       {AARRGGBB}
1772       %00011110: begin
1773         FGetInternalColorProc := @GetColor_BPP32_A8R8B8G8_BIO_TTB;
1774         FSetInternalColorProc := @SetColor_BPP32_A8R8B8G8_BIO_TTB;
1775       end;
1776       {AARRGGBB}
1777       %00101101: begin
1778         FGetInternalColorProc := @GetColor_BPP32_A8B8R8G8_BIO_TTB;
1779         FSetInternalColorProc := @SetColor_BPP32_A8B8R8G8_BIO_TTB;
1780       end;
1781       {AARRGGBB}
1782       %11100100: begin
1783         FGetInternalColorProc := @GetColor_BPP32_B8G8R8A8_BIO_TTB;
1784         FSetInternalColorProc := @SetColor_BPP32_B8G8R8A8_BIO_TTB;
1785       end;
1786       {AARRGGBB}
1787       %11000110: begin
1788         FGetInternalColorProc := @GetColor_BPP32_R8G8B8A8_BIO_TTB;
1789         FSetInternalColorProc := @SetColor_BPP32_R8G8B8A8_BIO_TTB;
1790       end;
1791       {AARRGGBB}
1792       %11100001: begin
1793         FGetInternalColorProc := @GetColor_BPP32_G8B8R8A8_BIO_TTB;
1794         FSetInternalColorProc := @SetColor_BPP32_G8B8R8A8_BIO_TTB;
1795       end;
1796       {AARRGGBB}
1797       %11010010: begin
1798         FGetInternalColorProc := @GetColor_BPP32_G8R8B8A8_BIO_TTB;
1799         FSetInternalColorProc := @SetColor_BPP32_G8R8B8A8_BIO_TTB;
1800       end;
1801       {AARRGGBB}
1802       %11011000: begin
1803         FGetInternalColorProc := @GetColor_BPP32_B8R8G8A8_BIO_TTB;
1804         FSetInternalColorProc := @SetColor_BPP32_B8R8G8A8_BIO_TTB;
1805       end;
1806       {AARRGGBB}
1807       %11001001: begin
1808         FGetInternalColorProc := @GetColor_BPP32_R8B8G8A8_BIO_TTB;
1809         FSetInternalColorProc := @SetColor_BPP32_R8B8G8A8_BIO_TTB;
1810       end;
1811     else
1812       Exit;
1813     end;
1814     Result := True;
1815   end;
1816 
1817   function ChooseRGB_32Bpp: Boolean;
1818   var
1819     Positions: Byte;
1820   begin
1821     Result := False;
1822     with FRawImage.Description do
1823     begin
1824       if Depth <> 24 then Exit;
1825       if BitsPerPixel <> 32 then Exit;
1826       if LineOrder <> riloTopToBottom then Exit;
1827       if RedPrec <> 8 then Exit;
1828       if GreenPrec <> 8 then Exit;
1829       if BluePrec <> 8 then Exit;
1830       if RedShift and 7 <> 0 then Exit;
1831       if GreenShift and 7 <> 0 then Exit;
1832       if BlueShift and 7 <> 0 then Exit;
1833 
1834       Positions := (((RedShift shr 3) and 3) shl 4
1835                 or ((GreenShift shr 3) and 3) shl 2
1836                 or ((BlueShift shr 3) and 3)) and $FF;
1837 
1838       if ByteOrder = riboMSBFirst
1839       then Positions := not Positions and %00111111; // reverse positions
1840     end;
1841 
1842     // the locations of R,G,B are now coded in 2 bits each: xxRRBBGG
1843     // the 2-bit value (0..3) represents the location of the channel,
1844     // counting from left
1845     case Positions of
1846       {xxRRGGBB}
1847       %00011011: begin
1848         FGetInternalColorProc := @GetColor_BPP32_X8R8G8B8_BIO_TTB;
1849         FSetInternalColorProc := @SetColor_BPP32_X8R8G8B8_BIO_TTB;
1850       end;
1851       {xxRRGGBB}
1852       %00111001: begin
1853         FGetInternalColorProc := @GetColor_BPP32_X8B8G8R8_BIO_TTB;
1854         FSetInternalColorProc := @SetColor_BPP32_X8B8G8R8_BIO_TTB;
1855       end;
1856       {xxRRGGBB}
1857       %00100111: begin
1858         FGetInternalColorProc := @GetColor_BPP32_X8G8R8B8_BIO_TTB;
1859         FSetInternalColorProc := @SetColor_BPP32_X8G8R8B8_BIO_TTB;
1860       end;
1861       {xxRRGGBB}
1862       %00110110: begin
1863         FGetInternalColorProc := @GetColor_BPP32_X8G8B8R8_BIO_TTB;
1864         FSetInternalColorProc := @SetColor_BPP32_X8G8B8R8_BIO_TTB;
1865       end;
1866       {xxRRGGBB}
1867       %00011110: begin
1868         FGetInternalColorProc := @GetColor_BPP32_X8R8B8G8_BIO_TTB;
1869         FSetInternalColorProc := @SetColor_BPP32_X8R8B8G8_BIO_TTB;
1870       end;
1871       {xxRRGGBB}
1872       %00101101: begin
1873         FGetInternalColorProc := @GetColor_BPP32_X8B8R8G8_BIO_TTB;
1874         FSetInternalColorProc := @SetColor_BPP32_X8B8R8G8_BIO_TTB;
1875       end;
1876       {xxRRGGBB}
1877       %00100100: begin
1878         FGetInternalColorProc := @GetColor_BPP32_B8G8R8X8_BIO_TTB;
1879         FSetInternalColorProc := @SetColor_BPP32_B8G8R8X8_BIO_TTB;
1880       end;
1881       {xxRRGGBB}
1882       %00000110: begin
1883         FGetInternalColorProc := @GetColor_BPP32_R8G8B8X8_BIO_TTB;
1884         FSetInternalColorProc := @SetColor_BPP32_R8G8B8X8_BIO_TTB;
1885       end;
1886       {xxRRGGBB}
1887       %00100001: begin
1888         FGetInternalColorProc := @GetColor_BPP32_G8B8R8X8_BIO_TTB;
1889         FSetInternalColorProc := @SetColor_BPP32_G8B8R8X8_BIO_TTB;
1890       end;
1891       {xxRRGGBB}
1892       %00010010: begin
1893         FGetInternalColorProc := @GetColor_BPP32_G8R8B8X8_BIO_TTB;
1894         FSetInternalColorProc := @SetColor_BPP32_G8R8B8X8_BIO_TTB;
1895       end;
1896       {xxRRGGBB}
1897       %00011000: begin
1898         FGetInternalColorProc := @GetColor_BPP32_B8R8G8X8_BIO_TTB;
1899         FSetInternalColorProc := @SetColor_BPP32_B8R8G8X8_BIO_TTB;
1900       end;
1901       {xxRRGGBB}
1902       %00001001: begin
1903         FGetInternalColorProc := @GetColor_BPP32_R8B8G8X8_BIO_TTB;
1904         FSetInternalColorProc := @SetColor_BPP32_R8B8G8X8_BIO_TTB;
1905       end;
1906     else
1907       Exit;
1908     end;
1909     Result := True;
1910   end;
1911 
1912   function ChooseRGB_24Bpp: Boolean;
1913   var
1914     Positions: Byte;
1915   begin
1916     Result := False;
1917     with FRawImage.Description do
1918     begin
1919       if Depth <> 24 then Exit;
1920       if BitsPerPixel <> 24 then Exit;
1921       if LineOrder <> riloTopToBottom then Exit;
1922       if RedPrec <> 8 then Exit;
1923       if GreenPrec <> 8 then Exit;
1924       if BluePrec <> 8 then Exit;
1925       if RedShift and 7 <> 0 then Exit;
1926       if GreenShift and 7 <> 0 then Exit;
1927       if BlueShift and 7 <> 0 then Exit;
1928 
1929       if ByteOrder = riboMSBFirst
1930       then
1931         Positions := ((2-((RedShift   shr 3) and 3)) shl 4
1932                   or (2-((GreenShift shr 3) and 3)) shl 2
1933                   or (2-((BlueShift  shr 3) and 3))) and $FF
1934       else
1935         Positions := (((RedShift   shr 3) and 3) shl 4
1936                   or ((GreenShift shr 3) and 3) shl 2
1937                   or ((BlueShift  shr 3) and 3)) and $FF;
1938     end;
1939 
1940 
1941     // the locations of R,G,B are now coded in 2 bits each: xxRRBBGG
1942     // the 2-bit value (0..3) represents the location of the channel,
1943     // counting from left
1944     case Positions of
1945       {xxRRGGBB}
1946       %00100100: begin
1947         FGetInternalColorProc := @GetColor_BPP24_B8G8R8_BIO_TTB;
1948         FSetInternalColorProc := @SetColor_BPP24_B8G8R8_BIO_TTB;
1949       end;
1950       {xxRRGGBB}
1951       %00000110: begin
1952         FGetInternalColorProc := @GetColor_BPP24_R8G8B8_BIO_TTB;
1953         FSetInternalColorProc := @SetColor_BPP24_R8G8B8_BIO_TTB;
1954       end;
1955       {xxRRGGBB}
1956       %00100001: begin
1957         FGetInternalColorProc := @GetColor_BPP24_G8B8R8_BIO_TTB;
1958         FSetInternalColorProc := @SetColor_BPP24_G8B8R8_BIO_TTB;
1959       end;
1960       {xxRRGGBB}
1961       %00010010: begin
1962         FGetInternalColorProc := @GetColor_BPP24_G8R8B8_BIO_TTB;
1963         FSetInternalColorProc := @SetColor_BPP24_G8R8B8_BIO_TTB;
1964       end;
1965       {xxRRGGBB}
1966       %00011000: begin
1967         FGetInternalColorProc := @GetColor_BPP24_B8R8G8_BIO_TTB;
1968         FSetInternalColorProc := @SetColor_BPP24_B8R8G8_BIO_TTB;
1969       end;
1970       {xxRRGGBB}
1971       %00001001: begin
1972         FGetInternalColorProc := @GetColor_BPP24_R8B8G8_BIO_TTB;
1973         FSetInternalColorProc := @SetColor_BPP24_R8B8G8_BIO_TTB;
1974       end;
1975     else
1976       Exit;
1977     end;
1978     Result := True;
1979   end;
1980 
1981   procedure ChooseRGBAFunctions;
1982   begin
1983     with FRawImage.Description do
1984     begin
1985       ChooseRawBitsProc(BitsPerPixel, ByteOrder, BitOrder,
1986                         FReadRawImageBits, FWriteRawImageBits);
1987 
1988       if AlphaPrec > 0
1989       then begin
1990         FGetInternalColorProc := @GetColor_RGBA_NoPalette;
1991         FSetInternalColorProc := @SetColor_RGBA_NoPalette;
1992       end
1993       else begin
1994         FGetInternalColorProc := @GetColor_RGB_NoPalette;
1995         FSetInternalColorProc := @SetColor_RGB_NoPalette;
1996       end;
1997     end;
1998   end;
1999 
2000 begin
2001   // Default: use the generic functions, that can handle all kinds of RawImages
2002   FGetInternalColorProc := @GetColor_Generic;
2003   FSetInternalColorProc := @SetColor_Generic;
2004 
2005   if FUpdateCount > 0
2006   then begin
2007     FGetSetColorFunctionsUpdateNeeded := true;
2008     Exit;
2009   end;
2010   FGetSetColorFunctionsUpdateNeeded := false;
2011 
2012   with FRawImage.Description do
2013   begin
2014     if MaskBitsPerPixel > 0
2015     then ChooseRawBitsProc(MaskBitsPerPixel, ByteOrder, MaskBitOrder,
2016                            FMaskReadRawImageBits, FMaskWriteRawImageBits);
2017 
2018     if PaletteColorCount = 0
2019     then begin
2020       case Format of
2021         ricfRGBA: begin
2022           if not (ChooseRGBA_32Bpp or ChooseRGB_32Bpp or ChooseRGB_24Bpp)
2023           then ChooseRGBAFunctions;
2024         end;
2025         ricfGray: begin
2026           ChooseRawBitsProc(BitsPerPixel,
2027                             ByteOrder,
2028                             BitOrder,
2029                             FReadRawImageBits, FWriteRawImageBits);
2030 
2031           if AlphaPrec = 0
2032           then begin
2033             FGetInternalColorProc := @GetColor_Gray_NoPalette;
2034             FSetInternalColorProc := @SetColor_Gray_NoPalette;
2035           end
2036           else begin
2037             FGetInternalColorProc := @GetColor_GrayAlpha_NoPalette;
2038             FSetInternalColorProc := @SetColor_GrayAlpha_NoPalette;
2039           end;
2040         end;
2041       end;
2042     end
2043     else begin
2044       // palette
2045       // ToDo
2046       {$IFNDEF DisableChecks}
2047       DebugLn('WARNING: TLazIntfImage.ChooseGetSetColorFunctions Palette is unsupported');
2048       {$ENDIF}
2049     end;
2050   end;
2051 end;
2052 
2053 procedure TLazIntfImage.GetColor_Generic(x, y: integer; out Value: TFPColor);
2054 var
2055   Position: TRawImagePosition;
2056 begin
2057   GetXYDataPosition(x,y,Position);
2058 
2059   if FRawImage.Description.PaletteColorCount = 0
2060   then begin
2061     FRawimage.ReadChannels(Position, Value.Red, Value.Green, Value.Blue, Value.Alpha);
2062   end
2063   else begin
2064     // ToDo: read index, then palette
2065     Value.Red:=0;
2066     Value.Green:=0;
2067     Value.Blue:=0;
2068     Value.Alpha:=0;
2069   end;
2070 end;
2071 
2072 procedure TLazIntfImage.GetMask_Generic(x, y: integer; out AValue: Boolean);
2073 var
2074   Position: TRawImagePosition;
2075 begin
2076   if FRawImage.Description.MaskBitsPerPixel = 0
2077   then begin
2078     Avalue := False;
2079   end
2080   else begin
2081     GetXYMaskPosition(x,y,Position);
2082     FRawimage.ReadMask(Position, AValue);
2083   end;
2084 end;
2085 
2086 procedure TLazIntfImage.SetColor_Generic(x, y: integer; const Value: TFPColor);
2087 var
2088   Position: TRawImagePosition;
2089 begin
2090   GetXYDataPosition(x,y,Position);
2091 
2092   if FRawImage.Description.PaletteColorCount = 0
2093   then begin
2094     FRawImage.WriteChannels(Position, Value.Red, Value.Green, Value.Blue, Value.Alpha);
2095   end
2096   else begin
2097     // ToDo: Palette
2098   end;
2099 end;
2100 
2101 procedure TLazIntfImage.SetMask_Generic(x, y: integer; const AValue: Boolean);
2102 var
2103   Position: TRawImagePosition;
2104 begin
2105   if FRawImage.Description.MaskBitsPerPixel = 0 then Exit;
2106 
2107   GetXYMaskPosition(x,y,Position);
2108   FRawImage.WriteMask(Position, AValue);
2109 end;
2110 
2111 
2112 procedure TLazIntfImage.GetColor_RGBA_NoPalette(x, y: integer; out Value: TFPColor);
2113 var
2114   Position: TRawImagePosition;
2115 begin
2116   GetXYDataPosition(x,y,Position);
2117   with FRawImage.Description do
2118   begin
2119     FReadRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red);
2120     FReadRawImageBits(FRawImage.Data, Position, GreenPrec, GreenShift, Value.Green);
2121     FReadRawImageBits(FRawImage.Data, Position, BluePrec, BlueShift, Value.Blue);
2122     FReadRawImageBits(FRawImage.Data, Position, AlphaPrec, AlphaShift, Value.Alpha);
2123   end;
2124 end;
2125 
2126 procedure TLazIntfImage.GetColor_RGB_NoPalette(x, y: integer; out Value: TFPColor);
2127 var
2128   Position: TRawImagePosition;
2129 begin
2130   GetXYDataPosition(x,y,Position);
2131   with FRawImage.Description do
2132   begin
2133     FReadRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red);
2134     FReadRawImageBits(FRawImage.Data, Position, GreenPrec, GreenShift, Value.Green);
2135     FReadRawImageBits(FRawImage.Data, Position, BluePrec, BlueShift, Value.Blue);
2136   end;
2137   // no alpha -> set opaque
2138   Value.Alpha:=high(Value.Alpha);
2139 end;
2140 
2141 procedure TLazIntfImage.GetColor_Gray_NoPalette(x, y: integer; out Value: TFPColor);
2142 var
2143   Position: TRawImagePosition;
2144 begin
2145   GetXYDataPosition(x,y,Position);
2146   with FRawImage.Description do
2147     FReadRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red);
2148   Value.Green := Value.Red;
2149   Value.Blue := Value.Red;
2150   // no alpha -> set opaque
2151   Value.Alpha:=high(Value.Alpha);
2152 end;
2153 
2154 procedure TLazIntfImage.GetColor_GrayAlpha_NoPalette(x, y: integer; out Value: TFPColor);
2155 var
2156   Position: TRawImagePosition;
2157 begin
2158   GetXYDataPosition(x,y,Position);
2159   with FRawImage.Description do
2160   begin
2161     FReadRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red);
2162     FReadRawImageBits(FRawImage.Data, Position, AlphaPrec, AlphaShift, Value.Alpha);
2163   end;
2164   Value.Green := Value.Red;
2165   Value.Blue := Value.Red;
2166 end;
2167 
2168 procedure TLazIntfImage.GetColor_BPP32_A8B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
2169 var
2170   VBytes: TFPColorBytes absolute Value;
2171 begin
2172   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2173   begin
2174     VBytes.Ah := B0;
2175     VBytes.Al := B0;
2176     VBytes.Bh := B1;
2177     VBytes.Bl := B1;
2178     VBytes.Rh := B2;
2179     VBytes.Rl := B2;
2180     VBytes.Gh := B3;
2181     VBytes.Gl := B3;
2182   end;
2183 end;
2184 
2185 procedure TLazIntfImage.GetColor_BPP32_A8B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
2186 var
2187   VBytes: TFPColorBytes absolute Value;
2188 begin
2189   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2190   begin
2191     VBytes.Ah := B0;
2192     VBytes.Al := B0;
2193     VBytes.Bh := B1;
2194     VBytes.Bl := B1;
2195     VBytes.Rh := B2;
2196     VBytes.Rl := B2;
2197     VBytes.Gh := B3;
2198     VBytes.Gl := B3;
2199   end;
2200 end;
2201 
2202 procedure TLazIntfImage.GetColor_BPP32_A8G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
2203 var
2204   VBytes: TFPColorBytes absolute Value;
2205 begin
2206   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2207   begin
2208     VBytes.Ah := B0;
2209     VBytes.Al := B0;
2210     VBytes.Gh := B1;
2211     VBytes.Gl := B1;
2212     VBytes.Bh := B2;
2213     VBytes.Bl := B2;
2214     VBytes.Rh := B3;
2215     VBytes.Rl := B3;
2216   end;
2217 end;
2218 
2219 procedure TLazIntfImage.GetColor_BPP32_A8G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
2220 var
2221   VBytes: TFPColorBytes absolute Value;
2222 begin
2223   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2224   begin
2225     VBytes.Ah := B0;
2226     VBytes.Al := B0;
2227     VBytes.Gh := B1;
2228     VBytes.Gl := B1;
2229     VBytes.Rh := B2;
2230     VBytes.Rl := B2;
2231     VBytes.Bh := B3;
2232     VBytes.Bl := B3;
2233   end;
2234 end;
2235 
2236 procedure TLazIntfImage.GetColor_BPP32_A8R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
2237 var
2238   VBytes: TFPColorBytes absolute Value;
2239 begin
2240   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2241   begin
2242     VBytes.Ah := B0;
2243     VBytes.Al := B0;
2244     VBytes.Rh := B1;
2245     VBytes.Rl := B1;
2246     VBytes.Bh := B2;
2247     VBytes.Bl := B2;
2248     VBytes.Gh := B3;
2249     VBytes.Gl := B3;
2250   end;
2251 end;
2252 
2253 procedure TLazIntfImage.GetColor_BPP32_A8R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
2254 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2255 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2256 // BitsPerPixel=32
2257 var
2258   VBytes: TFPColorBytes absolute Value;
2259 begin
2260   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2261   begin
2262     VBytes.Ah := B0;
2263     VBytes.Al := B0;
2264     VBytes.Rh := B1;
2265     VBytes.Rl := B1;
2266     VBytes.Gh := B2;
2267     VBytes.Gl := B2;
2268     VBytes.Bh := B3;
2269     VBytes.Bl := B3;
2270   end;
2271 end;
2272 
2273 procedure TLazIntfImage.GetColor_BPP32_B8G8R8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
2274 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2275 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2276 // BitsPerPixel=32
2277 var
2278   VBytes: TFPColorBytes absolute Value;
2279 begin
2280   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2281   begin
2282     VBytes.Bh := B0;
2283     VBytes.Bl := B0;
2284     VBytes.Gh := B1;
2285     VBytes.Gl := B1;
2286     VBytes.Rh := B2;
2287     VBytes.Rl := B2;
2288     VBytes.Ah := B3;
2289     VBytes.Al := B3;
2290   end;
2291 end;
2292 
2293 procedure TLazIntfImage.GetColor_BPP32_B8R8G8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
2294 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2295 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2296 // BitsPerPixel=32
2297 var
2298   VBytes: TFPColorBytes absolute Value;
2299 begin
2300   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2301   begin
2302     VBytes.Bh := B0;
2303     VBytes.Bl := B0;
2304     VBytes.Rh := B1;
2305     VBytes.Rl := B1;
2306     VBytes.Gh := B2;
2307     VBytes.Gl := B2;
2308     VBytes.Ah := B3;
2309     VBytes.Al := B3;
2310   end;
2311 end;
2312 
2313 procedure TLazIntfImage.GetColor_BPP32_G8B8R8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
2314 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2315 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2316 // BitsPerPixel=32
2317 var
2318   VBytes: TFPColorBytes absolute Value;
2319 begin
2320   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2321   begin
2322     VBytes.Gh := B0;
2323     VBytes.Gl := B0;
2324     VBytes.Bh := B1;
2325     VBytes.Bl := B1;
2326     VBytes.Rh := B2;
2327     VBytes.Rl := B2;
2328     VBytes.Ah := B3;
2329     VBytes.Al := B3;
2330   end;
2331 end;
2332 
2333 procedure TLazIntfImage.GetColor_BPP32_G8R8B8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
2334 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2335 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2336 // BitsPerPixel=32
2337 var
2338   VBytes: TFPColorBytes absolute Value;
2339 begin
2340   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2341   begin
2342     VBytes.Gh := B0;
2343     VBytes.Gl := B0;
2344     VBytes.Rh := B1;
2345     VBytes.Rl := B1;
2346     VBytes.Bh := B2;
2347     VBytes.Bl := B2;
2348     VBytes.Ah := B3;
2349     VBytes.Al := B3;
2350   end;
2351 end;
2352 
2353 procedure TLazIntfImage.GetColor_BPP32_R8B8G8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
2354 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2355 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2356 // BitsPerPixel=32
2357 var
2358   VBytes: TFPColorBytes absolute Value;
2359 begin
2360   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2361   begin
2362     VBytes.Rh := B0;
2363     VBytes.Rl := B0;
2364     VBytes.Bh := B1;
2365     VBytes.Bl := B1;
2366     VBytes.Gh := B2;
2367     VBytes.Gl := B2;
2368     VBytes.Ah := B3;
2369     VBytes.Al := B3;
2370   end;
2371 end;
2372 
2373 procedure TLazIntfImage.GetColor_BPP32_R8G8B8A8_BIO_TTB(x, y: integer; out Value: TFPColor);
2374 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2375 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2376 // BitsPerPixel=32
2377 var
2378   VBytes: TFPColorBytes absolute Value;
2379 begin
2380   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2381   begin
2382     VBytes.Rh := B0;
2383     VBytes.Rl := B0;
2384     VBytes.Gh := B1;
2385     VBytes.Gl := B1;
2386     VBytes.Bh := B2;
2387     VBytes.Bl := B2;
2388     VBytes.Ah := B3;
2389     VBytes.Al := B3;
2390   end;
2391 end;
2392 
2393 procedure TLazIntfImage.GetColor_BPP32_X8B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
2394 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2395 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2396 // BitsPerPixel=32
2397 var
2398   VBytes: TFPColorBytes absolute Value;
2399 begin
2400   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2401   begin
2402     VBytes.Bh := B1;
2403     VBytes.Bl := B1;
2404     VBytes.Rh := B2;
2405     VBytes.Rl := B2;
2406     VBytes.Gh := B3;
2407     VBytes.Gl := B3;
2408   end;
2409   // no alpha -> set opaque
2410   Value.Alpha:=high(Value.Alpha);
2411 end;
2412 
2413 procedure TLazIntfImage.GetColor_BPP32_X8B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
2414 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2415 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2416 // BitsPerPixel=32
2417 var
2418   VBytes: TFPColorBytes absolute Value;
2419 begin
2420   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2421   begin
2422     VBytes.Bh := B1;
2423     VBytes.Bl := B1;
2424     VBytes.Rh := B2;
2425     VBytes.Rl := B2;
2426     VBytes.Gh := B3;
2427     VBytes.Gl := B3;
2428   end;
2429   // no alpha -> set opaque
2430   Value.Alpha:=high(Value.Alpha);
2431 end;
2432 
2433 procedure TLazIntfImage.GetColor_BPP32_X8G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
2434 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2435 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2436 // BitsPerPixel=32
2437 var
2438   VBytes: TFPColorBytes absolute Value;
2439 begin
2440   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2441   begin
2442     VBytes.Gh := B1;
2443     VBytes.Gl := B1;
2444     VBytes.Bh := B2;
2445     VBytes.Bl := B2;
2446     VBytes.Rh := B3;
2447     VBytes.Rl := B3;
2448   end;
2449   // no alpha -> set opaque
2450   Value.Alpha:=high(Value.Alpha);
2451 end;
2452 
2453 procedure TLazIntfImage.GetColor_BPP32_X8G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
2454 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2455 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2456 // BitsPerPixel=32
2457 var
2458   VBytes: TFPColorBytes absolute Value;
2459 begin
2460   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2461   begin
2462     VBytes.Gh := B1;
2463     VBytes.Gl := B1;
2464     VBytes.Rh := B2;
2465     VBytes.Rl := B2;
2466     VBytes.Bh := B3;
2467     VBytes.Bl := B3;
2468   end;
2469   // no alpha -> set opaque
2470   Value.Alpha:=high(Value.Alpha);
2471 end;
2472 
2473 procedure TLazIntfImage.GetColor_BPP32_X8R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
2474 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2475 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2476 // BitsPerPixel=32
2477 var
2478   VBytes: TFPColorBytes absolute Value;
2479 begin
2480   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2481   begin
2482     VBytes.Rh := B1;
2483     VBytes.Rl := B1;
2484     VBytes.Bh := B2;
2485     VBytes.Bl := B2;
2486     VBytes.Gh := B3;
2487     VBytes.Gl := B3;
2488   end;
2489   // no alpha -> set opaque
2490   Value.Alpha:=high(Value.Alpha);
2491 end;
2492 
2493 procedure TLazIntfImage.GetColor_BPP32_X8R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
2494 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2495 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2496 // BitsPerPixel=32
2497 var
2498   VBytes: TFPColorBytes absolute Value;
2499 begin
2500   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2501   begin
2502     VBytes.Rh := B1;
2503     VBytes.Rl := B1;
2504     VBytes.Gh := B2;
2505     VBytes.Gl := B2;
2506     VBytes.Bh := B3;
2507     VBytes.Bl := B3;
2508   end;
2509   // no alpha -> set opaque
2510   Value.Alpha:=high(Value.Alpha);
2511 end;
2512 
2513 procedure TLazIntfImage.GetColor_BPP32_B8G8R8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
2514 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2515 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2516 // BitsPerPixel=32
2517 var
2518   VBytes: TFPColorBytes absolute Value;
2519 begin
2520   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2521   begin
2522     VBytes.Bh := B0;
2523     VBytes.Bl := B0;
2524     VBytes.Gh := B1;
2525     VBytes.Gl := B1;
2526     VBytes.Rh := B2;
2527     VBytes.Rl := B2;
2528   end;
2529   // no alpha -> set opaque
2530   Value.Alpha:=high(Value.Alpha);
2531 end;
2532 
2533 procedure TLazIntfImage.GetColor_BPP32_B8R8G8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
2534 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2535 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2536 // BitsPerPixel=32
2537 var
2538   VBytes: TFPColorBytes absolute Value;
2539 begin
2540   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2541   begin
2542     VBytes.Bh := B0;
2543     VBytes.Bl := B0;
2544     VBytes.Rh := B1;
2545     VBytes.Rl := B1;
2546     VBytes.Gh := B2;
2547     VBytes.Gl := B2;
2548   end;
2549   // no alpha -> set opaque
2550   Value.Alpha:=high(Value.Alpha);
2551 end;
2552 
2553 procedure TLazIntfImage.GetColor_BPP32_G8B8R8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
2554 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2555 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2556 // BitsPerPixel=32
2557 var
2558   VBytes: TFPColorBytes absolute Value;
2559 begin
2560   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2561   begin
2562     VBytes.Gh := B0;
2563     VBytes.Gl := B0;
2564     VBytes.Bh := B1;
2565     VBytes.Bl := B1;
2566     VBytes.Rh := B2;
2567     VBytes.Rl := B2;
2568   end;
2569   // no alpha -> set opaque
2570   Value.Alpha:=high(Value.Alpha);
2571 end;
2572 
2573 procedure TLazIntfImage.GetColor_BPP32_G8R8B8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
2574 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2575 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2576 // BitsPerPixel=32
2577 var
2578   VBytes: TFPColorBytes absolute Value;
2579 begin
2580   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2581   begin
2582     VBytes.Gh := B0;
2583     VBytes.Gl := B0;
2584     VBytes.Rh := B1;
2585     VBytes.Rl := B1;
2586     VBytes.Bh := B2;
2587     VBytes.Bl := B2;
2588   end;
2589   // no alpha -> set opaque
2590   Value.Alpha:=high(Value.Alpha);
2591 end;
2592 
2593 procedure TLazIntfImage.GetColor_BPP32_R8B8G8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
2594 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2595 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2596 // BitsPerPixel=32
2597 var
2598   VBytes: TFPColorBytes absolute Value;
2599 begin
2600   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2601   begin
2602     VBytes.Rh := B0;
2603     VBytes.Rl := B0;
2604     VBytes.Bh := B1;
2605     VBytes.Bl := B1;
2606     VBytes.Gh := B2;
2607     VBytes.Gl := B2;
2608   end;
2609   // no alpha -> set opaque
2610   Value.Alpha:=high(Value.Alpha);
2611 end;
2612 
2613 procedure TLazIntfImage.GetColor_BPP32_R8G8B8X8_BIO_TTB(x, y: integer; out Value: TFPColor);
2614 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2615 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2616 // BitsPerPixel=32
2617 var
2618   VBytes: TFPColorBytes absolute Value;
2619 begin
2620   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2621   begin
2622     VBytes.Rh := B0;
2623     VBytes.Rl := B0;
2624     VBytes.Gh := B1;
2625     VBytes.Gl := B1;
2626     VBytes.Bh := B2;
2627     VBytes.Bl := B2;
2628   end;
2629   // no alpha -> set opaque
2630   Value.Alpha:=high(Value.Alpha);
2631 end;
2632 
2633 procedure TLazIntfImage.GetColor_BPP24_B8G8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
2634 // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0
2635 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2636 // BitsPerPixel=24
2637 var
2638   VBytes: TFPColorBytes absolute Value;
2639 begin
2640   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
2641   begin
2642     VBytes.Bh := B0;
2643     VBytes.Bl := B0;
2644     VBytes.Gh := B1;
2645     VBytes.Gl := B1;
2646     VBytes.Rh := B2;
2647     VBytes.Rl := B2;
2648   end;
2649   // no alpha -> set opaque
2650   Value.Alpha:=high(Value.Alpha);
2651 end;
2652 
2653 procedure TLazIntfImage.GetColor_BPP24_B8R8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
2654 // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0
2655 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2656 // BitsPerPixel=24
2657 var
2658   VBytes: TFPColorBytes absolute Value;
2659 begin
2660   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
2661   begin
2662     VBytes.Bh := B0;
2663     VBytes.Bl := B0;
2664     VBytes.Rh := B1;
2665     VBytes.Rl := B1;
2666     VBytes.Gh := B2;
2667     VBytes.Gl := B2;
2668   end;
2669   // no alpha -> set opaque
2670   Value.Alpha:=high(Value.Alpha);
2671 end;
2672 
2673 procedure TLazIntfImage.GetColor_BPP24_G8B8R8_BIO_TTB(x, y: integer; out Value: TFPColor);
2674 // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0
2675 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2676 // BitsPerPixel=24
2677 var
2678   VBytes: TFPColorBytes absolute Value;
2679 begin
2680   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
2681   begin
2682     VBytes.Gh := B0;
2683     VBytes.Gl := B0;
2684     VBytes.Bh := B1;
2685     VBytes.Bl := B1;
2686     VBytes.Rh := B2;
2687     VBytes.Rl := B2;
2688   end;
2689   // no alpha -> set opaque
2690   Value.Alpha:=high(Value.Alpha);
2691 end;
2692 
2693 procedure TLazIntfImage.GetColor_BPP24_G8R8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
2694 // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0
2695 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2696 // BitsPerPixel=24
2697 var
2698   VBytes: TFPColorBytes absolute Value;
2699 begin
2700   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
2701   begin
2702     VBytes.Gh := B0;
2703     VBytes.Gl := B0;
2704     VBytes.Rh := B1;
2705     VBytes.Rl := B1;
2706     VBytes.Bh := B2;
2707     VBytes.Bl := B2;
2708   end;
2709   // no alpha -> set opaque
2710   Value.Alpha:=high(Value.Alpha);
2711 end;
2712 
2713 procedure TLazIntfImage.GetColor_BPP24_R8B8G8_BIO_TTB(x, y: integer; out Value: TFPColor);
2714 // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0
2715 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2716 // BitsPerPixel=24
2717 var
2718   VBytes: TFPColorBytes absolute Value;
2719 begin
2720   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
2721   begin
2722     VBytes.Rh := B0;
2723     VBytes.Rl := B0;
2724     VBytes.Bh := B1;
2725     VBytes.Bl := B1;
2726     VBytes.Gh := B2;
2727     VBytes.Gl := B2;
2728   end;
2729   // no alpha -> set opaque
2730   Value.Alpha:=high(Value.Alpha);
2731 end;
2732 
2733 procedure TLazIntfImage.GetColor_BPP24_R8G8B8_BIO_TTB(x, y: integer; out Value: TFPColor);
2734 // Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0
2735 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2736 // BitsPerPixel=24
2737 var
2738   VBytes: TFPColorBytes absolute Value;
2739 begin
2740   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
2741   begin
2742     VBytes.Rh := B0;
2743     VBytes.Rl := B0;
2744     VBytes.Gh := B1;
2745     VBytes.Gl := B1;
2746     VBytes.Bh := B2;
2747     VBytes.Bl := B2;
2748   end;
2749   // no alpha -> set opaque
2750   Value.Alpha:=high(Value.Alpha);
2751 end;
2752 
2753 procedure TLazIntfImage.GetColor_NULL(x, y: integer; out Value: TFPColor);
2754 //var
2755 //  Position: TRawImagePosition;
2756 begin
2757 //  GetXYDataPosition(x,y,Position);
2758   Value.Red:=0;
2759   Value.Green:=0;
2760   Value.Blue:=0;
2761   Value.Alpha:=0;
2762 end;
2763 
2764 procedure TLazIntfImage.SetColor_RGBA_NoPalette(x, y: integer; const Value: TFPColor);
2765 var
2766   Position: TRawImagePosition;
2767 begin
2768   GetXYDataPosition(x,y,Position);
2769   with FRawImage.Description do
2770   begin
2771     FWriteRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red);
2772     FWriteRawImageBits(FRawImage.Data, Position, GreenPrec, GreenShift, Value.Green);
2773     FWriteRawImageBits(FRawImage.Data, Position, BluePrec, BlueShift, Value.Blue);
2774     FWriteRawImageBits(FRawImage.Data, Position, AlphaPrec, AlphaShift, Value.Alpha)
2775   end;
2776 end;
2777 
2778 procedure TLazIntfImage.SetColor_RGB_NoPalette(x, y: integer; const Value: TFPColor);
2779 var
2780   Position: TRawImagePosition;
2781 begin
2782   GetXYDataPosition(x,y,Position);
2783   with FRawImage.Description do
2784   begin
2785     FWriteRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red);
2786     FWriteRawImageBits(FRawImage.Data, Position, GreenPrec, GreenShift, Value.Green);
2787     FWriteRawImageBits(FRawImage.Data, Position, BluePrec, BlueShift, Value.Blue);
2788   end;
2789   // no alpha -> ignore
2790 end;
2791 
2792 procedure TLazIntfImage.SetColor_Gray_NoPalette(x, y: integer; const Value: TFPColor);
2793 var
2794   Position: TRawImagePosition;
2795 begin
2796   GetXYDataPosition(x,y,Position);
2797   with FRawImage.Description do
2798     FWriteRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red);
2799 end;
2800 
2801 procedure TLazIntfImage.SetColor_GrayAlpha_NoPalette(x, y: integer; const Value: TFPColor);
2802 var
2803   Position: TRawImagePosition;
2804 begin
2805   GetXYDataPosition(x,y,Position);
2806   with FRawImage.Description do
2807   begin
2808     FWriteRawImageBits(FRawImage.Data, Position, RedPrec, RedShift, Value.Red);
2809     FWriteRawImageBits(FRawImage.Data, Position, AlphaPrec, AlphaShift, Value.Alpha)
2810   end;
2811 end;
2812 
2813 
2814 procedure TLazIntfImage.SetColor_NULL(x, y: integer; const Value: TFPColor);
2815 begin
2816   // NULL, not implemented
2817 end;
2818 
2819 procedure TLazIntfImage.SetColor_BPP32_A8R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
2820 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2821 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2822 // BitsPerPixel=32
2823 var
2824   VBytes: TFPColorBytes absolute Value;
2825 begin
2826   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2827   begin
2828     B0 := VBytes.Ah;
2829     B1 := VBytes.Rh;
2830     B2 := VBytes.Gh;
2831     B3 := VBytes.Bh;
2832   end;
2833 end;
2834 
2835 procedure TLazIntfImage.SetColor_BPP32_A8B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
2836 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2837 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2838 // BitsPerPixel=32
2839 var
2840   VBytes: TFPColorBytes absolute Value;
2841 begin
2842   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2843   begin
2844     B0 := VBytes.Ah;
2845     B1 := VBytes.Bh;
2846     B2 := VBytes.Gh;
2847     B3 := VBytes.Rh;
2848   end;
2849 end;
2850 
2851 procedure TLazIntfImage.SetColor_BPP32_A8B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
2852 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2853 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2854 // BitsPerPixel=32
2855 var
2856   VBytes: TFPColorBytes absolute Value;
2857 begin
2858   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2859   begin
2860     B0 := VBytes.Ah;
2861     B1 := VBytes.Bh;
2862     B2 := VBytes.Rh;
2863     B3 := VBytes.Gh;
2864   end;
2865 end;
2866 
2867 procedure TLazIntfImage.SetColor_BPP32_A8G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
2868 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2869 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2870 // BitsPerPixel=32
2871 var
2872   VBytes: TFPColorBytes absolute Value;
2873 begin
2874   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2875   begin
2876     B0 := VBytes.Ah;
2877     B1 := VBytes.Gh;
2878     B2 := VBytes.Bh;
2879     B3 := VBytes.Rh;
2880   end;
2881 end;
2882 
2883 procedure TLazIntfImage.SetColor_BPP32_A8G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
2884 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2885 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2886 // BitsPerPixel=32
2887 var
2888   VBytes: TFPColorBytes absolute Value;
2889 begin
2890   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2891   begin
2892     B0 := VBytes.Ah;
2893     B1 := VBytes.Gh;
2894     B2 := VBytes.Rh;
2895     B3 := VBytes.Bh;
2896   end;
2897 end;
2898 
2899 procedure TLazIntfImage.SetColor_BPP32_A8R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
2900 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2901 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2902 // BitsPerPixel=32
2903 var
2904   VBytes: TFPColorBytes absolute Value;
2905 begin
2906   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2907   begin
2908     B0 := VBytes.Ah;
2909     B1 := VBytes.Rh;
2910     B2 := VBytes.Bh;
2911     B3 := VBytes.Gh;
2912   end;
2913 end;
2914 
2915 procedure TLazIntfImage.SetColor_BPP32_B8G8R8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
2916 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2917 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2918 // BitsPerPixel=32
2919 var
2920   VBytes: TFPColorBytes absolute Value;
2921 begin
2922   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2923   begin
2924     B0 := VBytes.Bh;
2925     B1 := VBytes.Gh;
2926     B2 := VBytes.Rh;
2927     B3 := VBytes.Ah;
2928   end;
2929 end;
2930 
2931 procedure TLazIntfImage.SetColor_BPP32_B8R8G8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
2932 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2933 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2934 // BitsPerPixel=32
2935 var
2936   VBytes: TFPColorBytes absolute Value;
2937 begin
2938   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2939   begin
2940     B0 := VBytes.Bh;
2941     B1 := VBytes.Rh;
2942     B2 := VBytes.Gh;
2943     B3 := VBytes.Ah;
2944   end;
2945 end;
2946 
2947 procedure TLazIntfImage.SetColor_BPP32_G8B8R8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
2948 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2949 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2950 // BitsPerPixel=32
2951 var
2952   VBytes: TFPColorBytes absolute Value;
2953 begin
2954   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2955   begin
2956     B0 := VBytes.Gh;
2957     B1 := VBytes.Bh;
2958     B2 := VBytes.Rh;
2959     B3 := VBytes.Ah;
2960   end;
2961 end;
2962 
2963 procedure TLazIntfImage.SetColor_BPP32_G8R8B8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
2964 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2965 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2966 // BitsPerPixel=32
2967 var
2968   VBytes: TFPColorBytes absolute Value;
2969 begin
2970   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2971   begin
2972     B0 := VBytes.Gh;
2973     B1 := VBytes.Rh;
2974     B2 := VBytes.Bh;
2975     B3 := VBytes.Ah;
2976   end;
2977 end;
2978 
2979 procedure TLazIntfImage.SetColor_BPP32_R8B8G8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
2980 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2981 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2982 // BitsPerPixel=32
2983 var
2984   VBytes: TFPColorBytes absolute Value;
2985 begin
2986   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
2987   begin
2988     B0 := VBytes.Rh;
2989     B1 := VBytes.Bh;
2990     B2 := VBytes.Gh;
2991     B3 := VBytes.Ah;
2992   end;
2993 end;
2994 
2995 procedure TLazIntfImage.SetColor_BPP32_R8G8B8A8_BIO_TTB(x, y: integer; const Value: TFPColor);
2996 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
2997 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
2998 // BitsPerPixel=32
2999 var
3000   VBytes: TFPColorBytes absolute Value;
3001 begin
3002   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3003   begin
3004     B0 := VBytes.Rh;
3005     B1 := VBytes.Gh;
3006     B2 := VBytes.Bh;
3007     B3 := VBytes.Ah;
3008   end;
3009 end;
3010 
3011 procedure TLazIntfImage.SetColor_BPP32_X8R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
3012 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3013 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3014 // BitsPerPixel=32
3015 var
3016   VBytes: TFPColorBytes absolute Value;
3017 begin
3018   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3019   begin
3020     B1 := VBytes.Rh;
3021     B2 := VBytes.Gh;
3022     B3 := VBytes.Bh;
3023   end;
3024 end;
3025 
3026 procedure TLazIntfImage.SetColor_BPP32_X8B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
3027 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3028 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3029 // BitsPerPixel=32
3030 var
3031   VBytes: TFPColorBytes absolute Value;
3032 begin
3033   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3034   begin
3035     B1 := VBytes.Bh;
3036     B2 := VBytes.Gh;
3037     B3 := VBytes.Rh;
3038   end;
3039 end;
3040 
3041 procedure TLazIntfImage.SetColor_BPP32_X8B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
3042 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3043 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3044 // BitsPerPixel=32
3045 var
3046   VBytes: TFPColorBytes absolute Value;
3047 begin
3048   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3049   begin
3050     B1 := VBytes.Bh;
3051     B2 := VBytes.Rh;
3052     B3 := VBytes.Gh;
3053   end;
3054 end;
3055 
3056 procedure TLazIntfImage.SetColor_BPP32_X8G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
3057 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3058 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3059 // BitsPerPixel=32
3060 var
3061   VBytes: TFPColorBytes absolute Value;
3062 begin
3063   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3064   begin
3065     B1 := VBytes.Gh;
3066     B2 := VBytes.Bh;
3067     B3 := VBytes.Rh;
3068   end;
3069 end;
3070 
3071 procedure TLazIntfImage.SetColor_BPP32_X8G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
3072 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3073 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3074 // BitsPerPixel=32
3075 var
3076   VBytes: TFPColorBytes absolute Value;
3077 begin
3078   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3079   begin
3080     B1 := VBytes.Gh;
3081     B2 := VBytes.Rh;
3082     B3 := VBytes.Bh;
3083   end;
3084 end;
3085 
3086 procedure TLazIntfImage.SetColor_BPP32_X8R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
3087 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3088 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3089 // BitsPerPixel=32
3090 var
3091   VBytes: TFPColorBytes absolute Value;
3092 begin
3093   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3094   begin
3095     B1 := VBytes.Rh;
3096     B2 := VBytes.Bh;
3097     B3 := VBytes.Gh;
3098   end;
3099 end;
3100 
3101 procedure TLazIntfImage.SetColor_BPP32_B8G8R8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
3102 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3103 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3104 // BitsPerPixel=32
3105 var
3106   VBytes: TFPColorBytes absolute Value;
3107 begin
3108   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3109   begin
3110     B0 := VBytes.Bh;
3111     B1 := VBytes.Gh;
3112     B2 := VBytes.Rh;
3113   end;
3114 end;
3115 
3116 procedure TLazIntfImage.SetColor_BPP32_B8R8G8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
3117 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3118 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3119 // BitsPerPixel=32
3120 var
3121   VBytes: TFPColorBytes absolute Value;
3122 begin
3123   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3124   begin
3125     B0 := VBytes.Bh;
3126     B1 := VBytes.Rh;
3127     B2 := VBytes.Gh;
3128   end;
3129 end;
3130 
3131 procedure TLazIntfImage.SetColor_BPP32_G8B8R8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
3132 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3133 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3134 // BitsPerPixel=32
3135 var
3136   VBytes: TFPColorBytes absolute Value;
3137 begin
3138   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3139   begin
3140     B0 := VBytes.Gh;
3141     B1 := VBytes.Bh;
3142     B2 := VBytes.Rh;
3143   end;
3144 end;
3145 
3146 procedure TLazIntfImage.SetColor_BPP32_G8R8B8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
3147 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3148 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3149 // BitsPerPixel=32
3150 var
3151   VBytes: TFPColorBytes absolute Value;
3152 begin
3153   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3154   begin
3155     B0 := VBytes.Gh;
3156     B1 := VBytes.Rh;
3157     B2 := VBytes.Bh;
3158   end;
3159 end;
3160 
3161 procedure TLazIntfImage.SetColor_BPP32_R8B8G8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
3162 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3163 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3164 // BitsPerPixel=32
3165 var
3166   VBytes: TFPColorBytes absolute Value;
3167 begin
3168   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3169   begin
3170     B0 := VBytes.Rh;
3171     B1 := VBytes.Bh;
3172     B2 := VBytes.Gh;
3173   end;
3174 end;
3175 
3176 procedure TLazIntfImage.SetColor_BPP32_R8G8B8X8_BIO_TTB(x, y: integer; const Value: TFPColor);
3177 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3178 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3179 // BitsPerPixel=32
3180 var
3181   VBytes: TFPColorBytes absolute Value;
3182 begin
3183   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x shl 2))^ do
3184   begin
3185     B0 := VBytes.Rh;
3186     B1 := VBytes.Gh;
3187     B2 := VBytes.Bh;
3188   end;
3189 end;
3190 
3191 procedure TLazIntfImage.SetColor_BPP24_B8G8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
3192 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3193 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3194 // BitsPerPixel=32
3195 var
3196   VBytes: TFPColorBytes absolute Value;
3197 begin
3198   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
3199   begin
3200     B0 := VBytes.Bh;
3201     B1 := VBytes.Gh;
3202     B2 := VBytes.Rh;
3203   end;
3204 end;
3205 
3206 procedure TLazIntfImage.SetColor_BPP24_B8R8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
3207 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3208 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3209 // BitsPerPixel=32
3210 var
3211   VBytes: TFPColorBytes absolute Value;
3212 begin
3213   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
3214   begin
3215     B0 := VBytes.Bh;
3216     B1 := VBytes.Rh;
3217     B2 := VBytes.Gh;
3218   end;
3219 end;
3220 
3221 procedure TLazIntfImage.SetColor_BPP24_G8B8R8_BIO_TTB(x, y: integer; const Value: TFPColor);
3222 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3223 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3224 // BitsPerPixel=32
3225 var
3226   VBytes: TFPColorBytes absolute Value;
3227 begin
3228   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
3229   begin
3230     B0 := VBytes.Gh;
3231     B1 := VBytes.Bh;
3232     B2 := VBytes.Rh;
3233   end;
3234 end;
3235 
3236 procedure TLazIntfImage.SetColor_BPP24_G8R8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
3237 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3238 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3239 // BitsPerPixel=32
3240 var
3241   VBytes: TFPColorBytes absolute Value;
3242 begin
3243   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
3244   begin
3245     B0 := VBytes.Gh;
3246     B1 := VBytes.Rh;
3247     B2 := VBytes.Bh;
3248   end;
3249 end;
3250 
3251 procedure TLazIntfImage.SetColor_BPP24_R8B8G8_BIO_TTB(x, y: integer; const Value: TFPColor);
3252 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3253 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3254 // BitsPerPixel=32
3255 var
3256   VBytes: TFPColorBytes absolute Value;
3257 begin
3258   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
3259   begin
3260     B0 := VBytes.Rh;
3261     B1 := VBytes.Bh;
3262     B2 := VBytes.Gh;
3263   end;
3264 end;
3265 
3266 procedure TLazIntfImage.SetColor_BPP24_R8G8B8_BIO_TTB(x, y: integer; const Value: TFPColor);
3267 // Format=ricfRGBA HasPalette=false Depth=32 PaletteColorCount=0
3268 // BitOrder=riboBitsInOrder LineOrder=riloTopToBottom
3269 // BitsPerPixel=32
3270 var
3271   VBytes: TFPColorBytes absolute Value;
3272 begin
3273   with PFourBytes(FRawImage.Data+FLineStarts^.Positions[y].Byte+(x * 3))^ do
3274   begin
3275     B0 := VBytes.Rh;
3276     B1 := VBytes.Gh;
3277     B2 := VBytes.Bh;
3278   end;
3279 end;
3280 
GetTColorsnull3281 function TLazIntfImage.GetTColors(x, y: integer): TGraphicsColor;
3282 begin
3283   Result:=FPColorToTColor(Colors[x,y]);
3284 end;
3285 
3286 procedure TLazIntfImage.SetTColors(x, y: integer; const AValue: TGraphicsColor);
3287 begin
3288   Colors[x,y]:=TColorToFPColor(AValue);
3289 end;
3290 
3291 procedure TLazIntfImage.SetUsePalette(Value: boolean);
3292 begin
3293   inherited // we can SetUsePalette(False);  // Can't handle palettes at the moment
3294 end;
3295 
3296 procedure TLazIntfImage.SetInternalColor(x, y: integer; const Value: TFPColor);
3297 begin
3298   {if (x=0) and (y=0) then begin
3299     // a common bug in the readers is that Alpha is reversed
3300     DebugLn('TLazIntfImage.SetInternalColor ',x,',',y,' ',Value.Red,',',Value.Green,',',Value.Blue,',',Value.Alpha);
3301     if Value.Alpha<>alphaOpaque then
3302       RaiseGDBException('');
3303   end;}
3304   FSetInternalColorProc(x,y,Value);
3305   {if y=Height-1 then
3306     DebugLn(['TLazIntfImage.SetInternalColor x=',x,' y=',y,' ',dbgs(Value),' ',dbgs(GetInternalColor(x,y))]);}
3307 end;
3308 
GetInternalColornull3309 function TLazIntfImage.GetInternalColor(x, y: integer): TFPColor;
3310 begin
3311   FGetInternalColorProc(x,y,Result);
3312 end;
3313 
3314 procedure TLazIntfImage.SetInternalPixel(x, y: integer; Value: integer);
3315 begin
3316   if Palette = nil then Exit;
3317   if FRawImage.Description.PaletteColorCount = 0
3318   then begin
3319     // Non palettebased image so set the color
3320     SetInternalColor(x, y, Palette.Color[Value]);
3321   end
3322   else begin
3323     // TODO: Setting of palette colors
3324   end;
3325 end;
3326 
3327 procedure TLazIntfImage.SetMasked(x, y: integer; const AValue: Boolean);
3328 begin
3329 //  CheckIndex(x,y);
3330   SetMask_Generic(x, y, AValue);
3331   FMaskSet := FMaskSet or AValue;
3332 end;
3333 
GetInternalPixelnull3334 function TLazIntfImage.GetInternalPixel(x, y: integer): integer;
3335 begin
3336   if Palette = nil then Exit(0);
3337 
3338   if FRawImage.Description.PaletteColorCount = 0
3339   then begin
3340     // Non palettebased image so lookup the color
3341     Result := Palette.IndexOf(GetInternalColor(x, y));
3342   end
3343   else begin
3344     // TODO: Setting of palette colors
3345     Result := 0;
3346   end;
3347 end;
3348 
GetMaskednull3349 function TLazIntfImage.GetMasked(x, y: integer): Boolean;
3350 begin
3351 //  CheckIndex (x,y);
3352   GetMask_Generic(x, y, Result);
3353 end;
3354 
3355 procedure TLazIntfImage.FreeData;
3356 begin
3357   //DebugLn(Format('[TLazIntfImage.FreeData] Self=%x Data=%x', [PtrUInt(Self), PtrUInt(FRawImage.Data)]));
3358   if FDataOwner
3359   then ReallocMem(FRawImage.Data, 0)
3360   else FRawImage.Data := nil;
3361   FRawImage.DataSize := 0;
3362 
3363   if FLineStarts <> nil then Dispose(FLineStarts);
3364   FLineStarts := nil;
3365 
3366   if FDataOwner and (FRawImage.Mask <> nil)
3367   then ReallocMem(FRawImage.Mask, 0)
3368   else FRawImage.Mask := nil;
3369   FRawImage.MaskSize := 0;
3370 
3371   if FMaskLineStarts <> nil then Dispose(FMaskLineStarts);
3372   FMaskLineStarts := nil;
3373   FMaskSet := False;
3374 
3375   if FDataOwner and (FRawImage.Palette <> nil)
3376   then ReallocMem(FRawImage.Palette, 0)
3377   else FRawImage.Palette := nil;
3378   FRawImage.PaletteSize := 0;
3379 
3380   // old RawImage data has been cleared/destroyed => so new data must be owned by us
3381   FDataOwner := True;
3382 end;
3383 
3384 procedure TLazIntfImage.CreateData;
3385 begin
3386   if FUpdateCount > 0
3387   then begin
3388     FCreateAllDataNeeded := True;
3389     Exit;
3390   end;
3391   FCreateAllDataNeeded := False;
3392 
3393   FreeData;
3394 
3395   New(FLineStarts);
3396   FLineStarts^.Init(Width, Height, FRawImage.Description.BitsPerPixel, FRawImage.Description.LineEnd, FRawImage.Description.LineOrder);
3397   New(FMaskLineStarts);
3398   FMaskLineStarts^.Init(Width, Height, FRawImage.Description.MaskBitsPerPixel, FRawImage.Description.MaskLineEnd, FRawImage.Description.LineOrder);
3399 
3400   FRawImage.CreateData(False);
3401 end;
3402 
HasTransparencynull3403 function TLazIntfImage.HasTransparency: boolean;
3404 begin
3405   Result := FMaskSet or FRawImage.IsTransparent(True);
3406 end;
3407 
HasMasknull3408 function TLazIntfImage.HasMask: boolean;
3409 begin
3410   Result := FMaskSet;
3411 end;
3412 
3413 procedure TLazIntfImage.SetDataDescriptionKeepData(
3414   const ADescription: TRawImageDescription);
3415 begin
3416   FRawImage.Description:=ADescription;
3417 end;
3418 
3419 constructor TLazIntfImage.Create(AWidth, AHeight: integer);
3420 begin
3421   Create(AWidth, AHeight, []);
3422 end;
3423 
3424 constructor TLazIntfImage.Create(AWidth, AHeight: integer; AFlags: TRawImageQueryFlags);
3425 begin
3426   FDataOwner := True;
3427   FGetInternalColorProc := @GetColor_NULL;
3428   FSetInternalColorProc := @SetColor_NULL;
3429   inherited Create(AWidth, AHeight);
3430 
3431   if AFlags <> []
3432   then begin
3433     QueryDescription(FRawImage.Description, AFlags, AWidth, AHeight);
3434     ChooseGetSetColorFunctions;
3435   end;
3436 end;
3437 
3438 constructor TLazIntfImage.Create(ARawImage: TRawImage; ADataOwner: Boolean);
3439 var
3440   Desc: TRawImageDescription absolute ARawImage.Description;
3441 begin
3442   BeginUpdate;
3443   FRawImage := ARawImage;
3444   Create(Desc.Width, Desc.Height, []);
3445   FDataOwner := ADataOwner;
3446   FCreateAllDataNeeded := False;
3447   EndUpdate;
3448   New(FLineStarts);
3449   FLineStarts^.Init(Width, Height, Desc.BitsPerPixel, Desc.LineEnd, Desc.LineOrder);
3450   New(FMaskLineStarts);
3451   FMaskLineStarts^.Init(Width, Height, Desc.MaskBitsPerPixel, Desc.MaskLineEnd, Desc.LineOrder);
3452   ChooseGetSetColorFunctions;
3453 end;
3454 
3455 constructor TLazIntfImage.CreateCompatible(IntfImg: TLazIntfImage; AWidth,
3456   AHeight: integer);
3457 var
3458   Desc: TRawImageDescription;
3459 begin
3460   Create(0,0);
3461   Desc:=IntfImg.DataDescription;
3462   Desc.Width:=AWidth;
3463   Desc.Height:=AHeight;
3464   DataDescription:=Desc;
3465 end;
3466 
3467 destructor TLazIntfImage.Destroy;
3468 begin
3469   FreeData;
3470   inherited Destroy;
3471 end;
3472 
3473 procedure TLazIntfImage.Assign(Source: TPersistent);
3474 begin
3475   if Source is TLazIntfImage then
3476     DataDescription:=TLazIntfImage(Source).DataDescription;
3477   inherited Assign(Source);
3478 end;
3479 
3480 procedure TLazIntfImage.AlphaFromMask(AKeepAlpha: Boolean);
3481 var
3482   x, y, xStop, yStop: Integer;
3483   Color: TFPColor;
3484 begin
3485   if FRawImage.Mask = nil then Exit;
3486   if FRawImage.MaskSize = 0 then Exit;
3487 
3488   xStop := Width - 1;
3489   yStop := Height - 1;
3490 
3491   if AKeepAlpha
3492   then begin
3493     for y:=0 to yStop do
3494       for x:=0 to xStop do
3495       begin
3496         if not Masked[x,y] then Continue;
3497         Color := Colors[x,y];
3498         Color.alpha := Low(Color.alpha);
3499         Colors[x,y] := Color;
3500       end;
3501   end
3502   else begin
3503     for y:=0 to yStop do
3504       for x:=0 to xStop do
3505       begin
3506         Color := Colors[x,y];
3507         if Masked[x,y]
3508         then Color.alpha := Low(Color.alpha)
3509         else Color.alpha := High(Color.alpha);
3510         Colors[x,y] := Color;
3511       end;
3512   end;
3513 end;
3514 
3515 procedure TLazIntfImage.Mask(const AColor: TFPColor; AKeepOldMask: Boolean = False);
3516 var
3517   x, y: Integer;
3518 begin
3519   if AKeepOldMask then
3520     for y := 0 to Height - 1 do
3521       for x := 0 to Width - 1 do
3522         Masked[x,y] := Masked[x,y] or (Colors[x,y] = AColor)
3523   else
3524     for y := 0 to Height - 1 do
3525       for x := 0 to Width - 1 do
3526         Masked[x,y] := Colors[x,y] = AColor;
3527 end;
3528 
3529 procedure TLazIntfImage.BeginUpdate;
3530 begin
3531   Inc(FUpdateCount);
3532 end;
3533 
3534 procedure TLazIntfImage.EndUpdate;
3535 begin
3536   if FUpdateCount = 0 then Exit;
3537   Dec(FUpdateCount);
3538   if FUpdateCount > 0 then Exit;
3539 
3540   if FCreateAllDataNeeded then
3541     CreateData;
3542   if FGetSetColorFunctionsUpdateNeeded then
3543     ChooseGetSetColorFunctions;
3544 end;
3545 
3546 procedure TLazIntfImage.InternalSetSize(AWidth, AHeight: integer);
3547   procedure Error;
3548   begin
3549     raise FPImageException.Create('Invalid Size');
3550   end;
3551 begin
3552   if (AWidth = Width) and (AHeight = Height) then exit;
3553   if (AWidth<0) or (AHeight<0) then Error;
3554   inherited SetSize(AWidth, AHeight);
3555 
3556   FRawImage.Description.Width := Width;
3557   FRawImage.Description.Height := Height;
3558 end;
3559 
3560 procedure TLazIntfImage.SetSize(AWidth, AHeight: integer);
3561 begin
3562   InternalSetSize(AWidth, AHeight);
3563   CreateData;
3564 end;
3565 
CheckDescriptionnull3566 function TLazIntfImage.CheckDescription(
3567   const ADescription: TRawImageDescription; ExceptionOnError: boolean
3568     ): boolean;
3569 
3570   procedure DoError(const Msg: string);
3571   begin
3572     if ExceptionOnError then Raise FPImageException.Create(Msg);
3573     {$IFNDEF DisableChecks}
3574     DebugLn('TLazIntfImage.CheckDescription: ',Msg);
3575     {$ENDIF}
3576   end;
3577 
3578 begin
3579   Result:=false;
3580   // check format
3581   if (not (ADescription.Format
3582       in [low(TRawImageColorFormat)..high(TRawImageColorFormat)]))
3583   then begin
3584     DoError('Invalid Raw Image Description Format'); exit;
3585   end;
3586 
3587   Result:=true;
3588 end;
3589 
3590 procedure TLazIntfImage.GetXYDataPosition(x, y: integer; out Position: TRawImagePosition);
3591 begin
3592   Position := FLineStarts^.GetPosition(x, y);
3593 end;
3594 
3595 procedure TLazIntfImage.GetXYMaskPosition(x, y: integer; out Position: TRawImagePosition);
3596 begin
3597   Position := FMaskLineStarts^.GetPosition(x, y);
3598 end;
3599 
GetDataLineStartnull3600 function TLazIntfImage.GetDataLineStart(y: integer): Pointer;
3601 begin
3602   if FRawimage.Description.LineOrder = riloBottomToTop then
3603     y:=Height-y;
3604   Result := FRawImage.Data+FLineStarts^.Positions[y].Byte;
3605 end;
3606 
3607 procedure TLazIntfImage.LoadFromDevice(DC: HDC);
3608 var
3609   R: TRect;
3610   RawImage: TRawImage;
3611   DeviceSize: TPoint;
3612 begin
3613   GetDeviceSize(DC, DeviceSize);
3614   R := Rect(0,0,DeviceSize.X,DeviceSize.Y);
3615   if not RawImage_FromDevice(RawImage, DC, R) then
3616     raise FPImageException.Create('Failed to get raw image from device');
3617   SetRawImage(RawImage);
3618 end;
3619 
3620 procedure TLazIntfImage.LoadFromBitmap(ABitmap, AMaskBitmap: HBitmap;
3621   AWidth: integer; AHeight: integer);
3622 var
3623   R: TRect;
3624   RawImage: TRawImage;
3625   Desc: TRawImageDescription;
3626 begin
3627   if not RawImage_DescriptionFromBitmap(ABitmap, Desc) then
3628     raise FPImageException.Create('Failed to get raw image description from bitmap');
3629 
3630   if AWidth < 0 then AWidth := Desc.Width;
3631   if AHeight < 0 then AHeight := Desc.Height;
3632   R := Rect(0, 0, AWidth, AHeight);
3633   if not RawImage_FromBitmap(RawImage, ABitmap, AMaskBitmap, @R) then
3634     raise FPImageException.Create('Failed to get raw image from bitmap');
3635 
3636   SetRawImage(RawImage);
3637 end;
3638 
3639 procedure TLazIntfImage.CreateBitmaps(out ABitmap, AMask: HBitmap; ASkipMask: boolean);
3640 begin
3641   if not RawImage_CreateBitmaps(FRawImage, ABitmap, AMask, ASkipMask)
3642   then raise FPImageException.Create('Failed to create handles');
3643 end;
3644 
3645 procedure TLazIntfImage.SetRawImage(const ARawImage: TRawImage; ADataOwner: Boolean);
3646 var
3647   Desc: TRawImageDescription absolute ARawImage.Description;
3648 begin
3649   if FRawImage.IsEqual(ARawImage) then Exit;
3650 
3651   BeginUpdate;
3652   try
3653     FreeData;
3654     FRawImage := ARawImage;
3655     FDataOwner := ADataOwner;
3656     SetSize(Desc.Width, Desc.Height);
3657     FCreateAllDataNeeded := False;
3658     New(FLineStarts);
3659     FLineStarts^.Init(Width, Height, Desc.BitsPerPixel, Desc.LineEnd, Desc.LineOrder);
3660     New(FMaskLineStarts);
3661     FMaskLineStarts^.Init(Width, Height, Desc.MaskBitsPerPixel, Desc.MaskLineEnd, Desc.LineOrder);
3662     ChooseGetSetColorFunctions;
3663   finally
3664     EndUpdate;
3665   end;
3666 end;
3667 
3668 procedure TLazIntfImage.GetRawImage(out ARawImage: TRawImage; ATransferOwnership: Boolean);
3669 begin
3670   ARawImage := FRawImage;
3671   if ATransferOwnership
3672   then FDataOwner := False;
3673 end;
3674 
3675 procedure TLazIntfImage.FillPixels(const Color: TFPColor);
3676 var
3677   ColorChar: char;
3678   ColorWord: Word;
3679   Cnt: Integer;
3680   i: Integer;
3681   ColorDWord: Cardinal;
3682   y: Integer;
3683   x: Integer;
3684 begin
3685   if (Width=0) or (Height=0) or (FRawImage.Data=nil) then exit;
3686 
3687   case FRawImage.Description.BitsPerPixel of
3688 
3689   8:
3690     begin
3691       SetInternalColor(0,0,Color);
3692       ColorChar:=Char(FRawImage.Data[0]);
3693       FillChar(FRawImage.Data^,FRawImage.DataSize,ColorChar);
3694     end;
3695 
3696   16:
3697     begin
3698       SetInternalColor(0,0,Color);
3699       ColorWord:=PWord(FRawImage.Data)[0];
3700       Cnt:=FRawImage.DataSize div 2;
3701       for i:=0 to Cnt-1 do
3702         PWord(FRawImage.Data)[i]:=ColorWord;
3703     end;
3704 
3705   32:
3706     begin
3707       SetInternalColor(0,0,Color);
3708       ColorDWord:=PDWord(FRawImage.Data)[0];
3709       Cnt:=FRawImage.DataSize div 4;
3710       for i:=0 to Cnt-1 do
3711         PDWord(FRawImage.Data)[i]:=ColorDWord;
3712     end;
3713 
3714   else
3715     for y:=0 to Height-1 do
3716       for x:=0 to Width-1 do
3717         SetInternalColor(x,y,Color);
3718   end;
3719 
3720   // ToDo: mask
3721 end;
3722 
3723 {
3724   Merges an image to a canvas using alpha blend acording to a separate image
3725   containing the alpha channel. White pixels in the alpha channel will correspond
3726   to the source image pixel being fully drawn, grey ones are merged and
3727   black ones ignored.
3728 
3729   If ASourceAlpha = nil then it will utilize the alpha channel from ASource
3730 }
3731 procedure TLazIntfImage.AlphaBlend(ASource, ASourceAlpha: TLazIntfImage;
3732   const ADestX, ADestY: Integer);
3733 var
3734   x, y, CurX, CurY: Integer;
3735   MaskValue, InvMaskValue: Word;
3736   CurColor: TFPColor;
3737   lDrawWidth, lDrawHeight: Integer;
3738 begin
3739   // Take care not to draw outside the destination area
3740   lDrawWidth := Min(Self.Width - ADestX, ASource.Width);
3741   lDrawHeight := Min(Self.Height - ADestY, ASource.Height);
3742   for y := 0 to lDrawHeight - 1 do
3743   begin
3744     for x := 0 to lDrawWidth - 1 do
3745     begin
3746       CurX := ADestX + x;
3747       CurY := ADestY + y;
3748 
3749       // Never draw outside the destination
3750       if (CurX < 0) or (CurY < 0) then Continue;
3751 
3752       if ASourceAlpha <> nil then
3753         MaskValue := ASourceAlpha.Colors[x, y].alpha
3754       else
3755         MaskValue := ASource.Colors[x, y].alpha;
3756 
3757       InvMaskValue := $FFFF - MaskValue;
3758 
3759       if MaskValue = $FFFF then
3760       begin
3761         Self.Colors[CurX, CurY] := ASource.Colors[x, y];
3762       end
3763       else if MaskValue > $00 then
3764       begin
3765         CurColor := Self.Colors[CurX, CurY];
3766 
3767         CurColor.Red := Round(
3768           CurColor.Red * InvMaskValue / $FFFF +
3769           ASource.Colors[x, y].Red * MaskValue / $FFFF);
3770 
3771         CurColor.Green := Round(
3772           CurColor.Green * InvMaskValue / $FFFF +
3773           ASource.Colors[x, y].Green * MaskValue / $FFFF);
3774 
3775         CurColor.Blue := Round(
3776           CurColor.Blue * InvMaskValue / $FFFF +
3777           ASource.Colors[x, y].Blue * MaskValue / $FFFF);
3778 
3779         Self.Colors[CurX, CurY] := CurColor;
3780       end;
3781     end;
3782   end;
3783 end;
3784 
3785 procedure TLazIntfImage.CopyPixels(ASource: TFPCustomImage; XDst: Integer;
3786   YDst: Integer; AlphaMask: Boolean; AlphaTreshold: Word);
3787 var
3788   SrcImg: TLazIntfImage absolute ASource;
3789   SrcHasMask, DstHasMask: Boolean;
3790   x, y, xStart, yStart, xStop, yStop: Integer;
3791   c: TFPColor;
3792 begin
3793 {
3794   if (Src.Width<>Width) or (Src.Height<>Height) then
3795     SetSize(Src.Width,Src.Height);
3796 }
3797   if (ASource is TLazIntfImage) and
3798      FRawImage.Description.IsEqual(SrcImg.FRawImage.Description) and (XDst =  0) and (YDst = 0) then
3799   begin
3800     // same description -> copy
3801     if FRawImage.Data <> nil then
3802       System.Move(SrcImg.FRawImage.Data^,FRawImage.Data^,FRawImage.DataSize);
3803     if FRawImage.Mask <> nil then
3804       System.Move(SrcImg.FRawImage.Mask^,FRawImage.Mask^,FRawImage.MaskSize);
3805     Exit;
3806   end;
3807 
3808   // copy pixels
3809   XStart := IfThen(XDst < 0, -XDst, 0);
3810   YStart := IfThen(YDst < 0, -YDst, 0);
3811   XStop := IfThen(Width - XDst < ASource.Width, Width - XDst, ASource.Width) - 1;
3812   YStop := IfTHen(Height - YDst < ASource.Height, Height - YDst, ASource.Height) - 1;
3813 
3814   SrcHasMask := (ASource is TLazIntfImage) and (SrcImg.FRawImage.Description.MaskBitsPerPixel > 0);
3815   DstHasMask := FRawImage.Description.MaskBitsPerPixel > 0;
3816 
3817   if DstHasMask and (ASource is TLazIntfImage)
3818   then begin
3819     for y:= yStart to yStop do
3820       for x:=xStart to xStop do
3821         Masked[x+XDst,y+YDst] := SrcHasMask and SrcImg.Masked[x,y];
3822   end;
3823 
3824   for y:=yStart to yStop do
3825     for x:=xStart to xStop do
3826     begin
3827       c := ASource.Colors[x,y];
3828 
3829       if not DstHasMask and SrcHasMask and (c.alpha = $FFFF) then // copy mask to alpha channel
3830         if SrcImg.Masked[x,y] then
3831           c.alpha := 0;
3832 
3833       Colors[x+XDst,y+YDst] := c;
3834       if AlphaMask and (c.alpha < AlphaTreshold) then
3835         Masked[x+XDst,y+YDst] := True;
3836     end;
3837 
3838 end;
3839 
3840 { TLazReaderXPM }
3841 
3842 type
3843   TXPMPixelToColorEntry = record
3844     Color: TFPColor;
3845   end;
3846   PXPMPixelToColorEntry = ^TXPMPixelToColorEntry;
3847 
3848 procedure TLazReaderXPM.ClearPixelToColorTree;
3849 var
3850   Entry: PXPMPixelToColorEntry;
3851   ArrNode: TArrayNode;
3852 begin
3853   if FPixelToColorTree<>nil then begin
3854     ArrNode:=FPixelToColorTree.Root;
3855     while ArrNode<>nil do begin
3856       Entry:=PXPMPixelToColorEntry(ArrNode.Data);
3857       if Entry<>nil then begin
3858         //DebugLn('TLazReaderXPM.ClearPixelToColorTree A ',DbgS(ArrNode),' ',DbgS(Entry));
3859         Dispose(Entry);
3860       end;
3861       ArrNode:=ArrNode.FindNextUTF8;
3862     end;
3863     FPixelToColorTree.Free;
3864     FPixelToColorTree:=nil;
3865   end;
3866 end;
3867 
3868 procedure TLazReaderXPM.InternalRead(Str: TStream; Img: TFPCustomImage);
3869 type
3870   TSrcLine = record
3871     StartPos: integer;
3872     EndPos: integer;
3873   end;
3874 
3875 var
3876   SrcPos: integer;
3877   Src: String;
3878   SrcLen: Integer;
3879   CurLineNumber, LastLineStart: integer;
3880   HasAlpha: Boolean;
3881 
3882   procedure RaiseXPMReadError(const Msg: string; ReadPos: integer);
3883   var
3884     CurColumn: Integer;
3885   begin
3886     CurColumn:=ReadPos-LastLineStart+1;
3887     raise Exception.Create(Msg
3888                            +' in xpm stream at line '+IntToStr(CurLineNumber)
3889                            +' column '+IntToStr(CurColumn));
3890   end;
3891 
3892   // read next string constant "" and skip comments
3893   function ReadNextLine(var Line: TSrcLine;
3894     ExceptionOnNotFound: Boolean): boolean;
3895   begin
3896     while SrcPos<=SrcLen do begin
3897       case Src[SrcPos] of
3898 
3899       #10,#13:
3900         begin
3901           // count linenumbers for nicer error output
3902           inc(SrcPos);
3903           inc(CurLineNumber);
3904           if (SrcPos<=SrcLen) and (Src[SrcPos] in [#10,#13])
3905           and (Src[SrcPos]<>Src[SrcPos-1]) then
3906             inc(SrcPos);
3907           LastLineStart:=SrcPos;
3908         end;
3909 
3910       '/':
3911         begin
3912           if (SrcPos<SrcLen) and (Src[SrcPos+1]='*') then begin
3913             // this is a C comment
3914             // -> skip comment
3915             inc(SrcPos,2);
3916             while (SrcPos<SrcLen) do begin
3917               if (Src[SrcPos]='*') and (Src[SrcPos+1]='/') then begin
3918                 // comment end found
3919                 inc(SrcPos,2);
3920                 break;
3921               end;
3922               inc(SrcPos);
3923             end;
3924           end else
3925             RaiseXPMReadError('syntax error',SrcPos);
3926         end;
3927 
3928       '"':
3929         begin
3930           // start of a string constant
3931           inc(SrcPos);
3932           Line.StartPos:=SrcPos;
3933           while (SrcPos<SrcLen) do begin
3934             if (Src[SrcPos]='"') and (Src[SrcPos-1]<>'\') then begin
3935               // string end found
3936               Line.EndPos:=SrcPos;
3937               //DebugLn('  ',copy(Src,Line.StartPos-1,Line.EndPos-Line.StartPos+2));
3938               inc(SrcPos);
3939               Result:=true;
3940               exit;
3941             end;
3942             inc(SrcPos);
3943           end;
3944         end;
3945 
3946       else
3947         inc(SrcPos);
3948       end;
3949     end;
3950     Result:=false;
3951     if ExceptionOnNotFound then
3952       Raise Exception.Create('Unexpected end of xpm stream');
3953   end;
3954 
3955   function ReadNumber(var ReadPos: integer;
3956     ExceptionOnNotFound: Boolean): integer;
3957   begin
3958     // skip spaces
3959     while IsSpaceChar[Src[ReadPos]] do inc(ReadPos);
3960     // read number
3961     Result:=0;
3962     if IsNumberChar[Src[ReadPos]] then begin
3963       repeat
3964         Result:=Result*10+ord(Src[ReadPos])-Ord('0');
3965         inc(ReadPos);
3966       until not IsNumberChar[Src[ReadPos]];
3967     end else if ExceptionOnNotFound then
3968       RaiseXPMReadError('number expected',ReadPos);
3969   end;
3970 
3971   procedure ReadHeader;
3972   var
3973     FirstLine: TSrcLine;
3974   begin
3975     ReadNextLine(FirstLine,true);
3976     FWidth:=ReadNumber(FirstLine.StartPos,true);
3977     FHeight:=ReadNumber(FirstLine.StartPos,true);
3978     FColorCount:=ReadNumber(FirstLine.StartPos,true);
3979     FCharsPerPixel:=ReadNumber(FirstLine.StartPos,true);
3980     fXHot:=ReadNumber(FirstLine.StartPos,false);
3981     fYHot:=ReadNumber(FirstLine.StartPos,fXHot<>0);
3982     //DebugLn('ReadHeader A Width=',FWidth,' Height=',FHeight,' ColorCount=',FColorCount,' CharsPerPixel=',FCharsPerPixel);
3983     // ToDo: parse XPMExt tag
3984   end;
3985 
3986   function HexToColor(HexStart, HexEnd: integer): TFPColor;
3987 
3988     procedure ReadHexNumber(var StartPos: integer; Len: integer;
3989       var Number: word);
3990     var
3991       c: Char;
3992       i: Integer;
3993     begin
3994       Number:=0;
3995       for i:=1 to 4 do begin
3996         Number:=Number shl 4;
3997         if i<=Len then begin
3998           c:=Src[StartPos];
3999           case c of
4000           '0'..'9': inc(Number,ord(c)-ord('0'));
4001           'A'..'F': inc(Number,ord(c)-ord('A')+10);
4002           'a'..'f': inc(Number,ord(c)-ord('a')+10);
4003           end;
4004           inc(StartPos);
4005         end;
4006       end;
4007       // fill missing bits
4008       case Len of
4009       1: Number:=Number or (Number shr 4) or (Number shr 8) or (Number shr 12);
4010       2: Number:=Number or (Number shr 8);
4011       3: Number:=Number or (Number shr 12);
4012       end;
4013     end;
4014 
4015   var
4016     HexLen: Integer;
4017     SampleLen: Integer;
4018     SampleStart: Integer;
4019   begin
4020     HexLen:=HexEnd-HexStart;
4021     case HexLen of
4022     3: SampleLen:=1;
4023     6: SampleLen:=2;
4024     9: SampleLen:=3;
4025     12:SampleLen:=4;
4026     else
4027       RaiseXPMReadError('hexnumber expected',HexStart);
4028     end;
4029     SampleStart:=HexStart;
4030     ReadHexNumber(SampleStart,SampleLen,Result.Red);
4031     ReadHexNumber(SampleStart,SampleLen,Result.Green);
4032     ReadHexNumber(SampleStart,SampleLen,Result.Blue);
4033     Result.Alpha:=alphaOpaque;
4034   end;
4035 
4036   function TextToColor(TextStart, TextEnd: integer): TFPColor;
4037   var
4038     s: String;
4039   begin
4040     s := lowercase(copy(Src,TextStart,TextEnd-TextStart));
4041     if s = 'transparent' then
4042       Result := FPImage.colTransparent
4043     else if s = 'none' then
4044       Result := FPImage.colTransparent
4045     else if s = 'black' then
4046       result := FPImage.colBlack
4047     else if s = 'blue' then
4048       Result := FPImage.colBlue
4049     else if s = 'green' then
4050       Result := FPImage.colGreen
4051     else if s = 'cyan' then
4052       Result := FPImage.colCyan
4053     else if s = 'red' then
4054       Result := FPImage.colRed
4055     else if s = 'magenta' then
4056       Result := FPImage.colMagenta
4057     else if s = 'yellow' then
4058       Result := FPImage.colYellow
4059     else if s = 'white' then
4060       Result := FPImage.colWhite
4061     else if s = 'gray' then
4062       Result := FPImage.colGray
4063     else if s = 'lightgray' then
4064       Result := FPImage.colLtGray
4065     else if (s = 'darkgray') or (s='grey') then
4066       Result := FPImage.colDKGray
4067     else if s = 'darkblue' then
4068       Result := FPImage.colDkBlue
4069     else if s = 'darkgreen' then
4070       Result := FPImage.colDkGreen
4071     else if s = 'darkcyan' then
4072       Result := FPImage.colDkCyan
4073     else if s = 'darkred' then
4074       Result := FPImage.colDkRed
4075     else if s = 'darkmagenta' then
4076       Result := FPImage.colDkMagenta
4077     else if s = 'darkyellow' then
4078       Result := FPImage.colDkYellow
4079     else if s = 'maroon' then
4080       Result := FPImage.colMaroon
4081     else if s = 'lightgreen' then
4082       Result := FPImage.colLtGreen
4083     else if s = 'olive' then
4084       Result := FPImage.colOlive
4085     else if s = 'navy' then
4086       Result := FPImage.colNavy
4087     else if s = 'purple' then
4088       Result := FPImage.colPurple
4089     else if s = 'teal' then
4090       Result := FPImage.colTeal
4091     else if s = 'silver' then
4092       Result := FPImage.colSilver
4093     else if s = 'lime' then
4094       Result := FPImage.colLime
4095     else if s = 'fuchsia' then
4096       Result := FPImage.colFuchsia
4097     else if s = 'aqua' then
4098       Result := FPImage.colAqua
4099     else
4100       Result := FPImage.colTransparent;
4101   end;
4102 
4103   procedure AddColor(PixelStart: integer; const AColor: TFPColor;
4104     IntArray: PInteger);
4105   var
4106     NewEntry: PXPMPixelToColorEntry;
4107     i: Integer;
4108   begin
4109     {DebugLn('TLazReaderXPM.InternalRead.AddColor A "',DbgStr(copy(Src,PixelStart,FCharsPerPixel)),'"=',
4110       DbgS(AColor.Red),',',
4111       DbgS(AColor.Green),',',
4112       DbgS(AColor.Blue),',',
4113       DbgS(AColor.Alpha));}
4114     New(NewEntry);
4115     NewEntry^.Color:=AColor;
4116     // add entry to Array Tree
4117     if FPixelToColorTree=nil then
4118       FPixelToColorTree:=TArrayNodesTree.Create;
4119     for i:=0 to FCharsPerPixel-1 do
4120       IntArray[i]:=ord(Src[PixelStart+i]);
4121     FPixelToColorTree.SetNode(IntArray,FCharsPerPixel,NewEntry);
4122     //if FPixelToColorTree.FindData(IntArray,FCharsPerPixel)<>NewEntry then RaiseGDBException('');
4123   end;
4124 
4125   procedure ReadPalette(IntArray: PInteger);
4126   var
4127     i: Integer;
4128     Line: TSrcLine;
4129     ReadPos: Integer;
4130     ColorStart: Integer;
4131     ColorEnd: Integer;
4132     NewColor: TFPColor;
4133     PixelStart: Integer;
4134   begin
4135     for i:=1 to FColorCount do begin
4136       ReadNextLine(Line,true);
4137       ReadPos:=Line.StartPos;
4138       // read pixel string
4139       PixelStart:=ReadPos;
4140       inc(ReadPos,FCharsPerPixel);
4141       // skip spaces
4142       while IsSpaceChar[Src[ReadPos]] do inc(ReadPos);
4143       // read 'c' (sometimes the 'c' is an 's')
4144       if not (Src[ReadPos] in ['c','s']) then
4145         RaiseXPMReadError('"c" expected',ReadPos);
4146       inc(ReadPos);
4147       // skip spaces
4148       while IsSpaceChar[Src[ReadPos]] do inc(ReadPos);
4149       // read color string
4150       ColorStart:=ReadPos;
4151       if Src[ReadPos]='#' then begin
4152         inc(ColorStart);
4153         // read as hexnumber
4154         repeat
4155           inc(ReadPos);
4156         until not (IsHexNumberChar[Src[ReadPos]]);
4157         ColorEnd:=ReadPos;
4158         NewColor:=HexToColor(ColorStart,ColorEnd);
4159       end
4160       else begin
4161         // read as text
4162         repeat
4163           inc(ReadPos);
4164         until not (Src[ReadPos] in ['A'..'Z','a'..'z']);
4165         ColorEnd:=ReadPos;
4166         NewColor:=TextToColor(ColorStart,ColorEnd);
4167       end;
4168       AddColor(PixelStart,NewColor,IntArray);
4169 
4170       HasAlpha := HasAlpha or (NewColor.alpha <> alphaOpaque);
4171     end;
4172   end;
4173 
4174   procedure ReadPixels(IntArray: PInteger);
4175   var
4176     y: Integer;
4177     Line: TSrcLine;
4178     ReadPos: Integer;
4179     x: Integer;
4180     i: Integer;
4181     CurColor: TFPColor;
4182     CurEntry: PXPMPixelToColorEntry;
4183   begin
4184     Img.SetSize(FWidth, FHeight);
4185     for y := 0 to FHeight - 1 do
4186     begin
4187       if not FContinue then
4188         Exit;
4189       ReadNextLine(Line,true);
4190       ReadPos:=Line.StartPos;
4191       if Line.EndPos-Line.StartPos<FCharsPerPixel*FWidth then
4192         RaiseXPMReadError('line too short',ReadPos);
4193       for x:=0 to FWidth-1 do
4194       begin
4195         //DebugLn('ReadPixels x=',dbgs(x),' y=',dbgs(y),' color="',DbgStr(copy(Src,ReadPos,FCharsPerPixel)),'"');
4196         for i:=0 to FCharsPerPixel-1 do begin
4197           IntArray[i]:=ord(Src[ReadPos]);
4198           inc(ReadPos);
4199         end;
4200         CurEntry:=PXPMPixelToColorEntry(
4201                            FPixelToColorTree.FindData(IntArray,FCharsPerPixel));
4202         if CurEntry<>nil then
4203           CurColor:=CurEntry^.Color
4204         else
4205           RaiseXPMReadError('invalid color',ReadPos-FCharsPerPixel);
4206         {if CurEntry2<>CurEntry then begin
4207           DebugLn('x=',x,' y=',y,' Pixel=',Entry^.Pixel,
4208             ' RefPixel=',CurEntry^.Pixel,
4209             ' Color=',
4210             DbgS(CurColor.Red),',',
4211             DbgS(CurColor.Green),',',
4212             DbgS(CurColor.Blue),',',
4213             DbgS(CurColor.Alpha));
4214           DebugLn('Entry2: Pixel=',CurEntry2^.Pixel,
4215             ' RefPixel=',CurEntry2^.Pixel,
4216             ' Color=',
4217             DbgS(CurEntry2^.Color.Red),',',
4218             DbgS(CurEntry2^.Color.Green),',',
4219             DbgS(CurEntry2^.Color.Blue),',',
4220             DbgS(CurEntry2^.Color.Alpha));
4221         end;}
4222 
4223         {DebugLn('x=',x,' y=',y,' Pixel=',Entry^.Pixel,
4224           ' RefPixel=',PXPMPixelToColorEntry(Node.Data)^.Pixel,
4225           ' Color=',
4226           DbgS(CurColor.Red),',',
4227           DbgS(CurColor.Green),',',
4228           DbgS(CurColor.Blue),',',
4229           DbgS(CurColor.Alpha));}
4230         Img.Colors[x,y]:=CurColor;
4231       end;
4232       Progress(psRunning, trunc(100.0 * (Y + 1) / FHeight), False, Rect(0, 0, FWidth - 1, y), 'reading XPM pixels', FContinue);
4233     end;
4234   end;
4235 
4236 var
4237   IntArray: array of Integer;
4238   Desc: TRawImageDescription;
4239 begin
4240   FContinue := True;
4241   Progress(psStarting, 0, False, Rect(0,0,0,0), '', FContinue);
4242 
4243   ClearPixelToColorTree;
4244   Src:=ReadCompleteStreamToString(Str,1024);
4245   SrcLen:=length(Src);
4246   SrcPos:=1;
4247   CurLineNumber:=1;
4248   LastLineStart:=1;
4249   ReadHeader;
4250 
4251   SetLength(IntArray, FCharsPerPixel+1);
4252 
4253   HasAlpha := False;
4254   ReadPalette(@IntArray[0]);
4255 
4256   if FUpdateDescription and (theImage is TLazIntfImage)
4257   then begin
4258     if HasAlpha
4259     then DefaultReaderDescription(FWidth, FHeight, 32, Desc)
4260     else DefaultReaderDescription(FWidth, FHeight, 24, Desc);
4261 //  MWE: keep mask ?
4262 //    if FMaskMode = lrmmNone
4263 //    then Desc.MaskBitsPerPixel := 0;
4264     TLazIntfImage(theImage).DataDescription := Desc;
4265   end
4266   else begin
4267     if HasAlpha
4268     then CheckAlphaDescription(TheImage);
4269   end;
4270   //FPixelToColorTree.ConsistencyCheck;
4271   ReadPixels(@IntArray[0]);
4272 
4273   Progress(psEnding, 100, false, Rect(0,0,0,0), '', FContinue);
4274 end;
4275 
QueryInterfacenull4276 function TLazReaderXPM.QueryInterface(constref iid: TGuid; out obj): longint; {$IFDEF WINDOWs}stdcall{$ELSE}cdecl{$ENDIF};
4277 begin
4278   if GetInterface(iid, obj)
4279   then Result := S_OK
4280   else Result := E_NOINTERFACE;
4281 end;
4282 
4283 procedure TLazReaderXPM.SetUpdateDescription(AValue: Boolean);
4284 begin
4285   FUpdateDescription := AValue;
4286 end;
4287 
_AddRefnull4288 function TLazReaderXPM._AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
4289 begin
4290   Result := -1;
4291 end;
4292 
_Releasenull4293 function TLazReaderXPM._Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
4294 begin
4295   Result := -1;
4296 end;
4297 
InternalChecknull4298 function TLazReaderXPM.InternalCheck(Str: TStream): boolean;
4299 var s : string[9];
4300     l : integer;
4301 begin
4302   try
4303     l := str.Read (s[1],9);
4304     s[0] := char(l);
4305     if l <> 9 then
4306       result := False
4307     else
4308       result := (s = '/* XPM */');
4309   except
4310     result := false;
4311   end;
4312 end;
4313 
4314 constructor TLazReaderXPM.Create;
4315 begin
4316   inherited Create;
4317 end;
4318 
4319 destructor TLazReaderXPM.Destroy;
4320 begin
4321   ClearPixelToColorTree;
4322   inherited Destroy;
4323 end;
4324 
GetUpdateDescriptionnull4325 function TLazReaderXPM.GetUpdateDescription: Boolean;
4326 begin
4327   Result := FUpdateDescription;
4328 end;
4329 
4330 { TLazAVLPalette }
4331 
4332 type
4333   TLazAVLPaletteEntry = record
4334     Palette: TLazAVLPalette;
4335     Index: integer;
4336   end;
4337   PLazAVLPaletteEntry = ^TLazAVLPaletteEntry;
4338 
4339 function CompareLazAVLPaletteEntries(Entry1, Entry2: PLazAVLPaletteEntry): integer;
4340 begin
4341   Result := Entry1^.Palette.CompareEntries(Entry1^.Index, Entry2^.Index);
4342 end;
4343 
4344 function ComparePFPColorAndLazAVLPalEntry(PColor: PFPColor; Entry: PLazAVLPaletteEntry): integer;
4345 begin
4346   Result := Entry^.Palette.CompareColorWithEntries(PColor^, Entry^.Index);
4347 end;
4348 
4349 procedure TLazAVLPalette.SetCount(NewCount: integer);
4350 var
4351   NewAVLPalEntry: PLazAVLPaletteEntry;
4352   AVLNode: TAvlTreeNode;
4353   CurAVLPalEntry: PLazAVLPaletteEntry;
4354   Index: Integer;
4355 begin
4356   if FCount=NewCount then exit;
4357   // remove unused colors from 'color to index' tree
4358   if FAVLPalette<>nil then begin
4359     for Index:=FCount-1 downto NewCount do begin
4360       AVLNode:=FAVLNodes[Index];
4361       CurAVLPalEntry:=PLazAVLPaletteEntry(AVLNode.Data);
4362       FAVLPalette.Delete(AVLNode);
4363       FAVLNodes[Index]:=nil;
4364       Dispose(CurAVLPalEntry);
4365     end;
4366   end;
4367   inherited SetCount(NewCount);
4368   // create tree if not already done
4369   if (FAVLPalette=nil) and (FCount>0) then
4370     FAVLPalette:=TAvlTree.Create(TListSortCompare(@CompareLazAVLPaletteEntries));
4371   if FAVLPalette=nil then exit;
4372   // add new colors to 'color to index' tree and 'index to node' array
4373   while FAVLPalette.Count<FCount do begin
4374     Index:=FAVLPalette.Count;
4375     New(NewAVLPalEntry);
4376     NewAVLPalEntry^.Palette:=Self;
4377     NewAVLPalEntry^.Index:=Index;
4378     FAVLNodes[Index]:=FAVLPalette.Add(NewAVLPalEntry);
4379   end;
4380 end;
4381 
4382 procedure TLazAVLPalette.SetColor(Index: integer; const NewColor: TFPColor);
4383 var
4384   Node: TAvlTreeNode;
4385   Entry: PLazAVLPaletteEntry;
4386 begin
4387   if Index=FCount then
4388     Add(NewColor)
4389   else begin
4390     CheckIndex(Index);
4391     if FData^[Index]=NewColor then exit;
4392     // remove node from tree
4393     Node:=FAVLNodes[Index];
4394     Entry:=PLazAVLPaletteEntry(Node.Data);
4395     FAVLPalette.Delete(Node);
4396     // change color
4397     FData^[index] := NewColor;
4398     // add node
4399     FAVLNodes[Index]:=FAVLPalette.Add(Entry);
4400   end;
4401 end;
4402 
4403 destructor TLazAVLPalette.Destroy;
4404 begin
4405   SetCount(0);
4406   FAVLPalette.Free;
4407   FAVLPalette:=nil;
4408   if FCapacity>0 then
4409     FreeMem(FAVLNodes);
4410   inherited Destroy;
4411 end;
4412 
IndexOfnull4413 function TLazAVLPalette.IndexOf(const AColor: TFPColor): integer;
4414 var
4415   Node: TAvlTreeNode;
4416 begin
4417   if FAVLPalette<>nil then
4418     Node:=FAVLPalette.FindKey(@AColor,TListSortCompare(@ComparePFPColorAndLazAVLPalEntry))
4419   else
4420     Node:=nil;
4421   if Node<>nil then
4422     Result:=PLazAVLPaletteEntry(Node.Data)^.Index
4423   else
4424     Result:=Add(AColor);
4425 end;
4426 
Addnull4427 function TLazAVLPalette.Add(const NewColor: TFPColor): integer;
4428 begin
4429   Result:=FCount;
4430   if FCount=FCapacity then EnlargeData;
4431   SetCount(FCount+1);
4432   SetColor(Result,NewColor);
4433 end;
4434 
CompareEntriesnull4435 function TLazAVLPalette.CompareEntries(Index1, Index2: integer): integer;
4436 begin
4437   Result:=CompareColors(FData^[Index1],FData^[Index2]);
4438 end;
4439 
CompareColorWithEntriesnull4440 function TLazAVLPalette.CompareColorWithEntries(const AColor: TFPColor;
4441   Index: integer): integer;
4442 begin
4443   Result:=CompareColors(AColor,FData^[Index]);
4444 end;
4445 
4446 procedure TLazAVLPalette.EnlargeData;
4447 var
4448   NewCapacity: Integer;
4449 begin
4450   if FCapacity<16 then
4451     NewCapacity:=32
4452   else if FCapacity<64 then
4453     NewCapacity:=128
4454   else
4455     NewCapacity:=FCapacity*2;
4456   ReallocMem(FData,SizeOf(TFPColor)*NewCapacity);
4457   ReallocMem(FAVLNodes,SizeOf(Pointer)*NewCapacity);
4458   FCapacity:=NewCapacity;
4459 end;
4460 
4461 procedure TLazAVLPalette.CheckConsistency;
4462 var
4463   Node: TAvlTreeNode;
4464   Entry: PLazAVLPaletteEntry;
4465   i: Integer;
4466 begin
4467   if FAVLPalette<>nil then begin
4468     FAVLPalette.ConsistencyCheck;
4469     if FAVLPalette.Count<>FCount then
4470       RaiseGDBException('TLazAVLPalette.ConsistencyCheck');
4471   end;
4472   if FAVLNodes<>nil then begin
4473     for i:=0 to FCapacity-1 do begin
4474       Node:=FAVLNodes[i];
4475       if i>=FCount then begin
4476         continue;
4477       end;
4478       if Node=nil then
4479         RaiseGDBException('TLazAVLPalette.ConsistencyCheck');
4480       Entry:=PLazAVLPaletteEntry(Node.Data);
4481       if Entry=nil then
4482         RaiseGDBException('TLazAVLPalette.ConsistencyCheck');
4483       if Entry^.Index<>i then
4484         RaiseGDBException('TLazAVLPalette.ConsistencyCheck');
4485       if Entry^.Palette<>Self then
4486         RaiseGDBException('TLazAVLPalette.ConsistencyCheck');
4487     end;
4488   end;
4489 end;
4490 
4491 { TLazWriterXPM }
4492 
4493 const
4494   DefXPMPalChars = '.,-*abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'
4495                   +'0123456789@#;:=+%$()[]';
4496 
4497 procedure TLazWriterXPM.SetNibblesPerSample(const AValue: word);
4498 begin
4499   if FNibblesPerSample=AValue then exit;
4500   FNibblesPerSample:=AValue;
4501   if FNibblesPerSample>4 then FNibblesPerSample:=4;
4502   FRightShiftSample:=(4-FNibblesPerSample)*4;
4503 end;
4504 
4505 procedure TLazWriterXPM.InternalWrite(Str: TStream; Img: TFPCustomImage);
4506 var
4507   Palette: TLazAVLPalette;
4508   PixelStrings: ^AnsiString;
4509   ColorStrings: ^AnsiString;
4510   CharsPerPixel: Integer;
4511   LineEnd: string;
4512 
4513   function GetColor(x,y: integer): TFPColor;
4514   begin
4515     Result:=Img.Colors[x,y];
4516     if (Result.Alpha>=(alphaOpaque shr 1)) then
4517       Result.Alpha:=alphaOpaque
4518     else
4519       Result:=colTransparent;
4520     Result.Red:=Result.Red shr FRightShiftSample;
4521     Result.Green:=Result.Green shr FRightShiftSample;
4522     Result.Blue:=Result.Blue shr FRightShiftSample;
4523   end;
4524 
4525   function SampleToHex(Sample: word): string;
4526   begin
4527     Result:=HexStr(Sample,FNibblesPerSample);
4528   end;
4529 
4530   procedure BuildPalette;
4531   var
4532     x: Integer;
4533     y: Integer;
4534     PixelStringsSize: Integer;
4535     i: Integer;
4536     Rest: Integer;
4537     c: char;
4538     CharPos: Integer;
4539     ColorStringsSize: Integer;
4540     Color: TFPColor;
4541   begin
4542     // create Palette
4543     Palette:=TLazAVLPalette.Create(0);
4544     for y:=0 to Img.Height-1 do
4545       for x:=0 to Img.Width-1 do
4546         Palette.IndexOf(GetColor(x,y));
4547     // calclulate CharsPerPixel
4548     CharsPerPixel:=0;
4549     i:=Palette.Count;
4550     while i>0 do begin
4551       i:=i div length(DefXPMPalChars);
4552       inc(CharsPerPixel);
4553     end;
4554     // create pixel strings
4555     PixelStringsSize:=SizeOf(Pointer)*Palette.Count;
4556     ReAllocMem(PixelStrings,PixelStringsSize);
4557     FillChar(PixelStrings^,PixelStringsSize,0);
4558     for i:=0 to Palette.Count-1 do begin
4559       SetLength(PixelStrings[i],CharsPerPixel);
4560       Rest:=i;
4561       for CharPos:=CharsPerPixel downto 1 do begin
4562         c:=DefXPMPalChars[(Rest mod length(DefXPMPalChars))+1];
4563         PixelStrings[i][CharPos]:=c;
4564         Rest:=Rest div length(DefXPMPalChars);
4565       end;
4566     end;
4567     // create color strings
4568     ColorStringsSize:=SizeOf(Pointer)*Palette.Count;
4569     ReAllocMem(ColorStrings,ColorStringsSize);
4570     FillChar(ColorStrings^,ColorStringsSize,0);
4571     for i:=0 to Palette.Count-1 do begin
4572       Color:=Palette[i];
4573       if Color.Alpha=0 then begin
4574         ColorStrings[i]:='None';
4575       end else begin
4576         ColorStrings[i]:='#'+SampleToHex(Color.Red)+SampleToHex(Color.Green)
4577                             +SampleToHex(Color.Blue);
4578       end;
4579     end;
4580   end;
4581 
4582   procedure WriteString(const s: string);
4583   begin
4584     Str.Write(s[1],length(s));
4585   end;
4586 
4587   procedure WriteHeader;
4588   var
4589     s: String;
4590   begin
4591     s:='/* XPM */'+LineEnd;
4592     s:=s+'static char *graphic[] = {'+LineEnd;
4593     s:=s+'"'+IntToStr(Img.Width)+' '+IntToStr(Img.Height)
4594         +' '+IntToStr(Palette.Count)+' '+IntToStr(CharsPerPixel)+'"';
4595     if Palette.Count>0 then s:=s+',';
4596     s:=s+LineEnd;
4597     WriteString(s);
4598   end;
4599 
4600   procedure WritePalette;
4601   var
4602     s: string;
4603     SrcPos: Integer;
4604 
4605     procedure WriteToSrc(const AddString: string);
4606     var
4607       i: Integer;
4608     begin
4609       for i:=1 to length(AddString) do begin
4610         s[SrcPos]:=AddString[i];
4611         inc(SrcPos);
4612       end;
4613     end;
4614 
4615   var
4616     PaletteLineLen: Integer;
4617     i: Integer;
4618     SrcLen: Integer;
4619   begin
4620     // calculate needed memory
4621     PaletteLineLen:=length('"')+CharsPerPixel+length(' c ')+length('",'+LineEnd);
4622     SrcLen:=0;
4623     for i:=0 to Palette.Count-1 do begin
4624       inc(SrcLen,PaletteLineLen);
4625       inc(SrcLen,length(ColorStrings[i]));
4626     end;
4627     // build palette source
4628     SetLength(s,SrcLen);
4629     SrcPos:=1;
4630     for i:=0 to Palette.Count-1 do begin
4631       WriteToSrc('"');
4632       WriteToSrc(PixelStrings[i]);
4633       WriteToSrc(' c ');
4634       WriteToSrc(ColorStrings[i]);
4635       WriteToSrc('",');
4636       WriteToSrc(LineEnd);
4637     end;
4638     if SrcPos<>length(s)+1 then
4639       RaiseGDBException('TLazWriterXPM.InternalWrite consistency ERROR SrcPos<>length(s)');
4640     WriteString(s);
4641   end;
4642 
4643   procedure WritePixels;
4644   var
4645     s: string;
4646     SrcPos: Integer;
4647 
4648     procedure WriteToSrc(const AddString: string);
4649     var
4650       i: Integer;
4651     begin
4652       for i:=1 to length(AddString) do begin
4653         s[SrcPos]:=AddString[i];
4654         inc(SrcPos);
4655       end;
4656     end;
4657 
4658   var
4659     y: Integer;
4660     x: Integer;
4661     i: Integer;
4662     SrcLenPerLine: Integer;
4663     SrcLen: Integer;
4664   begin
4665     // calculate needed memory
4666     SrcLenPerLine:=length('"')+CharsPerPixel*Img.Width+length('",')+length(LineEnd);
4667     SrcLen:=Img.Height*SrcLenPerLine;
4668     // build palette source
4669     SetLength(s,SrcLen);
4670     SrcPos:=1;
4671     for y:=0 to Img.Height-1 do
4672     begin
4673       WriteToSrc('"');
4674       for x:=0 to Img.Width-1 do
4675       begin
4676         i := Palette.IndexOf(GetColor(x,y));
4677         WriteToSrc(PixelStrings[i]);
4678       end;
4679       Progress(psRunning, trunc(100.0 * ((y + 1) / Img.Height)),
4680            False, Rect(0,0,Img.Width-1,y), 'writing XPM pixels', FContinue);
4681       if y<Img.Height-1 then
4682         WriteToSrc('",'+LineEnd)
4683       else
4684         WriteToSrc('"}'+LineEnd);
4685     end;
4686     if SrcPos<>length(s)+1 then
4687       RaiseGDBException('TLazWriterXPM.InternalWrite consistency ERROR SrcPos<>length(s)');
4688     WriteString(s);
4689   end;
4690 
4691 var
4692   i: Integer;
4693 begin
4694   FContinue := True;
4695   Progress(psStarting, 0, False, Rect(0,0,0,0), '', FContinue);
4696 
4697   Palette:=nil;
4698   PixelStrings:=nil;
4699   ColorStrings:=nil;
4700   LineEnd:=#10;
4701   try
4702     BuildPalette;
4703     WriteHeader;
4704     WritePalette;
4705     WritePixels;
4706   finally
4707     if PixelStrings<>nil then begin
4708       for i:=0 to Palette.Count-1 do begin
4709         PixelStrings[i]:='';
4710         ColorStrings[i]:='';
4711       end;
4712       ReAllocMem(PixelStrings,0);
4713       ReAllocMem(ColorStrings,0);
4714     end;
4715     Palette.Free;
4716   end;
4717   Progress(psEnding, 100, false, Rect(0,0,0,0), '', FContinue);
4718 end;
4719 
4720 constructor TLazWriterXPM.Create;
4721 begin
4722   inherited Create;
4723   FNibblesPerSample:=2;
4724   FRightShiftSample:=8;
4725 end;
4726 
4727 { TArrayNode }
4728 
4729 constructor TArrayNode.Create;
4730 begin
4731   //DebugLn('TArrayNode.Create ',Capacity,' Self=',DbgS(Self));
4732 end;
4733 
4734 destructor TArrayNode.Destroy;
4735 begin
4736   DeleteChilds;
4737   UnbindFromParent;
4738   inherited Destroy;
4739 end;
4740 
4741 procedure TArrayNode.DeleteChilds;
4742 var
4743   i: Integer;
4744 begin
4745   if Children<>nil then begin
4746     for i:=0 to Capacity-1 do
4747       Children[i].Free;
4748     FreeMem(Children);
4749     Children:=nil;
4750     Capacity:=0;
4751   end;
4752 end;
4753 
4754 procedure TArrayNode.UnbindFromParent;
4755 begin
4756   if Parent<>nil then begin
4757     Parent.Children[Value-Parent.StartValue]:=nil;
4758     Parent:=nil;
4759   end;
4760 end;
4761 
4762 procedure TArrayNode.CreateChildNode(ChildValue: integer);
4763 var
4764   NewNode: TArrayNode;
4765   Index: Integer;
4766 begin
4767   NewNode:=TArrayNode.Create;
4768   NewNode.Value:=ChildValue;
4769   NewNode.Parent:=Self;
4770   Index:=ChildValue-StartValue;
4771   Children[Index]:=NewNode;
4772 end;
4773 
GetChildNodenull4774 function TArrayNode.GetChildNode(ChildValue: integer; CreateIfNotExists: boolean
4775   ): TArrayNode;
4776 var
4777   Index: Integer;
4778 begin
4779   Result:=nil;
4780   Index:=ChildValue-StartValue;
4781   if (Index<0) or (Index>=Capacity) then begin
4782     // out of range
4783     if not CreateIfNotExists then exit;
4784     Expand(ChildValue);
4785     Index:=ChildValue-StartValue;
4786   end;
4787   Result:=Children[Index];
4788   if (Result=nil) and CreateIfNotExists then begin
4789     CreateChildNode(ChildValue);
4790     Result:=Children[Index];
4791   end;
4792 end;
4793 
4794 procedure TArrayNode.Expand(ValueToInclude: integer);
4795 var
4796   Index: Integer;
4797   NewChilds: PArrayNode;
4798   NewSize: Integer;
4799   i: Integer;
4800   NewStartValue: Integer;
4801   NewCapacity: Integer;
4802   OldSize: Integer;
4803 begin
4804   //DebugLn('TArrayNode.Expand A ',ValueToInclude,' Capacity=',Capacity,' StartValue=',StartValue);
4805   if Children=nil then begin
4806     NewStartValue:=ValueToInclude;
4807     NewCapacity:=4;
4808   end else begin
4809     Index:=ValueToInclude-StartValue;
4810     if (Index>=0) and (Index<Capacity) then exit;
4811     NewStartValue:=StartValue;
4812     NewCapacity:=Capacity;
4813     if NewStartValue>ValueToInclude then begin
4814       inc(NewCapacity,NewStartValue-ValueToInclude);
4815       NewStartValue:=ValueToInclude;
4816     end else begin
4817       Index:=ValueToInclude-NewStartValue;
4818       if Index>=NewCapacity then
4819         NewCapacity:=Index+1;
4820     end;
4821     // make NewCapacity a power of 2
4822     for i:=1 to 30 do begin
4823       if (1 shl i)>=NewCapacity then begin
4824         NewCapacity:=1 shl i;
4825         break;
4826       end;
4827     end;
4828   end;
4829   NewSize:=SizeOf(Pointer)*NewCapacity;
4830   GetMem(NewChilds,NewSize);
4831   FillChar(NewChilds^,NewSize,0);
4832   if Children<>nil then begin
4833     OldSize:=SizeOf(Pointer)*Capacity;
4834     System.Move(Children^,NewChilds[StartValue-NewStartValue],OldSize);
4835     FreeMem(Children);
4836   end;
4837   Children:=NewChilds;
4838   StartValue:=NewStartValue;
4839   Capacity:=NewCapacity;
4840 end;
4841 
FindPrevSiblingnull4842 function TArrayNode.FindPrevSibling: TArrayNode;
4843 var
4844   i: Integer;
4845 begin
4846   Result:=nil;
4847   if Parent=nil then exit;
4848   i:=Value-Parent.StartValue-1;
4849   while (i>=0) do begin
4850     if Parent.Children[i]<>nil then begin
4851       Result:=Parent.Children[i];
4852       exit;
4853     end;
4854     dec(i);
4855   end;
4856 end;
4857 
FindNextSiblingnull4858 function TArrayNode.FindNextSibling: TArrayNode;
4859 var
4860   i: Integer;
4861 begin
4862   Result:=nil;
4863   if Parent=nil then exit;
4864   i:=Value-Parent.StartValue+1;
4865   while (i<Parent.Capacity) do begin
4866     if Parent.Children[i]<>nil then begin
4867       Result:=Parent.Children[i];
4868       exit;
4869     end;
4870     inc(i);
4871   end;
4872 end;
4873 
FindNextUTF8null4874 function TArrayNode.FindNextUTF8: TArrayNode;
4875 var
4876   SiblingNode: TArrayNode;
4877 begin
4878   Result:=FindFirstChild;
4879   if Result<>nil then exit;
4880   SiblingNode:=Self;
4881   while SiblingNode<>nil do begin
4882     Result:=SiblingNode.FindNextSibling;
4883     if Result<>nil then exit;
4884     SiblingNode:=SiblingNode.Parent;
4885   end;
4886 end;
4887 
FindPrevnull4888 function TArrayNode.FindPrev: TArrayNode;
4889 begin
4890   Result:=FindPrevSibling;
4891   if Result=nil then begin
4892     Result:=Parent;
4893     exit;
4894   end;
4895   Result:=Result.FindLastSubChild;
4896 end;
4897 
FindFirstChildnull4898 function TArrayNode.FindFirstChild: TArrayNode;
4899 var
4900   i: Integer;
4901 begin
4902   Result:=nil;
4903   if Capacity=0 then exit;
4904   i:=0;
4905   while i<Capacity do begin
4906     if Children[i]<>nil then begin
4907       Result:=Children[i];
4908       exit;
4909     end;
4910     inc(i);
4911   end;
4912 end;
4913 
FindLastChildnull4914 function TArrayNode.FindLastChild: TArrayNode;
4915 var
4916   i: Integer;
4917 begin
4918   Result:=nil;
4919   if Capacity=0 then exit;
4920   i:=Capacity-1;
4921   while i>=0 do begin
4922     if Children[i]<>nil then begin
4923       Result:=Children[i];
4924       exit;
4925     end;
4926     dec(i);
4927   end;
4928 end;
4929 
FindLastSubChildnull4930 function TArrayNode.FindLastSubChild: TArrayNode;
4931 var
4932   ANode: TArrayNode;
4933 begin
4934   ANode:=Self;
4935   while ANode<>nil do begin
4936     Result:=ANode;
4937     ANode:=ANode.FindLastChild;
4938   end;
4939 end;
4940 
FindFirstSiblingnull4941 function TArrayNode.FindFirstSibling: TArrayNode;
4942 begin
4943   if Parent=nil then
4944     Result:=nil
4945   else
4946     Result:=Parent.FindFirstChild;
4947 end;
4948 
FindLastSiblingnull4949 function TArrayNode.FindLastSibling: TArrayNode;
4950 begin
4951   if Parent=nil then
4952     Result:=nil
4953   else
4954     Result:=Parent.FindLastChild;
4955 end;
4956 
4957 procedure TArrayNode.ConsistencyCheck;
4958 
4959   procedure R(const Msg: string);
4960   begin
4961     RaiseGDBException(Msg);
4962   end;
4963 
4964 var
4965   i: Integer;
4966   ChildNode: TArrayNode;
4967 begin
4968   if Children<>nil then begin
4969     if Capacity<=0 then R('Capacity too small');
4970     for i:=0 to Capacity-1 do begin
4971       ChildNode:=Children[i];
4972       if ChildNode<>nil then begin
4973         if ChildNode.Value<>i+StartValue then
4974           R('Value wrong');
4975         if ChildNode.Parent<>Self then
4976           R('Parent wrong');
4977         ChildNode.ConsistencyCheck;
4978       end;
4979     end;
4980   end else begin
4981     if Capacity<>0 then R('Capacity wrong');
4982   end;
4983 end;
4984 
4985 { TArrayNodesTree }
4986 
FindNodenull4987 function TArrayNodesTree.FindNode(Path: PInteger; Count: integer
4988   ): TArrayNode;
4989 var
4990   i: Integer;
4991 begin
4992   Result:=Root;
4993   i:=0;
4994   while (Result<>nil) and (i<Count) do begin
4995     Result:=Result.GetChildNode(Path[i],false);
4996     inc(i);
4997   end;
4998 end;
4999 
FindDatanull5000 function TArrayNodesTree.FindData(Path: PInteger; Count: integer): Pointer;
5001 var
5002   ANode: TArrayNode;
5003 begin
5004   ANode:=FindNode(Path,Count);
5005   if ANode<>nil then
5006     Result:=ANode.Data
5007   else
5008     Result:=nil;
5009 end;
5010 
SetNodenull5011 function TArrayNodesTree.SetNode(Path: PInteger; Count: integer;
5012   Data: Pointer): TArrayNode;
5013 var
5014   i: Integer;
5015 begin
5016   if Root=nil then
5017     Root:=TArrayNode.Create;
5018   Result:=Root;
5019   for i:=0 to Count-1 do begin
5020     //DebugLn('TArrayNodesTree.SetNode A ',DbgS(Result));
5021     Result:=Result.GetChildNode(Path[i],true);
5022   end;
5023   Result.Data:=Data;
5024 end;
5025 
5026 procedure TArrayNodesTree.Delete(Node: TArrayNode);
5027 begin
5028   if Node=nil then exit;
5029   if Node=Root then Root:=nil;
5030   Node.Free;
5031 end;
5032 
5033 procedure TArrayNodesTree.Clear;
5034 begin
5035   Delete(Root);
5036 end;
5037 
5038 constructor TArrayNodesTree.Create;
5039 begin
5040 
5041 end;
5042 
5043 destructor TArrayNodesTree.Destroy;
5044 begin
5045   Clear;
5046   inherited Destroy;
5047 end;
5048 
5049 procedure TArrayNodesTree.ConsistencyCheck;
5050 begin
5051   if Root<>nil then
5052     Root.ConsistencyCheck;
5053 end;
5054 
5055 { TLazReaderBMP }
5056 
InternalChecknull5057 function TLazReaderBMP.InternalCheck(Stream: TStream): boolean;
5058 var
5059   BFH: TBitMapFileHeader;
5060   offbits: DWORD;
5061 begin
5062   Stream.Read(BFH, SizeOf(BFH));
5063   Result := BFH.bfType = LEtoN(BMmagic); // Just check magic number
5064 
5065   { Store the data offset. BFH is poorly aligned (dictated by the .bmp file
5066     format), which can cause problems for architectures such as SPARC and some
5067     ARM implementations which have strict alignment requirements. That is why
5068     the code below uses an intermediate variable, rather than a direct call to
5069     LEtoN(BFH.bfOffBits) which will try to pass a misaligned parameter.        }
5070   if Result and (BFH.bfOffBits <> 0)
5071   then begin
5072     offbits := BFH.bfOffBits;
5073     FDataOffset := Stream.Position + LEtoN(offbits) - SizeOf(BFH)
5074   end
5075 end;
5076 
5077 procedure TLazReaderBMP.InternalReadHead;
5078 begin
5079   inherited InternalReadHead;
5080   if FDataOffset <> 0
5081   then TheStream.Position := FDataOffset;
5082 end;
5083 
5084 { TLazWriterBMP }
5085 
5086 procedure TLazWriterBMP.Finalize;
5087 begin
5088 end;
5089 
5090 procedure TLazWriterBMP.Initialize(AImage: TLazIntfImage);
5091 begin
5092   // set BPP
5093   // we can also look at PixelFormat, but it can be inexact
5094   BitsPerPixel := AImage.DataDescription.Depth;
5095 end;
5096 
QueryInterfacenull5097 function TLazWriterBMP.QueryInterface(constref iid: TGuid; out obj): longint; {$IFDEF WINDOWs}stdcall{$ELSE}cdecl{$ENDIF};
5098 begin
5099   if GetInterface(iid, obj)
5100   then Result := S_OK
5101   else Result := E_NOINTERFACE;
5102 end;
5103 
_AddRefnull5104 function TLazWriterBMP._AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
5105 begin
5106   Result := -1;
5107 end;
5108 
_Releasenull5109 function TLazWriterBMP._Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
5110 begin
5111   Result := -1;
5112 end;
5113 
5114 { TLazReaderDIB }
5115 
5116 procedure TLazReaderDIB.InitLineBuf;
5117 begin
5118   FreeLineBuf;
5119 
5120   if Info.BitCount < 8
5121   then FReadSize := ((Info.BitCount * Info.Width + 31) shr 5) shl 2
5122   else FReadSize := (((Info.BitCount shr 3) * Info.Width + 3) shr 2) shl 2;
5123 
5124   // allocate 3 bytes more so we can always use a cardinal to read (in case of bitfields)
5125   GetMem(FLineBuf, FReadSize+3);
5126 end;
5127 
5128 procedure TLazReaderDIB.FreeLineBuf;
5129 begin
5130   FreeMem(FLineBuf);
5131   FLineBuf := nil;
5132 end;
5133 
GetUpdateDescriptionnull5134 function TLazReaderDIB.GetUpdateDescription: Boolean;
5135 begin
5136   Result := FUpdateDescription;
5137 end;
5138 
5139 procedure TLazReaderDIB.ReadScanLine(Row: Integer);
5140   procedure DoRLE4;
5141   var
5142     Head: array[0..1] of Byte;
5143     Value, NibbleCount, ByteCount: Byte;
5144     WriteNibble: Boolean;       // Set when only lower nibble needs to be written
5145     BufPtr, DstPtr: PByte;
5146     Buf: array[0..127] of Byte; // temp buffer to read nibbles
5147   begin
5148     DstPtr := @LineBuf[0];
5149     WriteNibble := False;
5150     while True do
5151     begin
5152       TheStream.Read(Head[0], 2);
5153       NibbleCount := Head[0];
5154 
5155       if NibbleCount > 0 then
5156       begin
5157         if WriteNibble
5158         then begin
5159           // low nibble needs to be written
5160           // swap pixels so that they are in order after this nibble
5161           Value := (Head[1] shl 4) or (Head[1] shr 4);
5162           DstPtr^ := (DstPtr^ and $F0) or (Value and $0F);
5163           Inc(DstPtr);
5164           // we have written one
5165           Dec(NibbleCount);
5166         end
5167         else begin
5168           Value := Head[1];
5169         end;
5170         ByteCount := (NibbleCount + 1) div 2;
5171         FillChar(DstPtr^, ByteCount , Value);
5172         // if we have written an odd number of nibbles we still have to write one
5173         WriteNibble := NibbleCount and 1 = 1;
5174         Inc(DstPtr, ByteCount);
5175         // correct DstPtr if we still need to write a nibble
5176         if WriteNibble then Dec(DstPtr);
5177       end
5178       else begin
5179         NibbleCount := Head[1];
5180         case NibbleCount of
5181           0, 1: break;       // End of scanline or end of bitmap
5182           2: raise FPImageException.Create('RLE code #2 is not supported');
5183         else
5184           ByteCount := (NibbleCount + 1) div 2;
5185 
5186           if WriteNibble
5187           then begin
5188             // we cannot read directly into destination, so use temp buf
5189             TheStream.Read(Buf[0], ByteCount);
5190             BufPtr := @Buf[0];
5191             repeat
5192               DstPtr^ := (DstPtr^ and $F0) or (BufPtr^ shr 4);
5193               Inc(DstPtr);
5194               Dec(NibbleCount);
5195               if NibbleCount = 0
5196               then begin
5197                 // if we have written both nibbles
5198                 WriteNibble := False;
5199                 Break;
5200               end;
5201               DstPtr^ := (BufPtr^ shl 4);
5202               Inc(BufPtr);
5203               Dec(NibbleCount);
5204             until NibbleCount = 0;
5205           end
5206           else begin
5207             TheStream.Read(DstPtr^, ByteCount);
5208             // if we have written an odd number of nibbles we still have to write one
5209             WriteNibble := NibbleCount and 1 = 1;
5210             Inc(DstPtr, ByteCount);
5211             // correct DstPtr if we still need to write a nibble
5212             if WriteNibble then Dec(DstPtr);
5213           end;
5214 
5215           // keep stream at word boundary
5216           if ByteCount and 1 = 1
5217           then TheStream.Seek(1, soCurrent);
5218         end;
5219       end;
5220 
5221     end
5222   end;
5223 
5224   procedure DoRLE8;
5225   var
5226     Head: array[0..1] of Byte;
5227     Value, Count: Byte;
5228     DstPtr: PByte;
5229   begin
5230     DstPtr := @LineBuf[0];
5231     while True do
5232     begin
5233       TheStream.Read(Head[0], 2);
5234       Count := Head[0];
5235       if Count > 0
5236       then begin
5237         Value := Head[1];
5238         FillChar(DstPtr^, Count, Value);
5239       end
5240       else begin
5241         Count := Head[1];
5242         case Count of
5243           0, 1: break;       // End of scanline or end of bitmap
5244           2: raise FPImageException.Create('RLE code #2 is not supported');
5245         else
5246           TheStream.Read(DstPtr^, Count);
5247           // keep stream at word boundary
5248           if Count and 1 = 1
5249           then TheStream.Seek(1, soCurrent);
5250         end;
5251       end;
5252 
5253       Inc(DstPtr, Count);
5254     end
5255   end;
5256 begin
5257   // Add here support for compressed lines. The 'readsize' is the same in the end.
5258 
5259   // MWE: Note: when doing so, keep in mind that the bufer is expected to be in Little Endian.
5260   // for better performance, the conversion is done when writeing the buffer.
5261 
5262   if Info.Encoding = lrdeRLE
5263   then begin
5264     case Info.BitCount of
5265       4: DoRLE4;
5266       8: DoRLE8;
5267      //24: DoRLE24;
5268     end;
5269   end
5270   else begin
5271     TheStream.Read(LineBuf[0], ReadSize);
5272   end;
5273 end;
5274 
BitfieldsToFPColornull5275 function TLazReaderDIB.BitfieldsToFPColor(const AColor: Cardinal): TFPcolor;
5276 var
5277   V: Word;
5278 begin
5279   //--- red ---
5280   V := ((AColor and Info.PixelMasks.R) shl (32 - Info.MaskShift.R - Info.MaskSize.R)) shr 16;
5281   Result.Red := V;
5282   repeat
5283     V := V shr Info.MaskSize.R;
5284     Result.Red := Result.Red or V;
5285   until V = 0;
5286 
5287   //--- green ---
5288   V := ((AColor and Info.PixelMasks.G) shl (32 - Info.MaskShift.G - Info.MaskSize.G)) shr 16;
5289   Result.Green := V;
5290   repeat
5291     V := V shr Info.MaskSize.G;
5292     Result.Green := Result.Green or V;
5293   until V = 0;
5294 
5295   //--- blue ---
5296   V := ((AColor and Info.PixelMasks.B) shl (32 - Info.MaskShift.B - Info.MaskSize.B)) shr 16;
5297   Result.Blue := V;
5298   repeat
5299     V := V shr Info.MaskSize.B;
5300     Result.Blue := Result.Blue or V;
5301   until V = 0;
5302 
5303   //--- alpha ---
5304   if Info.MaskSize.A = 0
5305   then begin
5306     Result.Alpha := AlphaOpaque;
5307   end
5308   else begin
5309     V := ((AColor and Info.PixelMasks.A) shl (32 - Info.MaskShift.A - Info.MaskSize.A)) shr 16;
5310     Result.Alpha := V;
5311     repeat
5312       V := V shr Info.MaskSize.A;
5313       Result.Alpha := Result.Alpha or V;
5314     until V = 0;
5315   end;
5316 end;
5317 
RGBToFPColornull5318 function TLazReaderDIB.RGBToFPColor(const AColor: TColorRGB): TFPcolor;
5319 var
5320   RBytes: TFPColorBytes absolute Result;
5321 begin
5322   RBytes.Bh := AColor.B;
5323   RBytes.Bl := AColor.B;
5324   RBytes.Gh := AColor.G;
5325   RBytes.Gl := AColor.G;
5326   RBytes.Rh := AColor.R;
5327   RBytes.Rl := AColor.R;
5328   Result.Alpha := AlphaOpaque;
5329 end;
5330 
RGBToFPColornull5331 function TLazReaderDIB.RGBToFPColor(const AColor: TColorRGBA): TFPcolor;
5332 var
5333   RBytes: TFPColorBytes absolute Result;
5334 begin
5335   RBytes.Bh := AColor.B;
5336   RBytes.Bl := AColor.B;
5337   RBytes.Gh := AColor.G;
5338   RBytes.Gl := AColor.G;
5339   RBytes.Rh := AColor.R;
5340   RBytes.Rl := AColor.R;
5341   if Info.MaskSize.A = 0
5342   then Result.Alpha := AlphaOpaque
5343   else begin
5344     RBytes.Ah := AColor.A;
5345     RBytes.Al := AColor.A;
5346   end;
5347 end;
5348 
RGBToFPColornull5349 function TLazReaderDIB.RGBToFPColor(const AColor: Word): TFPcolor;
5350 var
5351   V1, V2: Cardinal;
5352 begin
5353   // 5 bit for red  -> 16 bit for TFPColor
5354   V1 := (AColor shl 1) and $F800;     // 15..11
5355   V2 := V1;
5356   V1 := V1 shr 5;                  // 10..6
5357   V2 := V2 or V1;
5358   V1 := V1 shr 5;                  // 5..1
5359   V2 := V2 or V1;
5360   V1 := V1 shr 5;                  // 0
5361   Result.Red := Word(V2 or V1);
5362   // 5 bit for red  -> 16 bit for TFPColor
5363   V1 := (AColor shl 6) and $F800;     // 15..11
5364   V2 := V1;
5365   V1 := V1 shr 5;                  // 10..6
5366   V2 := V2 or V1;
5367   V1 := V1 shr 5;                  // 5..1
5368   V2 := V2 or V1;
5369   V1 := V1 shr 5;                  // 0
5370   Result.Green := Word(V2 or V1);
5371   // 5 bit for blue -> 16 bit for TFPColor
5372   V1 := (AColor shl 11) and $F800;    // 15..11
5373   V2 := V1;
5374   V1 := V1 shr 5;
5375   V2 := V2 or V1;                  // 10..6
5376   V1 := V1 shr 5;
5377   V2 := V2 or V1;                  // 5..1
5378   V1 := V1 shr 5;
5379   Result.Blue := Word(V2 or V1);   // 0
5380   // opaque, no mask
5381   Result.Alpha:=alphaOpaque;
5382 end;
5383 
5384 procedure TLazReaderDIB.SetUpdateDescription(AValue: Boolean);
5385 begin
5386   FUpdateDescription := AValue;
5387 end;
5388 
5389 procedure TLazReaderDIB.WriteScanLine(Row: Cardinal);
5390 // using cardinals generates compacter code
5391 var
5392   Column: Cardinal;
5393   Color: TFPColor;
5394   Index: Byte;
5395 begin
5396   if FMaskMode = lrmmNone
5397   then begin
5398     case Info.BitCount of
5399      1 :
5400        for Column := 0 to TheImage.Width - 1 do
5401          TheImage.colors[Column,Row] := FPalette[Ord(LineBuf[Column div 8] and ($80 shr (Column and 7)) <> 0)];
5402      4 :
5403        for Column := 0 to TheImage.Width - 1 do
5404          TheImage.colors[Column,Row] := FPalette[(LineBuf[Column div 2] shr (((not Column) and 1)*4)) and $0f];
5405      8 :
5406        for Column := 0 to TheImage.Width - 1 do
5407          TheImage.colors[Column,Row] := FPalette[LineBuf[Column]];
5408     else
5409       if Info.Encoding = lrdeBitfield
5410       then begin
5411         // always cast to cardinal without conversion
5412         // this way the value will have the same order as the bitfields
5413         case Info.BitCount of
5414           16:
5415             for Column := 0 to TheImage.Width - 1 do
5416               TheImage.colors[Column,Row] := BitfieldsToFPColor(PCardinal(@PWord(LineBuf)[Column])^);
5417           24:
5418             for Column := 0 to TheImage.Width - 1 do
5419               TheImage.colors[Column,Row] := BitfieldsToFPColor(PCardinal(@PColorRGB(LineBuf)[Column])^);
5420           32:
5421             for Column := 0 to TheImage.Width - 1 do
5422             begin
5423               Color := BitfieldsToFPColor(PCardinal(@PColorRGBA(LineBuf)[Column])^);
5424               TheImage.colors[Column,Row] := Color;
5425               FIgnoreAlpha := FIgnoreAlpha and (Color.alpha = alphaTransparent);
5426             end;
5427         end;
5428       end
5429       else begin
5430         case Info.BitCount of
5431           16:
5432             for Column := 0 to TheImage.Width - 1 do
5433               TheImage.colors[Column,Row] := RGBToFPColor({$ifdef FPC_BIG_ENDIAN}LeToN{$endif}(PWord(LineBuf)[Column]));
5434           24:
5435             for Column := 0 to TheImage.Width - 1 do
5436               TheImage.colors[Column,Row] := RGBToFPColor(PColorRGB(LineBuf)[Column]);
5437           32:
5438             for Column := 0 to TheImage.Width - 1 do
5439             begin
5440               Color := RGBToFPColor(PColorRGBA(LineBuf)[Column]);
5441               TheImage.colors[Column,Row] := Color;
5442               FIgnoreAlpha := FIgnoreAlpha and (Color.alpha = alphaTransparent);
5443             end;
5444         end;
5445       end;
5446     end;
5447   end
5448   else begin
5449     case Info.BitCount of
5450      1 :
5451        for Column := 0 to TheImage.Width - 1 do
5452        begin
5453          Index := Ord(LineBuf[Column div 8] and ($80 shr (Column and 7)) <> 0);
5454          FImage.colors[Column,Row] := FPalette[Index];
5455          FImage.Masked[Column,Row] := Index = FMaskIndex;
5456        end;
5457      4 :
5458        for Column := 0 to TheImage.Width - 1 do
5459        begin
5460          Index := (LineBuf[Column div 2] shr (((not Column) and 1)*4)) and $0f;
5461          FImage.colors[Column,Row] := FPalette[Index];
5462          FImage.Masked[Column,Row] := Index = FMaskIndex;
5463        end;
5464      8 :
5465        for Column := 0 to TheImage.Width - 1 do
5466        begin
5467          Index := LineBuf[Column];
5468          FImage.colors[Column,Row] := FPalette[Index];
5469          FImage.Masked[Column,Row] := Index = FMaskIndex;
5470        end;
5471     else
5472       if Info.Encoding = lrdeBitfield
5473       then begin
5474         // always cast to cardinal without conversion
5475         // this way the value will have the same order as the bitfields
5476         case Info.BitCount of
5477          16:
5478            for Column := 0 to TheImage.Width - 1 do
5479            begin
5480              Color := BitfieldsToFPColor(PCardinal(@PWord(LineBuf)[Column])^);
5481              FImage.colors[Column,Row] := Color;
5482              FImage.Masked[Column,Row] := Color = FMaskColor;
5483            end;
5484          24:
5485            for Column := 0 to TheImage.Width - 1 do
5486            begin
5487              Color := BitfieldsToFPColor(PCardinal(@PColorRGB(LineBuf)[Column])^);
5488              FImage.colors[Column,Row] := Color;
5489              FImage.Masked[Column,Row] := Color = FMaskColor;
5490            end;
5491          32:
5492            for Column := 0 to TheImage.Width - 1 do
5493            begin
5494              Color := BitfieldsToFPColor(PCardinal(@PColorRGBA(LineBuf)[Column])^);
5495              FImage.colors[Column,Row] := Color;
5496              FImage.Masked[Column,Row] := Color = FMaskColor;
5497              FIgnoreAlpha := FIgnoreAlpha and (Color.alpha = alphaTransparent);
5498            end;
5499         end;
5500       end
5501       else begin
5502         case Info.BitCount of
5503          16:
5504            for Column := 0 to TheImage.Width - 1 do
5505            begin
5506              Color := RGBToFPColor({$ifdef FPC_BIG_ENDIAN}LeToN{$endif}(PWord(LineBuf)[Column]));
5507              FImage.colors[Column,Row] := Color;
5508              FImage.Masked[Column,Row] := Color = FMaskColor;
5509            end;
5510          24:
5511            for Column := 0 to TheImage.Width - 1 do
5512            begin
5513              Color := RGBToFPColor(PColorRGB(LineBuf)[Column]);
5514              FImage.colors[Column,Row] := Color;
5515              FImage.Masked[Column,Row] := Color = FMaskColor;
5516            end;
5517          32:
5518            for Column := 0 to TheImage.Width - 1 do
5519            begin
5520              Color := RGBToFPColor(PColorRGBA(LineBuf)[Column]);
5521              FImage.colors[Column,Row] := Color;
5522              FImage.Masked[Column,Row] := Color = FMaskColor;
5523              FIgnoreAlpha := FIgnoreAlpha and (Color.alpha = alphaTransparent);
5524            end;
5525         end;
5526       end;
5527     end;
5528   end;
5529 end;
5530 
_AddRefnull5531 function TLazReaderDIB._AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
5532 begin
5533   Result := -1;
5534 end;
5535 
_Releasenull5536 function TLazReaderDIB._Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
5537 begin
5538   Result := -1;
5539 end;
5540 
5541 procedure TLazReaderDIB.InternalRead(Stream: TStream; Img: TFPCustomImage);
5542 var
5543   Desc: TRawImageDescription;
5544   Depth: Byte;
5545 begin
5546   FContinue := True;
5547   Progress(psStarting, 0, False, Rect(0,0,0,0), '', FContinue);
5548   FImage := TheImage as TLazIntfImage;
5549   FIgnoreAlpha := True;
5550   Depth := 0;
5551   InternalReadHead;
5552 
5553   if FUpdateDescription
5554   then begin
5555     if (Info.BitCount = 32) and (Info.MaskSize.A = 0)
5556     then Depth := 24
5557     else Depth := Info.BitCount;
5558     DefaultReaderDescription(Info.Width, Info.Height, Depth, Desc);
5559     FImage.DataDescription := Desc;
5560   end;
5561 
5562   InternalReadBody;
5563 
5564   // if there is no alpha in real (all alpha values = 0) then update the description
5565   if FUpdateDescription and FIgnoreAlpha and (Depth = 32) then
5566   begin
5567     Desc.AlphaPrec:=0;
5568     FImage.SetDataDescriptionKeepData(Desc);
5569   end;
5570 
5571   Progress(psEnding, 100, false, Rect(0,0,0,0), '', FContinue);
5572 end;
5573 
5574 procedure TLazReaderDIB.InternalReadHead;
5575 const
5576   SUnknownCompression = 'Bitmap with unknown compression (%d)';
5577   SUnsupportedCompression = 'Bitmap with unsupported compression (%s)';
5578   SWrongCombination = 'Bitmap with wrong combination of bit count (%d) and compression (%s)';
5579   SUnsupportedPixelMask = 'Bitmap with non-standard pixel masks not supported';
5580 
5581   SEncoding: array[TLazReaderDIBEncoding] of string = (
5582     'RGB',
5583     'RLE',
5584     'Bitfield',
5585     'Jpeg',
5586     'Png',
5587     'Huffman'
5588   );
5589 
5590   function ValidCompression: Boolean;
5591   begin
5592     case Info.BitCount of
5593       1:   Result := FDibInfo.Encoding in [lrdeRGB, lrdeHuffman];
5594       4,8: Result := FDibInfo.Encoding in [lrdeRGB, lrdeRLE];
5595       16:  Result := FDibInfo.Encoding in [lrdeRGB, lrdeBitfield];
5596       24:  Result := FDibInfo.Encoding in [lrdeRGB, lrdeBitfield, lrdeRLE];
5597       32:  Result := FDibInfo.Encoding in [lrdeRGB, lrdeBitfield];
5598     else
5599       raise FPImageException.CreateFmt('Wrong bitmap bit count: %d', [Info.BitCount]);
5600     end;
5601   end;
5602 
5603   procedure GetMaskShiftSize(AMask: LongWord; var AShift, ASize: Byte);
5604   begin
5605     AShift := 0;
5606     repeat
5607       if (AMask and 1) <> 0 then Break;
5608       AMask := AMask shr 1;
5609       Inc(AShift);
5610     until AShift >= 32;
5611 
5612     ASize := 0;
5613     repeat
5614       if (AMask and 1) = 0 then Break;
5615       AMask := AMask shr 1;
5616       Inc(ASize);
5617     until AShift + ASize >= 32;
5618   end;
5619 
5620   procedure ReadPalette(APaletteIsOS2: Boolean);
5621   var
5622     ColorSize: Byte;
5623     C: TColorRGBA;
5624     n, len, maxlen: Integer;
5625   begin
5626     SetLength(FPalette, 0);
5627     if Info.PaletteCount = 0 then Exit;
5628 
5629     if APaletteIsOS2
5630     then ColorSize := 3
5631     else ColorSize := 4;
5632 
5633     if FDibInfo.BitCount > 8
5634     then begin
5635       // Bitmaps can have a color table stored in the palette entries,
5636       // skip them, since we don't use it
5637       TheStream.Seek(Info.PaletteCount * ColorSize, soCurrent);
5638       Exit;
5639     end;
5640 
5641     maxlen := 1 shl Info.BitCount;
5642     if Info.PaletteCount <= maxlen
5643     then len := maxlen
5644     else len := Info.PaletteCount; // more colors ???
5645 
5646     SetLength(FPalette, len);
5647 
5648     for n := 0 to Info.PaletteCount - 1 do
5649     begin
5650       TheStream.Read(C, ColorSize);
5651       C.A := $FF; //palette has no alpha
5652       FPalette[n] := RGBToFPColor(C);
5653     end;
5654 
5655     // fill remaining with black color, so we don't have to check for out of index values
5656     for n := Info.PaletteCount to maxlen - 1 do
5657       FPalette[n] := colBlack;
5658   end;
5659 
5660 var
5661   BIH: TBitmapInfoHeader;
5662   BCH: TBitmapCoreHeader;
5663   H: Integer;
5664   StreamStart: Int64;
5665 begin
5666   StreamStart := theStream.Position;
5667   TheStream.Read(BIH.biSize,SizeOf(BIH.biSize));
5668   {$IFDEF FPC_BIG_ENDIAN}
5669   BIH.biSize := LEtoN(BIH.biSize);
5670   {$ENDIF}
5671 
5672   if BIH.biSize = 12
5673   then begin
5674     // OS2 V1 header
5675     TheStream.Read(BCH.bcWidth, BIH.biSize - SizeOf(BIH.biSize));
5676 
5677     FDibInfo.Width := LEtoN(BCH.bcWidth);
5678     FDibInfo.Height := LEtoN(BCH.bcHeight);
5679     FDibInfo.BitCount := LEtoN(BCH.bcBitCount);
5680     FDibInfo.Encoding := lrdeRGB;
5681     FDibInfo.UpsideDown := True;
5682 
5683     if FDibInfo.BitCount > 8
5684     then FDibInfo.PaletteCount := 0
5685     else FDibInfo.PaletteCount := 1 shl FDibInfo.BitCount;
5686   end
5687   else begin
5688     // Windows Vx header or OSX V2, all start with BitmapInfoHeader
5689     TheStream.Read(BIH.biWidth, SizeOf(BIH) - SizeOf(BIH.biSize));
5690 
5691     FDibInfo.Width := LEtoN(BIH.biWidth);
5692     H := LEtoN(BIH.biHeight);
5693     // by default bitmaps are stored upside down
5694     if H >= 0
5695     then begin
5696       FDibInfo.UpsideDown := True;
5697       FDibInfo.Height := H;
5698     end
5699     else begin
5700       FDibInfo.UpsideDown := False;
5701       FDibInfo.Height := -H;
5702     end;
5703 
5704     FDibInfo.BitCount := LEtoN(BIH.biBitCount);
5705     case LEtoN(BIH.biCompression) of
5706       BI_RGB        : FDibInfo.Encoding := lrdeRGB;
5707       4, {BCA_RLE24}
5708       BI_RLE8,
5709       BI_RLE4       : FDibInfo.Encoding := lrdeRLE;
5710       {BCA_HUFFMAN1D, }
5711       BI_BITFIELDS  : begin
5712         // OS2 can use huffman encoding for mono bitmaps
5713         // bitfields only work for 16 and 32
5714         if FDibInfo.BitCount = 1
5715         then FDibInfo.Encoding := lrdeHuffman
5716         else FDibInfo.Encoding := lrdeBitfield;
5717       end;
5718     else
5719       raise FPImageException.CreateFmt(SUnknownCompression, [LEtoN(BIH.biCompression)]);
5720     end;
5721 
5722     if not (FDibInfo.Encoding in [lrdeRGB, lrdeRLE, lrdeBitfield])
5723     then raise FPImageException.CreateFmt(SUnsupportedCompression, [SEncoding[FDibInfo.Encoding]]);
5724 
5725     FDibInfo.PaletteCount := LEtoN(BIH.biClrUsed);
5726     if  (FDibInfo.PaletteCount = 0)
5727     and (FDibInfo.BitCount <= 8)
5728     then FDibInfo.PaletteCount := 1 shl FDibInfo.BitCount;
5729   end;
5730 
5731   if not ValidCompression
5732   then raise FPImageException.CreateFmt(SWrongCombination, [FDibInfo.BitCount, SEncoding[FDibInfo.Encoding]]);
5733 
5734   if BIH.biSize >= 108
5735   then begin
5736     // at least a V4 header -> has alpha mask, which is always valid (read other masks too)
5737     TheStream.Read(FDibInfo.PixelMasks, 4 * SizeOf(FDibInfo.PixelMasks.R));
5738     GetMaskShiftSize(FDibInfo.PixelMasks.A, FDibInfo.MaskShift.A, FDibInfo.MaskSize.A);
5739   end
5740   else begin
5741     // officially no alpha support, but that breaks older LCL compatebility
5742     // so add it
5743     if Info.BitCount = 32
5744     then begin
5745       {$ifdef ENDIAN_BIG}
5746       FDibInfo.PixelMasks.A := $000000FF;
5747       {$else}
5748       FDibInfo.PixelMasks.A := $FF000000;
5749       {$endif}
5750       GetMaskShiftSize(FDibInfo.PixelMasks.A, FDibInfo.MaskShift.A, FDibInfo.MaskSize.A);
5751     end
5752     else begin
5753       FDibInfo.PixelMasks.A := 0;
5754       FDibInfo.MaskShift.A := 0;
5755       FDibInfo.MaskSize.A := 0;
5756     end;
5757   end;
5758 
5759   if Info.Encoding = lrdeBitfield
5760   then begin
5761     if BIH.biSize < 108
5762     then begin
5763       // not read yet
5764       TheStream.Read(FDibInfo.PixelMasks, 3 * SizeOf(FDibInfo.PixelMasks.R));
5765       // check if added mask is valid
5766       if (Info.PixelMasks.R or Info.PixelMasks.G or Info.PixelMasks.B) and Info.PixelMasks.A <> 0
5767       then begin
5768         // Alpha mask overlaps others
5769         FDibInfo.PixelMasks.A := 0;
5770         FDibInfo.MaskShift.A := 0;
5771         FDibInfo.MaskSize.A := 0;
5772       end;
5773     end;
5774     GetMaskShiftSize(FDibInfo.PixelMasks.R, FDibInfo.MaskShift.R, FDibInfo.MaskSize.R);
5775     GetMaskShiftSize(FDibInfo.PixelMasks.G, FDibInfo.MaskShift.G, FDibInfo.MaskSize.G);
5776     GetMaskShiftSize(FDibInfo.PixelMasks.B, FDibInfo.MaskShift.B, FDibInfo.MaskSize.B);
5777 
5778     TheStream.Seek(StreamStart + BIH.biSize, soBeginning);
5779   end
5780   else begin
5781     TheStream.Seek(StreamStart + BIH.biSize, soBeginning);
5782     ReadPalette(BIH.biSize = 12);
5783   end;
5784 
5785   if Info.MaskSize.A <> 0 {Info.BitCount = 32}
5786   then CheckAlphaDescription(TheImage);
5787 end;
5788 
QueryInterfacenull5789 function TLazReaderDIB.QueryInterface(constref iid: TGuid; out obj): longint; {$IFDEF WINDOWs}stdcall{$ELSE}cdecl{$ENDIF};
5790 begin
5791   if GetInterface(iid, obj)
5792   then Result := S_OK
5793   else Result := E_NOINTERFACE;
5794 end;
5795 
5796 procedure TLazReaderDIB.InternalReadBody;
5797 
5798 
5799   procedure SaveTransparentColor;
5800   begin
5801     if FMaskMode <> lrmmAuto then Exit;
5802 
5803     // define transparent color: 1-8 use palette, 15-24 use fixed color
5804     case Info.BitCount of
5805       1: FMaskIndex := (LineBuf[0] shr 7) and 1;
5806       4: FMaskIndex := (LineBuf[0] shr 4) and $f;
5807       8: FMaskIndex := LineBuf[0];
5808     else
5809       FMaskIndex := -1;
5810       if Info.Encoding = lrdeBitfield
5811       then begin
5812         FMaskColor := BitfieldsToFPColor(PCardinal(LineBuf)[0]);
5813         Exit;
5814       end;
5815 
5816       case Info.BitCount of
5817         16: FMaskColor := RGBToFPColor({$ifdef FPC_BIG_ENDIAN}LeToN{$endif}(PWord(LineBuf)[0]));
5818         24: FMaskColor := RGBToFPColor(PColorRGB(LineBuf)[0]);
5819         32: FMaskColor := RGBToFPColor(PColorRGBA(LineBuf)[0]);
5820       end;
5821 
5822       Exit;
5823     end;
5824     if FMaskIndex <> -1
5825     then FMaskColor := FPalette[FMaskIndex];
5826   end;
5827 
5828   procedure UpdateProgress(Row: Integer); inline;
5829   begin
5830     Progress(psRunning, trunc(100.0 * ((TheImage.Height - Row) / TheImage.Height)),
5831       False, Rect(0, 0, TheImage.Width - 1, TheImage.Height - 1 - Row), 'reading BMP pixels', FContinue);
5832   end;
5833 
5834 var
5835   Row : Cardinal;
5836 begin
5837   TheImage.SetSize(Info.Width, Info.Height);
5838 
5839   if Info.Height = 0 then Exit;
5840   if Info.Width = 0 then Exit;
5841 
5842   InitLineBuf;
5843   try
5844     if not FContinue then Exit;
5845 
5846     Row := Info.Height - 1;
5847     ReadScanLine(Row);
5848     SaveTransparentColor;
5849 
5850     if Info.UpsideDown
5851     then WriteScanLine(Row)
5852     else WriteScanLine(Info.Height - 1 - Row);
5853 
5854     UpdateProgress(Row);
5855 
5856     while Row > 0 do
5857     begin
5858       if not FContinue then Exit;
5859       Dec(Row);
5860       ReadScanLine(Row); // Scanline in LineBuf with Size ReadSize.
5861 
5862       if Info.UpsideDown
5863       then WriteScanLine(Row)
5864       else WriteScanLine(Info.Height - 1 - Row);
5865 
5866       UpdateProgress(Row);
5867     end;
5868   finally
5869     FreeLineBuf;
5870   end;
5871 end;
5872 
InternalChecknull5873 function TLazReaderDIB.InternalCheck(Stream: TStream): boolean;
5874 begin
5875   Result := True;
5876 end;
5877 
5878 constructor TLazReaderDIB.Create;
5879 begin
5880   inherited Create;
5881   FMaskColor := colTransparent;
5882   FContinue := True;
5883 end;
5884 
5885 destructor TLazReaderDIB.Destroy;
5886 begin
5887   FreeLineBuf;
5888   inherited Destroy;
5889 end;
5890 
5891 { TLazIntfImageMask }
5892 
5893 procedure TLazIntfImageMask.SetInternalColor(x, y: integer; const Value: TFPColor);
5894 begin
5895   FImage.Masked[x, y] := Value.red < $8000;
5896 end;
5897 
GetInternalColornull5898 function TLazIntfImageMask.GetInternalColor(x, y: integer): TFPColor;
5899 begin
5900   if FImage.Masked[x, y]
5901   then Result := FPImage.colWhite
5902   else Result := FPImage.colBlack;
5903 end;
5904 
5905 procedure TLazIntfImageMask.SetInternalPixel(x, y: integer; Value: integer);
5906 begin
5907   FImage.Masked[x, y] := Value <> 0;
5908 end;
5909 
GetInternalPixelnull5910 function TLazIntfImageMask.GetInternalPixel(x, y: integer): integer;
5911 begin
5912   Result := Ord(FImage.Masked[x, y]);
5913 end;
5914 
5915 constructor TLazIntfImageMask.CreateWithImage(TheImage: TLazIntfImage);
5916 begin
5917   FImage:=TheImage;
5918   inherited Create(FImage.Width,FImage.Height);
5919 end;
5920 
5921 { TLazReaderIconDIB }
5922 
5923 procedure TLazReaderIconDIB.InternalRead(Stream: TStream; Img: TFPCustomImage);
5924 var
5925   Desc: TRawImageDescription;
5926   Row, Column: Integer;
5927   NewColor: TFPColor;
5928   BufPtr: PByte;
5929   MaskBit: Byte;
5930 begin
5931   FImage := TheImage as TLazIntfImage;
5932   InternalReadHead;
5933 
5934   // Height field is doubled, to (sort of) accomodate mask
5935   // MWE: it shoud be safer to verify the division agains the dirinfo.height
5936   //      anyway I haven't encountered an icon in the wild which doesn't have a mask
5937   FDIBinfo.Height := FDIBinfo.Height div 2;
5938   if FUpdateDescription
5939   then begin
5940     DefaultReaderDescription(Info.Width, Info.Height, Info.BitCount, Desc);
5941     FImage.DataDescription := Desc;
5942   end
5943   else Desc := FImage.DataDescription;
5944   InternalReadBody; { Now read standard bitmap }
5945 
5946   // Mask immediately follows unless bitmap was 32 bit - monchrome bitmap with no header
5947   // MWE: Correction, it seems that even 32bit icons can have a mask following
5948   // if BFI.biBitCount >= 32 then Exit;
5949 
5950   FDIBinfo.Encoding := lrdeRGB;
5951   FDIBinfo.BitCount := 1;
5952   InitLineBuf;
5953   try
5954     for Row := Desc.Height - 1 downto 0 do
5955     begin
5956       ReadScanLine(Row); // Scanline in LineBuf with Size ReadSize.
5957       BufPtr := LineBuf;
5958       MaskBit := $80;
5959       for Column:=0 to Desc.Width - 1 do
5960       begin
5961         if BufPtr^ and MaskBit = 0
5962         then begin
5963           // opaque
5964           FImage.Masked[Column, Row] := False;
5965         end
5966         else begin
5967           // transparent
5968           FImage.Masked[Column, Row] := True;
5969           // add alpha when source wasn't 32bit
5970           if  (Desc.AlphaPrec <> 0)
5971           and ((Desc.Depth < 32) or (Info.MaskSize.A = 0))
5972           then begin
5973             NewColor := FImage.Colors[Column, Row];
5974             NewColor.Alpha := alphaTransparent;
5975             FImage.Colors[Column, Row] := NewColor;
5976           end;
5977         end;
5978         if MaskBit = 1
5979         then begin
5980           MaskBit := $80;
5981           Inc(BufPtr);
5982         end
5983         else begin
5984           MaskBit := MaskBit shr 1;
5985         end;
5986       end;
5987     end;
5988   finally
5989     FreeLineBuf;
5990   end;
5991 end;
5992 
5993 
5994 { TLazReaderPNG }
5995 
5996 procedure TLazReaderPNG.DoDecompress;
5997 var
5998   Desc: TRawImageDescription;
5999   IsAlpha, IsGray: Boolean;
6000 begin
6001   if FUpdateDescription and (theImage is TLazIntfImage)
6002   then begin
6003     // init some default
6004 
6005     IsGray := Header.ColorType and 3 = 0;
6006 
6007     // Paul: if we have a mask in the description then we need to set it manually
6008     // by Masked[x, y] := Color.Alpha = AlphaTransparent, but to do that we must
6009     // read format ourself. fpReaders set alpha instead - they do not have Masked[].
6010     // So if we want true description with mask we must teach our SetInternalColor
6011     // method to handle Alpha if mask needed (or do it any other way). In other words
6012     // this is now unimplemented and we'll get randomly masked image.
6013     // As a temporary solution I'm enable alpha description if transparent color
6014     // is present. This is indicated by UseTransparent property.
6015     // When we will handle Mask in SetInternalColor please remove UseTransparent
6016     // from the IsAlpha assignment.
6017 
6018     IsAlpha := (Header.ColorType and 4 <> 0) or FAlphaPalette or UseTransparent;
6019 
6020     if not IsAlpha and UseTransparent
6021     then Desc.Init_BPP32_B8G8R8A8_M1_BIO_TTB(Header.Width, Header.height)
6022     else Desc.Init_BPP32_B8G8R8A8_BIO_TTB(Header.Width, Header.height);
6023 
6024     if IsGray
6025     then Desc.Format := ricfGray;
6026     if not IsAlpha
6027     then Desc.AlphaPrec := 0;
6028 
6029     // check palette
6030     if (Header.ColorType and 1 <> 0)
6031     then begin
6032       // todo: palette
6033     end
6034     else begin
6035       // no palette, adjust description
6036       if IsGray
6037       then begin
6038         Desc.RedPrec := Header.BitDepth;
6039         Desc.RedShift := 0;
6040         if IsAlpha
6041         then begin
6042           Desc.BitsPerPixel := 2 * Header.BitDepth;
6043           Desc.AlphaPrec := Header.BitDepth;
6044           Desc.AlphaShift := Header.BitDepth;
6045         end
6046         else begin
6047           Desc.BitsPerPixel := Header.BitDepth;
6048         end;
6049         Desc.Depth := Desc.BitsPerPixel;
6050       end
6051       else begin
6052         if IsAlpha
6053         then Desc.Depth := 4 * Header.BitDepth
6054         else Desc.Depth := 3 * Header.BitDepth
6055       end;
6056 
6057       case Header.BitDepth of
6058         1,2,4: begin
6059           // only gray
6060         end;
6061         8: begin
6062           // no change
6063         end;
6064         16: begin
6065           if not IsGray then begin
6066             Desc.BitsPerPixel := Desc.Depth;
6067             Desc.RedPrec := 16;
6068             Desc.RedShift := Desc.RedShift * 2;
6069             Desc.GreenPrec := 16;
6070             Desc.GreenShift := Desc.GreenShift * 2;
6071             Desc.BluePrec := 16;
6072             Desc.BlueShift := Desc.BlueShift * 2;
6073             Desc.AlphaPrec := Desc.AlphaPrec * 2; // might be zero
6074             Desc.AlphaShift := Desc.AlphaShift * 2;
6075           end;
6076         end;
6077       end;
6078     end;
6079 
6080     TLazIntfImage(theImage).DataDescription := Desc;
6081   end;
6082 
6083   inherited DoDecompress;
6084 end;
6085 
GetUpdateDescriptionnull6086 function TLazReaderPNG.GetUpdateDescription: Boolean;
6087 begin
6088   Result := FUpdateDescription;
6089 end;
6090 
6091 procedure TLazReaderPNG.HandleAlpha;
6092 begin
6093   inherited HandleAlpha;
6094   FAlphaPalette := Header.ColorType = 3;
6095 end;
6096 
6097 procedure TLazReaderPNG.InternalRead(Str: TStream; Img: TFPCustomImage);
6098 begin
6099   FAlphaPalette := False;
6100   inherited InternalRead(Str, Img);
6101 end;
6102 
QueryInterfacenull6103 function TLazReaderPNG.QueryInterface(constref iid: TGuid; out obj): longint; {$IFDEF WINDOWs}stdcall{$ELSE}cdecl{$ENDIF};
6104 begin
6105   if GetInterface(iid, obj)
6106   then Result := S_OK
6107   else Result := E_NOINTERFACE;
6108 end;
6109 
6110 procedure TLazReaderPNG.SetUpdateDescription(AValue: Boolean);
6111 begin
6112   FUpdateDescription := AValue;
6113 end;
6114 
_AddRefnull6115 function TLazReaderPNG._AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
6116 begin
6117   Result := -1;
6118 end;
6119 
_Releasenull6120 function TLazReaderPNG._Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
6121 begin
6122   Result := -1;
6123 end;
6124 
6125 { TLazWriterPNG }
6126 
6127 procedure TLazWriterPNG.Finalize;
6128 begin
6129 end;
6130 
6131 procedure TLazWriterPNG.Initialize(AImage: TLazIntfImage);
6132 begin
6133   UseAlpha := AImage.DataDescription.AlphaPrec <> 0;
6134   GrayScale := AImage.DataDescription.Format = ricfGray;
6135   Indexed := AImage.DataDescription.Depth <= 8;
6136   WordSized := (AImage.DataDescription.RedPrec > 8)
6137             or (AImage.DataDescription.GreenPrec > 8)
6138             or (AImage.DataDescription.BluePrec > 8);
6139 end;
6140 
QueryInterfacenull6141 function TLazWriterPNG.QueryInterface(constref iid: TGuid; out obj): longint; {$IFDEF WINDOWs}stdcall{$ELSE}cdecl{$ENDIF};
6142 begin
6143   if GetInterface(iid, obj)
6144   then Result := S_OK
6145   else Result := E_NOINTERFACE;
6146 end;
6147 
_AddRefnull6148 function TLazWriterPNG._AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
6149 begin
6150   Result := -1;
6151 end;
6152 
_Releasenull6153 function TLazWriterPNG._Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
6154 begin
6155   Result := -1;
6156 end;
6157 
6158 {$IFNDEF DisableLCLTIFF}
6159 
6160 { TLazReaderTiff }
6161 
6162 {$IFDEF OldTiffCreateImageHook}
6163 procedure TLazReaderTiff.CreateImageHook(Sender: TFPReaderTiff; var NewImage: TFPCustomImage);
6164 begin
6165   if Assigned(FOrgEvent) then FOrgEvent(Sender, NewImage);
6166   FirstImg.Img:=NewImage;
6167   DoCreateImage(FirstImg);
6168 end;
6169 {$ENDIF}
6170 
6171 procedure TLazReaderTiff.DoCreateImage(
6172   ImgFileDir: {$IFDEF OldTiffCreateImageHook}TTiffIDF{$ELSE}TTiffIFD{$ENDIF});
6173 var
6174   Desc: TRawImageDescription;
6175   IsAlpha, IsGray: Boolean;
6176 begin
6177   {$IFNDEF OldTiffCreateImageHook}
6178   inherited;
6179   {$ENDIF}
6180 
6181   if not FUpdateDescription then Exit;
6182   if not (theImage is TLazIntfImage) then Exit;
6183 
6184   // init some default
6185 
6186   IsGray := ImgFileDir.PhotoMetricInterpretation in [0, 1];
6187   IsAlpha := ImgFileDir.AlphaBits <> 0;
6188 
6189   if IsAlpha
6190   then Desc.Init_BPP32_B8G8R8A8_BIO_TTB(ImgFileDir.ImageWidth, ImgFileDir.ImageHeight)
6191   else Desc.Init_BPP24_B8G8R8_BIO_TTB(ImgFileDir.ImageWidth, ImgFileDir.ImageHeight);
6192 
6193   if IsGray
6194   then Desc.Format := ricfGray;
6195 
6196   // check mask
6197   if ImgFileDir.PhotoMetricInterpretation = 4
6198   then begin
6199     // todo: mask
6200   end
6201   else
6202   // check palette
6203   if ImgFileDir.PhotoMetricInterpretation = 3
6204   then begin
6205     // todo: palette
6206   end
6207   else begin
6208     // no palette, adjust description
6209     if IsGray
6210     then begin
6211       Desc.RedPrec := ImgFileDir.GrayBits;
6212       Desc.RedShift := 0;
6213       if IsAlpha
6214       then begin
6215         Desc.Depth := ImgFileDir.GrayBits + ImgFileDir.AlphaBits;
6216         Desc.AlphaPrec := ImgFileDir.AlphaBits;
6217         Desc.AlphaShift := ImgFileDir.GrayBits;
6218       end
6219       else begin
6220         Desc.Depth := ImgFileDir.GrayBits;
6221         Desc.BitsPerPixel := ImgFileDir.GrayBits;
6222       end;
6223     end
6224     else begin
6225       Desc.Depth := ImgFileDir.RedBits + ImgFileDir.GreenBits + ImgFileDir.BlueBits + ImgFileDir.AlphaBits;
6226       if Desc.Depth > 32
6227       then begin
6228         // switch to 64bit description
6229         Desc.BitsPerPixel := Desc.BitsPerPixel * 2;
6230         Desc.RedPrec := 16;
6231         Desc.RedShift := Desc.RedShift * 2;
6232         Desc.GreenPrec := 16;
6233         Desc.GreenShift := Desc.GreenShift * 2;
6234         Desc.BluePrec := 16;
6235         Desc.BlueShift := Desc.BlueShift * 2;
6236         Desc.AlphaPrec := Desc.AlphaPrec * 2; // might be zero
6237         Desc.AlphaShift := Desc.AlphaShift * 2;
6238       end;
6239     end;
6240   end;
6241 
6242   TLazIntfImage(theImage).DataDescription := Desc;
6243 end;
6244 
GetUpdateDescriptionnull6245 function TLazReaderTiff.GetUpdateDescription: Boolean;
6246 begin
6247   Result := FUpdateDescription;
6248 end;
6249 
6250 procedure TLazReaderTiff.InternalRead(Str: TStream; Img: TFPCustomImage);
6251 begin
6252   {$IFDEF OldTiffCreateImageHook}
6253   FOrgEvent := OnCreateImage;
6254   OnCreateImage := @CreateImageHook;
6255   inherited InternalRead(Str, Img);
6256   OnCreateImage := FOrgEvent;
6257   FOrgEvent := nil;
6258   {$ELSE}
6259   inherited InternalRead(Str, Img);
6260   {$ENDIF}
6261 end;
6262 
QueryInterfacenull6263 function TLazReaderTiff.QueryInterface(constref iid: TGuid; out obj): longint; {$IFDEF WINDOWs}stdcall{$ELSE}cdecl{$ENDIF};
6264 begin
6265   if GetInterface(iid, obj)
6266   then Result := S_OK
6267   else Result := E_NOINTERFACE;
6268 end;
6269 
6270 procedure TLazReaderTiff.SetUpdateDescription(AValue: Boolean);
6271 begin
6272   FUpdateDescription := AValue;
6273 end;
6274 
_AddRefnull6275 function TLazReaderTiff._AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
6276 begin
6277   Result := -1;
6278 end;
6279 
_Releasenull6280 function TLazReaderTiff._Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
6281 begin
6282   Result := -1;
6283 end;
6284 
6285 { TLazWriterTiff }
6286 
6287 procedure TLazWriterTiff.Finalize;
6288 begin
6289 end;
6290 
6291 procedure TLazWriterTiff.Initialize(AImage: TLazIntfImage);
6292 begin
6293   AImage.Extra[LazTiffSoftware] := 'TLazWriterTiff - Lazarus LCL: ' + lcl_version + ' - FPC: ' + {$I %FPCVERSION%};
6294 end;
6295 
6296 procedure TLazWriterTiff.InternalWrite(Stream: TStream; Img: TFPCustomImage);
6297 var
6298   S: String;
6299 begin
6300   AddImage(Img);
6301 
6302   //add additional elements
6303 
6304   S := Img.Extra[LazTiffHostComputer];
6305   if S <> '' then AddEntryString(316, S);
6306   S := Img.Extra[LazTiffMake];
6307   if S <> '' then AddEntryString(271, S);
6308   S := Img.Extra[LazTiffModel];
6309   if S <> '' then AddEntryString(272, S);
6310   S := Img.Extra[LazTiffSoftware];
6311   if S <> '' then AddEntryString(305, S);
6312 
6313   SaveToStream(Stream);
6314 end;
6315 
QueryInterfacenull6316 function TLazWriterTiff.QueryInterface(constref iid: TGuid; out obj): longint; {$IFDEF WINDOWs}stdcall{$ELSE}cdecl{$ENDIF};
6317 begin
6318   if GetInterface(iid, obj)
6319   then Result := S_OK
6320   else Result := E_NOINTERFACE;
6321 end;
6322 
_AddRefnull6323 function TLazWriterTiff._AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
6324 begin
6325   Result := -1;
6326 end;
6327 
_Releasenull6328 function TLazWriterTiff._Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
6329 begin
6330   Result := -1;
6331 end;
6332 
6333 {$ENDIF} //DisableLCLTIFF
6334 
6335 { TLazReaderIcnsPart }
6336 
InternalChecknull6337 function TLazReaderIcnsPart.InternalCheck(Str: TStream): boolean;
6338 begin
6339   // todo: write check code
6340   Result := True;
6341 end;
6342 
6343 procedure TLazReaderIcnsPart.InternalRead(Stream: TStream; Img: TFPCustomImage);
6344 var
6345   Desc: TRawImageDescription;
6346   Element: TIconFamilyElement;
6347   IsMask: Boolean;
6348 begin
6349   FImage := TheImage as TLazIntfImage;
6350 
6351   Stream.Read(Element, SizeOf(Element));
6352   Element.elementSize := BEtoN(Element.elementSize);
6353   FIconType := GetIcnsIconType(Element.elementType);
6354   FIconInfo := icnsIconTypeInfo[FIconType];
6355   IsMask := FIconType in icnsMaskTypes;
6356 
6357   if UpdateDescription
6358   then begin
6359     if IsMask then
6360     begin
6361       if FIconInfo.Depth = 1 then
6362         DefaultReaderDescription(FIconInfo.Width, FIconInfo.Height, FIconInfo.Depth, Desc)
6363       else
6364         DefaultReaderDescription(FIconInfo.Width, FIconInfo.Height, 32, Desc);
6365     end
6366     else
6367       DefaultReaderDescription(FIconInfo.Width, FIconInfo.Height, FIconInfo.Depth, Desc);
6368     if (Desc.BitsPerPixel = 32) then
6369       Desc.MaskBitsPerPixel := 0;
6370     FImage.DataDescription := Desc;
6371   end
6372   else Desc := FImage.DataDescription;
6373 
6374   SetupRead(FIconInfo.Width, FIconInfo.Height, FIconInfo.Depth, IsMask);
6375 
6376   FDataSize := Element.elementSize - SizeOf(Element);
6377 
6378   GetMem(FData, FDataSize);
6379   try
6380     Stream.Read(FData^, FDataSize);
6381     if FIconType in icnsWithAlpha then
6382       DoReadJpeg2000
6383     else
6384     if IsMask then
6385       DoReadMask
6386     else
6387     if FIconType in icnsRGB then
6388       DoReadRLE
6389     else
6390       DoReadRaw;
6391   finally
6392     FreeMem(FData);
6393     FData := nil;
6394   end;
6395 end;
6396 
QueryInterfacenull6397 function TLazReaderIcnsPart.QueryInterface(constref iid: TGuid; out obj): longint; {$IFDEF WINDOWs}stdcall{$ELSE}cdecl{$ENDIF};
6398 begin
6399   if GetInterface(iid, obj)
6400   then Result := S_OK
6401   else Result := E_NOINTERFACE;
6402 end;
6403 
_AddRefnull6404 function TLazReaderIcnsPart._AddRef: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
6405 begin
6406   Result := -1;
6407 end;
6408 
_Releasenull6409 function TLazReaderIcnsPart._Release: LongInt; {$IFDEF WINDOWS}stdcall{$ELSE}cdecl{$ENDIF};
6410 begin
6411   Result := -1;
6412 end;
6413 
GetUpdateDescriptionnull6414 function TLazReaderIcnsPart.GetUpdateDescription: Boolean;
6415 begin
6416   Result := FUpdateDescription;
6417 end;
6418 
6419 procedure TLazReaderIcnsPart.SetUpdateDescription(AValue: Boolean);
6420 begin
6421   FUpdateDescription := AValue;
6422 end;
6423 
6424 procedure TLazReaderIcnsPart.SetupRead(AWidth, AHeight, ADepth: Integer; IsMask: Boolean);
6425 begin
6426   if FData <> nil then
6427     FreeMem(FData);
6428   FreeAndNil(FPalette);
6429   if not IsMask then
6430     case ADepth of
6431       4: FPalette := CreateVGAPalette;
6432       8: FPalette := Create256ColorPalette;
6433     end;
6434 
6435   FCalcSize := ((AWidth * AHeight * ADepth) shr 3);
6436   TheImage.SetSize(AWidth, AHeight);
6437 end;
6438 
6439 procedure TLazReaderIcnsPart.DoReadRaw;
6440 var
6441   Row, Column: Integer;
6442   shift: byte;
6443   b: PByte;
6444 begin
6445   // only 4 and 8 are stored as raw image format
6446   case FIconInfo.Depth of
6447     4 :
6448       begin
6449         b := FData;
6450         shift := 4;
6451         for Row := 0 to FIconInfo.Height - 1 do
6452           for Column := 0 to FIconInfo.Width - 1 do
6453           begin
6454             FImage.colors[Column, Row] := FPalette[(b^ shr shift) mod 16];
6455             if shift = 0 then
6456             begin
6457               shift := 4;
6458               inc(b);
6459             end
6460             else
6461               shift := 0;
6462           end;
6463       end;
6464     8 :
6465       begin
6466         b := FData;
6467         for Row := 0 to FIconInfo.Height - 1 do
6468           for Column := 0 to FIconInfo.Width - 1 do
6469           begin
6470             FImage.colors[Column, Row] := FPalette[b^];
6471             inc(b);
6472           end;
6473       end;
6474   end;
6475 end;
6476 
6477 procedure TLazReaderIcnsPart.DoReadRLE;
6478 var
6479   ADecompData: PDWord;
6480   ARGBAData: PRGBAQuad;
6481   Component, Shift: Byte;
6482   PixelCount, j, l: Integer;
6483   RepeatValue: DWord;
6484   SourcePtr: PByte;
6485   DestPtr: PDWord;
6486 begin
6487   // only 24 bit RGB is RLE encoded the same way as TIFF or TGA RLE
6488   // data is encoded channel by channel:
6489   // high bit = 0 => length = low 0..6 bits + 1; read length times next value
6490   // high bit = 1 => length = value - 125      ; read one value and repeat length times
6491 
6492   ADecompData := AllocMem(FCalcSize);
6493   DestPtr := ADecompData;
6494 
6495   if FIconType = iitThumbnail32BitData
6496   then SourcePtr := @FData[4]
6497   else SourcePtr := FData;
6498 
6499   PixelCount := FIconInfo.Height * FIconInfo.Width;
6500 
6501   for Component := 0 to 2 do
6502   begin
6503     DestPtr := ADecompData;
6504     Shift := (2 - Component) * 8;
6505     while DestPtr - ADecompData < PixelCount do
6506     begin
6507       l := SourcePtr^;
6508       inc(SourcePtr);
6509       if (l and $80) = 0 then // high bit = 0
6510       begin
6511         for j := 0 to l do
6512         begin
6513           DestPtr^ := DestPtr^ or (DWord(SourcePtr^) shl Shift);
6514           inc(SourcePtr);
6515           inc(DestPtr);
6516         end;
6517       end
6518       else
6519       begin                   // high bit = 1
6520         l := l - 126;
6521         RepeatValue := DWord(SourcePtr^) shl Shift;
6522         inc(SourcePtr);
6523         for j := 0 to l do
6524         begin
6525           DestPtr^ := DestPtr^ or RepeatValue;
6526           inc(DestPtr);
6527         end;
6528       end;
6529     end;
6530   end;
6531 
6532   ARGBAData := PRGBAQuad(ADecompData);
6533   for l := 0 to FIconInfo.Height - 1 do
6534     for j := 0 to FIconInfo.Width - 1 do
6535     begin
6536       FImage.Colors[j, l] :=
6537         FPColor(ARGBAData^.Red shl 8 or ARGBAData^.Red,
6538                 ARGBAData^.Green shl 8 or ARGBAData^.Green,
6539                 ARGBAData^.Blue shl 8 or ARGBAData^.Blue,
6540                 alphaOpaque);
6541       inc(ARGBAData);
6542     end;
6543   FreeMem(ADecompData);
6544 end;
6545 
6546 procedure TLazReaderIcnsPart.DoReadJpeg2000;
6547 begin
6548   // TODO: according to some research in the web we need to read jpeg 2000 data
6549 end;
6550 
6551 procedure TLazReaderIcnsPart.DoReadMask;
6552 var
6553   Row, Column: Integer;
6554   shift: byte;
6555   b: PByte;
6556 begin
6557   case FIconInfo.Depth of
6558     1:
6559       begin
6560         // actually here is stored 2 1-bit images, but we will get only first
6561         shift := 7;
6562         b := FData;
6563         for Row := 0 to FIconInfo.Height - 1 do
6564         begin
6565           for Column := 0 to FIconInfo.Width - 1 do
6566           begin
6567             FImage.colors[Column, Row] := FPColor(0, 0, 0);
6568             FImage.Masked[Column, Row] := (b^ shr shift) mod 2 = 0;
6569             if shift = 0 then
6570             begin
6571               shift := 7;
6572               inc(b);
6573             end
6574             else
6575               dec(shift);
6576           end;
6577         end;
6578       end;
6579     8:
6580       begin
6581         b := FData;
6582         for Row := 0 to FIconInfo.Height - 1 do
6583           for Column := 0 to FIconInfo.Width - 1 do
6584           begin
6585             FImage.colors[Column, Row] := FPColor(0, 0, 0, (b^ shl 8) or b^);
6586             inc(b);
6587           end;
6588       end;
6589   end;
6590 end;
6591 
Create256ColorPalettenull6592 function TLazReaderIcnsPart.Create256ColorPalette: TFPPalette;
6593 const
6594   CHANNELVAL: array[0..15] of Word = (
6595     $FFFF, $CCCC, $9999, $6666, $3333, $0000,
6596     $EEEE, $DDDD, $BBBB, $AAAA, $8888,
6597     $7777, $5555, $4444, $2222, $1111
6598   );
6599 
6600 var
6601   rIdx, gIdx, bIdx: byte;
6602   PalIdx: Byte;
6603 begin
6604   Result := TFPPalette.Create(256);
6605   PalIdx := 0;
6606   for rIdx := 0 to 5 do
6607   begin
6608     for gIdx := 0 to 5 do
6609     begin
6610       for bIdx := 0 to 5 do
6611       begin
6612         Result[PalIdx] := FPColor(CHANNELVAL[rIdx], CHANNELVAL[gIdx], CHANNELVAL[bIdx]);
6613         Inc(PalIdx);
6614       end;
6615     end;
6616   end;
6617   for rIdx := 6 to 15 do
6618   begin
6619     Result[PalIdx] := FPColor(CHANNELVAL[rIdx], 0, 0);
6620     Inc(PalIdx);
6621   end;
6622   for gIdx := 6 to 15 do
6623   begin
6624     Result[PalIdx] := FPColor(0, CHANNELVAL[gIdx], 0);
6625     Inc(PalIdx);
6626   end;
6627   for bIdx := 6 to 15 do
6628   begin
6629     Result[PalIdx] := FPColor(0, 0, CHANNELVAL[bIdx]);
6630     Inc(PalIdx);
6631   end;
6632   for rIdx := 6 to 15 do
6633   begin
6634     Result[PalIdx] := FPColor(CHANNELVAL[rIdx], CHANNELVAL[rIdx], CHANNELVAL[rIdx]);
6635     Inc(PalIdx);
6636   end;
6637   Result[PalIdx] := FPColor(0, 0, 0);
6638 end;
6639 
6640 constructor TLazReaderIcnsPart.Create;
6641 begin
6642   inherited Create;
6643   FData := nil;
6644   FPalette := nil;
6645   FCalcSize := 0;
6646   FIconType := iitNone;
6647 end;
6648 
6649 destructor TLazReaderIcnsPart.Destroy;
6650 begin
6651   FPalette.Free;
6652   FreeMem(FData);
6653   inherited Destroy;
6654 end;
6655 
6656 //------------------------------------------------------------------------------
6657 procedure InternalInit;
6658 var
6659   c: Char;
6660 begin
6661   for c:=Low(char) to High(char) do begin
6662     IsSpaceChar[c]:=c in [' ',#9,#10,#13];
6663     IsNumberChar[c]:=c in ['0'..'9'];
6664     IsHexNumberChar[c]:=c in ['0'..'9','A'..'F','a'..'f'];
6665   end;
6666 end;
6667 
6668 initialization
6669   InternalInit;
6670 
6671 end.
6672