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