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