1 unit GIFImage;
2 ////////////////////////////////////////////////////////////////////////////////
3 // //
4 // Project: GIF Graphics Object //
5 // Module: gifimage //
6 // Description: TGraphic implementation of the GIF89a graphics format //
7 // Version: 2.2 //
8 // Release: 5 //
9 // Date: 23-MAY-1999 //
10 // Target: Win32, Delphi 2, 3, 4 & 5, C++ Builder 3 & 4 //
11 // Author(s): anme: Anders Melander, anders@melander.dk //
12 // fila: Filip Larsen //
13 // rps: Reinier Sterkenburg //
14 // Copyright: (c) 1997-99 Anders Melander. //
15 // All rights reserved. //
16 // Formatting: 2 space indent, 8 space tabs, 80 columns. //
17 // //
18 ////////////////////////////////////////////////////////////////////////////////
19 // Changed 2001.07.23 by Finn Tolderlund: //
20 // Changed according to e-mail from "Rolf Frei" <rolf@eicom.ch> //
21 // on 2001.07.23 so that it works in Delphi 6. //
22 // //
23 // Changed 2002.07.07 by Finn Tolderlund: //
24 // Incorporated additional modifications by Alexey Barkovoy (clootie@reactor.ru)
25 // found in his Delphi 6 GifImage.pas (from 22-Dec-2001). //
26 // Alexey Barkovoy's Delphi 6 gifimage.pas can be downloaded from //
27 // http://clootie.narod.ru/delphi/download_vcl.html //
28 // These changes made showing of animated gif files more stable. The code //
29 // from 2001.07.23 could crash sometimes with an Execption EAccessViolation. //
30 // //
31 // Changed 2002.10.06 by Finn Tolderlund: //
32 // Delphi 7 compatible. //
33 // //
34 // Changed 2003-03-06 by Finn Tolderlund: //
35 // Changes made as a result of postings in borland.public.delphi.graphics //
36 // from 2003-02-28 to 2003-03-05 where white (255,255,255) in a bitmap //
37 // was converted to (254,254,254) in the gif. //
38 // The doCreateOptimizedPaletteFromSingleBitmap function and //
39 // the CreateOptimizedPaletteFromManyBitmaps function is changed so that //
40 // the correct offset 246 is used instead of 245. //
41 // The ReduceColors function is changed according to Anders Melander's post //
42 // so that a colour get converted to the precise colour if that colour is //
43 // present in the palette when using ColorReduction rmQuantize. //
44 // //
45 // Changed 2003-03-09 by Finn Tolderlund: //
46 // Delphi 7 version is now assumed if unknown compiler version is unknown //
47 // for better compatibility with future Delphi versions. //
48 // Hopefully this code is now compatible with future Delphi versions, //
49 // unless Borland makes some changes that breaks existing code. //
50 // //
51 // Changed 2003-08-04 by Finn Tolderlund: //
52 // Changed procedure AddMaskOnly so that it doesn't leak a GDI HBitmap-object //
53 // and it doesn't release the handle of the source bitmap which //
54 // is used to assign to the GIF object as in gif.assign(bm); //
55 // These changes were made as a result of a news post made by Renate Schaaf //
56 // with the subject "TGifImage HBitmap leak on assign?" //
57 // in borland.public.delphi.graphics on Mon 28 Jul 2003 and Sun 03 Aug 2003. //
58 // //
59 // Changed 2004.03.09 by Finn Tolderlund: //
60 // Added a ForceFrame property to the TGIFImage class. //
61 // The ForceFrame property can be used to make TGIFImage display a apecific //
62 // sub frame from an animated gif. //
63 // How to use: Set the Animate property to False and set the ForceFrame //
64 // property to a desired frame number (0-N) //
65 // Normal display: Set the ForceFrame property to -1 and set Animate to True. //
66 // If ForceFrame is negative TGIFImage behaves just as before this change. //
67 // Note that if the sub frame in the gif only contains part of the image //
68 // (i.e. only the changes from previous frames) the result is unpredictable. //
69 // The result is best if each sub frame contains a whole image. //
70 // If the sub frame is transparent the background is not automatically //
71 // restored, you must do so yourself if you want that. //
72 // If you are using a TImage to display the gif you can use //
73 // Image.Parent.Invalidate or Image.Parent.Refresh to restore the background. //
74 // This change was made as a result of a email correspondance with //
75 // Tineke Kosmis (http://www.classe.nl/) which requested such a property. //
76 // //
77 // Changed 2006.07.09 by Finn Tolderlund: //
78 // Added conditional switch as default: FIXHEADER_WIDTHHEIGHT_SILENT //
79 // When the switch is defined: //
80 // When loading a gif all frames are examined. If a frame has a larger //
81 // Width/Height than the header values then the header values are updated //
82 // with the larger values from the frame. //
83 // I had a MANTA.GIF where the header said 120x89 but the frames said 200x148 //
84 // and the frames got clipped. MSIE didn't clip it. //
85 // http://www.graphcomp.com/info/specs/ani_gif.html : //
86 // Do not assume all of your images are the same size. Read through their //
87 // sizes and set the logical screen to the largest width & height included //
88 // in the file. //
89 // By removing the define FIXHEADER_WIDTHHEIGHT_SILENT //
90 // the header is not altered. This makes the unit work as before. //
91 // //
92 // Changed 2006.07.10 by Finn Tolderlund: //
93 // Added conditional switch as default: DEFAULT_GOCLEARLOOP //
94 // When the switch is defined: //
95 // When loading a gif default DrawOptions include goClearLoop //
96 // Same as adding goClearLoop manually to DrawOptions. //
97 // This will clear an animated gif before first frame on each loop. //
98 // Someone sent me a 'conductor.gif' where some of the last frame was retaind //
99 // when beginning a new loop and that was visually incorrect. //
100 // Without glClearLoop the first frame may look different on the second loop //
101 // because some part of the last frame could still be present. //
102 // With goClearLoop the first frame will always look the same on each loop. //
103 // I think the last is better. //
104 // //
105 // Changed 2006.07.29 by Finn Tolderlund: //
106 // Added a check in procedure TGIFSubImage.Decompress to make sure that //
107 // the InitialBitsPerCode variable never exeeds the value 15. //
108 // Someone sent an animated iup110296.gif (corrupt I think) which caused //
109 // this unit to crash in function NextLZW because InitialBitsPerCode was 20. //
110 // This fix prevents the crash and should not cause problems with other gifs. //
111 // Not sure that the fix is the correct way to handle it. It seems to work. //
112 // //
113 // Changed 2006.10.09 by Finn Tolderlund: //
114 // Received a mail from Michael Thomas Greer with a fix that allows //
115 // the TGIFSubImage.Pixels[] property to be writeable. The help file states //
116 // that the Pixels property can be written, but it was read-only. //
117 // Help file: "Write Pixels to change the color index of individual pixels". //
118 // //
119 // Changed 2006.10.16 by Finn Tolderlund: //
120 // Received a mail from Maurizio Lotauro who was using Delphi 5 and FastMM4. //
121 // FastMM4 complains about a memory leak when using Delphi 5. //
122 // I don't have Delphi 5 installed so I can't test if there really is a //
123 // memory leak or if it's just FastMM4 which can't detect it correctly. //
124 // The problem and fix only applies to Delphi 5 or older. //
125 // Added a fix to keep FastMM4 happy. See more at this link: //
126 // http://sourceforge.net/forum/forum.php?thread_id=1559584&forum_id=443400 //
127 // //
128 // Changed 2007.01.18 by Finn Tolderlund: //
129 // The ReduceColors function is changed so that it's now possible to use //
130 // the TFastColorLookup class if you use ColorReduction rmQuantize. //
131 // The TFastColorLookup class was removed 2003-03-06, but is introduced again //
132 // because Paul Lopez needed speed when adding images to a gif. //
133 // This changes how rmQuantize works: It's now fast but less precise. //
134 // This means: //
135 // Use rmQuantizeWindows to get precision, use rmQuantize if you need speed. //
136 // //
137 ////////////////////////////////////////////////////////////////////////////////
138 // //
139 // Please read the "Conditions of use" in the release notes. //
140 // //
141 ////////////////////////////////////////////////////////////////////////////////
142 // Known problems:
143 //
144 // * The combination of buffered, tiled and transparent draw will display the
145 // background incorrectly (scaled).
146 // If this is a problem for you, use non-buffered (goDirectDraw) drawing
147 // instead.
148 //
149 // * The combination of non-buffered, transparent and stretched draw is
150 // sometimes distorted with a pattern effect when the image is displayed
151 // smaller than the real size (shrinked).
152 //
153 // * Buffered display flickers when TGIFImage is used by a transparent TImage
154 // component.
155 // This is a problem with TImage caused by the fact that TImage was designed
156 // with static images in mind. Not much I can do about it.
157 //
158 ////////////////////////////////////////////////////////////////////////////////
159 // To do (in rough order of priority):
160 // { TODO -oanme -cFeature : TImage hook for destroy notification. }
161 // { TODO -oanme -cFeature : TBitmap pool to limit resource consumption on Win95/98. }
162 // { TODO -oanme -cImprovement : Make BitsPerPixel property writable. }
163 // { TODO -oanme -cFeature : Visual GIF component. }
164 // { TODO -oanme -cImprovement : Easier method to determine DrawPainter status. }
165 // { TODO -oanme -cFeature : Import to 256+ color GIF. }
166 // { TODO -oanme -cFeature : Make some of TGIFImage's properties persistent (DrawOptions etc). }
167 // { TODO -oanme -cFeature : Add TGIFImage.Persistent property. Should save published properties in application extension when this options is set. }
168 // { TODO -oanme -cBugFix : Solution for background buffering in scrollbox. }
169 //
170 //////////////////////////////////////////////////////////////////////////////////
171 {$ifdef BCB}
172 {$ObjExportAll On}
173 {$endif}
174
175 interface
176 ////////////////////////////////////////////////////////////////////////////////
177 //
178 // Conditional Compiler Symbols
179 //
180 ////////////////////////////////////////////////////////////////////////////////
181 (*
182 DEBUG Must be defined if any of the DEBUG_xxx
183 symbols are defined.
184 If the symbol is defined the source will not be
185 optimized and overflow- and range checks will be
186 enabled.
187
188 DEBUG_HASHPERFORMANCE Calculates hash table performance data.
189 DEBUG_HASHFILLFACTOR Calculates fill factor of hash table -
190 Interferes with DEBUG_HASHPERFORMANCE.
191 DEBUG_COMPRESSPERFORMANCE Calculates LZW compressor performance data.
192 DEBUG_DECOMPRESSPERFORMANCE Calculates LZW decompressor performance data.
193 DEBUG_DITHERPERFORMANCE Calculates color reduction performance data.
194 DEBUG_DRAWPERFORMANCE Calculates low level drawing performance data.
195 The performance data for DEBUG_DRAWPERFORMANCE
196 will be displayed when you press the Ctrl key.
197 DEBUG_RENDERPERFORMANCE Calculates performance data for the GIF to
198 bitmap converter.
199 The performance data for DEBUG_DRAWPERFORMANCE
200 will be displayed when you press the Ctrl key.
201
202 GIF_NOSAFETY Define this symbol to disable overflow- and
203 range checks.
204 Ignored if the DEBUG symbol is defined.
205
206 STRICT_MOZILLA Define to mimic Mozilla as closely as possible.
207 If not defined, a slightly more "optimal"
208 implementation is used (IMHO).
209
210 FAST_AS_HELL Define this symbol to use strictly GIF compliant
211 (but too fast) animation timing.
212 Since our paint routines are much faster and
213 more precise timed than Mozilla's, the standard
214 GIF and Mozilla values causes animations to loop
215 faster than they would in Mozilla.
216 If the symbol is _not_ defined, an alternative
217 set of tweaked timing values will be used.
218 The tweaked values are not optimal but are based
219 on tests performed on my reference system:
220 - Windows 95
221 - 133 MHz Pentium
222 - 64Mb RAM
223 - Diamond Stealth64/V3000
224 - 1600*1200 in 256 colors
225 The alternate values can be modified if you are
226 not satisfied with my defaults (they can be
227 found a few pages down).
228
229 REGISTER_TGIFIMAGE Define this symbol to register TGIFImage with
230 the TPicture class and integrate with TImage.
231 This is required to be able to display GIFs in
232 the TImage component.
233 The symbol is defined by default.
234 Undefine if you use another GIF library to
235 provide GIF support for TImage.
236
237 PIXELFORMAT_TOO_SLOW When this symbol is defined, the internal
238 PixelFormat routines are used in some places
239 instead of TBitmap.PixelFormat.
240 The current implementation (Delphi4, Builder 3)
241 of TBitmap.PixelFormat can in some situation
242 degrade performance.
243 The symbol is defined by default.
244
245 CREATEDIBSECTION_SLOW If this symbol is defined, TDIBWriter will
246 use global memory as scanline storage, instead
247 of a DIB section.
248 Benchmarks have shown that a DIB section is
249 twice as slow as global memory.
250 The symbol is defined by default.
251 The symbol requires that PIXELFORMAT_TOO_SLOW
252 is defined.
253
254 SERIALIZE_RENDER Define this symbol to serialize threaded
255 GIF to bitmap rendering.
256 When a GIF is displayed with the goAsync option
257 (the default), the GIF to bitmap rendering is
258 executed in the context of the draw thread.
259 If more than one thread is drawing the same GIF
260 or the GIF is being modified while it is
261 animating, the GIF to bitmap rendering should be
262 serialized to guarantee that the bitmap isn't
263 modified by more than one thread at a time. If
264 SERIALIZE_RENDER is defined, the draw threads
265 uses TThread.Synchronize to serialize GIF to
266 bitmap rendering.
267
268 FIXHEADER_WIDTHHEIGHT_SILENT Define this symbol to adjust Width and Height
269 in the header if any of the frames has a larger
270 Width or Height.
271
272 DEFAULT_GOCLEARLOOP Define this symbol to clear animation on each
273 loop before first frame.
274 Same as adding goClearLoop to DrawOptions.
275 STRICT_MOZILLA does the same,
276 but STRICT_MOZILLA does something more.
277
278 *)
279
280 {$DEFINE REGISTER_TGIFIMAGE}
281 {$DEFINE PIXELFORMAT_TOO_SLOW}
282 {$DEFINE CREATEDIBSECTION_SLOW}
283 {$DEFINE FIXHEADER_WIDTHHEIGHT_SILENT}
284 {$DEFINE DEFAULT_GOCLEARLOOP}
285
286 ////////////////////////////////////////////////////////////////////////////////
287 //
288 // Determine Delphi and C++ Builder version
289 //
290 ////////////////////////////////////////////////////////////////////////////////
291
292 // Delphi 1.x
293 {$IFDEF VER80}
294 'Error: TGIFImage does not support Delphi 1.x'
295 {$ENDIF}
296
297 // Delphi 2.x
298 {$IFDEF VER90}
299 {$DEFINE VER9x}
300 {$ENDIF}
301
302 // C++ Builder 1.x
303 {$IFDEF VER93}
304 // Good luck...
305 {$DEFINE VER9x}
306 {$ENDIF}
307
308 // Delphi 3.x
309 {$IFDEF VER100}
310 {$DEFINE VER10_PLUS}
311 {$DEFINE D3_BCB3}
312 {$ENDIF}
313
314 // C++ Builder 3.x
315 {$IFDEF VER110}
316 {$DEFINE VER10_PLUS}
317 {$DEFINE VER11_PLUS}
318 {$DEFINE D3_BCB3}
319 {$DEFINE BAD_STACK_ALIGNMENT}
320 {$ENDIF}
321
322 // Delphi 4.x
323 {$IFDEF VER120}
324 {$DEFINE VER10_PLUS}
325 {$DEFINE VER11_PLUS}
326 {$DEFINE VER12_PLUS}
327 {$DEFINE BAD_STACK_ALIGNMENT}
328 {$ENDIF}
329
330 // C++ Builder 4.x
331 {$IFDEF VER125}
332 {$DEFINE VER10_PLUS}
333 {$DEFINE VER11_PLUS}
334 {$DEFINE VER12_PLUS}
335 {$DEFINE VER125_PLUS}
336 {$DEFINE BAD_STACK_ALIGNMENT}
337 {$ENDIF}
338
339 // Delphi 5.x
340 {$IFDEF VER130}
341 {$DEFINE VER10_PLUS}
342 {$DEFINE VER11_PLUS}
343 {$DEFINE VER12_PLUS}
344 {$DEFINE VER125_PLUS}
345 {$DEFINE VER13_PLUS}
346 {$DEFINE BAD_STACK_ALIGNMENT}
347 {$ENDIF}
348
349 // Delphi 6.x
350 {$IFDEF VER140}
351 {$WARN SYMBOL_PLATFORM OFF}
352 {$DEFINE VER10_PLUS}
353 {$DEFINE VER11_PLUS}
354 {$DEFINE VER12_PLUS}
355 {$DEFINE VER125_PLUS}
356 {$DEFINE VER13_PLUS}
357 {$DEFINE VER14_PLUS}
358 {$DEFINE BAD_STACK_ALIGNMENT}
359 {$ENDIF}
360
361 // Delphi 7.x
362 {$IFDEF VER150}
363 {$WARN SYMBOL_PLATFORM OFF}
364 {$DEFINE VER10_PLUS}
365 {$DEFINE VER11_PLUS}
366 {$DEFINE VER12_PLUS}
367 {$DEFINE VER125_PLUS}
368 {$DEFINE VER13_PLUS}
369 {$DEFINE VER14_PLUS}
370 {$DEFINE VER15_PLUS}
371 {$DEFINE BAD_STACK_ALIGNMENT}
372 {$ENDIF}
373
374 // 2003.03.09 ->
375 // Unknown compiler version - assume D4 compatible
376 //{$IFNDEF VER9x}
377 // {$IFNDEF VER10_PLUS}
378 // {$DEFINE VER10_PLUS}
379 // {$DEFINE VER11_PLUS}
380 // {$DEFINE VER12_PLUS}
381 // {$DEFINE BAD_STACK_ALIGNMENT}
382 // {$ENDIF}
383 //{$ENDIF}
384 // 2003.03.09 <-
385
386 // 2003.03.09 ->
387 // Unknown compiler version - assume D7 compatible
388 {$IFNDEF VER9x}
389 {$IFNDEF VER10_PLUS}
390 {$WARN SYMBOL_PLATFORM OFF}
391 {$DEFINE VER10_PLUS}
392 {$DEFINE VER11_PLUS}
393 {$DEFINE VER12_PLUS}
394 {$DEFINE VER125_PLUS}
395 {$DEFINE VER13_PLUS}
396 {$DEFINE VER14_PLUS}
397 {$DEFINE VER15_PLUS}
398 {$DEFINE BAD_STACK_ALIGNMENT}
399 {$ENDIF}
400 {$ENDIF}
401 // 2003.03.09 <-
402
403 ////////////////////////////////////////////////////////////////////////////////
404 //
405 // Compiler Options required to compile this library
406 //
407 ////////////////////////////////////////////////////////////////////////////////
408 {$A+,B-,H+,J+,K-,M-,T-,X+}
409
410 // Debug control - You can safely change these settings
411 {$IFDEF DEBUG}
412 {$C+} // ASSERTIONS
413 {$O-} // OPTIMIZATION
414 {$Q+} // OVERFLOWCHECKS
415 {$R+} // RANGECHECKS
416 {$ELSE}
417 {$C-} // ASSERTIONS
418 {$IFDEF GIF_NOSAFETY}
419 {$Q-}// OVERFLOWCHECKS
420 {$R-}// RANGECHECKS
421 {$ENDIF}
422 {$ENDIF}
423
424 // Special options for Time2Help parser
425 {$ifdef TIME2HELP}
426 {$UNDEF PIXELFORMAT_TOO_SLOW}
427 {$endif}
428
429 ////////////////////////////////////////////////////////////////////////////////
430 //
431 // External dependecies
432 //
433 ////////////////////////////////////////////////////////////////////////////////
434 uses
435 sysutils,
436 Windows,
437 Graphics,
438 Classes;
439
440 ////////////////////////////////////////////////////////////////////////////////
441 //
442 // TGIFImage library version
443 //
444 ////////////////////////////////////////////////////////////////////////////////
445 const
446 GIFVersion = $0202;
447 GIFVersionMajor = 2;
448 GIFVersionMinor = 2;
449 GIFVersionRelease = 5;
450
451 ////////////////////////////////////////////////////////////////////////////////
452 //
453 // Misc constants and support types
454 //
455 ////////////////////////////////////////////////////////////////////////////////
456 const
457 GIFMaxColors = 256; // Max number of colors supported by GIF
458 // Don't bother changing this value!
459
460 BitmapAllocationThreshold = 500000; // Bitmap pixel count limit at which
461 // a newly allocated bitmap will be
462 // converted to 1 bit format before
463 // being resized and converted to 8 bit.
464
465 var
466 {$IFDEF FAST_AS_HELL}
467 GIFDelayExp: integer = 10; // Delay multiplier in mS.
468 {$ELSE}
469 GIFDelayExp: integer = 12; // Delay multiplier in mS. Tweaked.
470 {$ENDIF}
471 // * GIFDelayExp:
472 // The following delay values should all
473 // be multiplied by this value to
474 // calculate the effective time (in mS).
475 // According to the GIF specs, this
476 // value should be 10.
477 // Since our paint routines are much
478 // faster than Mozilla's, you might need
479 // to increase this value if your
480 // animations loops too fast. The
481 // optimal value is impossible to
482 // determine since it depends on the
483 // speed of the CPU, the viceo card,
484 // memory and many other factors.
485
486 GIFDefaultDelay: integer = 10; // * GIFDefaultDelay:
487 // Default animation delay.
488 // This value is used if no GCE is
489 // defined.
490 // (10 = 100 mS)
491
492 {$IFDEF FAST_AS_HELL}
493 GIFMinimumDelay: integer = 1; // Minimum delay (from Mozilla source).
494 // (1 = 10 mS)
495 {$ELSE}
496 GIFMinimumDelay: integer = 3; // Minimum delay - Tweaked.
497 {$ENDIF}
498 // * GIFMinimumDelay:
499 // The minumum delay used in the Mozilla
500 // source is 10mS. This corresponds to a
501 // value of 1. However, since our paint
502 // routines are much faster than
503 // Mozilla's, a value of 3 or 4 gives
504 // better results.
505
506 GIFMaximumDelay: integer = 1000; // * GIFMaximumDelay:
507 // Maximum delay when painter is running
508 // in main thread (goAsync is not set).
509 // This value guarantees that a very
510 // long and slow GIF does not hang the
511 // system.
512 // (1000 = 10000 mS = 10 Seconds)
513
514 type
515 TGIFVersion = (gvUnknown, gv87a, gv89a);
516 TGIFVersionRec = array[0..2] of char;
517
518 const
519 GIFVersions : array[gv87a..gv89a] of TGIFVersionRec = ('87a', '89a');
520
521 type
522 // TGIFImage mostly throws exceptions of type GIFException
523 GIFException = class(EInvalidGraphic);
524
525 // Severity level as indicated in the Warning methods and the OnWarning event
526 TGIFSeverity = (gsInfo, gsWarning, gsError);
527
528 ////////////////////////////////////////////////////////////////////////////////
529 //
530 // Delphi 2.x support
531 //
532 ////////////////////////////////////////////////////////////////////////////////
533 {$IFDEF VER9x}
534 // Delphi 2 doesn't support TBitmap.PixelFormat
535 {$DEFINE PIXELFORMAT_TOO_SLOW}
536 type
537 // TThreadList from Delphi 3 classes.pas
538 TThreadList = class
539 private
540 FList: TList;
541 FLock: TRTLCriticalSection;
542 public
543 constructor Create;
544 destructor Destroy; override;
545 procedure Add(Item: Pointer);
546 procedure Clear;
LockListnull547 function LockList: TList;
548 procedure Remove(Item: Pointer);
549 procedure UnlockList;
550 end;
551
552 // From Delphi 3 sysutils.pas
553 EOutOfMemory = class(Exception);
554
555 // From Delphi 3 classes.pas
556 EOutOfResources = class(EOutOfMemory);
557
558 // From Delphi 3 windows.pas
559 PMaxLogPalette = ^TMaxLogPalette;
560 TMaxLogPalette = packed record
561 palVersion: Word;
562 palNumEntries: Word;
563 palPalEntry: array [Byte] of TPaletteEntry;
564 end; { TMaxLogPalette }
565
566 // From Delphi 3 graphics.pas. Used by the D3 TGraphic class.
567 TProgressStage = (psStarting, psRunning, psEnding);
568 TProgressEvent = procedure (Sender: TObject; Stage: TProgressStage;
569 PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string) of object;
570
571 // From Delphi 3 windows.pas
572 PRGBTriple = ^TRGBTriple;
573 {$ENDIF}
574
575 ////////////////////////////////////////////////////////////////////////////////
576 //
577 // Forward declarations
578 //
579 ////////////////////////////////////////////////////////////////////////////////
580 type
581 TGIFImage = class;
582 TGIFSubImage = class;
583
584 ////////////////////////////////////////////////////////////////////////////////
585 //
586 // TGIFItem
587 //
588 ////////////////////////////////////////////////////////////////////////////////
589 TGIFItem = class(TPersistent)
590 private
591 FGIFImage: TGIFImage;
592 protected
GetVersionnull593 function GetVersion: TGIFVersion; virtual;
594 procedure Warning(Severity: TGIFSeverity; Message: string); virtual;
595 public
596 constructor Create(GIFImage: TGIFImage); virtual;
597
598 procedure SaveToStream(Stream: TStream); virtual; abstract;
599 procedure LoadFromStream(Stream: TStream); virtual; abstract;
600 procedure SaveToFile(const Filename: string); virtual;
601 procedure LoadFromFile(const Filename: string); virtual;
602 property Version: TGIFVersion read GetVersion;
603 property Image: TGIFImage read FGIFImage;
604 end;
605
606 ////////////////////////////////////////////////////////////////////////////////
607 //
608 // TGIFList
609 //
610 ////////////////////////////////////////////////////////////////////////////////
611 TGIFList = class(TPersistent)
612 private
613 FItems: TList;
614 FImage: TGIFImage;
615 protected
GetItemnull616 function GetItem(Index: Integer): TGIFItem;
617 procedure SetItem(Index: Integer; Item: TGIFItem);
GetCountnull618 function GetCount: Integer;
619 procedure Warning(Severity: TGIFSeverity; Message: string); virtual;
620 public
621 constructor Create(Image: TGIFImage);
622 destructor Destroy; override;
623
Addnull624 function Add(Item: TGIFItem): Integer;
625 procedure Clear;
626 procedure Delete(Index: Integer);
627 procedure Exchange(Index1, Index2: Integer);
Firstnull628 function First: TGIFItem;
IndexOfnull629 function IndexOf(Item: TGIFItem): Integer;
630 procedure Insert(Index: Integer; Item: TGIFItem);
Lastnull631 function Last: TGIFItem;
632 procedure Move(CurIndex, NewIndex: Integer);
Removenull633 function Remove(Item: TGIFItem): Integer;
634 procedure SaveToStream(Stream: TStream); virtual;
635 procedure LoadFromStream(Stream: TStream; Parent: TObject); virtual; abstract;
636
637 property Items[Index: Integer]: TGIFItem read GetItem write SetItem; default;
638 property Count: Integer read GetCount;
639 property List: TList read FItems;
640 property Image: TGIFImage read FImage;
641 end;
642
643 ////////////////////////////////////////////////////////////////////////////////
644 //
645 // TGIFColorMap
646 //
647 ////////////////////////////////////////////////////////////////////////////////
648 // One way to do it:
649 // TBaseColor = (bcRed, bcGreen, bcBlue);
650 // TGIFColor = array[bcRed..bcBlue] of BYTE;
651 // Another way:
652 TGIFColor = packed record
653 Red: byte;
654 Green: byte;
655 Blue: byte;
656 end;
657
658 TColorMap = packed array[0..GIFMaxColors-1] of TGIFColor;
659 PColorMap = ^TColorMap;
660
661 TUsageCount = record
662 Count : integer; // # of pixels using color index
663 Index : integer; // Color index
664 end;
665 TColormapHistogram = array[0..255] of TUsageCount;
666 TColormapReverse = array[0..255] of byte;
667
668 TGIFColorMap = class(TPersistent)
669 private
670 FColorMap : PColorMap;
671 FCount : integer;
672 FCapacity : integer;
673 FOptimized : boolean;
674 protected
GetColornull675 function GetColor(Index: integer): TColor;
676 procedure SetColor(Index: integer; Value: TColor);
GetBitsPerPixelnull677 function GetBitsPerPixel: integer;
DoOptimizenull678 function DoOptimize: boolean;
679 procedure SetCapacity(Size: integer);
680 procedure Warning(Severity: TGIFSeverity; Message: string); virtual; abstract;
681 procedure BuildHistogram(var Histogram: TColormapHistogram); virtual; abstract;
682 procedure MapImages(var Map: TColormapReverse); virtual; abstract;
683
684 public
685 constructor Create;
686 destructor Destroy; override;
Color2RGBnull687 class function Color2RGB(Color: TColor): TGIFColor;
RGB2Colornull688 class function RGB2Color(Color: TGIFColor): TColor;
689 procedure SaveToStream(Stream: TStream);
690 procedure LoadFromStream(Stream: TStream; Count: integer);
691 procedure Assign(Source: TPersistent); override;
IndexOfnull692 function IndexOf(Color: TColor): integer;
Addnull693 function Add(Color: TColor): integer;
AddUniquenull694 function AddUnique(Color: TColor): integer;
695 procedure Delete(Index: integer);
696 procedure Clear;
Optimizenull697 function Optimize: boolean; virtual; abstract;
698 procedure Changed; virtual; abstract;
699 procedure ImportPalette(Palette: HPalette);
700 procedure ImportColorTable(Pal: pointer; Count: integer);
701 procedure ImportDIBColors(Handle: HDC);
702 procedure ImportColorMap(Map: TColorMap; Count: integer);
ExportPalettenull703 function ExportPalette: HPalette;
704 property Colors[Index: integer]: TColor read GetColor write SetColor; default;
705 property Data: PColorMap read FColorMap;
706 property Count: integer read FCount;
707 property Optimized: boolean read FOptimized write FOptimized;
708 property BitsPerPixel: integer read GetBitsPerPixel;
709 end;
710
711 ////////////////////////////////////////////////////////////////////////////////
712 //
713 // TGIFHeader
714 //
715 ////////////////////////////////////////////////////////////////////////////////
716 TLogicalScreenDescriptor = packed record
717 ScreenWidth: word; { logical screen width }
718 ScreenHeight: word; { logical screen height }
719 PackedFields: byte; { packed fields }
720 BackgroundColorIndex: byte; { index to global color table }
721 AspectRatio: byte; { actual ratio = (AspectRatio + 15) / 64 }
722 end;
723
724 TGIFHeader = class(TGIFItem)
725 private
726 FLogicalScreenDescriptor: TLogicalScreenDescriptor;
727 FColorMap : TGIFColorMap;
728 procedure Prepare;
729 protected
GetVersionnull730 function GetVersion: TGIFVersion; override;
GetBackgroundColornull731 function GetBackgroundColor: TColor;
732 procedure SetBackgroundColor(Color: TColor);
733 procedure SetBackgroundColorIndex(Index: BYTE);
GetBitsPerPixelnull734 function GetBitsPerPixel: integer;
GetColorResolutionnull735 function GetColorResolution: integer;
736 public
737 constructor Create(GIFImage: TGIFImage); override;
738 destructor Destroy; override;
739 procedure Assign(Source: TPersistent); override;
740 procedure SaveToStream(Stream: TStream); override;
741 procedure LoadFromStream(Stream: TStream); override;
742 procedure Clear;
743 property Version: TGIFVersion read GetVersion;
744 property Width: WORD read FLogicalScreenDescriptor.ScreenWidth
745 write FLogicalScreenDescriptor.ScreenWidth;
746 property Height: WORD read FLogicalScreenDescriptor.ScreenHeight
747 write FLogicalScreenDescriptor.Screenheight;
748 property BackgroundColorIndex: BYTE read FLogicalScreenDescriptor.BackgroundColorIndex
749 write SetBackgroundColorIndex;
750 property BackgroundColor: TColor read GetBackgroundColor
751 write SetBackgroundColor;
752 property AspectRatio: BYTE read FLogicalScreenDescriptor.AspectRatio
753 write FLogicalScreenDescriptor.AspectRatio;
754 property ColorMap: TGIFColorMap read FColorMap;
755 property BitsPerPixel: integer read GetBitsPerPixel;
756 property ColorResolution: integer read GetColorResolution;
757 end;
758
759 ////////////////////////////////////////////////////////////////////////////////
760 //
761 // TGIFExtension
762 //
763 ////////////////////////////////////////////////////////////////////////////////
764 TGIFExtensionType = BYTE;
765 TGIFExtension = class;
766 TGIFExtensionClass = class of TGIFExtension;
767
768 TGIFGraphicControlExtension = class;
769
770 TGIFExtension = class(TGIFItem)
771 private
772 FSubImage: TGIFSubImage;
773 protected
GetExtensionTypenull774 function GetExtensionType: TGIFExtensionType; virtual; abstract;
GetVersionnull775 function GetVersion: TGIFVersion; override;
DoReadFromStreamnull776 function DoReadFromStream(Stream: TStream): TGIFExtensionType;
777 class procedure RegisterExtension(elabel: BYTE; eClass: TGIFExtensionClass);
FindExtensionnull778 class function FindExtension(Stream: TStream): TGIFExtensionClass;
FindSubExtensionnull779 class function FindSubExtension(Stream: TStream): TGIFExtensionClass; virtual;
780 public
781 // Ignore compiler warning about hiding base class constructor
782 constructor Create(ASubImage: TGIFSubImage); {$IFDEF VER12_PLUS} reintroduce; {$ENDIF} virtual;
783 destructor Destroy; override;
784 procedure SaveToStream(Stream: TStream); override;
785 procedure LoadFromStream(Stream: TStream); override;
786 property ExtensionType: TGIFExtensionType read GetExtensionType;
787 property SubImage: TGIFSubImage read FSubImage;
788 end;
789
790 ////////////////////////////////////////////////////////////////////////////////
791 //
792 // TGIFSubImage
793 //
794 ////////////////////////////////////////////////////////////////////////////////
795 TGIFExtensionList = class(TGIFList)
796 protected
GetExtensionnull797 function GetExtension(Index: Integer): TGIFExtension;
798 procedure SetExtension(Index: Integer; Extension: TGIFExtension);
799 public
800 procedure LoadFromStream(Stream: TStream; Parent: TObject); override;
801 property Extensions[Index: Integer]: TGIFExtension read GetExtension write SetExtension; default;
802 end;
803
804 TImageDescriptor = packed record
805 Separator: byte; { fixed value of ImageSeparator }
806 Left: word; { Column in pixels in respect to left edge of logical screen }
807 Top: word; { row in pixels in respect to top of logical screen }
808 Width: word; { width of image in pixels }
809 Height: word; { height of image in pixels }
810 PackedFields: byte; { Bit fields }
811 end;
812
813 TGIFSubImage = class(TGIFItem)
814 private
815 FBitmap : TBitmap;
816 FMask : HBitmap;
817 FNeedMask : boolean;
818 FLocalPalette : HPalette;
819 FData : PChar;
820 FDataSize : integer;
821 FColorMap : TGIFColorMap;
822 FImageDescriptor : TImageDescriptor;
823 FExtensions : TGIFExtensionList;
824 FTransparent : boolean;
825 FGCE : TGIFGraphicControlExtension;
826 procedure Prepare;
827 procedure Compress(Stream: TStream);
828 procedure Decompress(Stream: TStream);
829 protected
GetVersionnull830 function GetVersion: TGIFVersion; override;
GetInterlacednull831 function GetInterlaced: boolean;
832 procedure SetInterlaced(Value: boolean);
GetColorResolutionnull833 function GetColorResolution: integer;
GetBitsPerPixelnull834 function GetBitsPerPixel: integer;
835 procedure AssignTo(Dest: TPersistent); override;
DoGetBitmapnull836 function DoGetBitmap: TBitmap;
DoGetDitherBitmapnull837 function DoGetDitherBitmap: TBitmap;
GetBitmapnull838 function GetBitmap: TBitmap;
839 procedure SetBitmap(Value: TBitmap);
840 procedure FreeMask;
GetEmptynull841 function GetEmpty: Boolean;
GetPalettenull842 function GetPalette: HPALETTE;
843 procedure SetPalette(Value: HPalette);
GetActiveColorMapnull844 function GetActiveColorMap: TGIFColorMap;
GetBoundsRectnull845 function GetBoundsRect: TRect;
846 procedure SetBoundsRect(const Value: TRect);
847 procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer);
GetClientRectnull848 function GetClientRect: TRect;
GetPixelnull849 function GetPixel(x, y: integer): BYTE;
850 // 2006.10.09 ->
851 procedure SetPixel(x, y: integer; Value: BYTE);
852 // 2006.10.09 <-
GetScanlinenull853 function GetScanline(y: integer): pointer;
854 procedure NewBitmap;
855 procedure FreeBitmap;
856 procedure NewImage;
857 procedure FreeImage;
858 procedure NeedImage;
ScaleRectnull859 function ScaleRect(DestRect: TRect): TRect;
HasMasknull860 function HasMask: boolean;
GetBoundsnull861 function GetBounds(Index: integer): WORD;
862 procedure SetBounds(Index: integer; Value: WORD);
GetHasBitmapnull863 function GetHasBitmap: boolean;
864 procedure SetHasBitmap(Value: boolean);
865 public
866 constructor Create(GIFImage: TGIFImage); override;
867 destructor Destroy; override;
868 procedure Clear;
869 procedure SaveToStream(Stream: TStream); override;
870 procedure LoadFromStream(Stream: TStream); override;
871 procedure Assign(Source: TPersistent); override;
872 procedure Draw(ACanvas: TCanvas; const Rect: TRect;
873 DoTransparent, DoTile: boolean);
874 procedure StretchDraw(ACanvas: TCanvas; const Rect: TRect;
875 DoTransparent, DoTile: boolean);
876 procedure Crop;
877 procedure Merge(Previous: TGIFSubImage);
878 property HasBitmap: boolean read GetHasBitmap write SetHasBitmap;
879 property Left: WORD index 1 read GetBounds write SetBounds;
880 property Top: WORD index 2 read GetBounds write SetBounds;
881 property Width: WORD index 3 read GetBounds write SetBounds;
882 property Height: WORD index 4 read GetBounds write SetBounds;
883 property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
884 property ClientRect: TRect read GetClientRect;
885 property Interlaced: boolean read GetInterlaced write SetInterlaced;
886 property ColorMap: TGIFColorMap read FColorMap;
887 property ActiveColorMap: TGIFColorMap read GetActiveColorMap;
888 property Data: PChar read FData;
889 property DataSize: integer read FDataSize;
890 property Extensions: TGIFExtensionList read FExtensions;
891 property Version: TGIFVersion read GetVersion;
892 property ColorResolution: integer read GetColorResolution;
893 property BitsPerPixel: integer read GetBitsPerPixel;
894 property Bitmap: TBitmap read GetBitmap write SetBitmap;
895 property Mask: HBitmap read FMask;
896 property Palette: HPALETTE read GetPalette write SetPalette;
897 property Empty: boolean read GetEmpty;
898 property Transparent: boolean read FTransparent;
899 property GraphicControlExtension: TGIFGraphicControlExtension read FGCE;
900 // 2006.10.09 ->
901 // property Pixels[x, y: integer]: BYTE read GetPixel;
902 property Pixels[x, y: integer]: BYTE read GetPixel write SetPixel;
903 // 2006.10.09 <-
904 property Scanline[y: integer]: pointer read GetScanline;
905 end;
906
907 ////////////////////////////////////////////////////////////////////////////////
908 //
909 // TGIFTrailer
910 //
911 ////////////////////////////////////////////////////////////////////////////////
912 TGIFTrailer = class(TGIFItem)
913 procedure SaveToStream(Stream: TStream); override;
914 procedure LoadFromStream(Stream: TStream); override;
915 end;
916
917 ////////////////////////////////////////////////////////////////////////////////
918 //
919 // TGIFGraphicControlExtension
920 //
921 ////////////////////////////////////////////////////////////////////////////////
922 // Graphic Control Extension block a.k.a GCE
923 TGIFGCERec = packed record
924 BlockSize: byte; { should be 4 }
925 PackedFields: Byte;
926 DelayTime: Word; { in centiseconds }
927 TransparentColorIndex: Byte;
928 Terminator: Byte;
929 end;
930
931 TDisposalMethod = (dmNone, dmNoDisposal, dmBackground, dmPrevious);
932
933 TGIFGraphicControlExtension = class(TGIFExtension)
934 private
935 FGCExtension: TGIFGCERec;
936 protected
GetExtensionTypenull937 function GetExtensionType: TGIFExtensionType; override;
GetTransparentnull938 function GetTransparent: boolean;
939 procedure SetTransparent(Value: boolean);
GetTransparentColornull940 function GetTransparentColor: TColor;
941 procedure SetTransparentColor(Color: TColor);
GetTransparentColorIndexnull942 function GetTransparentColorIndex: BYTE;
943 procedure SetTransparentColorIndex(Value: BYTE);
GetDelaynull944 function GetDelay: WORD;
945 procedure SetDelay(Value: WORD);
GetUserInputnull946 function GetUserInput: boolean;
947 procedure SetUserInput(Value: boolean);
GetDisposalnull948 function GetDisposal: TDisposalMethod;
949 procedure SetDisposal(Value: TDisposalMethod);
950
951 public
952 constructor Create(ASubImage: TGIFSubImage); override;
953 destructor Destroy; override;
954 procedure SaveToStream(Stream: TStream); override;
955 procedure LoadFromStream(Stream: TStream); override;
956 property Delay: WORD read GetDelay write SetDelay;
957 property Transparent: boolean read GetTransparent write SetTransparent;
958 property TransparentColorIndex: BYTE read GetTransparentColorIndex
959 write SetTransparentColorIndex;
960 property TransparentColor: TColor read GetTransparentColor write SetTransparentColor;
961 property UserInput: boolean read GetUserInput write SetUserInput;
962 property Disposal: TDisposalMethod read GetDisposal write SetDisposal;
963 end;
964
965 ////////////////////////////////////////////////////////////////////////////////
966 //
967 // TGIFTextExtension
968 //
969 ////////////////////////////////////////////////////////////////////////////////
970 TGIFPlainTextExtensionRec = packed record
971 BlockSize: byte; { should be 12 }
972 Left, Top, Width, Height: Word;
973 CellWidth, CellHeight: Byte;
974 TextFGColorIndex,
975 TextBGColorIndex: Byte;
976 end;
977
978 TGIFTextExtension = class(TGIFExtension)
979 private
980 FText : TStrings;
981 FPlainTextExtension : TGIFPlainTextExtensionRec;
982 protected
GetExtensionTypenull983 function GetExtensionType: TGIFExtensionType; override;
GetForegroundColornull984 function GetForegroundColor: TColor;
985 procedure SetForegroundColor(Color: TColor);
GetBackgroundColornull986 function GetBackgroundColor: TColor;
987 procedure SetBackgroundColor(Color: TColor);
GetBoundsnull988 function GetBounds(Index: integer): WORD;
989 procedure SetBounds(Index: integer; Value: WORD);
GetCharWidthHeightnull990 function GetCharWidthHeight(Index: integer): BYTE;
991 procedure SetCharWidthHeight(Index: integer; Value: BYTE);
GetColorIndexnull992 function GetColorIndex(Index: integer): BYTE;
993 procedure SetColorIndex(Index: integer; Value: BYTE);
994 public
995 constructor Create(ASubImage: TGIFSubImage); override;
996 destructor Destroy; override;
997 procedure SaveToStream(Stream: TStream); override;
998 procedure LoadFromStream(Stream: TStream); override;
999 property Left: WORD index 1 read GetBounds write SetBounds;
1000 property Top: WORD index 2 read GetBounds write SetBounds;
1001 property GridWidth: WORD index 3 read GetBounds write SetBounds;
1002 property GridHeight: WORD index 4 read GetBounds write SetBounds;
1003 property CharWidth: BYTE index 1 read GetCharWidthHeight write SetCharWidthHeight;
1004 property CharHeight: BYTE index 2 read GetCharWidthHeight write SetCharWidthHeight;
1005 property ForegroundColorIndex: BYTE index 1 read GetColorIndex write SetColorIndex;
1006 property ForegroundColor: TColor read GetForegroundColor;
1007 property BackgroundColorIndex: BYTE index 2 read GetColorIndex write SetColorIndex;
1008 property BackgroundColor: TColor read GetBackgroundColor;
1009 property Text: TStrings read FText write FText;
1010 end;
1011
1012 ////////////////////////////////////////////////////////////////////////////////
1013 //
1014 // TGIFCommentExtension
1015 //
1016 ////////////////////////////////////////////////////////////////////////////////
1017 TGIFCommentExtension = class(TGIFExtension)
1018 private
1019 FText : TStrings;
1020 protected
GetExtensionTypenull1021 function GetExtensionType: TGIFExtensionType; override;
1022 public
1023 constructor Create(ASubImage: TGIFSubImage); override;
1024 destructor Destroy; override;
1025 procedure SaveToStream(Stream: TStream); override;
1026 procedure LoadFromStream(Stream: TStream); override;
1027 property Text: TStrings read FText;
1028 end;
1029
1030 ////////////////////////////////////////////////////////////////////////////////
1031 //
1032 // TGIFApplicationExtension
1033 //
1034 ////////////////////////////////////////////////////////////////////////////////
1035 TGIFIdentifierCode = array[0..7] of char;
1036 TGIFAuthenticationCode = array[0..2] of char;
1037 TGIFApplicationRec = packed record
1038 Identifier : TGIFIdentifierCode;
1039 Authentication : TGIFAuthenticationCode;
1040 end;
1041
1042 TGIFApplicationExtension = class;
1043 TGIFAppExtensionClass = class of TGIFApplicationExtension;
1044
1045 TGIFApplicationExtension = class(TGIFExtension)
1046 private
1047 FIdent : TGIFApplicationRec;
GetAuthenticationnull1048 function GetAuthentication: string;
GetIdentifiernull1049 function GetIdentifier: string;
1050 protected
GetExtensionTypenull1051 function GetExtensionType: TGIFExtensionType; override;
1052 procedure SetAuthentication(const Value: string);
1053 procedure SetIdentifier(const Value: string);
1054 procedure SaveData(Stream: TStream); virtual; abstract;
1055 procedure LoadData(Stream: TStream); virtual; abstract;
1056 public
1057 constructor Create(ASubImage: TGIFSubImage); override;
1058 destructor Destroy; override;
1059 procedure SaveToStream(Stream: TStream); override;
1060 procedure LoadFromStream(Stream: TStream); override;
1061 class procedure RegisterExtension(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
FindSubExtensionnull1062 class function FindSubExtension(Stream: TStream): TGIFExtensionClass; override;
1063 property Identifier: string read GetIdentifier write SetIdentifier;
1064 property Authentication: string read GetAuthentication write SetAuthentication;
1065 end;
1066
1067 ////////////////////////////////////////////////////////////////////////////////
1068 //
1069 // TGIFUnknownAppExtension
1070 //
1071 ////////////////////////////////////////////////////////////////////////////////
1072 TGIFBlock = class(TObject)
1073 private
1074 FSize : BYTE;
1075 FData : pointer;
1076 public
1077 constructor Create(ASize: integer);
1078 destructor Destroy; override;
1079 procedure SaveToStream(Stream: TStream);
1080 procedure LoadFromStream(Stream: TStream);
1081 property Size: BYTE read FSize;
1082 property Data: pointer read FData;
1083 end;
1084
1085 TGIFUnknownAppExtension = class(TGIFApplicationExtension)
1086 private
1087 FBlocks : TList;
1088 protected
1089 procedure SaveData(Stream: TStream); override;
1090 procedure LoadData(Stream: TStream); override;
1091 public
1092 constructor Create(ASubImage: TGIFSubImage); override;
1093 destructor Destroy; override;
1094 property Blocks: TList read FBlocks;
1095 end;
1096
1097 ////////////////////////////////////////////////////////////////////////////////
1098 //
1099 // TGIFAppExtNSLoop
1100 //
1101 ////////////////////////////////////////////////////////////////////////////////
1102 TGIFAppExtNSLoop = class(TGIFApplicationExtension)
1103 private
1104 FLoops : WORD;
1105 FBufferSize : DWORD;
1106 protected
1107 procedure SaveData(Stream: TStream); override;
1108 procedure LoadData(Stream: TStream); override;
1109 public
1110 constructor Create(ASubImage: TGIFSubImage); override;
1111 property Loops: WORD read FLoops write FLoops;
1112 property BufferSize: DWORD read FBufferSize write FBufferSize;
1113 end;
1114
1115 ////////////////////////////////////////////////////////////////////////////////
1116 //
1117 // TGIFImage
1118 //
1119 ////////////////////////////////////////////////////////////////////////////////
1120 TGIFImageList = class(TGIFList)
1121 protected
GetImagenull1122 function GetImage(Index: Integer): TGIFSubImage;
1123 procedure SetImage(Index: Integer; SubImage: TGIFSubImage);
1124 public
1125 procedure LoadFromStream(Stream: TStream; Parent: TObject); override;
1126 procedure SaveToStream(Stream: TStream); override;
1127 property SubImages[Index: Integer]: TGIFSubImage read GetImage write SetImage; default;
1128 end;
1129
1130 // Compression algorithms
1131 TGIFCompression =
1132 (gcLZW, // Normal LZW compression
1133 gcRLE // GIF compatible RLE compression
1134 );
1135
1136 // Color reduction methods
1137 TColorReduction =
1138 (rmNone, // Do not perform color reduction
1139 rmWindows20, // Reduce to the Windows 20 color system palette
1140 rmWindows256, // Reduce to the Windows 256 color halftone palette (Only works in 256 color display mode)
1141 rmWindowsGray, // Reduce to the Windows 4 grayscale colors
1142 rmMonochrome, // Reduce to a black/white monochrome palette
1143 rmGrayScale, // Reduce to a uniform 256 shade grayscale palette
1144 rmNetscape, // Reduce to the Netscape 216 color palette
1145 rmQuantize, // Reduce to optimal 2^n color palette
1146 rmQuantizeWindows, // Reduce to optimal 256 color windows palette
1147 rmPalette // Reduce to custom palette
1148 );
1149 TDitherMode =
1150 (dmNearest, // Nearest color matching w/o error correction
1151 dmFloydSteinberg, // Floyd Steinberg Error Diffusion dithering
1152 dmStucki, // Stucki Error Diffusion dithering
1153 dmSierra, // Sierra Error Diffusion dithering
1154 dmJaJuNI, // Jarvis, Judice & Ninke Error Diffusion dithering
1155 dmSteveArche, // Stevenson & Arche Error Diffusion dithering
1156 dmBurkes // Burkes Error Diffusion dithering
1157 // dmOrdered, // Ordered dither
1158 );
1159
1160 // Optimization options
1161 TGIFOptimizeOption =
1162 (ooCrop, // Crop animated GIF frames
1163 ooMerge, // Merge pixels of same color
1164 ooCleanup, // Remove comments and application extensions
1165 ooColorMap, // Sort color map by usage and remove unused entries
1166 ooReduceColors // Reduce color depth ***NOT IMPLEMENTED***
1167 );
1168 TGIFOptimizeOptions = set of TGIFOptimizeOption;
1169
1170 TGIFDrawOption =
1171 (goAsync, // Asyncronous draws (paint in thread)
1172 goTransparent, // Transparent draws
1173 goAnimate, // Animate draws
1174 goLoop, // Loop animations
1175 goLoopContinously, // Ignore loop count and loop forever
1176 goValidateCanvas, // Validate canvas in threaded paint ***NOT IMPLEMENTED***
1177 goDirectDraw, // Draw() directly on canvas
1178 goClearOnLoop, // Clear animation on loop
1179 goTile, // Tiled display
1180 goDither, // Dither to Netscape palette
1181 goAutoDither // Only dither on 256 color systems
1182 );
1183 TGIFDrawOptions = set of TGIFDrawOption;
1184 // Note: if goAsync is not set then goDirectDraw should be set. Otherwise
1185 // the image will not be displayed.
1186
1187 PGIFPainter = ^TGIFPainter;
1188
1189 TGIFPainter = class(TThread)
1190 private
1191 FImage : TGIFImage; // The TGIFImage that owns this painter
1192 FCanvas : TCanvas; // Destination canvas
1193 FRect : TRect; // Destination rect
1194 FDrawOptions : TGIFDrawOptions;// Paint options
1195 FAnimationSpeed : integer; // Animation speed %
1196 FActiveImage : integer; // Current frame
1197 Disposal , // Used by synchronized paint
1198 OldDisposal : TDisposalMethod;// Used by synchronized paint
1199 BackupBuffer : TBitmap; // Used by synchronized paint
1200 FrameBuffer : TBitmap; // Used by synchronized paint
1201 Background : TBitmap; // Used by synchronized paint
1202 ValidateDC : HDC;
1203 DoRestart : boolean; // Flag used to restart animation
1204 FStarted : boolean; // Flag used to signal start of paint
1205 PainterRef : PGIFPainter; // Pointer to var referencing painter
1206 FEventHandle : THandle; // Animation delay event
1207 ExceptObject : Exception; // Eaten exception
1208 ExceptAddress : pointer; // Eaten exceptions address
1209 FEvent : TNotifyEvent; // Used by synchronized events
1210 FOnStartPaint : TNotifyEvent;
1211 FOnPaint : TNotifyEvent;
1212 FOnAfterPaint : TNotifyEvent;
1213 FOnLoop : TNotifyEvent;
1214 FOnEndPaint : TNotifyEvent;
1215 procedure DoOnTerminate(Sender: TObject);// Sync. shutdown procedure
1216 procedure DoSynchronize(Method: TThreadMethod);// Conditional sync stub
1217 {$ifdef SERIALIZE_RENDER}
1218 procedure PrefetchBitmap; // Sync. bitmap prefetch
1219 {$endif}
1220 procedure DoPaintFrame; // Sync. buffered paint procedure
1221 procedure DoPaint; // Sync. paint procedure
1222 procedure DoEvent;
1223 procedure SetActiveImage(const Value: integer);// Sync. event procedure
1224 protected
1225 procedure Execute; override;
1226 procedure SetAnimationSpeed(Value: integer);
1227 public
1228 constructor Create(AImage: TGIFImage; ACanvas: TCanvas; ARect: TRect;
1229 Options: TGIFDrawOptions);
1230 constructor CreateRef(Painter: PGIFPainter; AImage: TGIFImage; ACanvas: TCanvas; ARect: TRect;
1231 Options: TGIFDrawOptions);
1232 destructor Destroy; override;
1233 procedure Start;
1234 procedure Stop;
1235 procedure Restart;
1236 property Image: TGIFImage read FImage;
1237 property Canvas: TCanvas read FCanvas;
1238 property Rect: TRect read FRect write FRect;
1239 property DrawOptions: TGIFDrawOptions read FDrawOptions write FDrawOptions;
1240 property AnimationSpeed: integer read FAnimationSpeed write SetAnimationSpeed;
1241 property Started: boolean read FStarted;
1242 property ActiveImage: integer read FActiveImage write SetActiveImage;
1243 property OnStartPaint: TNotifyEvent read FOnStartPaint write FOnStartPaint;
1244 property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
1245 property OnAfterPaint: TNotifyEvent read FOnAfterPaint write FOnAfterPaint;
1246 property OnLoop: TNotifyEvent read FOnLoop write FOnLoop;
1247 property OnEndPaint : TNotifyEvent read FOnEndPaint write FOnEndPaint ;
1248 property EventHandle: THandle read FEventHandle;
1249 end;
1250
1251 TGIFWarning = procedure(Sender: TObject; Severity: TGIFSeverity; Message: string) of object;
1252
1253 TGIFImage = class(TGraphic)
1254 private
1255 IsDrawing : Boolean;
1256 IsInsideGetPalette : boolean;
1257 FImages : TGIFImageList;
1258 FHeader : TGIFHeader;
1259 FGlobalPalette : HPalette;
1260 FPainters : TThreadList;
1261 FDrawOptions : TGIFDrawOptions;
1262 FColorReduction : TColorReduction;
1263 FReductionBits : integer;
1264 FDitherMode : TDitherMode;
1265 FCompression : TGIFCompression;
1266 FOnWarning : TGIFWarning;
1267 FBitmap : TBitmap;
1268 FDrawPainter : TGIFPainter;
1269 FThreadPriority : TThreadPriority;
1270 FAnimationSpeed : integer;
1271 FForceFrame: Integer; // 2004.03.09
1272 FDrawBackgroundColor: TColor;
1273 FOnStartPaint : TNotifyEvent;
1274 FOnPaint : TNotifyEvent;
1275 FOnAfterPaint : TNotifyEvent;
1276 FOnLoop : TNotifyEvent;
1277 FOnEndPaint : TNotifyEvent;
1278 {$IFDEF VER9x}
1279 FPaletteModified : Boolean;
1280 FOnProgress : TProgressEvent;
1281 {$ENDIF}
GetAnimatenull1282 function GetAnimate: Boolean; // 2002.07.07
1283 procedure SetAnimate(const Value: Boolean); // 2002.07.07
1284 procedure SetForceFrame(const Value: Integer); // 2004.03.09
1285 protected
1286 // Obsolete: procedure Changed(Sender: TObject); {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
GetHeightnull1287 function GetHeight: Integer; override;
1288 procedure SetHeight(Value: Integer); override;
GetWidthnull1289 function GetWidth: Integer; override;
1290 procedure SetWidth(Value: Integer); override;
1291 procedure AssignTo(Dest: TPersistent); override;
InternalPaintnull1292 function InternalPaint(Painter: PGIFPainter; ACanvas: TCanvas; const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
1293 procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
Equalsnull1294 function Equals(Graphic: TGraphic): Boolean; override;
GetPalettenull1295 function GetPalette: HPALETTE; {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
1296 procedure SetPalette(Value: HPalette); {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
GetEmptynull1297 function GetEmpty: Boolean; override;
1298 procedure WriteData(Stream: TStream); override;
GetIsTransparentnull1299 function GetIsTransparent: Boolean;
GetVersionnull1300 function GetVersion: TGIFVersion;
GetColorResolutionnull1301 function GetColorResolution: integer;
GetBitsPerPixelnull1302 function GetBitsPerPixel: integer;
GetBackgroundColorIndexnull1303 function GetBackgroundColorIndex: BYTE;
1304 procedure SetBackgroundColorIndex(const Value: BYTE);
GetBackgroundColornull1305 function GetBackgroundColor: TColor;
1306 procedure SetBackgroundColor(const Value: TColor);
GetAspectRationull1307 function GetAspectRatio: BYTE;
1308 procedure SetAspectRatio(const Value: BYTE);
1309 procedure SetDrawOptions(Value: TGIFDrawOptions);
1310 procedure SetAnimationSpeed(Value: integer);
1311 procedure SetReductionBits(Value: integer);
1312 procedure NewImage;
GetBitmapnull1313 function GetBitmap: TBitmap;
NewBitmapnull1314 function NewBitmap: TBitmap;
1315 procedure FreeBitmap;
GetColorMapnull1316 function GetColorMap: TGIFColorMap;
GetDoDithernull1317 function GetDoDither: boolean;
1318 property DrawPainter: TGIFPainter read FDrawPainter; // Extremely volatile
1319 property DoDither: boolean read GetDoDither;
1320 {$IFDEF VER9x}
1321 procedure Progress(Sender: TObject; Stage: TProgressStage;
1322 PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
1323 {$ENDIF}
1324 {$IFDEF FIXHEADER_WIDTHHEIGHT_SILENT}
1325 procedure FixHeaderWidthHeight; // 2006.07.09
1326 {$ENDIF}
1327 public
1328 constructor Create; override;
1329 destructor Destroy; override;
1330 procedure SaveToStream(Stream: TStream); override;
1331 procedure LoadFromStream(Stream: TStream); override;
1332 procedure LoadFromResourceName(Instance: THandle; const ResName: String); // 2002.07.07
Addnull1333 function Add(Source: TPersistent): integer;
1334 procedure Pack;
1335 procedure OptimizeColorMap;
1336 procedure Optimize(Options: TGIFOptimizeOptions;
1337 ColorReduction: TColorReduction; DitherMode: TDitherMode;
1338 ReductionBits: integer);
1339 procedure Clear;
1340 procedure StopDraw;
Paintnull1341 function Paint(ACanvas: TCanvas; const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
1342 procedure PaintStart;
1343 procedure PaintPause;
1344 procedure PaintStop;
1345 procedure PaintResume;
1346 procedure PaintRestart;
1347 procedure Warning(Sender: TObject; Severity: TGIFSeverity; Message: string); virtual;
1348 procedure Assign(Source: TPersistent); override;
1349 procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
1350 APalette: HPALETTE); override;
1351 procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
1352 var APalette: HPALETTE); override;
1353 property GlobalColorMap: TGIFColorMap read GetColorMap;
1354 property Version: TGIFVersion read GetVersion;
1355 property Images: TGIFImageList read FImages;
1356 property ColorResolution: integer read GetColorResolution;
1357 property BitsPerPixel: integer read GetBitsPerPixel;
1358 property BackgroundColorIndex: BYTE read GetBackgroundColorIndex write SetBackgroundColorIndex;
1359 property BackgroundColor: TColor read GetBackgroundColor write SetBackgroundColor;
1360 property AspectRatio: BYTE read GetAspectRatio write SetAspectRatio;
1361 property Header: TGIFHeader read FHeader; // ***OBSOLETE***
1362 property IsTransparent: boolean read GetIsTransparent;
1363 property DrawOptions: TGIFDrawOptions read FDrawOptions write SetDrawOptions;
1364 property DrawBackgroundColor: TColor read FDrawBackgroundColor write FDrawBackgroundColor;
1365 property ColorReduction: TColorReduction read FColorReduction write FColorReduction;
1366 property ReductionBits: integer read FReductionBits write SetReductionBits;
1367 property DitherMode: TDitherMode read FDitherMode write FDitherMode;
1368 property Compression: TGIFCompression read FCompression write FCompression;
1369 property AnimationSpeed: integer read FAnimationSpeed write SetAnimationSpeed;
1370 property Animate: Boolean read GetAnimate write SetAnimate; // 2002.07.07
1371 property ForceFrame: Integer read FForceFrame write SetForceFrame; // 2004.03.09
1372 property Painters: TThreadList read FPainters;
1373 property ThreadPriority: TThreadPriority read FThreadPriority write FThreadPriority;
1374 property Bitmap: TBitmap read GetBitmap; // Volatile - beware!
1375 property OnWarning: TGIFWarning read FOnWarning write FOnWarning;
1376 property OnStartPaint: TNotifyEvent read FOnStartPaint write FOnStartPaint;
1377 property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
1378 property OnAfterPaint: TNotifyEvent read FOnAfterPaint write FOnAfterPaint;
1379 property OnLoop: TNotifyEvent read FOnLoop write FOnLoop;
1380 property OnEndPaint : TNotifyEvent read FOnEndPaint write FOnEndPaint ;
1381 {$IFDEF VER9x}
1382 property Palette: HPALETTE read GetPalette write SetPalette;
1383 property PaletteModified: Boolean read FPaletteModified write FPaletteModified;
1384 property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
1385 {$ENDIF}
1386 end;
1387
1388 ////////////////////////////////////////////////////////////////////////////////
1389 //
1390 // Utility routines
1391 //
1392 ////////////////////////////////////////////////////////////////////////////////
1393 // WebPalette creates a 216 color uniform palette a.k.a. the Netscape Palette
WebPalettenull1394 function WebPalette: HPalette;
1395
1396 // ReduceColors
1397 // Map colors in a bitmap to their nearest representation in a palette using
1398 // the methods specified by the ColorReduction and DitherMode parameters.
1399 // The ReductionBits parameter specifies the desired number of colors (bits
1400 // per pixel) when the reduction method is rmQuantize. The CustomPalette
1401 // specifies the palette when the rmPalette reduction method is used.
ReduceColorsnull1402 function ReduceColors(Bitmap: TBitmap; ColorReduction: TColorReduction;
1403 DitherMode: TDitherMode; ReductionBits: integer; CustomPalette: hPalette): TBitmap;
1404
1405 // CreateOptimizedPaletteFromManyBitmaps
1406 //: Performs Color Quantization on multiple bitmaps.
1407 // The Bitmaps parameter is a list of bitmaps. Returns an optimized palette.
CreateOptimizedPaletteFromManyBitmapsnull1408 function CreateOptimizedPaletteFromManyBitmaps(Bitmaps: TList; Colors, ColorBits: integer;
1409 Windows: boolean): hPalette;
1410
1411 {$IFDEF VER9x}
1412 // From Delphi 3 graphics.pas
1413 type
1414 TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom);
1415 {$ENDIF}
1416
1417 procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
1418 var ImageSize: longInt; PixelFormat: TPixelFormat);
InternalGetDIBnull1419 function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
1420 var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;
1421
1422 ////////////////////////////////////////////////////////////////////////////////
1423 //
1424 // Global variables
1425 //
1426 ////////////////////////////////////////////////////////////////////////////////
1427 // GIF Clipboard format identifier for use by LoadFromClipboardFormat and
1428 // SaveToClipboardFormat.
1429 // Set in Initialization section.
1430 var
1431 CF_GIF: WORD;
1432
1433 ////////////////////////////////////////////////////////////////////////////////
1434 //
1435 // Library defaults
1436 //
1437 ////////////////////////////////////////////////////////////////////////////////
1438 var
1439 //: Default options for TGIFImage.DrawOptions.
1440 GIFImageDefaultDrawOptions : TGIFDrawOptions =
1441 [goAsync, goLoop, goTransparent, goAnimate, goDither, goAutoDither
1442 {$IFDEF STRICT_MOZILLA}
1443 ,goClearOnLoop
1444 {$ENDIF}
1445 {$IFDEF DEFAULT_GOCLEARLOOP} // 2006.07.10
1446 ,goClearOnLoop
1447 {$ENDIF}
1448 ];
1449
1450 // WARNING! Do not use goAsync and goDirectDraw unless you have absolute
1451 // control of the destination canvas.
1452 // TGIFPainter will continue to write on the canvas even after the canvas has
1453 // been deleted, unless *you* prevent it.
1454 // The goValidateCanvas option will fix this problem if it is ever implemented.
1455
1456 //: Default color reduction methods for bitmap import.
1457 // These are the fastest settings, but also the ones that gives the
1458 // worst result (in most cases).
1459 GIFImageDefaultColorReduction: TColorReduction = rmNetscape;
1460 GIFImageDefaultColorReductionBits: integer = 8; // Range 3 - 8
1461 GIFImageDefaultDitherMode: TDitherMode = dmNearest;
1462
1463 //: Default encoder compression method.
1464 GIFImageDefaultCompression: TGIFCompression = gcLZW;
1465
1466 //: Default painter thread priority
1467 GIFImageDefaultThreadPriority: TThreadPriority = tpNormal;
1468
1469 //: Default animation speed in % of normal speed (range 0 - 1000)
1470 GIFImageDefaultAnimationSpeed: integer = 100;
1471
1472 // DoAutoDither is set to True in the initializaion section if the desktop DC
1473 // supports 256 colors or less.
1474 // It can be modified in your application to disable/enable Auto Dithering
1475 DoAutoDither: boolean = False;
1476
1477 // Palette is set to True in the initialization section if the desktop DC
1478 // supports 256 colors or less.
1479 // You should NOT modify it.
1480 PaletteDevice: boolean = False;
1481
1482 // Set GIFImageRenderOnLoad to True to render (convert to bitmap) the
1483 // GIF frames as they are loaded instead of rendering them on-demand.
1484 // This might increase resource consumption and will increase load time,
1485 // but will cause animated GIFs to display more smoothly.
1486 GIFImageRenderOnLoad: boolean = False;
1487
1488 // If GIFImageOptimizeOnStream is true, the GIF will be optimized
1489 // before it is streamed to the DFM file.
1490 // This will not affect TGIFImage.SaveToStream or SaveToFile.
1491 GIFImageOptimizeOnStream: boolean = False;
1492
1493 ////////////////////////////////////////////////////////////////////////////////
1494 //
1495 // Design Time support
1496 //
1497 ////////////////////////////////////////////////////////////////////////////////
1498 // Dummy component registration for design time support of GIFs in TImage
1499 procedure Register;
1500
1501 ////////////////////////////////////////////////////////////////////////////////
1502 //
1503 // Error messages
1504 //
1505 ////////////////////////////////////////////////////////////////////////////////
1506 {$ifndef VER9x}
1507 resourcestring
1508 {$else}
1509 const
1510 {$endif}
1511 // GIF Error messages
1512 sOutOfData = 'Premature end of data';
1513 sTooManyColors = 'Color table overflow';
1514 sBadColorIndex = 'Invalid color index';
1515 sBadVersion = 'Unsupported GIF version';
1516 sBadSignature = 'Invalid GIF signature';
1517 sScreenBadColorSize = 'Invalid number of colors specified in Screen Descriptor';
1518 sImageBadColorSize = 'Invalid number of colors specified in Image Descriptor';
1519 sUnknownExtension = 'Unknown extension type';
1520 sBadExtensionLabel = 'Invalid extension introducer';
1521 sOutOfMemDIB = 'Failed to allocate memory for GIF DIB';
1522 sDIBCreate = 'Failed to create DIB from Bitmap';
1523 sDecodeTooFewBits = 'Decoder bit buffer under-run';
1524 sDecodeCircular = 'Circular decoder table entry';
1525 sBadTrailer = 'Invalid Image trailer';
1526 sBadExtensionInstance = 'Internal error: Extension Instance does not match Extension Label';
1527 sBadBlockSize = 'Unsupported Application Extension block size';
1528 sBadBlock = 'Unknown GIF block type';
1529 sUnsupportedClass = 'Object type not supported for operation';
1530 sInvalidData = 'Invalid GIF data';
1531 sBadHeight = 'Image height too small for contained frames';
1532 sBadWidth = 'Image width too small for contained frames';
1533 {$IFNDEF REGISTER_TGIFIMAGE}
1534 sGIFToClipboard = 'Clipboard operations not supported for GIF objects';
1535 {$ELSE}
1536 sFailedPaste = 'Failed to store GIF on clipboard';
1537 {$IFDEF VER9x}
1538 sUnknownClipboardFormat= 'Unsupported clipboard format';
1539 {$ENDIF}
1540 {$ENDIF}
1541 sScreenSizeExceeded = 'Image exceeds Logical Screen size';
1542 sNoColorTable = 'No global or local color table defined';
1543 sBadPixelCoordinates = 'Invalid pixel coordinates';
1544 sUnsupportedBitmap = 'Unsupported bitmap format';
1545 sInvalidPixelFormat = 'Unsupported PixelFormat';
1546 sBadDimension = 'Invalid image dimensions';
1547 sNoDIB = 'Image has no DIB';
1548 sInvalidStream = 'Invalid stream operation';
1549 sInvalidColor = 'Color not in color table';
1550 sInvalidBitSize = 'Invalid Bits Per Pixel value';
1551 sEmptyColorMap = 'Color table is empty';
1552 sEmptyImage = 'Image is empty';
1553 sInvalidBitmapList = 'Invalid bitmap list';
1554 sInvalidReduction = 'Invalid reduction method';
1555 {$IFDEF VER9x}
1556 // From Delphi 3 consts.pas
1557 SOutOfResources = 'Out of system resources';
1558 SInvalidBitmap = 'Bitmap image is not valid';
1559 SScanLine = 'Scan line index out of range';
1560 {$ENDIF}
1561
1562 ////////////////////////////////////////////////////////////////////////////////
1563 //
1564 // Misc texts
1565 //
1566 ////////////////////////////////////////////////////////////////////////////////
1567 // File filter name
1568 sGIFImageFile = 'GIF Image';
1569
1570 // Progress messages
1571 sProgressLoading = 'Loading...';
1572 sProgressSaving = 'Saving...';
1573 sProgressConverting = 'Converting...';
1574 sProgressRendering = 'Rendering...';
1575 sProgressCopying = 'Copying...';
1576 sProgressOptimizing = 'Optimizing...';
1577
1578
1579 ////////////////////////////////////////////////////////////////////////////////
1580 ////////////////////////////////////////////////////////////////////////////////
1581 //
1582 // Implementation
1583 //
1584 ////////////////////////////////////////////////////////////////////////////////
1585 ////////////////////////////////////////////////////////////////////////////////
1586 implementation
1587
1588 { This makes me long for the C preprocessor... }
1589 {$ifdef DEBUG}
1590 {$ifdef DEBUG_COMPRESSPERFORMANCE}
1591 {$define DEBUG_PERFORMANCE}
1592 {$else}
1593 {$ifdef DEBUG_DECOMPRESSPERFORMANCE}
1594 {$define DEBUG_PERFORMANCE}
1595 {$else}
1596 {$ifdef DEBUG_DITHERPERFORMANCE}
1597 {$define DEBUG_PERFORMANCE}
1598 {$else}
1599 {$ifdef DEBUG_DITHERPERFORMANCE}
1600 {$define DEBUG_PERFORMANCE}
1601 {$else}
1602 {$ifdef DEBUG_DRAWPERFORMANCE}
1603 {$define DEBUG_PERFORMANCE}
1604 {$else}
1605 {$ifdef DEBUG_RENDERPERFORMANCE}
1606 {$define DEBUG_PERFORMANCE}
1607 {$endif}
1608 {$endif}
1609 {$endif}
1610 {$endif}
1611 {$endif}
1612 {$endif}
1613 {$endif}
1614
1615 uses
1616 {$ifdef DEBUG}
1617 dialogs,
1618 {$endif}
1619 mmsystem, // timeGetTime()
1620 messages,
1621 Consts;
1622
1623
1624 ////////////////////////////////////////////////////////////////////////////////
1625 //
1626 // Misc consts
1627 //
1628 ////////////////////////////////////////////////////////////////////////////////
1629 const
1630 { Extension/block label values }
1631 bsPlainTextExtension = $01;
1632 bsGraphicControlExtension = $F9;
1633 bsCommentExtension = $FE;
1634 bsApplicationExtension = $FF;
1635
1636 bsImageDescriptor = Ord(',');
1637 bsExtensionIntroducer = Ord('!');
1638 bsTrailer = ord(';');
1639
1640 // Thread messages - Used by TThread.Synchronize()
1641 CM_DESTROYWINDOW = $8FFE; // Defined in classes.pas
1642 CM_EXECPROC = $8FFF; // Defined in classes.pas
1643
1644
1645 ////////////////////////////////////////////////////////////////////////////////
1646 //
1647 // Design Time support
1648 //
1649 ////////////////////////////////////////////////////////////////////////////////
1650 //: Dummy component registration to add design-time support of GIFs to TImage.
1651 // Since TGIFImage isn't a component there's nothing to register here, but
1652 // since Register is only called at design time we can set the design time
1653 // GIF paint options here (modify as you please):
1654 procedure Register;
1655 begin
1656 // Don't loop animations at design-time. Animated GIFs will animate once and
1657 // then stop thus not using CPU resources and distracting the developer.
1658 Exclude(GIFImageDefaultDrawOptions, goLoop);
1659 end;
1660
1661 ////////////////////////////////////////////////////////////////////////////////
1662 //
1663 // Utilities
1664 //
1665 ////////////////////////////////////////////////////////////////////////////////
1666 //: Creates a 216 color uniform non-dithering Netscape palette.
1667 function WebPalette: HPalette;
1668 type
1669 TLogWebPalette = packed record
1670 palVersion : word;
1671 palNumEntries : word;
1672 PalEntries : array[0..5,0..5,0..5] of TPaletteEntry;
1673 end;
1674 var
1675 r, g, b : byte;
1676 LogWebPalette : TLogWebPalette;
1677 LogPalette : TLogpalette absolute LogWebPalette; // Stupid typecast
1678 begin
1679 with LogWebPalette do
1680 begin
1681 palVersion:= $0300;
1682 palNumEntries:= 216;
1683 for r:=0 to 5 do
1684 for g:=0 to 5 do
1685 for b:=0 to 5 do
1686 begin
1687 with PalEntries[r,g,b] do
1688 begin
1689 peRed := 51 * r;
1690 peGreen := 51 * g;
1691 peBlue := 51 * b;
1692 peFlags := 0;
1693 end;
1694 end;
1695 end;
1696 Result := CreatePalette(Logpalette);
1697 end;
1698
1699 (*
1700 ** GDI Error handling
1701 ** Adapted from graphics.pas
1702 *)
1703 {$IFOPT R+}
1704 {$DEFINE R_PLUS}
1705 {$RANGECHECKS OFF}
1706 {$ENDIF}
1707 {$ifdef D3_BCB3}
1708 function GDICheck(Value: Integer): Integer;
1709 {$else}
1710 function GDICheck(Value: Cardinal): Cardinal;
1711 {$endif}
1712 var
1713 ErrorCode : integer;
1714 Buf : array [byte] of char;
1715
1716 function ReturnAddr: Pointer;
1717 // From classes.pas
1718 asm
1719 MOV EAX,[EBP+4] // sysutils.pas says [EBP-4], but this works !
1720 end;
1721
1722 begin
1723 if (Value = 0) then
1724 begin
1725 ErrorCode := GetLastError;
1726 if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
1727 ErrorCode, LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil) <> 0) then
1728 raise EOutOfResources.Create(Buf) at ReturnAddr
1729 else
1730 raise EOutOfResources.Create(SOutOfResources) at ReturnAddr;
1731 end;
1732 Result := Value;
1733 end;
1734 {$IFDEF R_PLUS}
1735 {$RANGECHECKS ON}
1736 {$UNDEF R_PLUS}
1737 {$ENDIF}
1738
1739 (*
1740 ** Raise error condition
1741 *)
1742 procedure Error(msg: string);
1743 function ReturnAddr: Pointer;
1744 // From classes.pas
1745 asm
1746 MOV EAX,[EBP+4] // sysutils.pas says [EBP-4] !
1747 end;
1748 begin
1749 raise GIFException.Create(msg) at ReturnAddr;
1750 end;
1751
1752 (*
1753 ** Return number bytes required to
1754 ** hold a given number of bits.
1755 *)
1756 function ByteAlignBit(Bits: Cardinal): Cardinal;
1757 begin
1758 Result := (Bits+7) SHR 3;
1759 end;
1760 // Rounded up to nearest 2
1761 function WordAlignBit(Bits: Cardinal): Cardinal;
1762 begin
1763 Result := ((Bits+15) SHR 4) SHL 1;
1764 end;
1765 // Rounded up to nearest 4
1766 function DWordAlignBit(Bits: Cardinal): Cardinal;
1767 begin
1768 Result := ((Bits+31) SHR 5) SHL 2;
1769 end;
1770 // Round to arbitrary number of bits
1771 function AlignBit(Bits, BitsPerPixel, Alignment: Cardinal): Cardinal;
1772 begin
1773 Dec(Alignment);
1774 Result := ((Bits * BitsPerPixel) + Alignment) and not Alignment;
1775 Result := Result SHR 3;
1776 end;
1777
1778 (*
1779 ** Compute Bits per Pixel from Number of Colors
1780 ** (Return the ceiling log of n)
1781 *)
1782 function Colors2bpp(Colors: integer): integer;
1783 var
1784 MaxColor : integer;
1785 begin
1786 (*
1787 ** This might be faster computed by multiple if then else statements
1788 *)
1789
1790 if (Colors = 0) then
1791 Result := 0
1792 else
1793 begin
1794 Result := 1;
1795 MaxColor := 2;
1796 while (Colors > MaxColor) do
1797 begin
1798 inc(Result);
1799 MaxColor := MaxColor SHL 1;
1800 end;
1801 end;
1802 end;
1803
1804 (*
1805 ** Write an ordinal byte value to a stream
1806 *)
1807 procedure WriteByte(Stream: TStream; b: BYTE);
1808 begin
1809 Stream.Write(b, 1);
1810 end;
1811
1812 (*
1813 ** Read an ordinal byte value from a stream
1814 *)
1815 function ReadByte(Stream: TStream): BYTE;
1816 begin
1817 Stream.Read(Result, 1);
1818 end;
1819
1820 (*
1821 ** Read data from stream and raise exception of EOF
1822 *)
1823 procedure ReadCheck(Stream: TStream; var Buffer; Size: LongInt);
1824 var
1825 ReadSize : integer;
1826 begin
1827 ReadSize := Stream.Read(Buffer, Size);
1828 if (ReadSize <> Size) then
1829 Error(sOutOfData);
1830 end;
1831
1832 (*
1833 ** Write a string list to a stream as multiple blocks
1834 ** of max 255 characters in each.
1835 *)
1836 procedure WriteStrings(Stream: TStream; Text: TStrings);
1837 var
1838 i : integer;
1839 b : BYTE;
1840 size : integer;
1841 s : string;
1842 begin
1843 for i := 0 to Text.Count-1 do
1844 begin
1845 s := Text[i];
1846 size := length(s);
1847 if (size > 255) then
1848 b := 255
1849 else
1850 b := size;
1851 while (size > 0) do
1852 begin
1853 dec(size, b);
1854 WriteByte(Stream, b);
1855 Stream.Write(PChar(s)^, b);
1856 delete(s, 1, b);
1857 if (b > size) then
1858 b := size;
1859 end;
1860 end;
1861 // Terminating zero (length = 0)
1862 WriteByte(Stream, 0);
1863 end;
1864
1865
1866 (*
1867 ** Read a string list from a stream as multiple blocks
1868 ** of max 255 characters in each.
1869 *)
1870 { TODO -oanme -cImprovement : Replace ReadStrings with TGIFReader. }
1871 procedure ReadStrings(Stream: TStream; Text: TStrings);
1872 var
1873 size : BYTE;
1874 buf : array[0..255] of char;
1875 begin
1876 Text.Clear;
1877 if (Stream.Read(size, 1) <> 1) then
1878 exit;
1879 while (size > 0) do
1880 begin
1881 ReadCheck(Stream, buf, size);
1882 buf[size] := #0;
1883 Text.Add(Buf);
1884 if (Stream.Read(size, 1) <> 1) then
1885 exit;
1886 end;
1887 end;
1888
1889
1890 ////////////////////////////////////////////////////////////////////////////////
1891 //
1892 // Delphi 2.x / C++ Builder 1.x support
1893 //
1894 ////////////////////////////////////////////////////////////////////////////////
1895 {$IFDEF VER9x}
1896 var
1897 // From Delphi 3 graphics.pas
1898 SystemPalette16: HPalette; // 16 color palette that maps to the system palette
1899
1900 type
1901 TPixelFormats = set of TPixelFormat;
1902
1903 const
1904 // Only pf1bit, pf4bit and pf8bit is supported since they are the only ones
1905 // with palettes
1906 SupportedPixelformats: TPixelFormats = [pf1bit, pf4bit, pf8bit];
1907 {$ENDIF}
1908
1909
1910 // --------------------------
1911 // InitializeBitmapInfoHeader
1912 // --------------------------
1913 // Fills a TBitmapInfoHeader with the values of a bitmap when converted to a
1914 // DIB of a specified PixelFormat.
1915 //
1916 // Parameters:
1917 // Bitmap The handle of the source bitmap.
1918 // Info The TBitmapInfoHeader buffer that will receive the values.
1919 // PixelFormat The pixel format of the destination DIB.
1920 //
1921 {$IFDEF BAD_STACK_ALIGNMENT}
1922 // Disable optimization to circumvent optimizer bug...
1923 {$IFOPT O+}
1924 {$DEFINE O_PLUS}
1925 {$O-}
1926 {$ENDIF}
1927 {$ENDIF}
1928 procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var Info: TBitmapInfoHeader;
1929 PixelFormat: TPixelFormat);
1930 // From graphics.pas, "optimized" for our use
1931 var
1932 DIB : TDIBSection;
1933 Bytes : Integer;
1934 begin
1935 DIB.dsbmih.biSize := 0;
1936 Bytes := GetObject(Bitmap, SizeOf(DIB), @DIB);
1937 if (Bytes = 0) then
1938 Error(sInvalidBitmap);
1939
1940 if (Bytes >= (sizeof(DIB.dsbm) + sizeof(DIB.dsbmih))) and
1941 (DIB.dsbmih.biSize >= sizeof(DIB.dsbmih)) then
1942 Info := DIB.dsbmih
1943 else
1944 begin
1945 FillChar(Info, sizeof(Info), 0);
1946 with Info, DIB.dsbm do
1947 begin
1948 biSize := SizeOf(Info);
1949 biWidth := bmWidth;
1950 biHeight := bmHeight;
1951 end;
1952 end;
1953 case PixelFormat of
1954 pf1bit: Info.biBitCount := 1;
1955 pf4bit: Info.biBitCount := 4;
1956 pf8bit: Info.biBitCount := 8;
1957 pf24bit: Info.biBitCount := 24;
1958 else
1959 Error(sInvalidPixelFormat);
1960 // Info.biBitCount := DIB.dsbm.bmBitsPixel * DIB.dsbm.bmPlanes;
1961 end;
1962 Info.biPlanes := 1;
1963 Info.biCompression := BI_RGB; // Always return data in RGB format
1964 Info.biSizeImage := AlignBit(Info.biWidth, Info.biBitCount, 32) * Cardinal(abs(Info.biHeight));
1965 end;
1966 {$IFDEF O_PLUS}
1967 {$O+}
1968 {$UNDEF O_PLUS}
1969 {$ENDIF}
1970
1971 // -------------------
1972 // InternalGetDIBSizes
1973 // -------------------
1974 // Calculates the buffer sizes nescessary for convertion of a bitmap to a DIB
1975 // of a specified PixelFormat.
1976 // See the GetDIBSizes API function for more info.
1977 //
1978 // Parameters:
1979 // Bitmap The handle of the source bitmap.
1980 // InfoHeaderSize
1981 // The returned size of a buffer that will receive the DIB's
1982 // TBitmapInfo structure.
1983 // ImageSize The returned size of a buffer that will receive the DIB's
1984 // pixel data.
1985 // PixelFormat The pixel format of the destination DIB.
1986 //
1987 procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
1988 var ImageSize: longInt; PixelFormat: TPixelFormat);
1989 // From graphics.pas, "optimized" for our use
1990 var
1991 Info : TBitmapInfoHeader;
1992 begin
1993 InitializeBitmapInfoHeader(Bitmap, Info, PixelFormat);
1994 // Check for palette device format
1995 if (Info.biBitCount > 8) then
1996 begin
1997 // Header but no palette
1998 InfoHeaderSize := SizeOf(TBitmapInfoHeader);
1999 if ((Info.biCompression and BI_BITFIELDS) <> 0) then
2000 Inc(InfoHeaderSize, 12);
2001 end else
2002 // Header and palette
2003 InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * (1 shl Info.biBitCount);
2004 ImageSize := Info.biSizeImage;
2005 end;
2006
2007 // --------------
2008 // InternalGetDIB
2009 // --------------
2010 // Converts a bitmap to a DIB of a specified PixelFormat.
2011 //
2012 // Parameters:
2013 // Bitmap The handle of the source bitmap.
2014 // Pal The handle of the source palette.
2015 // BitmapInfo The buffer that will receive the DIB's TBitmapInfo structure.
2016 // A buffer of sufficient size must have been allocated prior to
2017 // calling this function.
2018 // Bits The buffer that will receive the DIB's pixel data.
2019 // A buffer of sufficient size must have been allocated prior to
2020 // calling this function.
2021 // PixelFormat The pixel format of the destination DIB.
2022 //
2023 // Returns:
2024 // True on success, False on failure.
2025 //
2026 // Note: The InternalGetDIBSizes function can be used to calculate the
2027 // nescessary sizes of the BitmapInfo and Bits buffers.
2028 //
2029 function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
2030 var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;
2031 // From graphics.pas, "optimized" for our use
2032 var
2033 OldPal : HPALETTE;
2034 DC : HDC;
2035 begin
2036 InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), PixelFormat);
2037 OldPal := 0;
2038 DC := CreateCompatibleDC(0);
2039 try
2040 if (Palette <> 0) then
2041 begin
2042 OldPal := SelectPalette(DC, Palette, False);
2043 RealizePalette(DC);
2044 end;
2045 Result := (GetDIBits(DC, Bitmap, 0, abs(TBitmapInfoHeader(BitmapInfo).biHeight),
2046 @Bits, TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0);
2047 finally
2048 if (OldPal <> 0) then
2049 SelectPalette(DC, OldPal, False);
2050 DeleteDC(DC);
2051 end;
2052 end;
2053
2054 // ----------
2055 // DIBFromBit
2056 // ----------
2057 // Converts a bitmap to a DIB of a specified PixelFormat.
2058 // The DIB is returned in a TMemoryStream ready for streaming to a BMP file.
2059 //
thenull2060 // Note: As opposed to D2's DIBFromBit function, the returned stream also
2061 // contains a TBitmapFileHeader at offset 0.
2062 //
2063 // Parameters:
2064 // Stream The TMemoryStream used to store the bitmap data.
2065 // The stream must be allocated and freed by the caller prior to
2066 // calling this function.
2067 // Src The handle of the source bitmap.
2068 // Pal The handle of the source palette.
2069 // PixelFormat The pixel format of the destination DIB.
2070 // DIBHeader A pointer to the DIB's TBitmapInfo (or TBitmapInfoHeader)
2071 // structure in the memory stream.
2072 // The size of the structure can either be deduced from the
2073 // pixel format (i.e. number of colors) or calculated by
2074 // subtracting the DIBHeader pointer from the DIBBits pointer.
2075 // DIBBits A pointer to the DIB's pixel data in the memory stream.
2076 //
2077 procedure DIBFromBit(Stream: TMemoryStream; Src: HBITMAP;
2078 Pal: HPALETTE; PixelFormat: TPixelFormat; var DIBHeader, DIBBits: Pointer);
2079 // (From D2 graphics.pas, "optimized" for our use)
2080 var
2081 HeaderSize : integer;
2082 FileSize : longInt;
2083 ImageSize : longInt;
2084 BitmapFileHeader : PBitmapFileHeader;
2085 begin
2086 if (Src = 0) then
2087 Error(sInvalidBitmap);
2088 // Get header- and pixel data size for new pixel format
2089 InternalGetDIBSizes(Src, HeaderSize, ImageSize, PixelFormat);
2090 // Make room in stream for a TBitmapInfo and pixel data
2091 FileSize := sizeof(TBitmapFileHeader) + HeaderSize + ImageSize;
2092 Stream.SetSize(FileSize);
2093 // Get pointer to TBitmapFileHeader
2094 BitmapFileHeader := Stream.Memory;
2095 // Get pointer to TBitmapInfo
2096 DIBHeader := Pointer(Longint(BitmapFileHeader) + sizeof(TBitmapFileHeader));
2097 // Get pointer to pixel data
2098 DIBBits := Pointer(Longint(DIBHeader) + HeaderSize);
2099 // Initialize file header
2100 FillChar(BitmapFileHeader^, sizeof(TBitmapFileHeader), 0);
2101 with BitmapFileHeader^ do
2102 begin
2103 bfType := $4D42; // 'BM' = Windows BMP signature
2104 bfSize := FileSize; // File size (not needed)
2105 bfOffBits := sizeof(TBitmapFileHeader) + HeaderSize; // Offset of pixel data
2106 end;
2107 // Get pixel data in new pixel format
2108 InternalGetDIB(Src, Pal, DIBHeader^, DIBBits^, PixelFormat);
2109 end;
2110
2111 // --------------
2112 // GetPixelFormat
2113 // --------------
2114 // Returns the current pixel format of a bitmap.
2115 //
2116 // Replacement for delphi 3 TBitmap.PixelFormat getter.
2117 //
2118 // Parameters:
2119 // Bitmap The bitmap which pixel format is returned.
2120 //
2121 // Returns:
2122 // The PixelFormat of the bitmap
2123 //
GetPixelFormatnull2124 function GetPixelFormat(Bitmap: TBitmap): TPixelFormat;
2125 {$IFDEF VER9x}
2126 // From graphics.pas, "optimized" for our use
2127 var
2128 DIBSection : TDIBSection;
2129 Bytes : Integer;
2130 Handle : HBitmap;
2131 begin
2132 Result := pfCustom; // This value is never returned
2133 // BAD_STACK_ALIGNMENT
2134 // Note: To work around an optimizer bug, we do not use Bitmap.Handle
2135 // directly. Instead we store the value and use it indirectly. Unless we do
2136 // this, the register containing Bitmap.Handle will be overwritten!
2137 Handle := Bitmap.Handle;
2138 if (Handle <> 0) then
2139 begin
2140 Bytes := GetObject(Handle, SizeOf(DIBSection), @DIBSection);
2141 if (Bytes = 0) then
2142 Error(sInvalidBitmap);
2143
2144 with (DIBSection) do
2145 begin
2146 // Check for NT bitmap
2147 if (Bytes < (SizeOf(dsbm) + SizeOf(dsbmih))) or (dsbmih.biSize < SizeOf(dsbmih)) then
2148 DIBSection.dsBmih.biBitCount := dsbm.bmBitsPixel * dsbm.bmPlanes;
2149
2150 case (dsBmih.biBitCount) of
2151 0: Result := pfDevice;
2152 1: Result := pf1bit;
2153 4: Result := pf4bit;
2154 8: Result := pf8bit;
2155 16: case (dsBmih.biCompression) of
2156 BI_RGB:
2157 Result := pf15Bit;
2158 BI_BITFIELDS:
2159 if (dsBitFields[1] = $07E0) then
2160 Result := pf16Bit;
2161 end;
2162 24: Result := pf24Bit;
2163 32: if (dsBmih.biCompression = BI_RGB) then
2164 Result := pf32Bit;
2165 else
2166 Error(sUnsupportedBitmap);
2167 end;
2168 end;
2169 end else
2170 // Result := pfDevice;
2171 Error(sUnsupportedBitmap);
2172 end;
2173 {$ELSE}
2174 begin
2175 Result := Bitmap.PixelFormat;
2176 end;
2177 {$ENDIF}
2178
2179 // --------------
2180 // SetPixelFormat
2181 // --------------
2182 // Changes the pixel format of a TBitmap.
2183 //
2184 // Replacement for delphi 3 TBitmap.PixelFormat setter.
2185 // The returned TBitmap will always be a DIB.
2186 //
willnull2187 // Note: Under Delphi 3.x this function will leak a palette handle each time it
2188 // converts a TBitmap to pf8bit format!
2189 // If possible, use SafeSetPixelFormat instead to avoid this.
2190 //
2191 // Parameters:
2192 // Bitmap The bitmap to modify.
2193 // PixelFormat The pixel format to convert to.
2194 //
2195 procedure SetPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat);
2196 {$IFDEF VER9x}
2197 var
2198 Stream : TMemoryStream;
2199 Header ,
2200 Bits : Pointer;
2201 begin
2202 // Can't change anything without a handle
2203 if (Bitmap.Handle = 0) then
2204 Error(sInvalidBitmap);
2205
2206 // Only convert to supported formats
2207 if not(PixelFormat in SupportedPixelformats) then
2208 Error(sInvalidPixelFormat);
2209
2210 // No need to convert to same format
2211 if (GetPixelFormat(Bitmap) = PixelFormat) then
2212 exit;
2213
2214 Stream := TMemoryStream.Create;
2215 try
2216 // Convert to DIB file in memory stream
2217 DIBFromBit(Stream, Bitmap.Handle, Bitmap.Palette, PixelFormat, Header, Bits);
2218 // Load DIB from stream
2219 Stream.Position := 0;
2220 Bitmap.LoadFromStream(Stream);
2221 finally
2222 Stream.Free;
2223 end;
2224 end;
2225 {$ELSE}
2226 begin
2227 Bitmap.PixelFormat := PixelFormat;
2228 end;
2229 {$ENDIF}
2230
2231 {$IFDEF VER100}
2232 var
2233 pf8BitBitmap: TBitmap = nil;
2234 {$ENDIF}
2235
2236 // ------------------
2237 // SafeSetPixelFormat
2238 // ------------------
2239 // Changes the pixel format of a TBitmap but doesn't preserve the contents.
2240 //
2241 // Replacement for Delphi 3 TBitmap.PixelFormat setter.
2242 // The returned TBitmap will always be an empty DIB of the same size as the
2243 // original bitmap.
2244 //
isnull2245 // This function is used to avoid the palette handle leak that Delphi 3's
2246 // SetPixelFormat and TBitmap.PixelFormat suffers from.
2247 //
2248 // Parameters:
2249 // Bitmap The bitmap to modify.
2250 // PixelFormat The pixel format to convert to.
2251 //
2252 procedure SafeSetPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat);
2253 {$IFDEF VER9x}
2254 begin
2255 SetPixelFormat(Bitmap, PixelFormat);
2256 end;
2257 {$ELSE}
2258 {$IFNDEF VER100}
2259 var
2260 Palette : hPalette;
2261 begin
2262 Bitmap.PixelFormat := PixelFormat;
2263
2264 // Work around a bug in TBitmap:
2265 // When converting to pf8bit format, the palette assigned to TBitmap.Palette
2266 // will be a half tone palette (which only contains the 20 system colors).
2267 // Unfortunately this is not the palette used to render the bitmap and it
2268 // is also not the palette saved with the bitmap.
2269 if (PixelFormat = pf8bit) then
2270 begin
2271 // Disassociate the wrong palette from the bitmap (without affecting
2272 // the DIB color table)
2273 Palette := Bitmap.ReleasePalette;
2274 if (Palette <> 0) then
2275 DeleteObject(Palette);
2276 // Recreate the palette from the DIB color table
2277 Bitmap.Palette;
2278 end;
2279 end;
2280 {$ELSE}
2281 var
2282 Width ,
2283 Height : integer;
2284 begin
2285 if (PixelFormat = pf8bit) then
2286 begin
2287 // Partial solution to "TBitmap.PixelFormat := pf8bit" leak
2288 // by Greg Chapman <glc@well.com>
2289 if (pf8BitBitmap = nil) then
2290 begin
2291 // Create a "template" bitmap
2292 // The bitmap is deleted in the finalization section of the unit.
2293 pf8BitBitmap:= TBitmap.Create;
2294 // Convert template to pf8bit format
2295 // This will leak 1 palette handle, but only once
2296 pf8BitBitmap.PixelFormat:= pf8Bit;
2297 end;
2298 // Store the size of the original bitmap
2299 Width := Bitmap.Width;
2300 Height := Bitmap.Height;
2301 // Convert to pf8bit format by copying template
2302 Bitmap.Assign(pf8BitBitmap);
2303 // Restore the original size
2304 Bitmap.Width := Width;
2305 Bitmap.Height := Height;
2306 end else
2307 // This is safe since only pf8bit leaks
2308 Bitmap.PixelFormat := PixelFormat;
2309 end;
2310 {$ENDIF}
2311 {$ENDIF}
2312
2313
2314 {$IFDEF VER9x}
2315
2316 // -----------
2317 // CopyPalette
2318 // -----------
2319 // Copies a HPALETTE.
2320 //
2321 // Copied from D3 graphics.pas.
2322 // This is declared private in some old versions of Delphi 2 so we have to
2323 // implement it here to support those old versions.
2324 //
2325 // Parameters:
2326 // Palette The palette to copy.
2327 //
2328 // Returns:
2329 // The handle to a new palette.
2330 //
2331 function CopyPalette(Palette: HPALETTE): HPALETTE;
2332 var
2333 PaletteSize: Integer;
2334 LogPal: TMaxLogPalette;
2335 begin
2336 Result := 0;
2337 if Palette = 0 then Exit;
2338 PaletteSize := 0;
2339 if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
2340 if PaletteSize = 0 then Exit;
2341 with LogPal do
2342 begin
2343 palVersion := $0300;
2344 palNumEntries := PaletteSize;
2345 GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
2346 end;
2347 Result := CreatePalette(PLogPalette(@LogPal)^);
2348 end;
2349
2350
2351 // TThreadList implementation from Delphi 3 classes.pas
2352 constructor TThreadList.Create;
2353 begin
2354 inherited Create;
2355 InitializeCriticalSection(FLock);
2356 FList := TList.Create;
2357 end;
2358
2359 destructor TThreadList.Destroy;
2360 begin
2361 LockList; // Make sure nobody else is inside the list.
2362 try
2363 FList.Free;
2364 inherited Destroy;
2365 finally
2366 UnlockList;
2367 DeleteCriticalSection(FLock);
2368 end;
2369 end;
2370
2371 procedure TThreadList.Add(Item: Pointer);
2372 begin
2373 LockList;
2374 try
2375 if FList.IndexOf(Item) = -1 then
2376 FList.Add(Item);
2377 finally
2378 UnlockList;
2379 end;
2380 end;
2381
2382 procedure TThreadList.Clear;
2383 begin
2384 LockList;
2385 try
2386 FList.Clear;
2387 finally
2388 UnlockList;
2389 end;
2390 end;
2391
LockListnull2392 function TThreadList.LockList: TList;
2393 begin
2394 EnterCriticalSection(FLock);
2395 Result := FList;
2396 end;
2397
2398 procedure TThreadList.Remove(Item: Pointer);
2399 begin
2400 LockList;
2401 try
2402 FList.Remove(Item);
2403 finally
2404 UnlockList;
2405 end;
2406 end;
2407
2408 procedure TThreadList.UnlockList;
2409 begin
2410 LeaveCriticalSection(FLock);
2411 end;
2412 // End of TThreadList implementation
2413
2414 // From Delphi 3 sysutils.pas
2415 { CompareMem performs a binary compare of Length bytes of memory referenced
2416 by P1 to that of P2. CompareMem returns True if the memory referenced by
2417 P1 is identical to that of P2. }
2418 function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
2419 asm
2420 PUSH ESI
2421 PUSH EDI
2422 MOV ESI,P1
2423 MOV EDI,P2
2424 MOV EDX,ECX
2425 XOR EAX,EAX
2426 AND EDX,3
2427 SHR ECX,1
2428 SHR ECX,1
2429 REPE CMPSD
2430 JNE @@2
2431 MOV ECX,EDX
2432 REPE CMPSB
2433 JNE @@2
2434 @@1: INC EAX
2435 @@2: POP EDI
2436 POP ESI
2437 end;
2438
2439 // Dummy ASSERT procedure since ASSERT does not exist in Delphi 2.x
2440 procedure ASSERT(Condition: boolean; Message: string);
2441 begin
2442 end;
2443
2444 {$ENDIF} // Delphi 2.x stuff
2445
2446 ////////////////////////////////////////////////////////////////////////////////
2447 //
2448 // TDIB Classes
2449 //
2450 // These classes gives read and write access to TBitmap's pixel data
2451 // independently of the Delphi version used.
2452 //
2453 ////////////////////////////////////////////////////////////////////////////////
2454 type
2455 TDIB = class(TObject)
2456 private
2457 FBitmap : TBitmap;
2458 FPixelFormat : TPixelFormat;
2459 protected
GetScanlinenull2460 function GetScanline(Row: integer): pointer; virtual; abstract;
2461 constructor Create(ABitmap: TBitmap; APixelFormat: TPixelFormat);
2462 public
2463 property Scanline[Row: integer]: pointer read GetScanline;
2464 property Bitmap: TBitmap read FBitmap;
2465 property PixelFormat: TPixelFormat read FPixelFormat;
2466 end;
2467
2468 TDIBReader = class(TDIB)
2469 private
2470 {$ifdef VER9x}
2471 FDIB : TDIBSection;
2472 FDC : HDC;
2473 FScanLine : pointer;
2474 FLastRow : integer;
2475 FInfo : PBitmapInfo;
2476 FBytes : integer;
2477 {$endif}
2478 protected
GetScanlinenull2479 function GetScanline(Row: integer): pointer; override;
2480 public
2481 constructor Create(ABitmap: TBitmap; APixelFormat: TPixelFormat);
2482 destructor Destroy; override;
2483 end;
2484
2485 TDIBWriter = class(TDIB)
2486 private
2487 {$ifdef PIXELFORMAT_TOO_SLOW}
2488 FDIBInfo : PBitmapInfo;
2489 FDIBBits : pointer;
2490 FDIBInfoSize : integer;
2491 FDIBBitsSize : longInt;
2492 {$ifndef CREATEDIBSECTION_SLOW}
2493 FDIB : HBITMAP;
2494 {$endif}
2495 {$endif}
2496 FPalette : HPalette;
2497 FHeight : integer;
2498 FWidth : integer;
2499 protected
2500 procedure CreateDIB;
2501 procedure FreeDIB;
2502 procedure NeedDIB;
GetScanlinenull2503 function GetScanline(Row: integer): pointer; override;
2504 public
2505 constructor Create(ABitmap: TBitmap; APixelFormat: TPixelFormat;
2506 AWidth, AHeight: integer; APalette: HPalette);
2507 destructor Destroy; override;
2508 procedure UpdateBitmap;
2509 property Width: integer read FWidth;
2510 property Height: integer read FHeight;
2511 property Palette: HPalette read FPalette;
2512 end;
2513
2514 ////////////////////////////////////////////////////////////////////////////////
2515 constructor TDIB.Create(ABitmap: TBitmap; APixelFormat: TPixelFormat);
2516 begin
2517 inherited Create;
2518 FBitmap := ABitmap;
2519 FPixelFormat := APixelFormat;
2520 end;
2521
2522 ////////////////////////////////////////////////////////////////////////////////
2523 constructor TDIBReader.Create(ABitmap: TBitmap; APixelFormat: TPixelFormat);
2524 {$ifdef VER9x}
2525 var
2526 InfoHeaderSize : integer;
2527 ImageSize : longInt;
2528 {$endif}
2529 begin
2530 inherited Create(ABitmap, APixelFormat);
2531 {$ifndef VER9x}
2532 SetPixelFormat(FBitmap, FPixelFormat);
2533 {$else}
2534 FDC := CreateCompatibleDC(0);
2535 SelectPalette(FDC, FBitmap.Palette, False);
2536
2537 // Allocate DIB info structure
2538 InternalGetDIBSizes(ABitmap.Handle, InfoHeaderSize, ImageSize, APixelFormat);
2539 GetMem(FInfo, InfoHeaderSize);
2540 // Get DIB info
2541 InitializeBitmapInfoHeader(ABitmap.Handle, FInfo^.bmiHeader, APixelFormat);
2542
2543 // Allocate scan line buffer
2544 GetMem(FScanLine, ImageSize DIV abs(FInfo^.bmiHeader.biHeight));
2545
2546 FLastRow := -1;
2547 {$endif}
2548 end;
2549
2550 destructor TDIBReader.Destroy;
2551 begin
2552 {$ifdef VER9x}
2553 DeleteDC(FDC);
2554 FreeMem(FScanLine);
2555 FreeMem(FInfo);
2556 {$endif}
2557 inherited Destroy;
2558 end;
2559
TDIBReader.GetScanlinenull2560 function TDIBReader.GetScanline(Row: integer): pointer;
2561 begin
2562 {$ifdef VER9x}
2563 if (Row < 0) or (Row >= FBitmap.Height) then
2564 raise EInvalidGraphicOperation.Create(SScanLine);
2565 GDIFlush;
2566
2567 Result := FScanLine;
2568 if (Row = FLastRow) then
2569 exit;
2570 FLastRow := Row;
2571
2572 if (FInfo^.bmiHeader.biHeight > 0) then // bottom-up DIB
2573 Row := FInfo^.bmiHeader.biHeight - Row - 1;
2574 GetDIBits(FDC, FBitmap.Handle, Row, 1, FScanLine, FInfo^, DIB_RGB_COLORS);
2575
2576 {$else}
2577 Result := FBitmap.ScanLine[Row];
2578 {$endif}
2579 end;
2580
2581 ////////////////////////////////////////////////////////////////////////////////
2582 constructor TDIBWriter.Create(ABitmap: TBitmap; APixelFormat: TPixelFormat;
2583 AWidth, AHeight: integer; APalette: HPalette);
2584 begin
2585 inherited Create(ABitmap, APixelFormat);
2586
2587 // DIB writer only supports 8 or 24 bit bitmaps
2588 if not(APixelFormat in [pf8bit, pf24bit]) then
2589 Error(sInvalidPixelFormat);
2590 if (AWidth = 0) or (AHeight = 0) then
2591 Error(sBadDimension);
2592
2593 FHeight := AHeight;
2594 FWidth := AWidth;
2595 {$ifndef PIXELFORMAT_TOO_SLOW}
2596 FBitmap.Palette := 0;
2597 FBitmap.Height := FHeight;
2598 FBitmap.Width := FWidth;
2599 SafeSetPixelFormat(FBitmap, FPixelFormat);
2600 FPalette := CopyPalette(APalette);
2601 FBitmap.Palette := FPalette;
2602 {$else}
2603 FPalette := APalette;
2604 FDIBInfo := nil;
2605 FDIBBits := nil;
2606 {$ifndef CREATEDIBSECTION_SLOW}
2607 FDIB := 0;
2608 {$endif}
2609 {$endif}
2610 end;
2611
2612 destructor TDIBWriter.Destroy;
2613 begin
2614 UpdateBitmap;
2615 FreeDIB;
2616 inherited Destroy;
2617 end;
2618
TDIBWriter.GetScanlinenull2619 function TDIBWriter.GetScanline(Row: integer): pointer;
2620 begin
2621 {$ifdef PIXELFORMAT_TOO_SLOW}
2622 NeedDIB;
2623
2624 if (FDIBBits = nil) then
2625 Error(sNoDIB);
2626 with FDIBInfo^.bmiHeader do
2627 begin
2628 if (Row < 0) or (Row >= Height) then
2629 raise EInvalidGraphicOperation.Create(SScanLine);
2630 GDIFlush;
2631
2632 if biHeight > 0 then // bottom-up DIB
2633 Row := biHeight - Row - 1;
2634 Result := PChar(Cardinal(FDIBBits) + Cardinal(Row) * AlignBit(biWidth, biBitCount, 32));
2635 end;
2636 {$else}
2637 Result := FBitmap.ScanLine[Row];
2638 {$endif}
2639 end;
2640
2641 procedure TDIBWriter.CreateDIB;
2642 {$IFDEF PIXELFORMAT_TOO_SLOW}
2643 var
2644 SrcColors : WORD;
2645 // ScreenDC : HDC;
2646
2647 // From Delphi 3.02 graphics.pas
2648 // There is a bug in the ByteSwapColors from Delphi 3.0!
2649 procedure ByteSwapColors(var Colors; Count: Integer);
2650 var // convert RGB to BGR and vice-versa. TRGBQuad <-> TPaletteEntry
2651 SysInfo: TSystemInfo;
2652 begin
2653 GetSystemInfo(SysInfo);
2654 asm
2655 MOV EDX, Colors
2656 MOV ECX, Count
2657 DEC ECX
2658 JS @@END
2659 LEA EAX, SysInfo
2660 CMP [EAX].TSystemInfo.wProcessorLevel, 3
2661 JE @@386
2662 @@1: MOV EAX, [EDX+ECX*4]
2663 BSWAP EAX
2664 SHR EAX,8
2665 MOV [EDX+ECX*4],EAX
2666 DEC ECX
2667 JNS @@1
2668 JMP @@END
2669 @@386:
2670 PUSH EBX
2671 @@2: XOR EBX,EBX
2672 MOV EAX, [EDX+ECX*4]
2673 MOV BH, AL
2674 MOV BL, AH
2675 SHR EAX,16
2676 SHL EBX,8
2677 MOV BL, AL
2678 MOV [EDX+ECX*4],EBX
2679 DEC ECX
2680 JNS @@2
2681 POP EBX
2682 @@END:
2683 end;
2684 end;
2685 {$ENDIF}
2686 begin
2687 {$ifdef PIXELFORMAT_TOO_SLOW}
2688 FreeDIB;
2689
2690 if (PixelFormat = pf8bit) then
2691 // 8 bit: Header and palette
2692 FDIBInfoSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * (1 shl 8)
2693 else
2694 // 24 bit: Header but no palette
2695 FDIBInfoSize := SizeOf(TBitmapInfoHeader);
2696
2697 // Allocate TBitmapInfo structure
2698 GetMem(FDIBInfo, FDIBInfoSize);
2699 try
2700 FDIBInfo^.bmiHeader.biSize := SizeOf(FDIBInfo^.bmiHeader);
2701 FDIBInfo^.bmiHeader.biWidth := Width;
2702 FDIBInfo^.bmiHeader.biHeight := Height;
2703 FDIBInfo^.bmiHeader.biPlanes := 1;
2704 FDIBInfo^.bmiHeader.biSizeImage := 0;
2705 FDIBInfo^.bmiHeader.biCompression := BI_RGB;
2706
2707 if (PixelFormat = pf8bit) then
2708 begin
2709 FDIBInfo^.bmiHeader.biBitCount := 8;
2710 // Find number of colors defined by palette
2711 if (Palette <> 0) and
2712 (GetObject(Palette, sizeof(SrcColors), @SrcColors) <> 0) and
2713 (SrcColors <> 0) then
2714 begin
2715 // Copy all colors...
2716 GetPaletteEntries(Palette, 0, SrcColors, FDIBInfo^.bmiColors[0]);
2717 // ...and convert BGR to RGB
2718 ByteSwapColors(FDIBInfo^.bmiColors[0], SrcColors);
2719 end else
2720 SrcColors := 0;
2721
2722 // Finally zero any unused entried
2723 if (SrcColors < 256) then
2724 FillChar(pointer(LongInt(@FDIBInfo^.bmiColors)+SizeOf(TRGBQuad)*SrcColors)^,
2725 256 - SrcColors, 0);
2726 FDIBInfo^.bmiHeader.biClrUsed := 256;
2727 FDIBInfo^.bmiHeader.biClrImportant := SrcColors;
2728 end else
2729 begin
2730 FDIBInfo^.bmiHeader.biBitCount := 24;
2731 FDIBInfo^.bmiHeader.biClrUsed := 0;
2732 FDIBInfo^.bmiHeader.biClrImportant := 0;
2733 end;
2734 FDIBBitsSize := AlignBit(Width, FDIBInfo^.bmiHeader.biBitCount, 32) * Cardinal(abs(Height));
2735
2736 {$ifdef CREATEDIBSECTION_SLOW}
2737 FDIBBits := GlobalAllocPtr(GMEM_MOVEABLE, FDIBBitsSize);
2738 if (FDIBBits = nil) then
2739 raise EOutOfMemory.Create(sOutOfMemDIB);
2740 {$else}
2741 // ScreenDC := GDICheck(GetDC(0));
2742 try
2743 // Allocate DIB section
2744 // Note: You can ignore warnings about the HDC parameter being 0. The
2745 // parameter is not used for 24 bit bitmaps
2746 FDIB := GDICheck(CreateDIBSection(0 {ScreenDC}, FDIBInfo^, DIB_RGB_COLORS,
2747 FDIBBits,
2748 {$IFDEF VER9x} nil, {$ELSE} 0, {$ENDIF}
2749 0));
2750 finally
2751 // ReleaseDC(0, ScreenDC);
2752 end;
2753 {$endif}
2754
2755 except
2756 FreeDIB;
2757 raise;
2758 end;
2759 {$endif}
2760 end;
2761
2762 procedure TDIBWriter.FreeDIB;
2763 begin
2764 {$ifdef PIXELFORMAT_TOO_SLOW}
2765 if (FDIBInfo <> nil) then
2766 FreeMem(FDIBInfo);
2767 {$ifdef CREATEDIBSECTION_SLOW}
2768 if (FDIBBits <> nil) then
2769 GlobalFreePtr(FDIBBits);
2770 {$else}
2771 if (FDIB <> 0) then
2772 DeleteObject(FDIB);
2773 FDIB := 0;
2774 {$endif}
2775 FDIBInfo := nil;
2776 FDIBBits := nil;
2777 {$endif}
2778 end;
2779
2780 procedure TDIBWriter.NeedDIB;
2781 begin
2782 {$ifdef PIXELFORMAT_TOO_SLOW}
2783 {$ifdef CREATEDIBSECTION_SLOW}
2784 if (FDIBBits = nil) then
2785 {$else}
2786 if (FDIB = 0) then
2787 {$endif}
2788 CreateDIB;
2789 {$endif}
2790 end;
2791
2792 // Convert the DIB created by CreateDIB back to a TBitmap
2793 procedure TDIBWriter.UpdateBitmap;
2794 {$ifdef PIXELFORMAT_TOO_SLOW}
2795 var
2796 Stream : TMemoryStream;
2797 FileSize : longInt;
2798 BitmapFileHeader : TBitmapFileHeader;
2799 {$endif}
2800 begin
2801 {$ifdef PIXELFORMAT_TOO_SLOW}
2802
2803 {$ifdef CREATEDIBSECTION_SLOW}
2804 if (FDIBBits = nil) then
2805 {$else}
2806 if (FDIB = 0) then
2807 {$endif}
2808 exit;
2809
2810 // Win95 and NT differs in what solution performs best
2811 {$ifndef CREATEDIBSECTION_SLOW}
2812 {$ifdef VER10_PLUS}
2813 if (Win32Platform = VER_PLATFORM_WIN32_NT) then
2814 begin
2815 // Assign DIB to bitmap
2816 FBitmap.Handle := FDIB;
2817 FDIB := 0;
2818 FBitmap.Palette := CopyPalette(Palette);
2819 end else
2820 {$endif}
2821 {$endif}
2822 begin
2823 // Write DIB to a stream in the BMP file format
2824 Stream := TMemoryStream.Create;
2825 try
2826 // Make room in stream for a TBitmapInfo and pixel data
2827 FileSize := sizeof(TBitmapFileHeader) + FDIBInfoSize + FDIBBitsSize;
2828 Stream.SetSize(FileSize);
2829 // Initialize file header
2830 FillChar(BitmapFileHeader, sizeof(TBitmapFileHeader), 0);
2831 with BitmapFileHeader do
2832 begin
2833 bfType := $4D42; // 'BM' = Windows BMP signature
2834 bfSize := FileSize; // File size (not needed)
2835 bfOffBits := sizeof(TBitmapFileHeader) + FDIBInfoSize; // Offset of pixel data
2836 end;
2837 // Save file header
2838 Stream.Write(BitmapFileHeader, sizeof(TBitmapFileHeader));
2839 // Save TBitmapInfo structure
2840 Stream.Write(FDIBInfo^, FDIBInfoSize);
2841 // Save pixel data
2842 Stream.Write(FDIBBits^, FDIBBitsSize);
2843
2844 // Rewind and load bitmap from stream
2845 Stream.Position := 0;
2846 FBitmap.LoadFromStream(Stream);
2847 finally
2848 Stream.Free;
2849 end;
2850 end;
2851 {$endif}
2852 end;
2853
2854 ////////////////////////////////////////////////////////////////////////////////
2855 //
2856 // Color Mapping
2857 //
2858 ////////////////////////////////////////////////////////////////////////////////
2859 type
2860 TColorLookup = class(TObject)
2861 private
2862 FColors : integer;
2863 public
2864 constructor Create(Palette: hPalette); virtual;
Lookupnull2865 function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; virtual; abstract;
2866 property Colors: integer read FColors;
2867 end;
2868
2869 PRGBQuadArray = ^TRGBQuadArray; // From Delphi 3 graphics.pas
2870 TRGBQuadArray = array[Byte] of TRGBQuad; // From Delphi 3 graphics.pas
2871
2872 BGRArray = array[0..0] of TRGBTriple;
2873 PBGRArray = ^BGRArray;
2874
2875 PalArray = array[byte] of TPaletteEntry;
2876 PPalArray = ^PalArray;
2877
2878 // TFastColorLookup implements a simple but reasonably fast generic color
2879 // mapper. It trades precision for speed by reducing the size of the color
2880 // space.
2881 // Using a class instead of inline code results in a speed penalty of
2882 // approx. 15% but reduces the complexity of the color reduction routines that
2883 // uses it. If bitmap to GIF conversion speed is really important to you, the
2884 // implementation can easily be inlined again.
2885 TInverseLookup = array[0..1 SHL 15-1] of SmallInt;
2886 PInverseLookup = ^TInverseLookup;
2887
2888 TFastColorLookup = class(TColorLookup)
2889 private
2890 FPaletteEntries : PPalArray;
2891 FInverseLookup : PInverseLookup;
2892 public
2893 constructor Create(Palette: hPalette); override;
2894 destructor Destroy; override;
Lookupnull2895 function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; override;
2896 end;
2897
2898 // TSlowColorLookup implements a precise but very slow generic color mapper.
2899 // It uses the GetNearestPaletteIndex GDI function.
2900 // Note: Tests has shown TFastColorLookup to be more precise than
2901 // TSlowColorLookup in many cases. I can't explain why...
2902 TSlowColorLookup = class(TColorLookup)
2903 private
2904 FPaletteEntries : PPalArray;
2905 FPalette : hPalette;
2906 public
2907 constructor Create(Palette: hPalette); override;
2908 destructor Destroy; override;
2909 function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; override;
2910 end;
2911
2912 // TNetscapeColorLookup maps colors to the netscape 6*6*6 color cube.
2913 TNetscapeColorLookup = class(TColorLookup)
2914 public
2915 constructor Create(Palette: hPalette); override;
2916 function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; override;
2917 end;
2918
2919 // TGrayWindowsLookup maps colors to 4 shade palette.
2920 TGrayWindowsLookup = class(TSlowColorLookup)
2921 public
2922 constructor Create(Palette: hPalette); override;
2923 function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; override;
2924 end;
2925
2926 // TGrayScaleLookup maps colors to a uniform 256 shade palette.
2927 TGrayScaleLookup = class(TColorLookup)
2928 public
2929 constructor Create(Palette: hPalette); override;
2930 function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; override;
2931 end;
2932
2933 // TMonochromeLookup maps colors to a black/white palette.
2934 TMonochromeLookup = class(TColorLookup)
2935 public
2936 constructor Create(Palette: hPalette); override;
2937 function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; override;
2938 end;
2939
2940 constructor TColorLookup.Create(Palette: hPalette);
2941 begin
2942 inherited Create;
2943 end;
2944
2945 constructor TFastColorLookup.Create(Palette: hPalette);
2946 var
2947 i : integer;
2948 InverseIndex : integer;
2949 begin
2950 inherited Create(Palette);
2951
2952 GetMem(FPaletteEntries, sizeof(TPaletteEntry) * 256);
2953 FColors := GetPaletteEntries(Palette, 0, 256, FPaletteEntries^);
2954
2955 New(FInverseLookup);
2956 for i := low(TInverseLookup) to high(TInverseLookup) do
2957 FInverseLookup^[i] := -1;
2958
2959 // Premap palette colors
2960 if (FColors > 0) then
2961 for i := 0 to FColors-1 do
2962 with FPaletteEntries^[i] do
2963 begin
2964 InverseIndex := (peRed SHR 3) OR ((peGreen AND $F8) SHL 2) OR ((peBlue AND $F8) SHL 7);
2965 if (FInverseLookup^[InverseIndex] = -1) then
2966 FInverseLookup^[InverseIndex] := i;
2967 end;
2968 end;
2969
2970 destructor TFastColorLookup.Destroy;
2971 begin
2972 if (FPaletteEntries <> nil) then
2973 FreeMem(FPaletteEntries);
2974 if (FInverseLookup <> nil) then
2975 Dispose(FInverseLookup);
2976
2977 inherited Destroy;
2978 end;
2979
2980 // Map color to arbitrary palette
Lookupnull2981 function TFastColorLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
2982 var
2983 i : integer;
2984 InverseIndex : integer;
2985 Delta ,
2986 MinDelta ,
2987 MinColor : integer;
2988 begin
2989 // Reduce color space with 3 bits in each dimension
2990 InverseIndex := (Red SHR 3) OR ((Green AND $F8) SHL 2) OR ((Blue AND $F8) SHL 7);
2991
2992 if (FInverseLookup^[InverseIndex] <> -1) then
2993 Result := char(FInverseLookup^[InverseIndex])
2994 else
2995 begin
2996 // Sequential scan for nearest color to minimize euclidian distance
2997 MinDelta := 3 * (256 * 256);
2998 MinColor := 0;
2999 for i := 0 to FColors-1 do
3000 with FPaletteEntries[i] do
3001 begin
3002 Delta := ABS(peRed - Red) + ABS(peGreen - Green) + ABS(peBlue - Blue);
3003 if (Delta < MinDelta) then
3004 begin
3005 MinDelta := Delta;
3006 MinColor := i;
3007 end;
3008 end;
3009 Result := char(MinColor);
3010 FInverseLookup^[InverseIndex] := MinColor;
3011 end;
3012
3013 with FPaletteEntries^[ord(Result)] do
3014 begin
3015 R := peRed;
3016 G := peGreen;
3017 B := peBlue;
3018 end;
3019 end;
3020
3021 constructor TSlowColorLookup.Create(Palette: hPalette);
3022 begin
3023 inherited Create(Palette);
3024 FPalette := Palette;
3025 FColors := GetPaletteEntries(Palette, 0, 256, nil^);
3026 if (FColors > 0) then
3027 begin
3028 GetMem(FPaletteEntries, sizeof(TPaletteEntry) * FColors);
3029 FColors := GetPaletteEntries(Palette, 0, 256, FPaletteEntries^);
3030 end;
3031 end;
3032
3033 destructor TSlowColorLookup.Destroy;
3034 begin
3035 if (FPaletteEntries <> nil) then
3036 FreeMem(FPaletteEntries);
3037
3038 inherited Destroy;
3039 end;
3040
3041 // Map color to arbitrary palette
Lookupnull3042 function TSlowColorLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
3043 begin
3044 Result := char(GetNearestPaletteIndex(FPalette, Red OR (Green SHL 8) OR (Blue SHL 16)));
3045 if (FPaletteEntries <> nil) then
3046 with FPaletteEntries^[ord(Result)] do
3047 begin
3048 R := peRed;
3049 G := peGreen;
3050 B := peBlue;
3051 end;
3052 end;
3053
3054 constructor TNetscapeColorLookup.Create(Palette: hPalette);
3055 begin
3056 inherited Create(Palette);
3057 FColors := 6*6*6; // This better be true or something is wrong
3058 end;
3059
3060 // Map color to netscape 6*6*6 color cube
Lookupnull3061 function TNetscapeColorLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
3062 begin
3063 R := (Red+3) DIV 51;
3064 G := (Green+3) DIV 51;
3065 B := (Blue+3) DIV 51;
3066 Result := char(B + 6*G + 36*R);
3067 R := R * 51;
3068 G := G * 51;
3069 B := B * 51;
3070 end;
3071
3072 constructor TGrayWindowsLookup.Create(Palette: hPalette);
3073 begin
3074 inherited Create(Palette);
3075 FColors := 4;
3076 end;
3077
3078 // Convert color to windows grays
Lookupnull3079 function TGrayWindowsLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
3080 begin
3081 Result := inherited Lookup(MulDiv(Red, 77, 256),
3082 MulDiv(Green, 150, 256), MulDiv(Blue, 29, 256), R, G, B);
3083 end;
3084
3085 constructor TGrayScaleLookup.Create(Palette: hPalette);
3086 begin
3087 inherited Create(Palette);
3088 FColors := 256;
3089 end;
3090
3091 // Convert color to grayscale
Lookupnull3092 function TGrayScaleLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
3093 begin
3094 Result := char((Blue*29 + Green*150 + Red*77) DIV 256);
3095 R := ord(Result);
3096 G := ord(Result);
3097 B := ord(Result);
3098 end;
3099
3100 constructor TMonochromeLookup.Create(Palette: hPalette);
3101 begin
3102 inherited Create(Palette);
3103 FColors := 2;
3104 end;
3105
3106 // Convert color to black/white
Lookupnull3107 function TMonochromeLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
3108 begin
3109 if ((Blue*29 + Green*150 + Red*77) > 32512) then
3110 begin
3111 Result := #1;
3112 R := 255;
3113 G := 255;
3114 B := 255;
3115 end else
3116 begin
3117 Result := #0;
3118 R := 0;
3119 G := 0;
3120 B := 0;
3121 end;
3122 end;
3123
3124 ////////////////////////////////////////////////////////////////////////////////
3125 //
3126 // Dithering engine
3127 //
3128 ////////////////////////////////////////////////////////////////////////////////
3129 type
3130 TDitherEngine = class
3131 private
3132 protected
3133 FDirection : integer;
3134 FColumn : integer;
3135 FLookup : TColorLookup;
3136 Width : integer;
3137 public
3138 constructor Create(AWidth: integer; Lookup: TColorLookup); virtual;
3139 function Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; virtual;
3140 procedure NextLine; virtual;
3141 procedure NextColumn;
3142
3143 property Direction: integer read FDirection;
3144 property Column: integer read FColumn;
3145 end;
3146
3147 // Note: TErrorTerm does only *need* to be 16 bits wide, but since
3148 // it is *much* faster to use native machine words (32 bit), we sacrifice
3149 // some bytes (a lot actually) to improve performance.
3150 TErrorTerm = Integer;
3151 TErrors = array[0..0] of TErrorTerm;
3152 PErrors = ^TErrors;
3153
3154 TFloydSteinbergDitherer = class(TDitherEngine)
3155 private
3156 ErrorsR ,
3157 ErrorsG ,
3158 ErrorsB : PErrors;
3159 ErrorR ,
3160 ErrorG ,
3161 ErrorB : PErrors;
3162 CurrentErrorR , // Current error or pixel value
3163 CurrentErrorG ,
3164 CurrentErrorB ,
3165 BelowErrorR , // Error for pixel below current
3166 BelowErrorG ,
3167 BelowErrorB ,
3168 BelowPrevErrorR , // Error for pixel below previous pixel
3169 BelowPrevErrorG ,
3170 BelowPrevErrorB : TErrorTerm;
3171 public
3172 constructor Create(AWidth: integer; Lookup: TColorLookup); override;
3173 destructor Destroy; override;
3174 function Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; override;
3175 procedure NextLine; override;
3176 end;
3177
3178 T5by3Ditherer = class(TDitherEngine)
3179 private
3180 ErrorsR0 ,
3181 ErrorsG0 ,
3182 ErrorsB0 ,
3183 ErrorsR1 ,
3184 ErrorsG1 ,
3185 ErrorsB1 ,
3186 ErrorsR2 ,
3187 ErrorsG2 ,
3188 ErrorsB2 : PErrors;
3189 ErrorR0 ,
3190 ErrorG0 ,
3191 ErrorB0 ,
3192 ErrorR1 ,
3193 ErrorG1 ,
3194 ErrorB1 ,
3195 ErrorR2 ,
3196 ErrorG2 ,
3197 ErrorB2 : PErrors;
3198 FDirection2 : integer;
3199 protected
3200 FDivisor : integer;
3201 procedure Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer); virtual; abstract;
3202 public
3203 constructor Create(AWidth: integer; Lookup: TColorLookup); override;
3204 destructor Destroy; override;
3205 function Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; override;
3206 procedure NextLine; override;
3207 end;
3208
3209 TStuckiDitherer = class(T5by3Ditherer)
3210 protected
3211 procedure Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer); override;
3212 public
3213 constructor Create(AWidth: integer; Lookup: TColorLookup); override;
3214 end;
3215
3216 TSierraDitherer = class(T5by3Ditherer)
3217 protected
3218 procedure Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer); override;
3219 public
3220 constructor Create(AWidth: integer; Lookup: TColorLookup); override;
3221 end;
3222
3223 TJaJuNiDitherer = class(T5by3Ditherer)
3224 protected
3225 procedure Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer); override;
3226 public
3227 constructor Create(AWidth: integer; Lookup: TColorLookup); override;
3228 end;
3229
3230 TSteveArcheDitherer = class(TDitherEngine)
3231 private
3232 ErrorsR0 ,
3233 ErrorsG0 ,
3234 ErrorsB0 ,
3235 ErrorsR1 ,
3236 ErrorsG1 ,
3237 ErrorsB1 ,
3238 ErrorsR2 ,
3239 ErrorsG2 ,
3240 ErrorsB2 ,
3241 ErrorsR3 ,
3242 ErrorsG3 ,
3243 ErrorsB3 : PErrors;
3244 ErrorR0 ,
3245 ErrorG0 ,
3246 ErrorB0 ,
3247 ErrorR1 ,
3248 ErrorG1 ,
3249 ErrorB1 ,
3250 ErrorR2 ,
3251 ErrorG2 ,
3252 ErrorB2 ,
3253 ErrorR3 ,
3254 ErrorG3 ,
3255 ErrorB3 : PErrors;
3256 FDirection2 ,
3257 FDirection3 : integer;
3258 public
3259 constructor Create(AWidth: integer; Lookup: TColorLookup); override;
3260 destructor Destroy; override;
3261 function Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; override;
3262 procedure NextLine; override;
3263 end;
3264
3265 TBurkesDitherer = class(TDitherEngine)
3266 private
3267 ErrorsR0 ,
3268 ErrorsG0 ,
3269 ErrorsB0 ,
3270 ErrorsR1 ,
3271 ErrorsG1 ,
3272 ErrorsB1 : PErrors;
3273 ErrorR0 ,
3274 ErrorG0 ,
3275 ErrorB0 ,
3276 ErrorR1 ,
3277 ErrorG1 ,
3278 ErrorB1 : PErrors;
3279 FDirection2 : integer;
3280 public
3281 constructor Create(AWidth: integer; Lookup: TColorLookup); override;
3282 destructor Destroy; override;
3283 function Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; override;
3284 procedure NextLine; override;
3285 end;
3286
3287 ////////////////////////////////////////////////////////////////////////////////
3288 // TDitherEngine
3289 constructor TDitherEngine.Create(AWidth: integer; Lookup: TColorLookup);
3290 begin
3291 inherited Create;
3292
3293 FLookup := Lookup;
3294 Width := AWidth;
3295
3296 FDirection := 1;
3297 FColumn := 0;
3298 end;
3299
Dithernull3300 function TDitherEngine.Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
3301 begin
3302 // Map color to palette
3303 Result := FLookup.Lookup(Red, Green, Blue, R, G, B);
3304 NextColumn;
3305 end;
3306
3307 procedure TDitherEngine.NextLine;
3308 begin
3309 FDirection := -FDirection;
3310 if (FDirection = 1) then
3311 FColumn := 0
3312 else
3313 FColumn := Width-1;
3314 end;
3315
3316 procedure TDitherEngine.NextColumn;
3317 begin
3318 inc(FColumn, FDirection);
3319 end;
3320
3321 ////////////////////////////////////////////////////////////////////////////////
3322 // TFloydSteinbergDitherer
3323 constructor TFloydSteinbergDitherer.Create(AWidth: integer; Lookup: TColorLookup);
3324 begin
3325 inherited Create(AWidth, Lookup);
3326
3327 // The Error arrays has (columns + 2) entries; the extra entry at
3328 // each end saves us from special-casing the first and last pixels.
3329 // We can get away with a single array (holding one row's worth of errors)
3330 // by using it to store the current row's errors at pixel columns not yet
3331 // processed, but the next row's errors at columns already processed. We
3332 // need only a few extra variables to hold the errors immediately around the
3333 // current column. (If we are lucky, those variables are in registers, but
3334 // even if not, they're probably cheaper to access than array elements are.)
3335 GetMem(ErrorsR, sizeof(TErrorTerm)*(Width+2));
3336 GetMem(ErrorsG, sizeof(TErrorTerm)*(Width+2));
3337 GetMem(ErrorsB, sizeof(TErrorTerm)*(Width+2));
3338 FillChar(ErrorsR^, sizeof(TErrorTerm)*(Width+2), 0);
3339 FillChar(ErrorsG^, sizeof(TErrorTerm)*(Width+2), 0);
3340 FillChar(ErrorsB^, sizeof(TErrorTerm)*(Width+2), 0);
3341 ErrorR := ErrorsR;
3342 ErrorG := ErrorsG;
3343 ErrorB := ErrorsB;
3344 CurrentErrorR := 0;
3345 CurrentErrorG := CurrentErrorR;
3346 CurrentErrorB := CurrentErrorR;
3347 BelowErrorR := CurrentErrorR;
3348 BelowErrorG := CurrentErrorR;
3349 BelowErrorB := CurrentErrorR;
3350 BelowPrevErrorR := CurrentErrorR;
3351 BelowPrevErrorG := CurrentErrorR;
3352 BelowPrevErrorB := CurrentErrorR;
3353 end;
3354
3355 destructor TFloydSteinbergDitherer.Destroy;
3356 begin
3357 FreeMem(ErrorsR);
3358 FreeMem(ErrorsG);
3359 FreeMem(ErrorsB);
3360 inherited Destroy;
3361 end;
3362
3363 {$IFOPT R+}
3364 {$DEFINE R_PLUS}
3365 {$RANGECHECKS OFF}
3366 {$ENDIF}
Dithernull3367 function TFloydSteinbergDitherer.Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
3368 var
3369 BelowNextError : TErrorTerm;
3370 Delta : TErrorTerm;
3371 begin
3372 CurrentErrorR := Red + (CurrentErrorR + ErrorR[0] + 8) DIV 16;
3373 // CurrentErrorR := Red + (CurrentErrorR + ErrorR[Direction] + 8) DIV 16;
3374 if (CurrentErrorR < 0) then
3375 CurrentErrorR := 0
3376 else if (CurrentErrorR > 255) then
3377 CurrentErrorR := 255;
3378
3379 CurrentErrorG := Green + (CurrentErrorG + ErrorG[0] + 8) DIV 16;
3380 // CurrentErrorG := Green + (CurrentErrorG + ErrorG[Direction] + 8) DIV 16;
3381 if (CurrentErrorG < 0) then
3382 CurrentErrorG := 0
3383 else if (CurrentErrorG > 255) then
3384 CurrentErrorG := 255;
3385
3386 CurrentErrorB := Blue + (CurrentErrorB + ErrorB[0] + 8) DIV 16;
3387 // CurrentErrorB := Blue + (CurrentErrorB + ErrorB[Direction] + 8) DIV 16;
3388 if (CurrentErrorB < 0) then
3389 CurrentErrorB := 0
3390 else if (CurrentErrorB > 255) then
3391 CurrentErrorB := 255;
3392
3393 // Map color to palette
3394 Result := inherited Dither(CurrentErrorR, CurrentErrorG, CurrentErrorB, R, G, B);
3395
3396 // Propagate Floyd-Steinberg error terms.
3397 // Errors are accumulated into the error arrays, at a resolution of
3398 // 1/16th of a pixel count. The error at a given pixel is propagated
3399 // to its not-yet-processed neighbors using the standard F-S fractions,
3400 // ... (here) 7/16
3401 // 3/16 5/16 1/16
3402 // We work left-to-right on even rows, right-to-left on odd rows.
3403
3404 // Red component
3405 CurrentErrorR := CurrentErrorR - R;
3406 if (CurrentErrorR <> 0) then
3407 begin
3408 BelowNextError := CurrentErrorR; // Error * 1
3409
3410 Delta := CurrentErrorR * 2;
3411 inc(CurrentErrorR, Delta);
3412 ErrorR[0] := BelowPrevErrorR + CurrentErrorR; // Error * 3
3413
3414 inc(CurrentErrorR, Delta);
3415 BelowPrevErrorR := BelowErrorR + CurrentErrorR; // Error * 5
3416
3417 BelowErrorR := BelowNextError; // Error * 1
3418
3419 inc(CurrentErrorR, Delta); // Error * 7
3420 end;
3421
3422 // Green component
3423 CurrentErrorG := CurrentErrorG - G;
3424 if (CurrentErrorG <> 0) then
3425 begin
3426 BelowNextError := CurrentErrorG; // Error * 1
3427
3428 Delta := CurrentErrorG * 2;
3429 inc(CurrentErrorG, Delta);
3430 ErrorG[0] := BelowPrevErrorG + CurrentErrorG; // Error * 3
3431
3432 inc(CurrentErrorG, Delta);
3433 BelowPrevErrorG := BelowErrorG + CurrentErrorG; // Error * 5
3434
3435 BelowErrorG := BelowNextError; // Error * 1
3436
3437 inc(CurrentErrorG, Delta); // Error * 7
3438 end;
3439
3440 // Blue component
3441 CurrentErrorB := CurrentErrorB - B;
3442 if (CurrentErrorB <> 0) then
3443 begin
3444 BelowNextError := CurrentErrorB; // Error * 1
3445
3446 Delta := CurrentErrorB * 2;
3447 inc(CurrentErrorB, Delta);
3448 ErrorB[0] := BelowPrevErrorB + CurrentErrorB; // Error * 3
3449
3450 inc(CurrentErrorB, Delta);
3451 BelowPrevErrorB := BelowErrorB + CurrentErrorB; // Error * 5
3452
3453 BelowErrorB := BelowNextError; // Error * 1
3454
3455 inc(CurrentErrorB, Delta); // Error * 7
3456 end;
3457
3458 // Move on to next column
3459 if (Direction = 1) then
3460 begin
3461 inc(longInt(ErrorR), sizeof(TErrorTerm));
3462 inc(longInt(ErrorG), sizeof(TErrorTerm));
3463 inc(longInt(ErrorB), sizeof(TErrorTerm));
3464 end else
3465 begin
3466 dec(longInt(ErrorR), sizeof(TErrorTerm));
3467 dec(longInt(ErrorG), sizeof(TErrorTerm));
3468 dec(longInt(ErrorB), sizeof(TErrorTerm));
3469 end;
3470 end;
3471 {$IFDEF R_PLUS}
3472 {$RANGECHECKS ON}
3473 {$UNDEF R_PLUS}
3474 {$ENDIF}
3475
3476 {$IFOPT R+}
3477 {$DEFINE R_PLUS}
3478 {$RANGECHECKS OFF}
3479 {$ENDIF}
3480 procedure TFloydSteinbergDitherer.NextLine;
3481 begin
3482 ErrorR[0] := BelowPrevErrorR;
3483 ErrorG[0] := BelowPrevErrorG;
3484 ErrorB[0] := BelowPrevErrorB;
3485
3486 // Note: The optimizer produces better code for this construct:
3487 // a := 0; b := a; c := a;
3488 // compared to this construct:
3489 // a := 0; b := 0; c := 0;
3490 CurrentErrorR := 0;
3491 CurrentErrorG := CurrentErrorR;
3492 CurrentErrorB := CurrentErrorG;
3493 BelowErrorR := CurrentErrorG;
3494 BelowErrorG := CurrentErrorG;
3495 BelowErrorB := CurrentErrorG;
3496 BelowPrevErrorR := CurrentErrorG;
3497 BelowPrevErrorG := CurrentErrorG;
3498 BelowPrevErrorB := CurrentErrorG;
3499
3500 inherited NextLine;
3501
3502 if (Direction = 1) then
3503 begin
3504 ErrorR := ErrorsR;
3505 ErrorG := ErrorsG;
3506 ErrorB := ErrorsB;
3507 end else
3508 begin
3509 ErrorR := @ErrorsR[Width+1];
3510 ErrorG := @ErrorsG[Width+1];
3511 ErrorB := @ErrorsB[Width+1];
3512 end;
3513 end;
3514 {$IFDEF R_PLUS}
3515 {$RANGECHECKS ON}
3516 {$UNDEF R_PLUS}
3517 {$ENDIF}
3518
3519 ////////////////////////////////////////////////////////////////////////////////
3520 // T5by3Ditherer
3521 constructor T5by3Ditherer.Create(AWidth: integer; Lookup: TColorLookup);
3522 begin
3523 inherited Create(AWidth, Lookup);
3524
3525 GetMem(ErrorsR0, sizeof(TErrorTerm)*(Width+4));
3526 GetMem(ErrorsG0, sizeof(TErrorTerm)*(Width+4));
3527 GetMem(ErrorsB0, sizeof(TErrorTerm)*(Width+4));
3528 GetMem(ErrorsR1, sizeof(TErrorTerm)*(Width+4));
3529 GetMem(ErrorsG1, sizeof(TErrorTerm)*(Width+4));
3530 GetMem(ErrorsB1, sizeof(TErrorTerm)*(Width+4));
3531 GetMem(ErrorsR2, sizeof(TErrorTerm)*(Width+4));
3532 GetMem(ErrorsG2, sizeof(TErrorTerm)*(Width+4));
3533 GetMem(ErrorsB2, sizeof(TErrorTerm)*(Width+4));
3534 FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+4), 0);
3535 FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+4), 0);
3536 FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+4), 0);
3537 FillChar(ErrorsR1^, sizeof(TErrorTerm)*(Width+4), 0);
3538 FillChar(ErrorsG1^, sizeof(TErrorTerm)*(Width+4), 0);
3539 FillChar(ErrorsB1^, sizeof(TErrorTerm)*(Width+4), 0);
3540 FillChar(ErrorsR2^, sizeof(TErrorTerm)*(Width+4), 0);
3541 FillChar(ErrorsG2^, sizeof(TErrorTerm)*(Width+4), 0);
3542 FillChar(ErrorsB2^, sizeof(TErrorTerm)*(Width+4), 0);
3543
3544 FDivisor := 1;
3545 FDirection2 := 2 * Direction;
3546 ErrorR0 := PErrors(longInt(ErrorsR0)+2*sizeof(TErrorTerm));
3547 ErrorG0 := PErrors(longInt(ErrorsG0)+2*sizeof(TErrorTerm));
3548 ErrorB0 := PErrors(longInt(ErrorsB0)+2*sizeof(TErrorTerm));
3549 ErrorR1 := PErrors(longInt(ErrorsR1)+2*sizeof(TErrorTerm));
3550 ErrorG1 := PErrors(longInt(ErrorsG1)+2*sizeof(TErrorTerm));
3551 ErrorB1 := PErrors(longInt(ErrorsB1)+2*sizeof(TErrorTerm));
3552 ErrorR2 := PErrors(longInt(ErrorsR2)+2*sizeof(TErrorTerm));
3553 ErrorG2 := PErrors(longInt(ErrorsG2)+2*sizeof(TErrorTerm));
3554 ErrorB2 := PErrors(longInt(ErrorsB2)+2*sizeof(TErrorTerm));
3555 end;
3556
3557 destructor T5by3Ditherer.Destroy;
3558 begin
3559 FreeMem(ErrorsR0);
3560 FreeMem(ErrorsG0);
3561 FreeMem(ErrorsB0);
3562 FreeMem(ErrorsR1);
3563 FreeMem(ErrorsG1);
3564 FreeMem(ErrorsB1);
3565 FreeMem(ErrorsR2);
3566 FreeMem(ErrorsG2);
3567 FreeMem(ErrorsB2);
3568 inherited Destroy;
3569 end;
3570
3571 {$IFOPT R+}
3572 {$DEFINE R_PLUS}
3573 {$RANGECHECKS OFF}
3574 {$ENDIF}
Dithernull3575 function T5by3Ditherer.Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
3576 var
3577 ColorR ,
3578 ColorG ,
3579 ColorB : integer; // Error for current pixel
3580 begin
3581 // Apply red component error correction
3582 ColorR := Red + (ErrorR0[0] + FDivisor DIV 2) DIV FDivisor;
3583 if (ColorR < 0) then
3584 ColorR := 0
3585 else if (ColorR > 255) then
3586 ColorR := 255;
3587
3588 // Apply green component error correction
3589 ColorG := Green + (ErrorG0[0] + FDivisor DIV 2) DIV FDivisor;
3590 if (ColorG < 0) then
3591 ColorG := 0
3592 else if (ColorG > 255) then
3593 ColorG := 255;
3594
3595 // Apply blue component error correction
3596 ColorB := Blue + (ErrorB0[0] + FDivisor DIV 2) DIV FDivisor;
3597 if (ColorB < 0) then
3598 ColorB := 0
3599 else if (ColorB > 255) then
3600 ColorB := 255;
3601
3602 // Map color to palette
3603 Result := inherited Dither(ColorR, ColorG, ColorB, R, G, B);
3604
3605 // Propagate red component error
3606 Propagate(ErrorR0, ErrorR1, ErrorR2, ColorR - R);
3607 // Propagate green component error
3608 Propagate(ErrorG0, ErrorG1, ErrorG2, ColorG - G);
3609 // Propagate blue component error
3610 Propagate(ErrorB0, ErrorB1, ErrorB2, ColorB - B);
3611
3612 // Move on to next column
3613 if (Direction = 1) then
3614 begin
3615 inc(longInt(ErrorR0), sizeof(TErrorTerm));
3616 inc(longInt(ErrorG0), sizeof(TErrorTerm));
3617 inc(longInt(ErrorB0), sizeof(TErrorTerm));
3618 inc(longInt(ErrorR1), sizeof(TErrorTerm));
3619 inc(longInt(ErrorG1), sizeof(TErrorTerm));
3620 inc(longInt(ErrorB1), sizeof(TErrorTerm));
3621 inc(longInt(ErrorR2), sizeof(TErrorTerm));
3622 inc(longInt(ErrorG2), sizeof(TErrorTerm));
3623 inc(longInt(ErrorB2), sizeof(TErrorTerm));
3624 end else
3625 begin
3626 dec(longInt(ErrorR0), sizeof(TErrorTerm));
3627 dec(longInt(ErrorG0), sizeof(TErrorTerm));
3628 dec(longInt(ErrorB0), sizeof(TErrorTerm));
3629 dec(longInt(ErrorR1), sizeof(TErrorTerm));
3630 dec(longInt(ErrorG1), sizeof(TErrorTerm));
3631 dec(longInt(ErrorB1), sizeof(TErrorTerm));
3632 dec(longInt(ErrorR2), sizeof(TErrorTerm));
3633 dec(longInt(ErrorG2), sizeof(TErrorTerm));
3634 dec(longInt(ErrorB2), sizeof(TErrorTerm));
3635 end;
3636 end;
3637 {$IFDEF R_PLUS}
3638 {$RANGECHECKS ON}
3639 {$UNDEF R_PLUS}
3640 {$ENDIF}
3641
3642 {$IFOPT R+}
3643 {$DEFINE R_PLUS}
3644 {$RANGECHECKS OFF}
3645 {$ENDIF}
3646 procedure T5by3Ditherer.NextLine;
3647 var
3648 TempErrors : PErrors;
3649 begin
3650 FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+4), 0);
3651 FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+4), 0);
3652 FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+4), 0);
3653
3654 // Swap lines
3655 TempErrors := ErrorsR0;
3656 ErrorsR0 := ErrorsR1;
3657 ErrorsR1 := ErrorsR2;
3658 ErrorsR2 := TempErrors;
3659
3660 TempErrors := ErrorsG0;
3661 ErrorsG0 := ErrorsG1;
3662 ErrorsG1 := ErrorsG2;
3663 ErrorsG2 := TempErrors;
3664
3665 TempErrors := ErrorsB0;
3666 ErrorsB0 := ErrorsB1;
3667 ErrorsB1 := ErrorsB2;
3668 ErrorsB2 := TempErrors;
3669
3670 inherited NextLine;
3671
3672 FDirection2 := 2 * Direction;
3673 if (Direction = 1) then
3674 begin
3675 // ErrorsR0[1] gives compiler error, so we
3676 // use PErrors(longInt(ErrorsR0)+sizeof(TErrorTerm)) instead...
3677 ErrorR0 := PErrors(longInt(ErrorsR0)+2*sizeof(TErrorTerm));
3678 ErrorG0 := PErrors(longInt(ErrorsG0)+2*sizeof(TErrorTerm));
3679 ErrorB0 := PErrors(longInt(ErrorsB0)+2*sizeof(TErrorTerm));
3680 ErrorR1 := PErrors(longInt(ErrorsR1)+2*sizeof(TErrorTerm));
3681 ErrorG1 := PErrors(longInt(ErrorsG1)+2*sizeof(TErrorTerm));
3682 ErrorB1 := PErrors(longInt(ErrorsB1)+2*sizeof(TErrorTerm));
3683 ErrorR2 := PErrors(longInt(ErrorsR2)+2*sizeof(TErrorTerm));
3684 ErrorG2 := PErrors(longInt(ErrorsG2)+2*sizeof(TErrorTerm));
3685 ErrorB2 := PErrors(longInt(ErrorsB2)+2*sizeof(TErrorTerm));
3686 end else
3687 begin
3688 ErrorR0 := @ErrorsR0[Width+1];
3689 ErrorG0 := @ErrorsG0[Width+1];
3690 ErrorB0 := @ErrorsB0[Width+1];
3691 ErrorR1 := @ErrorsR1[Width+1];
3692 ErrorG1 := @ErrorsG1[Width+1];
3693 ErrorB1 := @ErrorsB1[Width+1];
3694 ErrorR2 := @ErrorsR2[Width+1];
3695 ErrorG2 := @ErrorsG2[Width+1];
3696 ErrorB2 := @ErrorsB2[Width+1];
3697 end;
3698 end;
3699 {$IFDEF R_PLUS}
3700 {$RANGECHECKS ON}
3701 {$UNDEF R_PLUS}
3702 {$ENDIF}
3703
3704 ////////////////////////////////////////////////////////////////////////////////
3705 // TStuckiDitherer
3706 constructor TStuckiDitherer.Create(AWidth: integer; Lookup: TColorLookup);
3707 begin
3708 inherited Create(AWidth, Lookup);
3709 FDivisor := 42;
3710 end;
3711
3712 {$IFOPT R+}
3713 {$DEFINE R_PLUS}
3714 {$RANGECHECKS OFF}
3715 {$ENDIF}
3716 procedure TStuckiDitherer.Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer);
3717 begin
3718 if (Error = 0) then
3719 exit;
3720 // Propagate Stucki error terms:
3721 // ... ... (here) 8/42 4/42
3722 // 2/42 4/42 8/42 4/42 2/42
3723 // 1/42 2/42 4/42 2/42 1/42
3724 inc(Errors2[FDirection2], Error); // Error * 1
3725 inc(Errors2[-FDirection2], Error); // Error * 1
3726
3727 Error := Error + Error;
3728 inc(Errors1[FDirection2], Error); // Error * 2
3729 inc(Errors1[-FDirection2], Error); // Error * 2
3730 inc(Errors2[Direction], Error); // Error * 2
3731 inc(Errors2[-Direction], Error); // Error * 2
3732
3733 Error := Error + Error;
3734 inc(Errors0[FDirection2], Error); // Error * 4
3735 inc(Errors1[-Direction], Error); // Error * 4
3736 inc(Errors1[Direction], Error); // Error * 4
3737 inc(Errors2[0], Error); // Error * 4
3738
3739 Error := Error + Error;
3740 inc(Errors0[Direction], Error); // Error * 8
3741 inc(Errors1[0], Error); // Error * 8
3742 end;
3743 {$IFDEF R_PLUS}
3744 {$RANGECHECKS ON}
3745 {$UNDEF R_PLUS}
3746 {$ENDIF}
3747
3748 ////////////////////////////////////////////////////////////////////////////////
3749 // TSierraDitherer
3750 constructor TSierraDitherer.Create(AWidth: integer; Lookup: TColorLookup);
3751 begin
3752 inherited Create(AWidth, Lookup);
3753 FDivisor := 32;
3754 end;
3755
3756 {$IFOPT R+}
3757 {$DEFINE R_PLUS}
3758 {$RANGECHECKS OFF}
3759 {$ENDIF}
3760 procedure TSierraDitherer.Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer);
3761 var
3762 TempError : integer;
3763 begin
3764 if (Error = 0) then
3765 exit;
3766 // Propagate Sierra error terms:
3767 // ... ... (here) 5/32 3/32
3768 // 2/32 4/32 5/32 4/32 2/32
3769 // ... 2/32 3/32 2/32 ...
3770 TempError := Error + Error;
3771 inc(Errors1[FDirection2], TempError); // Error * 2
3772 inc(Errors1[-FDirection2], TempError);// Error * 2
3773 inc(Errors2[Direction], TempError); // Error * 2
3774 inc(Errors2[-Direction], TempError); // Error * 2
3775
3776 inc(TempError, Error);
3777 inc(Errors0[FDirection2], TempError); // Error * 3
3778 inc(Errors2[0], TempError); // Error * 3
3779
3780 inc(TempError, Error);
3781 inc(Errors1[-Direction], TempError); // Error * 4
3782 inc(Errors1[Direction], TempError); // Error * 4
3783
3784 inc(TempError, Error);
3785 inc(Errors0[Direction], TempError); // Error * 5
3786 inc(Errors1[0], TempError); // Error * 5
3787 end;
3788 {$IFDEF R_PLUS}
3789 {$RANGECHECKS ON}
3790 {$UNDEF R_PLUS}
3791 {$ENDIF}
3792
3793 ////////////////////////////////////////////////////////////////////////////////
3794 // TJaJuNiDitherer
3795 constructor TJaJuNiDitherer.Create(AWidth: integer; Lookup: TColorLookup);
3796 begin
3797 inherited Create(AWidth, Lookup);
3798 FDivisor := 38;
3799 end;
3800
3801 {$IFOPT R+}
3802 {$DEFINE R_PLUS}
3803 {$RANGECHECKS OFF}
3804 {$ENDIF}
3805 procedure TJaJuNiDitherer.Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer);
3806 var
3807 TempError : integer;
3808 begin
3809 if (Error = 0) then
3810 exit;
3811 // Propagate Jarvis, Judice and Ninke error terms:
3812 // ... ... (here) 8/38 4/38
3813 // 2/38 4/38 8/38 4/38 2/38
3814 // 1/38 2/38 4/38 2/38 1/38
3815 inc(Errors2[FDirection2], Error); // Error * 1
3816 inc(Errors2[-FDirection2], Error); // Error * 1
3817
3818 TempError := Error + Error;
3819 inc(Error, TempError);
3820 inc(Errors1[FDirection2], Error); // Error * 3
3821 inc(Errors1[-FDirection2], Error); // Error * 3
3822 inc(Errors2[Direction], Error); // Error * 3
3823 inc(Errors2[-Direction], Error); // Error * 3
3824
3825 inc(Error, TempError);
3826 inc(Errors0[FDirection2], Error); // Error * 5
3827 inc(Errors1[-Direction], Error); // Error * 5
3828 inc(Errors1[Direction], Error); // Error * 5
3829 inc(Errors2[0], Error); // Error * 5
3830
3831 inc(Error, TempError);
3832 inc(Errors0[Direction], Error); // Error * 7
3833 inc(Errors1[0], Error); // Error * 7
3834 end;
3835 {$IFDEF R_PLUS}
3836 {$RANGECHECKS ON}
3837 {$UNDEF R_PLUS}
3838 {$ENDIF}
3839
3840 ////////////////////////////////////////////////////////////////////////////////
3841 // TSteveArcheDitherer
3842 constructor TSteveArcheDitherer.Create(AWidth: integer; Lookup: TColorLookup);
3843 begin
3844 inherited Create(AWidth, Lookup);
3845
3846 GetMem(ErrorsR0, sizeof(TErrorTerm)*(Width+6));
3847 GetMem(ErrorsG0, sizeof(TErrorTerm)*(Width+6));
3848 GetMem(ErrorsB0, sizeof(TErrorTerm)*(Width+6));
3849 GetMem(ErrorsR1, sizeof(TErrorTerm)*(Width+6));
3850 GetMem(ErrorsG1, sizeof(TErrorTerm)*(Width+6));
3851 GetMem(ErrorsB1, sizeof(TErrorTerm)*(Width+6));
3852 GetMem(ErrorsR2, sizeof(TErrorTerm)*(Width+6));
3853 GetMem(ErrorsG2, sizeof(TErrorTerm)*(Width+6));
3854 GetMem(ErrorsB2, sizeof(TErrorTerm)*(Width+6));
3855 GetMem(ErrorsR3, sizeof(TErrorTerm)*(Width+6));
3856 GetMem(ErrorsG3, sizeof(TErrorTerm)*(Width+6));
3857 GetMem(ErrorsB3, sizeof(TErrorTerm)*(Width+6));
3858 FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+6), 0);
3859 FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+6), 0);
3860 FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+6), 0);
3861 FillChar(ErrorsR1^, sizeof(TErrorTerm)*(Width+6), 0);
3862 FillChar(ErrorsG1^, sizeof(TErrorTerm)*(Width+6), 0);
3863 FillChar(ErrorsB1^, sizeof(TErrorTerm)*(Width+6), 0);
3864 FillChar(ErrorsR2^, sizeof(TErrorTerm)*(Width+6), 0);
3865 FillChar(ErrorsG2^, sizeof(TErrorTerm)*(Width+6), 0);
3866 FillChar(ErrorsB2^, sizeof(TErrorTerm)*(Width+6), 0);
3867 FillChar(ErrorsR3^, sizeof(TErrorTerm)*(Width+6), 0);
3868 FillChar(ErrorsG3^, sizeof(TErrorTerm)*(Width+6), 0);
3869 FillChar(ErrorsB3^, sizeof(TErrorTerm)*(Width+6), 0);
3870
3871 FDirection2 := 2 * Direction;
3872 FDirection3 := 3 * Direction;
3873
3874 ErrorR0 := PErrors(longInt(ErrorsR0)+3*sizeof(TErrorTerm));
3875 ErrorG0 := PErrors(longInt(ErrorsG0)+3*sizeof(TErrorTerm));
3876 ErrorB0 := PErrors(longInt(ErrorsB0)+3*sizeof(TErrorTerm));
3877 ErrorR1 := PErrors(longInt(ErrorsR1)+3*sizeof(TErrorTerm));
3878 ErrorG1 := PErrors(longInt(ErrorsG1)+3*sizeof(TErrorTerm));
3879 ErrorB1 := PErrors(longInt(ErrorsB1)+3*sizeof(TErrorTerm));
3880 ErrorR2 := PErrors(longInt(ErrorsR2)+3*sizeof(TErrorTerm));
3881 ErrorG2 := PErrors(longInt(ErrorsG2)+3*sizeof(TErrorTerm));
3882 ErrorB2 := PErrors(longInt(ErrorsB2)+3*sizeof(TErrorTerm));
3883 ErrorR3 := PErrors(longInt(ErrorsR3)+3*sizeof(TErrorTerm));
3884 ErrorG3 := PErrors(longInt(ErrorsG3)+3*sizeof(TErrorTerm));
3885 ErrorB3 := PErrors(longInt(ErrorsB3)+3*sizeof(TErrorTerm));
3886 end;
3887
3888 destructor TSteveArcheDitherer.Destroy;
3889 begin
3890 FreeMem(ErrorsR0);
3891 FreeMem(ErrorsG0);
3892 FreeMem(ErrorsB0);
3893 FreeMem(ErrorsR1);
3894 FreeMem(ErrorsG1);
3895 FreeMem(ErrorsB1);
3896 FreeMem(ErrorsR2);
3897 FreeMem(ErrorsG2);
3898 FreeMem(ErrorsB2);
3899 FreeMem(ErrorsR3);
3900 FreeMem(ErrorsG3);
3901 FreeMem(ErrorsB3);
3902 inherited Destroy;
3903 end;
3904
3905 {$IFOPT R+}
3906 {$DEFINE R_PLUS}
3907 {$RANGECHECKS OFF}
3908 {$ENDIF}
Dithernull3909 function TSteveArcheDitherer.Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
3910 var
3911 ColorR ,
3912 ColorG ,
3913 ColorB : integer; // Error for current pixel
3914
3915 // Propagate Stevenson & Arche error terms:
3916 // ... ... ... (here) ... 32/200 ...
3917 // 12/200 ... 26/200 ... 30/200 ... 16/200
3918 // ... 12/200 ... 26/200 ... 12/200 ...
3919 // 5/200 ... 12/200 ... 12/200 ... 5/200
3920 procedure Propagate(Errors0, Errors1, Errors2, Errors3: PErrors; Error: integer);
3921 var
3922 TempError : integer;
3923 begin
3924 if (Error = 0) then
3925 exit;
3926 TempError := 5 * Error;
3927 inc(Errors3[FDirection3], TempError); // Error * 5
3928 inc(Errors3[-FDirection3], TempError); // Error * 5
3929
3930 TempError := 12 * Error;
3931 inc(Errors1[-FDirection3], TempError); // Error * 12
3932 inc(Errors2[-FDirection2], TempError); // Error * 12
3933 inc(Errors2[FDirection2], TempError); // Error * 12
3934 inc(Errors3[-Direction], TempError); // Error * 12
3935 inc(Errors3[Direction], TempError); // Error * 12
3936
3937 inc(Errors1[FDirection3], 16 * TempError); // Error * 16
3938
3939 TempError := 26 * Error;
3940 inc(Errors1[-Direction], TempError); // Error * 26
3941 inc(Errors2[0], TempError); // Error * 26
3942
3943 inc(Errors1[Direction], 30 * Error); // Error * 30
3944
3945 inc(Errors0[FDirection2], 32 * Error); // Error * 32
3946 end;
3947
3948 begin
3949 // Apply red component error correction
3950 ColorR := Red + (ErrorR0[0] + 100) DIV 200;
3951 if (ColorR < 0) then
3952 ColorR := 0
3953 else if (ColorR > 255) then
3954 ColorR := 255;
3955
3956 // Apply green component error correction
3957 ColorG := Green + (ErrorG0[0] + 100) DIV 200;
3958 if (ColorG < 0) then
3959 ColorG := 0
3960 else if (ColorG > 255) then
3961 ColorG := 255;
3962
3963 // Apply blue component error correction
3964 ColorB := Blue + (ErrorB0[0] + 100) DIV 200;
3965 if (ColorB < 0) then
3966 ColorB := 0
3967 else if (ColorB > 255) then
3968 ColorB := 255;
3969
3970 // Map color to palette
3971 Result := inherited Dither(ColorR, ColorG, ColorB, R, G, B);
3972
3973 // Propagate red component error
3974 Propagate(ErrorR0, ErrorR1, ErrorR2, ErrorR3, ColorR - R);
3975 // Propagate green component error
3976 Propagate(ErrorG0, ErrorG1, ErrorG2, ErrorG3, ColorG - G);
3977 // Propagate blue component error
3978 Propagate(ErrorB0, ErrorB1, ErrorB2, ErrorB3, ColorB - B);
3979
3980 // Move on to next column
3981 if (Direction = 1) then
3982 begin
3983 inc(longInt(ErrorR0), sizeof(TErrorTerm));
3984 inc(longInt(ErrorG0), sizeof(TErrorTerm));
3985 inc(longInt(ErrorB0), sizeof(TErrorTerm));
3986 inc(longInt(ErrorR1), sizeof(TErrorTerm));
3987 inc(longInt(ErrorG1), sizeof(TErrorTerm));
3988 inc(longInt(ErrorB1), sizeof(TErrorTerm));
3989 inc(longInt(ErrorR2), sizeof(TErrorTerm));
3990 inc(longInt(ErrorG2), sizeof(TErrorTerm));
3991 inc(longInt(ErrorB2), sizeof(TErrorTerm));
3992 inc(longInt(ErrorR3), sizeof(TErrorTerm));
3993 inc(longInt(ErrorG3), sizeof(TErrorTerm));
3994 inc(longInt(ErrorB3), sizeof(TErrorTerm));
3995 end else
3996 begin
3997 dec(longInt(ErrorR0), sizeof(TErrorTerm));
3998 dec(longInt(ErrorG0), sizeof(TErrorTerm));
3999 dec(longInt(ErrorB0), sizeof(TErrorTerm));
4000 dec(longInt(ErrorR1), sizeof(TErrorTerm));
4001 dec(longInt(ErrorG1), sizeof(TErrorTerm));
4002 dec(longInt(ErrorB1), sizeof(TErrorTerm));
4003 dec(longInt(ErrorR2), sizeof(TErrorTerm));
4004 dec(longInt(ErrorG2), sizeof(TErrorTerm));
4005 dec(longInt(ErrorB2), sizeof(TErrorTerm));
4006 dec(longInt(ErrorR3), sizeof(TErrorTerm));
4007 dec(longInt(ErrorG3), sizeof(TErrorTerm));
4008 dec(longInt(ErrorB3), sizeof(TErrorTerm));
4009 end;
4010 end;
4011 {$IFDEF R_PLUS}
4012 {$RANGECHECKS ON}
4013 {$UNDEF R_PLUS}
4014 {$ENDIF}
4015
4016 {$IFOPT R+}
4017 {$DEFINE R_PLUS}
4018 {$RANGECHECKS OFF}
4019 {$ENDIF}
4020 procedure TSteveArcheDitherer.NextLine;
4021 var
4022 TempErrors : PErrors;
4023 begin
4024 FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+6), 0);
4025 FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+6), 0);
4026 FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+6), 0);
4027
4028 // Swap lines
4029 TempErrors := ErrorsR0;
4030 ErrorsR0 := ErrorsR1;
4031 ErrorsR1 := ErrorsR2;
4032 ErrorsR2 := ErrorsR3;
4033 ErrorsR3 := TempErrors;
4034
4035 TempErrors := ErrorsG0;
4036 ErrorsG0 := ErrorsG1;
4037 ErrorsG1 := ErrorsG2;
4038 ErrorsG2 := ErrorsG3;
4039 ErrorsG3 := TempErrors;
4040
4041 TempErrors := ErrorsB0;
4042 ErrorsB0 := ErrorsB1;
4043 ErrorsB1 := ErrorsB2;
4044 ErrorsB2 := ErrorsB3;
4045 ErrorsB3 := TempErrors;
4046
4047 inherited NextLine;
4048
4049 FDirection2 := 2 * Direction;
4050 FDirection3 := 3 * Direction;
4051
4052 if (Direction = 1) then
4053 begin
4054 // ErrorsR0[1] gives compiler error, so we
4055 // use PErrors(longInt(ErrorsR0)+sizeof(TErrorTerm)) instead...
4056 ErrorR0 := PErrors(longInt(ErrorsR0)+3*sizeof(TErrorTerm));
4057 ErrorG0 := PErrors(longInt(ErrorsG0)+3*sizeof(TErrorTerm));
4058 ErrorB0 := PErrors(longInt(ErrorsB0)+3*sizeof(TErrorTerm));
4059 ErrorR1 := PErrors(longInt(ErrorsR1)+3*sizeof(TErrorTerm));
4060 ErrorG1 := PErrors(longInt(ErrorsG1)+3*sizeof(TErrorTerm));
4061 ErrorB1 := PErrors(longInt(ErrorsB1)+3*sizeof(TErrorTerm));
4062 ErrorR2 := PErrors(longInt(ErrorsR2)+3*sizeof(TErrorTerm));
4063 ErrorG2 := PErrors(longInt(ErrorsG2)+3*sizeof(TErrorTerm));
4064 ErrorB2 := PErrors(longInt(ErrorsB2)+3*sizeof(TErrorTerm));
4065 ErrorR3 := PErrors(longInt(ErrorsR3)+3*sizeof(TErrorTerm));
4066 ErrorG3 := PErrors(longInt(ErrorsG3)+3*sizeof(TErrorTerm));
4067 ErrorB3 := PErrors(longInt(ErrorsB3)+3*sizeof(TErrorTerm));
4068 end else
4069 begin
4070 ErrorR0 := @ErrorsR0[Width+2];
4071 ErrorG0 := @ErrorsG0[Width+2];
4072 ErrorB0 := @ErrorsB0[Width+2];
4073 ErrorR1 := @ErrorsR1[Width+2];
4074 ErrorG1 := @ErrorsG1[Width+2];
4075 ErrorB1 := @ErrorsB1[Width+2];
4076 ErrorR2 := @ErrorsR2[Width+2];
4077 ErrorG2 := @ErrorsG2[Width+2];
4078 ErrorB2 := @ErrorsB2[Width+2];
4079 ErrorR3 := @ErrorsR2[Width+2];
4080 ErrorG3 := @ErrorsG2[Width+2];
4081 ErrorB3 := @ErrorsB2[Width+2];
4082 end;
4083 end;
4084 {$IFDEF R_PLUS}
4085 {$RANGECHECKS ON}
4086 {$UNDEF R_PLUS}
4087 {$ENDIF}
4088
4089 ////////////////////////////////////////////////////////////////////////////////
4090 // TBurkesDitherer
4091 constructor TBurkesDitherer.Create(AWidth: integer; Lookup: TColorLookup);
4092 begin
4093 inherited Create(AWidth, Lookup);
4094
4095 GetMem(ErrorsR0, sizeof(TErrorTerm)*(Width+4));
4096 GetMem(ErrorsG0, sizeof(TErrorTerm)*(Width+4));
4097 GetMem(ErrorsB0, sizeof(TErrorTerm)*(Width+4));
4098 GetMem(ErrorsR1, sizeof(TErrorTerm)*(Width+4));
4099 GetMem(ErrorsG1, sizeof(TErrorTerm)*(Width+4));
4100 GetMem(ErrorsB1, sizeof(TErrorTerm)*(Width+4));
4101 FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+4), 0);
4102 FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+4), 0);
4103 FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+4), 0);
4104 FillChar(ErrorsR1^, sizeof(TErrorTerm)*(Width+4), 0);
4105 FillChar(ErrorsG1^, sizeof(TErrorTerm)*(Width+4), 0);
4106 FillChar(ErrorsB1^, sizeof(TErrorTerm)*(Width+4), 0);
4107
4108 FDirection2 := 2 * Direction;
4109 ErrorR0 := PErrors(longInt(ErrorsR0)+2*sizeof(TErrorTerm));
4110 ErrorG0 := PErrors(longInt(ErrorsG0)+2*sizeof(TErrorTerm));
4111 ErrorB0 := PErrors(longInt(ErrorsB0)+2*sizeof(TErrorTerm));
4112 ErrorR1 := PErrors(longInt(ErrorsR1)+2*sizeof(TErrorTerm));
4113 ErrorG1 := PErrors(longInt(ErrorsG1)+2*sizeof(TErrorTerm));
4114 ErrorB1 := PErrors(longInt(ErrorsB1)+2*sizeof(TErrorTerm));
4115 end;
4116
4117 destructor TBurkesDitherer.Destroy;
4118 begin
4119 FreeMem(ErrorsR0);
4120 FreeMem(ErrorsG0);
4121 FreeMem(ErrorsB0);
4122 FreeMem(ErrorsR1);
4123 FreeMem(ErrorsG1);
4124 FreeMem(ErrorsB1);
4125 inherited Destroy;
4126 end;
4127
4128 {$IFOPT R+}
4129 {$DEFINE R_PLUS}
4130 {$RANGECHECKS OFF}
4131 {$ENDIF}
Dithernull4132 function TBurkesDitherer.Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
4133 var
4134 ErrorR ,
4135 ErrorG ,
4136 ErrorB : integer; // Error for current pixel
4137
4138 // Propagate Burkes error terms:
4139 // ... ... (here) 8/32 4/32
4140 // 2/32 4/32 8/32 4/32 2/32
4141 procedure Propagate(Errors0, Errors1: PErrors; Error: integer);
4142 begin
4143 if (Error = 0) then
4144 exit;
4145 inc(Error, Error);
4146 inc(Errors1[FDirection2], Error); // Error * 2
4147 inc(Errors1[-FDirection2], Error); // Error * 2
4148
4149 inc(Error, Error);
4150 inc(Errors0[FDirection2], Error); // Error * 4
4151 inc(Errors1[-Direction], Error); // Error * 4
4152 inc(Errors1[Direction], Error); // Error * 4
4153
4154 inc(Error, Error);
4155 inc(Errors0[Direction], Error); // Error * 8
4156 inc(Errors1[0], Error); // Error * 8
4157 end;
4158
4159 begin
4160 // Apply red component error correction
4161 ErrorR := Red + (ErrorR0[0] + 16) DIV 32;
4162 if (ErrorR < 0) then
4163 ErrorR := 0
4164 else if (ErrorR > 255) then
4165 ErrorR := 255;
4166
4167 // Apply green component error correction
4168 ErrorG := Green + (ErrorG0[0] + 16) DIV 32;
4169 if (ErrorG < 0) then
4170 ErrorG := 0
4171 else if (ErrorG > 255) then
4172 ErrorG := 255;
4173
4174 // Apply blue component error correction
4175 ErrorB := Blue + (ErrorB0[0] + 16) DIV 32;
4176 if (ErrorB < 0) then
4177 ErrorB := 0
4178 else if (ErrorB > 255) then
4179 ErrorB := 255;
4180
4181 // Map color to palette
4182 Result := inherited Dither(ErrorR, ErrorG, ErrorB, R, G, B);
4183
4184 // Propagate red component error
4185 Propagate(ErrorR0, ErrorR1, ErrorR - R);
4186 // Propagate green component error
4187 Propagate(ErrorG0, ErrorG1, ErrorG - G);
4188 // Propagate blue component error
4189 Propagate(ErrorB0, ErrorB1, ErrorB - B);
4190
4191 // Move on to next column
4192 if (Direction = 1) then
4193 begin
4194 inc(longInt(ErrorR0), sizeof(TErrorTerm));
4195 inc(longInt(ErrorG0), sizeof(TErrorTerm));
4196 inc(longInt(ErrorB0), sizeof(TErrorTerm));
4197 inc(longInt(ErrorR1), sizeof(TErrorTerm));
4198 inc(longInt(ErrorG1), sizeof(TErrorTerm));
4199 inc(longInt(ErrorB1), sizeof(TErrorTerm));
4200 end else
4201 begin
4202 dec(longInt(ErrorR0), sizeof(TErrorTerm));
4203 dec(longInt(ErrorG0), sizeof(TErrorTerm));
4204 dec(longInt(ErrorB0), sizeof(TErrorTerm));
4205 dec(longInt(ErrorR1), sizeof(TErrorTerm));
4206 dec(longInt(ErrorG1), sizeof(TErrorTerm));
4207 dec(longInt(ErrorB1), sizeof(TErrorTerm));
4208 end;
4209 end;
4210 {$IFDEF R_PLUS}
4211 {$RANGECHECKS ON}
4212 {$UNDEF R_PLUS}
4213 {$ENDIF}
4214
4215 {$IFOPT R+}
4216 {$DEFINE R_PLUS}
4217 {$RANGECHECKS OFF}
4218 {$ENDIF}
4219 procedure TBurkesDitherer.NextLine;
4220 var
4221 TempErrors : PErrors;
4222 begin
4223 FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+4), 0);
4224 FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+4), 0);
4225 FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+4), 0);
4226
4227 // Swap lines
4228 TempErrors := ErrorsR0;
4229 ErrorsR0 := ErrorsR1;
4230 ErrorsR1 := TempErrors;
4231
4232 TempErrors := ErrorsG0;
4233 ErrorsG0 := ErrorsG1;
4234 ErrorsG1 := TempErrors;
4235
4236 TempErrors := ErrorsB0;
4237 ErrorsB0 := ErrorsB1;
4238 ErrorsB1 := TempErrors;
4239
4240 inherited NextLine;
4241
4242 FDirection2 := 2 * Direction;
4243 if (Direction = 1) then
4244 begin
4245 // ErrorsR0[1] gives compiler error, so we
4246 // use PErrors(longInt(ErrorsR0)+sizeof(TErrorTerm)) instead...
4247 ErrorR0 := PErrors(longInt(ErrorsR0)+2*sizeof(TErrorTerm));
4248 ErrorG0 := PErrors(longInt(ErrorsG0)+2*sizeof(TErrorTerm));
4249 ErrorB0 := PErrors(longInt(ErrorsB0)+2*sizeof(TErrorTerm));
4250 ErrorR1 := PErrors(longInt(ErrorsR1)+2*sizeof(TErrorTerm));
4251 ErrorG1 := PErrors(longInt(ErrorsG1)+2*sizeof(TErrorTerm));
4252 ErrorB1 := PErrors(longInt(ErrorsB1)+2*sizeof(TErrorTerm));
4253 end else
4254 begin
4255 ErrorR0 := @ErrorsR0[Width+1];
4256 ErrorG0 := @ErrorsG0[Width+1];
4257 ErrorB0 := @ErrorsB0[Width+1];
4258 ErrorR1 := @ErrorsR1[Width+1];
4259 ErrorG1 := @ErrorsG1[Width+1];
4260 ErrorB1 := @ErrorsB1[Width+1];
4261 end;
4262 end;
4263 {$IFDEF R_PLUS}
4264 {$RANGECHECKS ON}
4265 {$UNDEF R_PLUS}
4266 {$ENDIF}
4267
4268 ////////////////////////////////////////////////////////////////////////////////
4269 //
4270 // Octree Color Quantization Engine
4271 //
4272 ////////////////////////////////////////////////////////////////////////////////
4273 // Adapted from Earl F. Glynn's ColorQuantizationLibrary, March 1998
4274 ////////////////////////////////////////////////////////////////////////////////
4275 type
4276 TOctreeNode = class; // Forward definition so TReducibleNodes can be declared
4277
4278 TReducibleNodes = array[0..7] of TOctreeNode;
4279
4280 TOctreeNode = Class(TObject)
4281 public
4282 IsLeaf : Boolean;
4283 PixelCount : integer;
4284 RedSum : integer;
4285 GreenSum : integer;
4286 BlueSum : integer;
4287 Next : TOctreeNode;
4288 Child : TReducibleNodes;
4289
4290 constructor Create(Level: integer; ColorBits: integer; var LeafCount: integer;
4291 var ReducibleNodes: TReducibleNodes);
4292 destructor Destroy; override;
4293 end;
4294
4295 TColorQuantizer = class(TObject)
4296 private
4297 FTree : TOctreeNode;
4298 FLeafCount : integer;
4299 FReducibleNodes : TReducibleNodes;
4300 FMaxColors : integer;
4301 FColorBits : integer;
4302
4303 protected
4304 procedure AddColor(var Node: TOctreeNode; r, g, b: byte; ColorBits: integer;
4305 Level: integer; var LeafCount: integer; var ReducibleNodes: TReducibleNodes);
4306 procedure DeleteTree(var Node: TOctreeNode);
4307 procedure GetPaletteColors(const Node: TOctreeNode;
4308 var RGBQuadArray: TRGBQuadArray; var Index: integer);
4309 procedure ReduceTree(ColorBits: integer; var LeafCount: integer;
4310 var ReducibleNodes: TReducibleNodes);
4311
4312 public
4313 constructor Create(MaxColors: integer; ColorBits: integer);
4314 destructor Destroy; override;
4315
4316 procedure GetColorTable(var RGBQuadArray: TRGBQuadArray);
ProcessImagenull4317 function ProcessImage(const DIB: TDIBReader): boolean;
4318
4319 property ColorCount: integer read FLeafCount;
4320 end;
4321
4322 constructor TOctreeNode.Create(Level: integer; ColorBits: integer;
4323 var LeafCount: integer; var ReducibleNodes: TReducibleNodes);
4324 var
4325 i : integer;
4326 begin
4327 PixelCount := 0;
4328 RedSum := 0;
4329 GreenSum := 0;
4330 BlueSum := 0;
4331 for i := Low(Child) to High(Child) do
4332 Child[i] := nil;
4333
4334 IsLeaf := (Level = ColorBits);
4335 if (IsLeaf) then
4336 begin
4337 Next := nil;
4338 inc(LeafCount);
4339 end else
4340 begin
4341 Next := ReducibleNodes[Level];
4342 ReducibleNodes[Level] := self;
4343 end;
4344 end;
4345
4346 destructor TOctreeNode.Destroy;
4347 var
4348 i : integer;
4349 begin
4350 for i := High(Child) downto Low(Child) do
4351 Child[i].Free;
4352 end;
4353
4354 constructor TColorQuantizer.Create(MaxColors: integer; ColorBits: integer);
4355 var
4356 i : integer;
4357 begin
4358 ASSERT(ColorBits <= 8, 'ColorBits must be 8 or less');
4359
4360 FTree := nil;
4361 FLeafCount := 0;
4362
4363 // Initialize all nodes even though only ColorBits+1 of them are needed
4364 for i := Low(FReducibleNodes) to High(FReducibleNodes) do
4365 FReducibleNodes[i] := nil;
4366
4367 FMaxColors := MaxColors;
4368 FColorBits := ColorBits;
4369 end;
4370
4371 destructor TColorQuantizer.Destroy;
4372 begin
4373 if (FTree <> nil) then
4374 DeleteTree(FTree);
4375 end;
4376
4377 procedure TColorQuantizer.GetColorTable(var RGBQuadArray: TRGBQuadArray);
4378 var
4379 Index : integer;
4380 begin
4381 Index := 0;
4382 GetPaletteColors(FTree, RGBQuadArray, Index);
4383 end;
4384
4385 // Handles passed to ProcessImage should refer to DIB sections, not DDBs.
4386 // In certain cases, specifically when it's called upon to process 1, 4, or
4387 // 8-bit per pixel images on systems with palettized display adapters,
4388 // ProcessImage can produce incorrect results if it's passed a handle to a
4389 // DDB.
TColorQuantizer.ProcessImagenull4390 function TColorQuantizer.ProcessImage(const DIB: TDIBReader): boolean;
4391 var
4392 i ,
4393 j : integer;
4394 ScanLine : pointer;
4395 Pixel : PRGBTriple;
4396 begin
4397 Result := True;
4398
4399 for j := 0 to DIB.Bitmap.Height-1 do
4400 begin
4401 Scanline := DIB.Scanline[j];
4402 Pixel := ScanLine;
4403 for i := 0 to DIB.Bitmap.Width-1 do
4404 begin
4405 with Pixel^ do
4406 AddColor(FTree, rgbtRed, rgbtGreen, rgbtBlue,
4407 FColorBits, 0, FLeafCount, FReducibleNodes);
4408
4409 while FLeafCount > FMaxColors do
4410 ReduceTree(FColorbits, FLeafCount, FReducibleNodes);
4411 inc(Pixel);
4412 end;
4413 end;
4414 end;
4415
4416 procedure TColorQuantizer.AddColor(var Node: TOctreeNode; r,g,b: byte;
4417 ColorBits: integer; Level: integer; var LeafCount: integer;
4418 var ReducibleNodes: TReducibleNodes);
4419 const
4420 Mask: array[0..7] of BYTE = ($80, $40, $20, $10, $08, $04, $02, $01);
4421 var
4422 Index : integer;
4423 Shift : integer;
4424 begin
4425 // If the node doesn't exist, create it.
4426 if (Node = nil) then
4427 Node := TOctreeNode.Create(Level, ColorBits, LeafCount, ReducibleNodes);
4428
4429 if (Node.IsLeaf) then
4430 begin
4431 inc(Node.PixelCount);
4432 inc(Node.RedSum, r);
4433 inc(Node.GreenSum, g);
4434 inc(Node.BlueSum, b);
4435 end else
4436 begin
4437 // Recurse a level deeper if the node is not a leaf.
4438 Shift := 7 - Level;
4439
4440 Index := (((r and mask[Level]) SHR Shift) SHL 2) or
4441 (((g and mask[Level]) SHR Shift) SHL 1) or
4442 ((b and mask[Level]) SHR Shift);
4443 AddColor(Node.Child[Index], r, g, b, ColorBits, Level+1, LeafCount, ReducibleNodes);
4444 end;
4445 end;
4446
4447 procedure TColorQuantizer.DeleteTree(var Node: TOctreeNode);
4448 var
4449 i : integer;
4450 begin
4451 for i := High(TReducibleNodes) downto Low(TReducibleNodes) do
4452 if (Node.Child[i] <> nil) then
4453 DeleteTree(Node.Child[i]);
4454
4455 Node.Free;
4456 Node := nil;
4457 end;
4458
4459 procedure TColorQuantizer.GetPaletteColors(const Node: TOctreeNode;
4460 var RGBQuadArray: TRGBQuadArray; var Index: integer);
4461 var
4462 i : integer;
4463 begin
4464 if (Node.IsLeaf) then
4465 begin
4466 with RGBQuadArray[Index] do
4467 begin
4468 if (Node.PixelCount <> 0) then
4469 begin
4470 rgbRed := BYTE(Node.RedSum DIV Node.PixelCount);
4471 rgbGreen := BYTE(Node.GreenSum DIV Node.PixelCount);
4472 rgbBlue := BYTE(Node.BlueSum DIV Node.PixelCount);
4473 end else
4474 begin
4475 rgbRed := 0;
4476 rgbGreen := 0;
4477 rgbBlue := 0;
4478 end;
4479 rgbReserved := 0;
4480 end;
4481 inc(Index);
4482 end else
4483 begin
4484 for i := Low(Node.Child) to High(Node.Child) do
4485 if (Node.Child[i] <> nil) then
4486 GetPaletteColors(Node.Child[i], RGBQuadArray, Index);
4487 end;
4488 end;
4489
4490 procedure TColorQuantizer.ReduceTree(ColorBits: integer; var LeafCount: integer;
4491 var ReducibleNodes: TReducibleNodes);
4492 var
4493 RedSum ,
4494 GreenSum ,
4495 BlueSum : integer;
4496 Children : integer;
4497 i : integer;
4498 Node : TOctreeNode;
4499 begin
4500 // Find the deepest level containing at least one reducible node
4501 i := Colorbits - 1;
4502 while (i > 0) and (ReducibleNodes[i] = nil) do
4503 dec(i);
4504
4505 // Reduce the node most recently added to the list at level i.
4506 Node := ReducibleNodes[i];
4507 ReducibleNodes[i] := Node.Next;
4508
4509 RedSum := 0;
4510 GreenSum := 0;
4511 BlueSum := 0;
4512 Children := 0;
4513
4514 for i := Low(ReducibleNodes) to High(ReducibleNodes) do
4515 if (Node.Child[i] <> nil) then
4516 begin
4517 inc(RedSum, Node.Child[i].RedSum);
4518 inc(GreenSum, Node.Child[i].GreenSum);
4519 inc(BlueSum, Node.Child[i].BlueSum);
4520 inc(Node.PixelCount, Node.Child[i].PixelCount);
4521 Node.Child[i].Free;
4522 Node.Child[i] := nil;
4523 inc(Children);
4524 end;
4525
4526 Node.IsLeaf := TRUE;
4527 Node.RedSum := RedSum;
4528 Node.GreenSum := GreenSum;
4529 Node.BlueSum := BlueSum;
4530 dec(LeafCount, Children-1);
4531 end;
4532
4533 ////////////////////////////////////////////////////////////////////////////////
4534 //
4535 // Octree Color Quantization Wrapper
4536 //
4537 ////////////////////////////////////////////////////////////////////////////////
4538 // Adapted from Earl F. Glynn's PaletteLibrary, March 1998
4539 ////////////////////////////////////////////////////////////////////////////////
4540
4541 // Wrapper for internal use - uses TDIBReader for bitmap access
doCreateOptimizedPaletteFromSingleBitmapnull4542 function doCreateOptimizedPaletteFromSingleBitmap(const DIB: TDIBReader;
4543 Colors, ColorBits: integer; Windows: boolean): hPalette;
4544 var
4545 SystemPalette : HPalette;
4546 ColorQuantizer : TColorQuantizer;
4547 i : integer;
4548 LogicalPalette : TMaxLogPalette;
4549 RGBQuadArray : TRGBQuadArray;
4550 Offset : integer;
4551 begin
4552 LogicalPalette.palVersion := $0300;
4553 LogicalPalette.palNumEntries := Colors;
4554 // 2003.03.06 ->
4555 {reset palette to black}
4556 FillChar(LogicalPalette.palPalEntry, SizeOf(LogicalPalette.palPalEntry), 0);
4557 for i := 0 to 255 do
4558 LogicalPalette.palPalEntry[i].peFlags := PC_NOCOLLAPSE;
4559 // 2003.03.06 <-
4560
4561 if (Windows) then
4562 begin
4563 // Get the windows 20 color system palette
4564 SystemPalette := GetStockObject(DEFAULT_PALETTE);
4565 GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
4566 //GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[245]); // wrong offset
4567 GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[246]); // 2003.03.06
4568 Colors := 236;
4569 Offset := 10;
4570 LogicalPalette.palNumEntries := 256;
4571 { Test code
4572 // 2003.03.06 ->
4573 // Get the windows 20 color system palette
4574 SystemPalette := GetStockObject(DEFAULT_PALETTE);
4575 GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
4576 GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[10]);
4577 Colors := 236;
4578 Offset := 20;
4579 LogicalPalette.palNumEntries := 256;
4580 // 2003.03.06 <-
4581 }
4582 end else
4583 Offset := 0;
4584
4585 // Normally for 24-bit images, use ColorBits of 5 or 6. For 8-bit images
4586 // use ColorBits = 8.
4587 ColorQuantizer := TColorQuantizer.Create(Colors, ColorBits);
4588 try
4589 ColorQuantizer.ProcessImage(DIB);
4590 ColorQuantizer.GetColorTable(RGBQuadArray);
4591 finally
4592 ColorQuantizer.Free;
4593 end;
4594
4595 for i := 0 to Colors-1 do
4596 with LogicalPalette.palPalEntry[i+Offset] do
4597 begin
4598 peRed := RGBQuadArray[i].rgbRed;
4599 peGreen := RGBQuadArray[i].rgbGreen;
4600 peBlue := RGBQuadArray[i].rgbBlue;
4601 peFlags := RGBQuadArray[i].rgbReserved;
4602 end;
4603 Result := CreatePalette(pLogPalette(@LogicalPalette)^);
4604 end;
4605
CreateOptimizedPaletteFromSingleBitmapnull4606 function CreateOptimizedPaletteFromSingleBitmap(const Bitmap: TBitmap;
4607 Colors, ColorBits: integer; Windows: boolean): hPalette;
4608 var
4609 DIB : TDIBReader;
4610 begin
4611 DIB := TDIBReader.Create(Bitmap, pf24bit);
4612 try
4613 Result := doCreateOptimizedPaletteFromSingleBitmap(DIB, Colors, ColorBits, Windows);
4614 finally
4615 DIB.Free;
4616 end;
4617 end;
4618
CreateOptimizedPaletteFromManyBitmapsnull4619 function CreateOptimizedPaletteFromManyBitmaps(Bitmaps: TList; Colors, ColorBits: integer;
4620 Windows: boolean): hPalette;
4621 var
4622 SystemPalette : HPalette;
4623 ColorQuantizer : TColorQuantizer;
4624 i : integer;
4625 LogicalPalette : TMaxLogPalette;
4626 RGBQuadArray : TRGBQuadArray;
4627 Offset : integer;
4628 DIB : TDIBReader;
4629 begin
4630 if (Bitmaps = nil) or (Bitmaps.Count = 0) then
4631 Error(sInvalidBitmapList);
4632
4633 LogicalPalette.palVersion := $0300;
4634 LogicalPalette.palNumEntries := Colors;
4635 // 2003.03.06 ->
4636 {reset palette to black}
4637 FillChar(LogicalPalette.palPalEntry, SizeOf(LogicalPalette.palPalEntry), 0);
4638 for i := 0 to 255 do
4639 LogicalPalette.palPalEntry[i].peFlags := PC_NOCOLLAPSE;
4640 // 2003.03.06 <-
4641
4642 if (Windows) then
4643 begin
4644 // Get the windows 20 color system palette
4645 SystemPalette := GetStockObject(DEFAULT_PALETTE);
4646 GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
4647 //GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[245]); // wrong offset
4648 GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[246]); // 2003.03.06
4649 Colors := 236;
4650 Offset := 10;
4651 LogicalPalette.palNumEntries := 256;
4652 { Test code
4653 // 2003.03.06 ->
4654 // Get the windows 20 color system palette
4655 SystemPalette := GetStockObject(DEFAULT_PALETTE);
4656 GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
4657 GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[10]);
4658 Colors := 236;
4659 Offset := 20;
4660 LogicalPalette.palNumEntries := 256;
4661 // 2003.03.06 <-
4662 }
4663 end else
4664 Offset := 0;
4665
4666 // Normally for 24-bit images, use ColorBits of 5 or 6. For 8-bit images
4667 // use ColorBits = 8.
4668 ColorQuantizer := TColorQuantizer.Create(Colors, ColorBits);
4669 try
4670 for i := 0 to Bitmaps.Count-1 do
4671 begin
4672 DIB := TDIBReader.Create(TBitmap(Bitmaps[i]), pf24bit);
4673 try
4674 ColorQuantizer.ProcessImage(DIB);
4675 finally
4676 DIB.Free;
4677 end;
4678 end;
4679 ColorQuantizer.GetColorTable(RGBQuadArray);
4680 finally
4681 ColorQuantizer.Free;
4682 end;
4683
4684 for i := 0 to Colors-1 do
4685 with LogicalPalette.palPalEntry[i+Offset] do
4686 begin
4687 peRed := RGBQuadArray[i].rgbRed;
4688 peGreen := RGBQuadArray[i].rgbGreen;
4689 peBlue := RGBQuadArray[i].rgbBlue;
4690 peFlags := RGBQuadArray[i].rgbReserved;
4691 end;
4692 Result := CreatePalette(pLogPalette(@LogicalPalette)^);
4693 end;
4694
4695 ////////////////////////////////////////////////////////////////////////////////
4696 //
4697 // Color reduction
4698 //
4699 ////////////////////////////////////////////////////////////////////////////////
4700 {$IFOPT R+}
4701 {$DEFINE R_PLUS}
4702 {$RANGECHECKS OFF}
4703 {$ENDIF}
4704 //: Reduces the color depth of a bitmap using color quantization and dithering.
ReduceColorsnull4705 function ReduceColors(Bitmap: TBitmap; ColorReduction: TColorReduction;
4706 DitherMode: TDitherMode; ReductionBits: integer; CustomPalette: hPalette): TBitmap;
4707 var
4708 Palette : hPalette;
4709 ColorLookup : TColorLookup;
4710 Ditherer : TDitherEngine;
4711 Row : Integer;
4712 DIBResult : TDIBWriter;
4713 DIBSource : TDIBReader;
4714 SrcScanLine ,
4715 Src : PRGBTriple;
4716 DstScanLine ,
4717 Dst : PChar;
4718 BGR : TRGBTriple;
4719 {$ifdef DEBUG_DITHERPERFORMANCE}
4720 TimeStart ,
4721 TimeStop : DWORD;
4722 {$endif}
4723
GrayScalePalettenull4724 function GrayScalePalette: hPalette;
4725 var
4726 i : integer;
4727 Pal : TMaxLogPalette;
4728 begin
4729 Pal.palVersion := $0300;
4730 Pal.palNumEntries := 256;
4731 for i := 0 to 255 do
4732 begin
4733 with (Pal.palPalEntry[i]) do
4734 begin
4735 peRed := i;
4736 peGreen := i;
4737 peBlue := i;
4738 peFlags := PC_NOCOLLAPSE;
4739 end;
4740 end;
4741 Result := CreatePalette(pLogPalette(@Pal)^);
4742 end;
4743
MonochromePalettenull4744 function MonochromePalette: hPalette;
4745 var
4746 i : integer;
4747 Pal : TMaxLogPalette;
4748 const
4749 Values : array[0..1] of byte
4750 = (0, 255);
4751 begin
4752 Pal.palVersion := $0300;
4753 Pal.palNumEntries := 2;
4754 for i := 0 to 1 do
4755 begin
4756 with (Pal.palPalEntry[i]) do
4757 begin
4758 peRed := Values[i];
4759 peGreen := Values[i];
4760 peBlue := Values[i];
4761 peFlags := PC_NOCOLLAPSE;
4762 end;
4763 end;
4764 Result := CreatePalette(pLogPalette(@Pal)^);
4765 end;
4766
WindowsGrayScalePalettenull4767 function WindowsGrayScalePalette: hPalette;
4768 var
4769 i : integer;
4770 Pal : TMaxLogPalette;
4771 const
4772 Values : array[0..3] of byte
4773 = (0, 128, 192, 255);
4774 begin
4775 Pal.palVersion := $0300;
4776 Pal.palNumEntries := 4;
4777 for i := 0 to 3 do
4778 begin
4779 with (Pal.palPalEntry[i]) do
4780 begin
4781 peRed := Values[i];
4782 peGreen := Values[i];
4783 peBlue := Values[i];
4784 peFlags := PC_NOCOLLAPSE;
4785 end;
4786 end;
4787 Result := CreatePalette(pLogPalette(@Pal)^);
4788 end;
4789
WindowsHalftonePalettenull4790 function WindowsHalftonePalette: hPalette;
4791 var
4792 DC : HDC;
4793 begin
4794 DC := GDICheck(GetDC(0));
4795 try
4796 Result := CreateHalfTonePalette(DC);
4797 finally
4798 ReleaseDC(0, DC);
4799 end;
4800 end;
4801
4802 begin
4803 {$ifdef DEBUG_DITHERPERFORMANCE}
4804 timeBeginPeriod(5);
4805 TimeStart := timeGetTime;
4806 {$endif}
4807
4808 Result := TBitmap.Create;
4809 try
4810
4811 if (ColorReduction = rmNone) then
4812 begin
4813 Result.Assign(Bitmap);
4814 {$ifndef VER9x}
4815 SetPixelFormat(Result, pf24bit);
4816 {$endif}
4817 exit;
4818 end;
4819
4820 {$IFNDEF VER9x}
4821 if (Bitmap.Width*Bitmap.Height > BitmapAllocationThreshold) then
4822 SetPixelFormat(Result, pf1bit); // To reduce resource consumption of resize
4823 {$ENDIF}
4824
4825 ColorLookup := nil;
4826 Ditherer := nil;
4827 DIBResult := nil;
4828 DIBSource := nil;
4829 Palette := 0;
4830 try // Protect above resources
4831
4832 // Dithering and color mapper only supports 24 bit bitmaps,
4833 // so we have convert the source bitmap to the appropiate format.
4834 DIBSource := TDIBReader.Create(Bitmap, pf24bit);
4835
4836 // Create a palette based on current options
4837 case (ColorReduction) of
4838 rmQuantize:
4839 Palette := doCreateOptimizedPaletteFromSingleBitmap(DIBSource, 1 SHL ReductionBits, 8, False);
4840 rmQuantizeWindows:
4841 Palette := CreateOptimizedPaletteFromSingleBitmap(Bitmap, 256, 8, True);
4842 rmNetscape:
4843 Palette := WebPalette;
4844 rmGrayScale:
4845 Palette := GrayScalePalette;
4846 rmMonochrome:
4847 Palette := MonochromePalette;
4848 rmWindowsGray:
4849 Palette := WindowsGrayScalePalette;
4850 rmWindows20:
4851 Palette := GetStockObject(DEFAULT_PALETTE);
4852 rmWindows256:
4853 Palette := WindowsHalftonePalette;
4854 rmPalette:
4855 Palette := CopyPalette(CustomPalette);
4856 else
4857 exit;
4858 end;
4859
4860 { TODO -oanme -cImprovement : Gray scale conversion should be done prior to dithering/mapping. Otherwise corrected values will be converted multiple times. }
4861
4862 // Create a color mapper based on current options
4863 case (ColorReduction) of
4864 // For some strange reason my fast and dirty color lookup
4865 // is more precise that Windows GetNearestPaletteIndex...
4866 // rmWindows20:
4867 // ColorLookup := TSlowColorLookup.Create(Palette);
4868 // rmWindowsGray:
4869 // ColorLookup := TGrayWindowsLookup.Create(Palette);
4870 rmQuantize:
4871 // 2007.01.18 -> // switch back to TFastColorLookup
4872 ColorLookup := TFastColorLookup.Create(Palette);
4873 // ColorLookup := TSlowColorLookup.Create(Palette); // 2003-03-06
4874 // 2007.01.18 <-
4875 rmNetscape:
4876 ColorLookup := TNetscapeColorLookup.Create(Palette);
4877 rmGrayScale:
4878 ColorLookup := TGrayScaleLookup.Create(Palette);
4879 rmMonochrome:
4880 ColorLookup := TMonochromeLookup.Create(Palette);
4881 else
4882 // ColorLookup := TFastColorLookup.Create(Palette);
4883 ColorLookup := TSlowColorLookup.Create(Palette); // 2003-03-06
4884 end;
4885
4886 // Nothing to do if palette doesn't contain any colors
4887 if (ColorLookup.Colors = 0) then
4888 exit;
4889
4890 // Create a ditherer based on current options
4891 case (DitherMode) of
4892 dmNearest:
4893 Ditherer := TDitherEngine.Create(Bitmap.Width, ColorLookup);
4894 dmFloydSteinberg:
4895 Ditherer := TFloydSteinbergDitherer.Create(Bitmap.Width, ColorLookup);
4896 dmStucki:
4897 Ditherer := TStuckiDitherer.Create(Bitmap.Width, ColorLookup);
4898 dmSierra:
4899 Ditherer := TSierraDitherer.Create(Bitmap.Width, ColorLookup);
4900 dmJaJuNI:
4901 Ditherer := TJaJuNIDitherer.Create(Bitmap.Width, ColorLookup);
4902 dmSteveArche:
4903 Ditherer := TSteveArcheDitherer.Create(Bitmap.Width, ColorLookup);
4904 dmBurkes:
4905 Ditherer := TBurkesDitherer.Create(Bitmap.Width, ColorLookup);
4906 else
4907 exit;
4908 end;
4909
4910 // The processed bitmap is returned in pf8bit format
4911 DIBResult := TDIBWriter.Create(Result, pf8bit, Bitmap.Width, Bitmap.Height,
4912 Palette);
4913
4914 // Process the image
4915 Row := 0;
4916 while (Row < Bitmap.Height) do
4917 begin
4918 SrcScanline := DIBSource.ScanLine[Row];
4919 DstScanline := DIBResult.ScanLine[Row];
4920 Src := pointer(longInt(SrcScanLine) + Ditherer.Column*sizeof(TRGBTriple));
4921 Dst := pointer(longInt(DstScanLine) + Ditherer.Column);
4922
4923 while (Ditherer.Column < Ditherer.Width) and (Ditherer.Column >= 0) do
4924 begin
4925 BGR := Src^;
4926 // Dither and map a single pixel
4927 Dst^ := Ditherer.Dither(BGR.rgbtRed, BGR.rgbtGreen, BGR.rgbtBlue,
4928 BGR.rgbtRed, BGR.rgbtGreen, BGR.rgbtBlue);
4929
4930 inc(Src, Ditherer.Direction);
4931 inc(Dst, Ditherer.Direction);
4932 end;
4933
4934 Inc(Row);
4935 Ditherer.NextLine;
4936 end;
4937 finally
4938 if (ColorLookup <> nil) then
4939 ColorLookup.Free;
4940 if (Ditherer <> nil) then
4941 Ditherer.Free;
4942 if (DIBResult <> nil) then
4943 DIBResult.Free;
4944 if (DIBSource <> nil) then
4945 DIBSource.Free;
4946 // Must delete palette after TDIBWriter since TDIBWriter uses palette
4947 if (Palette <> 0) then
4948 DeleteObject(Palette);
4949 end;
4950 except
4951 Result.Free;
4952 raise;
4953 end;
4954
4955 {$ifdef DEBUG_DITHERPERFORMANCE}
4956 TimeStop := timeGetTime;
4957 ShowMessage(format('Dithered %d pixels in %d mS, Rate %d pixels/mS (%d pixels/S)',
4958 [Bitmap.Height*Bitmap.Width, TimeStop-TimeStart,
4959 MulDiv(Bitmap.Height, Bitmap.Width, TimeStop-TimeStart+1),
4960 MulDiv(Bitmap.Height, Bitmap.Width * 1000, TimeStop-TimeStart+1)]));
4961 timeEndPeriod(5);
4962 {$endif}
4963 end;
4964 {$IFDEF R_PLUS}
4965 {$RANGECHECKS ON}
4966 {$UNDEF R_PLUS}
4967 {$ENDIF}
4968
4969 ////////////////////////////////////////////////////////////////////////////////
4970 //
4971 // TGIFColorMap
4972 //
4973 ////////////////////////////////////////////////////////////////////////////////
4974 const
4975 InitColorMapSize = 16;
4976 DeltaColorMapSize = 32;
4977
4978 //: Creates an instance of a TGIFColorMap object.
4979 constructor TGIFColorMap.Create;
4980 begin
4981 inherited Create;
4982 FColorMap := nil;
4983 FCapacity := 0;
4984 FCount := 0;
4985 FOptimized := False;
4986 end;
4987
4988 //: Destroys an instance of a TGIFColorMap object.
4989 destructor TGIFColorMap.Destroy;
4990 begin
4991 Clear;
4992 Changed;
4993 inherited Destroy;
4994 end;
4995
4996 //: Empties the color map.
4997 procedure TGIFColorMap.Clear;
4998 begin
4999 if (FColorMap <> nil) then
5000 FreeMem(FColorMap);
5001 FColorMap := nil;
5002 FCapacity := 0;
5003 FCount := 0;
5004 FOptimized := False;
5005 end;
5006
5007 //: Converts a Windows color value to a RGB value.
5008 class function TGIFColorMap.Color2RGB(Color: TColor): TGIFColor;
5009 begin
5010 Result.Blue := (Color shr 16) and $FF;
5011 Result.Green := (Color shr 8) and $FF;
5012 Result.Red := Color and $FF;
5013 end;
5014
5015 //: Converts a RGB value to a Windows color value.
5016 class function TGIFColorMap.RGB2Color(Color: TGIFColor): TColor;
5017 begin
5018 Result := (Color.Blue SHL 16) OR (Color.Green SHL 8) OR Color.Red;
5019 end;
5020
5021 //: Saves the color map to a stream.
5022 procedure TGIFColorMap.SaveToStream(Stream: TStream);
5023 var
5024 Dummies : integer;
5025 Dummy : TGIFColor;
5026 begin
5027 if (FCount = 0) then
5028 exit;
5029 Stream.WriteBuffer(FColorMap^, FCount*sizeof(TGIFColor));
5030 Dummies := (1 SHL BitsPerPixel)-FCount;
5031 Dummy.Red := 0;
5032 Dummy.Green := 0;
5033 Dummy.Blue := 0;
5034 while (Dummies > 0) do
5035 begin
5036 Stream.WriteBuffer(Dummy, sizeof(TGIFColor));
5037 dec(Dummies);
5038 end;
5039 end;
5040
5041 //: Loads the color map from a stream.
5042 procedure TGIFColorMap.LoadFromStream(Stream: TStream; Count: integer);
5043 begin
5044 Clear;
5045 SetCapacity(Count);
5046 ReadCheck(Stream, FColorMap^, Count*sizeof(TGIFColor));
5047 FCount := Count;
5048 end;
5049
5050 //: Returns the position of a color in the color map.
IndexOfnull5051 function TGIFColorMap.IndexOf(Color: TColor): integer;
5052 var
5053 RGB : TGIFColor;
5054 begin
5055 RGB := Color2RGB(Color);
5056 if (FOptimized) then
5057 begin
5058 // Optimized palette has most frequently occuring entries first
5059 Result := 0;
5060 // Reverse search to (hopefully) check latest colors first
5061 while (Result < FCount) do
5062 with (FColorMap^[Result]) do
5063 begin
5064 if (RGB.Red = Red) and (RGB.Green = Green) and (RGB.Blue = Blue) then
5065 exit;
5066 Inc(Result);
5067 end;
5068 Result := -1;
5069 end else
5070 begin
5071 Result := FCount-1;
5072 // Reverse search to (hopefully) check latest colors first
5073 while (Result >= 0) do
5074 with (FColorMap^[Result]) do
5075 begin
5076 if (RGB.Red = Red) and (RGB.Green = Green) and (RGB.Blue = Blue) then
5077 exit;
5078 Dec(Result);
5079 end;
5080 end;
5081 end;
5082
5083 procedure TGIFColorMap.SetCapacity(Size: integer);
5084 begin
5085 if (Size >= FCapacity) then
5086 begin
5087 if (Size <= InitColorMapSize) then
5088 FCapacity := InitColorMapSize
5089 else
5090 FCapacity := (Size + DeltaColorMapSize - 1) DIV DeltaColorMapSize * DeltaColorMapSize;
5091 if (FCapacity > GIFMaxColors) then
5092 FCapacity := GIFMaxColors;
5093 ReallocMem(FColorMap, FCapacity * sizeof(TGIFColor));
5094 end;
5095 end;
5096
5097 //: Imports a Windows palette into the color map.
5098 procedure TGIFColorMap.ImportPalette(Palette: HPalette);
5099 type
5100 PalArray = array[byte] of TPaletteEntry;
5101 var
5102 Pal : PalArray;
5103 NewCount : integer;
5104 i : integer;
5105 begin
5106 Clear;
5107 NewCount := GetPaletteEntries(Palette, 0, 256, pal);
5108 if (NewCount = 0) then
5109 exit;
5110 SetCapacity(NewCount);
5111 for i := 0 to NewCount-1 do
5112 with FColorMap[i], Pal[i] do
5113 begin
5114 Red := peRed;
5115 Green := peGreen;
5116 Blue := peBlue;
5117 end;
5118 FCount := NewCount;
5119 Changed;
5120 end;
5121
5122 //: Imports a color map structure into the color map.
5123 procedure TGIFColorMap.ImportColorMap(Map: TColorMap; Count: integer);
5124 begin
5125 Clear;
5126 if (Count = 0) then
5127 exit;
5128 SetCapacity(Count);
5129 FCount := Count;
5130
5131 System.Move(Map, FColorMap^, FCount * sizeof(TGIFColor));
5132
5133 Changed;
5134 end;
5135
5136 //: Imports a Windows palette structure into the color map.
5137 procedure TGIFColorMap.ImportColorTable(Pal: pointer; Count: integer);
5138 var
5139 i : integer;
5140 begin
5141 Clear;
5142 if (Count = 0) then
5143 exit;
5144 SetCapacity(Count);
5145 for i := 0 to Count-1 do
5146 with FColorMap[i], PRGBQuadArray(Pal)[i] do
5147 begin
5148 Red := rgbRed;
5149 Green := rgbGreen;
5150 Blue := rgbBlue;
5151 end;
5152 FCount := Count;
5153 Changed;
5154 end;
5155
5156 //: Imports the color table of a DIB into the color map.
5157 procedure TGIFColorMap.ImportDIBColors(Handle: HDC);
5158 var
5159 Pal : Pointer;
5160 NewCount : integer;
5161 begin
5162 Clear;
5163 GetMem(Pal, sizeof(TRGBQuad) * 256);
5164 try
5165 NewCount := GetDIBColorTable(Handle, 0, 256, Pal^);
5166 ImportColorTable(Pal, NewCount);
5167 finally
5168 FreeMem(Pal);
5169 end;
5170 Changed;
5171 end;
5172
5173 //: Creates a Windows palette from the color map.
ExportPalettenull5174 function TGIFColorMap.ExportPalette: HPalette;
5175 var
5176 Pal : TMaxLogPalette;
5177 i : Integer;
5178 begin
5179 if (Count = 0) then
5180 begin
5181 Result := 0;
5182 exit;
5183 end;
5184 Pal.palVersion := $300;
5185 Pal.palNumEntries := Count;
5186 for i := 0 to Count-1 do
5187 with FColorMap[i], Pal.palPalEntry[i] do
5188 begin
5189 peRed := Red;
5190 peGreen := Green;
5191 peBlue := Blue;
5192 peFlags := PC_NOCOLLAPSE; { TODO -oanme -cImprovement : Verify that PC_NOCOLLAPSE is the correct value to use. }
5193 end;
5194 Result := CreatePalette(PLogPalette(@Pal)^);
5195 end;
5196
5197 //: Adds a color to the color map.
Addnull5198 function TGIFColorMap.Add(Color: TColor): integer;
5199 begin
5200 if (FCount >= GIFMaxColors) then
5201 // Color map full
5202 Error(sTooManyColors);
5203
5204 Result := FCount;
5205 if (Result >= FCapacity) then
5206 SetCapacity(FCount+1);
5207 FColorMap^[FCount] := Color2RGB(Color);
5208 inc(FCount);
5209 FOptimized := False;
5210 Changed;
5211 end;
5212
AddUniquenull5213 function TGIFColorMap.AddUnique(Color: TColor): integer;
5214 begin
5215 // Look up color before add (same as IndexOf)
5216 Result := IndexOf(Color);
5217 if (Result >= 0) then
5218 // Color already in map
5219 exit;
5220
5221 Result := Add(Color);
5222 end;
5223
5224 //: Removes a color from the color map.
5225 procedure TGIFColorMap.Delete(Index: integer);
5226 begin
5227 if (Index < 0) or (Index >= FCount) then
5228 // Color index out of range
5229 Error(sBadColorIndex);
5230 dec(FCount);
5231 if (Index < FCount) then
5232 System.Move(FColorMap^[Index + 1], FColorMap^[Index], (FCount - Index)* sizeof(TGIFColor));
5233 FOptimized := False;
5234 Changed;
5235 end;
5236
GetColornull5237 function TGIFColorMap.GetColor(Index: integer): TColor;
5238 begin
5239 if (Index < 0) or (Index >= FCount) then
5240 begin
5241 // Color index out of range
5242 Warning(gsWarning, sBadColorIndex);
5243 // Raise an exception if the color map is empty
5244 if (FCount = 0) then
5245 Error(sEmptyColorMap);
5246 // Default to color index 0
5247 Index := 0;
5248 end;
5249 Result := RGB2Color(FColorMap^[Index]);
5250 end;
5251
5252 procedure TGIFColorMap.SetColor(Index: integer; Value: TColor);
5253 begin
5254 if (Index < 0) or (Index >= FCount) then
5255 // Color index out of range
5256 Error(sBadColorIndex);
5257 FColorMap^[Index] := Color2RGB(Value);
5258 Changed;
5259 end;
5260
DoOptimizenull5261 function TGIFColorMap.DoOptimize: boolean;
5262 var
5263 Usage : TColormapHistogram;
5264 TempMap : array[0..255] of TGIFColor;
5265 ReverseMap : TColormapReverse;
5266 i : integer;
5267 LastFound : boolean;
5268 NewCount : integer;
5269 T : TUsageCount;
5270 Pivot : integer;
5271
5272 procedure QuickSort(iLo, iHi: Integer);
5273 var
5274 Lo, Hi: Integer;
5275 begin
5276 repeat
5277 Lo := iLo;
5278 Hi := iHi;
5279 Pivot := Usage[(iLo + iHi) SHR 1].Count;
5280 repeat
5281 while (Usage[Lo].Count - Pivot > 0) do inc(Lo);
5282 while (Usage[Hi].Count - Pivot < 0) do dec(Hi);
5283 if (Lo <= Hi) then
5284 begin
5285 T := Usage[Lo];
5286 Usage[Lo] := Usage[Hi];
5287 Usage[Hi] := T;
5288 inc(Lo);
5289 dec(Hi);
5290 end;
5291 until (Lo > Hi);
5292 if (iLo < Hi) then
5293 QuickSort(iLo, Hi);
5294 iLo := Lo;
5295 until (Lo >= iHi);
5296 end;
5297
5298 begin
5299 if (FCount <= 1) then
5300 begin
5301 Result := False;
5302 exit;
5303 end;
5304
5305 FOptimized := True;
5306 Result := True;
5307
5308 BuildHistogram(Usage);
5309
5310 (*
5311 ** Sort according to usage count
5312 *)
5313 QuickSort(0, FCount-1);
5314
5315 (*
5316 ** Test for table already sorted
5317 *)
5318 for i := 0 to FCount-1 do
5319 if (Usage[i].Index <> i) then
5320 break;
5321 if (i = FCount) then
5322 exit;
5323
5324 (*
5325 ** Build old to new map
5326 *)
5327 for i := 0 to FCount-1 do
5328 ReverseMap[Usage[i].Index] := i;
5329
5330
5331 MapImages(ReverseMap);
5332
5333 (*
5334 ** Reorder colormap
5335 *)
5336 LastFound := False;
5337 NewCount := FCount;
5338 Move(FColorMap^, TempMap, FCount * sizeof(TGIFColor));
5339 for i := 0 to FCount-1 do
5340 begin
5341 FColorMap^[ReverseMap[i]] := TempMap[i];
5342 // Find last used color index
5343 if (Usage[i].Count = 0) and not(LastFound) then
5344 begin
5345 LastFound := True;
5346 NewCount := i;
5347 end;
5348 end;
5349
5350 FCount := NewCount;
5351
5352 Changed;
5353 end;
5354
GetBitsPerPixelnull5355 function TGIFColorMap.GetBitsPerPixel: integer;
5356 begin
5357 Result := Colors2bpp(FCount);
5358 end;
5359
5360 //: Copies one color map to another.
5361 procedure TGIFColorMap.Assign(Source: TPersistent);
5362 begin
5363 if (Source is TGIFColorMap) then
5364 begin
5365 Clear;
5366 FCapacity := TGIFColorMap(Source).FCapacity;
5367 FCount := TGIFColorMap(Source).FCount;
5368 FOptimized := TGIFColorMap(Source).FOptimized;
5369 FColorMap := AllocMem(FCapacity * sizeof(TGIFColor));
5370 System.Move(TGIFColorMap(Source).FColorMap^, FColorMap^, FCount * sizeof(TGIFColor));
5371 Changed;
5372 end else
5373 inherited Assign(Source);
5374 end;
5375
5376 ////////////////////////////////////////////////////////////////////////////////
5377 //
5378 // TGIFItem
5379 //
5380 ////////////////////////////////////////////////////////////////////////////////
5381 constructor TGIFItem.Create(GIFImage: TGIFImage);
5382 begin
5383 inherited Create;
5384
5385 FGIFImage := GIFImage;
5386 end;
5387
5388 procedure TGIFItem.Warning(Severity: TGIFSeverity; Message: string);
5389 begin
5390 FGIFImage.Warning(self, Severity, Message);
5391 end;
5392
GetVersionnull5393 function TGIFItem.GetVersion: TGIFVersion;
5394 begin
5395 Result := gv87a;
5396 end;
5397
5398 procedure TGIFItem.LoadFromFile(const Filename: string);
5399 var
5400 Stream: TStream;
5401 begin
5402 Stream := TFileStream.Create(Filename, fmOpenRead OR fmShareDenyWrite);
5403 try
5404 LoadFromStream(Stream);
5405 finally
5406 Stream.Free;
5407 end;
5408 end;
5409
5410 procedure TGIFItem.SaveToFile(const Filename: string);
5411 var
5412 Stream: TStream;
5413 begin
5414 Stream := TFileStream.Create(Filename, fmCreate);
5415 try
5416 SaveToStream(Stream);
5417 finally
5418 Stream.Free;
5419 end;
5420 end;
5421
5422 ////////////////////////////////////////////////////////////////////////////////
5423 //
5424 // TGIFList
5425 //
5426 ////////////////////////////////////////////////////////////////////////////////
5427 constructor TGIFList.Create(Image: TGIFImage);
5428 begin
5429 inherited Create;
5430 FImage := Image;
5431 FItems := TList.Create;
5432 end;
5433
5434 destructor TGIFList.Destroy;
5435 begin
5436 Clear;
5437 FItems.Free;
5438 inherited Destroy;
5439 end;
5440
GetItemnull5441 function TGIFList.GetItem(Index: Integer): TGIFItem;
5442 begin
5443 Result := TGIFItem(FItems[Index]);
5444 end;
5445
5446 procedure TGIFList.SetItem(Index: Integer; Item: TGIFItem);
5447 begin
5448 FItems[Index] := Item;
5449 end;
5450
GetCountnull5451 function TGIFList.GetCount: Integer;
5452 begin
5453 Result := FItems.Count;
5454 end;
5455
Addnull5456 function TGIFList.Add(Item: TGIFItem): Integer;
5457 begin
5458 Result := FItems.Add(Item);
5459 end;
5460
5461 procedure TGIFList.Clear;
5462 begin
5463 while (FItems.Count > 0) do
5464 Delete(0);
5465 end;
5466
5467 procedure TGIFList.Delete(Index: Integer);
5468 var
5469 Item : TGIFItem;
5470 begin
5471 Item := TGIFItem(FItems[Index]);
5472 // Delete before item is destroyed to avoid recursion
5473 FItems.Delete(Index);
5474 Item.Free;
5475 end;
5476
5477 procedure TGIFList.Exchange(Index1, Index2: Integer);
5478 begin
5479 FItems.Exchange(Index1, Index2);
5480 end;
5481
Firstnull5482 function TGIFList.First: TGIFItem;
5483 begin
5484 Result := TGIFItem(FItems.First);
5485 end;
5486
IndexOfnull5487 function TGIFList.IndexOf(Item: TGIFItem): Integer;
5488 begin
5489 Result := FItems.IndexOf(Item);
5490 end;
5491
5492 procedure TGIFList.Insert(Index: Integer; Item: TGIFItem);
5493 begin
5494 FItems.Insert(Index, Item);
5495 end;
5496
Lastnull5497 function TGIFList.Last: TGIFItem;
5498 begin
5499 Result := TGIFItem(FItems.Last);
5500 end;
5501
5502 procedure TGIFList.Move(CurIndex, NewIndex: Integer);
5503 begin
5504 FItems.Move(CurIndex, NewIndex);
5505 end;
5506
Removenull5507 function TGIFList.Remove(Item: TGIFItem): Integer;
5508 begin
5509 // Note: TGIFList.Remove must not destroy item
5510 Result := FItems.Remove(Item);
5511 end;
5512
5513 procedure TGIFList.SaveToStream(Stream: TStream);
5514 var
5515 i : integer;
5516 begin
5517 for i := 0 to FItems.Count-1 do
5518 TGIFItem(FItems[i]).SaveToStream(Stream);
5519 end;
5520
5521 procedure TGIFList.Warning(Severity: TGIFSeverity; Message: string);
5522 begin
5523 Image.Warning(self, Severity, Message);
5524 end;
5525
5526 ////////////////////////////////////////////////////////////////////////////////
5527 //
5528 // TGIFGlobalColorMap
5529 //
5530 ////////////////////////////////////////////////////////////////////////////////
5531 type
5532 TGIFGlobalColorMap = class(TGIFColorMap)
5533 private
5534 FHeader : TGIFHeader;
5535 protected
5536 procedure Warning(Severity: TGIFSeverity; Message: string); override;
5537 procedure BuildHistogram(var Histogram: TColormapHistogram); override;
5538 procedure MapImages(var Map: TColormapReverse); override;
5539 public
5540 constructor Create(HeaderItem: TGIFHeader);
5541 function Optimize: boolean; override;
5542 procedure Changed; override;
5543 end;
5544
5545 constructor TGIFGlobalColorMap.Create(HeaderItem: TGIFHeader);
5546 begin
5547 Inherited Create;
5548 FHeader := HeaderItem;
5549 end;
5550
5551 procedure TGIFGlobalColorMap.Warning(Severity: TGIFSeverity; Message: string);
5552 begin
5553 FHeader.Image.Warning(self, Severity, Message);
5554 end;
5555
5556 procedure TGIFGlobalColorMap.BuildHistogram(var Histogram: TColormapHistogram);
5557 var
5558 Pixel ,
5559 LastPixel : PChar;
5560 i : integer;
5561 begin
5562 (*
5563 ** Init histogram
5564 *)
5565 for i := 0 to Count-1 do
5566 begin
5567 Histogram[i].Index := i;
5568 Histogram[i].Count := 0;
5569 end;
5570
5571 for i := 0 to FHeader.Image.Images.Count-1 do
5572 if (FHeader.Image.Images[i].ActiveColorMap = self) then
5573 begin
5574 Pixel := FHeader.Image.Images[i].Data;
5575 LastPixel := Pixel + FHeader.Image.Images[i].Width * FHeader.Image.Images[i].Height;
5576
5577 (*
5578 ** Sum up usage count for each color
5579 *)
5580 while (Pixel < LastPixel) do
5581 begin
5582 inc(Histogram[ord(Pixel^)].Count);
5583 inc(Pixel);
5584 end;
5585 end;
5586 end;
5587
5588 procedure TGIFGlobalColorMap.MapImages(var Map: TColormapReverse);
5589 var
5590 Pixel ,
5591 LastPixel : PChar;
5592 i : integer;
5593 begin
5594 for i := 0 to FHeader.Image.Images.Count-1 do
5595 if (FHeader.Image.Images[i].ActiveColorMap = self) then
5596 begin
5597 Pixel := FHeader.Image.Images[i].Data;
5598 LastPixel := Pixel + FHeader.Image.Images[i].Width * FHeader.Image.Images[i].Height;
5599
5600 (*
5601 ** Reorder all pixel to new map
5602 *)
5603 while (Pixel < LastPixel) do
5604 begin
5605 Pixel^ := chr(Map[ord(Pixel^)]);
5606 inc(Pixel);
5607 end;
5608
5609 (*
5610 ** Reorder transparent colors
5611 *)
5612 if (FHeader.Image.Images[i].Transparent) then
5613 FHeader.Image.Images[i].GraphicControlExtension.TransparentColorIndex :=
5614 Map[FHeader.Image.Images[i].GraphicControlExtension.TransparentColorIndex];
5615 end;
5616 end;
5617
Optimizenull5618 function TGIFGlobalColorMap.Optimize: boolean;
5619 begin
5620 { Optimize with first image, Remove unused colors if only one image }
5621 if (FHeader.Image.Images.Count > 0) then
5622 Result := DoOptimize
5623 else
5624 Result := False;
5625 end;
5626
5627 procedure TGIFGlobalColorMap.Changed;
5628 begin
5629 FHeader.Image.Palette := 0;
5630 end;
5631
5632 ////////////////////////////////////////////////////////////////////////////////
5633 //
5634 // TGIFHeader
5635 //
5636 ////////////////////////////////////////////////////////////////////////////////
5637 constructor TGIFHeader.Create(GIFImage: TGIFImage);
5638 begin
5639 inherited Create(GIFImage);
5640 FColorMap := TGIFGlobalColorMap.Create(self);
5641 Clear;
5642 end;
5643
5644 destructor TGIFHeader.Destroy;
5645 begin
5646 FColorMap.Free;
5647 inherited Destroy;
5648 end;
5649
5650 procedure TGIFHeader.Clear;
5651 begin
5652 FColorMap.Clear;
5653 FLogicalScreenDescriptor.ScreenWidth := 0;
5654 FLogicalScreenDescriptor.ScreenHeight := 0;
5655 FLogicalScreenDescriptor.PackedFields := 0;
5656 FLogicalScreenDescriptor.BackgroundColorIndex := 0;
5657 FLogicalScreenDescriptor.AspectRatio := 0;
5658 end;
5659
5660 procedure TGIFHeader.Assign(Source: TPersistent);
5661 begin
5662 if (Source is TGIFHeader) then
5663 begin
5664 ColorMap.Assign(TGIFHeader(Source).ColorMap);
5665 FLogicalScreenDescriptor := TGIFHeader(Source).FLogicalScreenDescriptor;
5666 end else
5667 if (Source is TGIFColorMap) then
5668 begin
5669 Clear;
5670 ColorMap.Assign(TGIFColorMap(Source));
5671 end else
5672 inherited Assign(Source);
5673 end;
5674
5675 type
5676 TGIFHeaderRec = packed record
5677 Signature: array[0..2] of char; { contains 'GIF' }
5678 Version: TGIFVersionRec; { '87a' or '89a' }
5679 end;
5680
5681 const
5682 { logical screen descriptor packed field masks }
5683 lsdGlobalColorTable = $80; { set if global color table follows L.S.D. }
5684 lsdColorResolution = $70; { Color resolution - 3 bits }
5685 lsdSort = $08; { set if global color table is sorted - 1 bit }
5686 lsdColorTableSize = $07; { size of global color table - 3 bits }
5687 { Actual size = 2^value+1 - value is 3 bits }
5688 procedure TGIFHeader.Prepare;
5689 var
5690 pack : BYTE;
5691 begin
5692 Pack := $00;
5693 if (ColorMap.Count > 0) then
5694 begin
5695 Pack := lsdGlobalColorTable;
5696 if (ColorMap.Optimized) then
5697 Pack := Pack OR lsdSort;
5698 end;
5699 // Note: The SHL below was SHL 5 in the original source, but that looks wrong
5700 Pack := Pack OR ((Image.ColorResolution SHL 4) AND lsdColorResolution);
5701 Pack := Pack OR ((Image.BitsPerPixel-1) AND lsdColorTableSize);
5702 FLogicalScreenDescriptor.PackedFields := Pack;
5703 end;
5704
5705 procedure TGIFHeader.SaveToStream(Stream: TStream);
5706 var
5707 GifHeader : TGIFHeaderRec;
5708 v : TGIFVersion;
5709 begin
5710 v := Image.Version;
5711 if (v = gvUnknown) then
5712 Error(sBadVersion);
5713
5714 GifHeader.Signature := 'GIF';
5715 GifHeader.Version := GIFVersions[v];
5716
5717 Prepare;
5718 Stream.Write(GifHeader, sizeof(GifHeader));
5719 Stream.Write(FLogicalScreenDescriptor, sizeof(FLogicalScreenDescriptor));
5720 if (FLogicalScreenDescriptor.PackedFields AND lsdGlobalColorTable = lsdGlobalColorTable) then
5721 ColorMap.SaveToStream(Stream);
5722 end;
5723
5724 procedure TGIFHeader.LoadFromStream(Stream: TStream);
5725 var
5726 GifHeader : TGIFHeaderRec;
5727 ColorCount : integer;
5728 Position : integer;
5729 begin
5730 Position := Stream.Position;
5731
5732 ReadCheck(Stream, GifHeader, sizeof(GifHeader));
5733 if (uppercase(GifHeader.Signature) <> 'GIF') then
5734 begin
5735 // Attempt recovery in case we are reading a GIF stored in a form by rxLib
5736 Stream.Position := Position;
5737 // Seek past size stored in stream
5738 Stream.Seek(sizeof(longInt), soFromCurrent);
5739 // Attempt to read signature again
5740 ReadCheck(Stream, GifHeader, sizeof(GifHeader));
5741 if (uppercase(GifHeader.Signature) <> 'GIF') then
5742 Error(sBadSignature);
5743 end;
5744
5745 ReadCheck(Stream, FLogicalScreenDescriptor, sizeof(FLogicalScreenDescriptor));
5746
5747 if (FLogicalScreenDescriptor.PackedFields AND lsdGlobalColorTable = lsdGlobalColorTable) then
5748 begin
5749 ColorCount := 2 SHL (FLogicalScreenDescriptor.PackedFields AND lsdColorTableSize);
5750 if (ColorCount < 2) or (ColorCount > 256) then
5751 Error(sScreenBadColorSize);
5752 ColorMap.LoadFromStream(Stream, ColorCount)
5753 end else
5754 ColorMap.Clear;
5755 end;
5756
GetVersionnull5757 function TGIFHeader.GetVersion: TGIFVersion;
5758 begin
5759 if (FColorMap.Optimized) or (AspectRatio <> 0) then
5760 Result := gv89a
5761 else
5762 Result := inherited GetVersion;
5763 end;
5764
GetBackgroundColornull5765 function TGIFHeader.GetBackgroundColor: TColor;
5766 begin
5767 Result := FColorMap[BackgroundColorIndex];
5768 end;
5769
5770 procedure TGIFHeader.SetBackgroundColor(Color: TColor);
5771 begin
5772 BackgroundColorIndex := FColorMap.AddUnique(Color);
5773 end;
5774
5775 procedure TGIFHeader.SetBackgroundColorIndex(Index: BYTE);
5776 begin
5777 if ((Index >= FColorMap.Count) and (FColorMap.Count > 0)) then
5778 begin
5779 Warning(gsWarning, sBadColorIndex);
5780 Index := 0;
5781 end;
5782 FLogicalScreenDescriptor.BackgroundColorIndex := Index;
5783 end;
5784
GetBitsPerPixelnull5785 function TGIFHeader.GetBitsPerPixel: integer;
5786 begin
5787 Result := FColorMap.BitsPerPixel;
5788 end;
5789
GetColorResolutionnull5790 function TGIFHeader.GetColorResolution: integer;
5791 begin
5792 Result := FColorMap.BitsPerPixel-1;
5793 end;
5794
5795 ////////////////////////////////////////////////////////////////////////////////
5796 //
5797 // TGIFLocalColorMap
5798 //
5799 ////////////////////////////////////////////////////////////////////////////////
5800 type
5801 TGIFLocalColorMap = class(TGIFColorMap)
5802 private
5803 FSubImage : TGIFSubImage;
5804 protected
5805 procedure Warning(Severity: TGIFSeverity; Message: string); override;
5806 procedure BuildHistogram(var Histogram: TColormapHistogram); override;
5807 procedure MapImages(var Map: TColormapReverse); override;
5808 public
5809 constructor Create(SubImage: TGIFSubImage);
5810 function Optimize: boolean; override;
5811 procedure Changed; override;
5812 end;
5813
5814 constructor TGIFLocalColorMap.Create(SubImage: TGIFSubImage);
5815 begin
5816 Inherited Create;
5817 FSubImage := SubImage;
5818 end;
5819
5820 procedure TGIFLocalColorMap.Warning(Severity: TGIFSeverity; Message: string);
5821 begin
5822 FSubImage.Image.Warning(self, Severity, Message);
5823 end;
5824
5825 procedure TGIFLocalColorMap.BuildHistogram(var Histogram: TColormapHistogram);
5826 var
5827 Pixel ,
5828 LastPixel : PChar;
5829 i : integer;
5830 begin
5831 Pixel := FSubImage.Data;
5832 LastPixel := Pixel + FSubImage.Width * FSubImage.Height;
5833
5834 (*
5835 ** Init histogram
5836 *)
5837 for i := 0 to Count-1 do
5838 begin
5839 Histogram[i].Index := i;
5840 Histogram[i].Count := 0;
5841 end;
5842
5843 (*
5844 ** Sum up usage count for each color
5845 *)
5846 while (Pixel < LastPixel) do
5847 begin
5848 inc(Histogram[ord(Pixel^)].Count);
5849 inc(Pixel);
5850 end;
5851 end;
5852
5853 procedure TGIFLocalColorMap.MapImages(var Map: TColormapReverse);
5854 var
5855 Pixel ,
5856 LastPixel : PChar;
5857 begin
5858 Pixel := FSubImage.Data;
5859 LastPixel := Pixel + FSubImage.Width * FSubImage.Height;
5860
5861 (*
5862 ** Reorder all pixel to new map
5863 *)
5864 while (Pixel < LastPixel) do
5865 begin
5866 Pixel^ := chr(Map[ord(Pixel^)]);
5867 inc(Pixel);
5868 end;
5869
5870 (*
5871 ** Reorder transparent colors
5872 *)
5873 if (FSubImage.Transparent) then
5874 FSubImage.GraphicControlExtension.TransparentColorIndex :=
5875 Map[FSubImage.GraphicControlExtension.TransparentColorIndex];
5876 end;
5877
Optimizenull5878 function TGIFLocalColorMap.Optimize: boolean;
5879 begin
5880 Result := DoOptimize;
5881 end;
5882
5883 procedure TGIFLocalColorMap.Changed;
5884 begin
5885 FSubImage.Palette := 0;
5886 end;
5887
5888
5889 ////////////////////////////////////////////////////////////////////////////////
5890 //
5891 // LZW Decoder
5892 //
5893 ////////////////////////////////////////////////////////////////////////////////
5894 const
5895 GIFCodeBits = 12; // Max number of bits per GIF token code
5896 GIFCodeMax = (1 SHL GIFCodeBits)-1;// Max GIF token code
5897 // 12 bits = 4095
5898 StackSize = (2 SHL GIFCodeBits); // Size of decompression stack
5899 TableSize = (1 SHL GIFCodeBits); // Size of decompression table
5900
5901 procedure TGIFSubImage.Decompress(Stream: TStream);
5902 var
5903 table0 : array[0..TableSize-1] of integer;
5904 table1 : array[0..TableSize-1] of integer;
5905 firstcode, oldcode : integer;
5906 buf : array[0..257] of BYTE;
5907
5908 Dest : PChar;
5909 v ,
5910 xpos, ypos, pass : integer;
5911
5912 stack : array[0..StackSize-1] of integer;
5913 Source : ^integer;
5914 BitsPerCode : integer; // number of CodeTableBits/code
5915 InitialBitsPerCode : BYTE;
5916
5917 MaxCode : integer; // maximum code, given BitsPerCode
5918 MaxCodeSize : integer;
5919 ClearCode : integer; // Special code to signal "Clear table"
5920 EOFCode : integer; // Special code to signal EOF
5921 step : integer;
5922 i : integer;
5923
5924 StartBit , // Index of bit buffer start
5925 LastBit , // Index of last bit in buffer
5926 LastByte : integer; // Index of last byte in buffer
5927 get_done ,
5928 return_clear ,
5929 ZeroBlock : boolean;
5930 ClearValue : BYTE;
5931 {$ifdef DEBUG_DECOMPRESSPERFORMANCE}
5932 TimeStartDecompress ,
5933 TimeStopDecompress : DWORD;
5934 {$endif}
5935
5936 function nextCode(BitsPerCode: integer): integer;
5937 const
5938 masks: array[0..15] of integer =
5939 ($0000, $0001, $0003, $0007,
5940 $000f, $001f, $003f, $007f,
5941 $00ff, $01ff, $03ff, $07ff,
5942 $0fff, $1fff, $3fff, $7fff);
5943 var
5944 StartIndex, EndIndex : integer;
5945 ret : integer;
5946 EndBit : integer;
5947 count : BYTE;
5948 begin
5949 if (return_clear) then
5950 begin
5951 return_clear := False;
5952 Result := ClearCode;
5953 exit;
5954 end;
5955
5956 EndBit := StartBit + BitsPerCode;
5957
5958 if (EndBit >= LastBit) then
5959 begin
5960 if (get_done) then
5961 begin
5962 if (StartBit >= LastBit) then
5963 Warning(gsWarning, sDecodeTooFewBits);
5964 Result := -1;
5965 exit;
5966 end;
5967 buf[0] := buf[LastByte-2];
5968 buf[1] := buf[LastByte-1];
5969
5970 if (Stream.Read(count, 1) <> 1) then
5971 begin
5972 Result := -1;
5973 exit;
5974 end;
5975 if (count = 0) then
5976 begin
5977 ZeroBlock := True;
5978 get_done := TRUE;
5979 end else
5980 begin
5981 // Handle premature end of file
5982 if (Stream.Size - Stream.Position < Count) then
5983 begin
5984 Warning(gsWarning, sOutOfData);
5985 // Not enough data left - Just read as much as we can get
5986 Count := Stream.Size - Stream.Position;
5987 end;
5988 if (Count <> 0) then
5989 ReadCheck(Stream, Buf[2], Count);
5990 end;
5991
5992 LastByte := 2 + count;
5993 StartBit := (StartBit - LastBit) + 16;
5994 LastBit := LastByte * 8;
5995
5996 EndBit := StartBit + BitsPerCode;
5997 end;
5998
5999 EndIndex := EndBit DIV 8;
6000 StartIndex := StartBit DIV 8;
6001
6002 ASSERT(StartIndex <= high(buf), 'StartIndex too large');
6003 if (StartIndex = EndIndex) then
6004 ret := buf[StartIndex]
6005 else
6006 if (StartIndex + 1 = EndIndex) then
6007 ret := buf[StartIndex] OR (buf[StartIndex+1] SHL 8)
6008 else
6009 ret := buf[StartIndex] OR (buf[StartIndex+1] SHL 8) OR (buf[StartIndex+2] SHL 16);
6010
6011 ret := (ret SHR (StartBit AND $0007)) AND masks[BitsPerCode];
6012
6013 Inc(StartBit, BitsPerCode);
6014
6015 Result := ret;
6016 end;
6017
6018 function NextLZW: integer;
6019 var
6020 code, incode : integer;
6021 i : integer;
6022 b : BYTE;
6023 begin
6024 code := nextCode(BitsPerCode);
6025 while (code >= 0) do
6026 begin
6027 if (code = ClearCode) then
6028 begin
6029 ASSERT(ClearCode < TableSize, 'ClearCode too large');
6030 for i := 0 to ClearCode-1 do
6031 begin
6032 table0[i] := 0;
6033 table1[i] := i;
6034 end;
6035 for i := ClearCode to TableSize-1 do
6036 begin
6037 table0[i] := 0;
6038 table1[i] := 0;
6039 end;
6040 BitsPerCode := InitialBitsPerCode+1;
6041 MaxCodeSize := 2 * ClearCode;
6042 MaxCode := ClearCode + 2;
6043 Source := @stack;
6044 repeat
6045 firstcode := nextCode(BitsPerCode);
6046 oldcode := firstcode;
6047 until (firstcode <> ClearCode);
6048
6049 Result := firstcode;
6050 exit;
6051 end;
6052 if (code = EOFCode) then
6053 begin
6054 Result := -2;
6055 if (ZeroBlock) then
6056 exit;
6057 // Eat rest of data blocks
6058 if (Stream.Read(b, 1) <> 1) then
6059 exit;
6060 while (b <> 0) do
6061 begin
6062 Stream.Seek(b, soFromCurrent);
6063 if (Stream.Read(b, 1) <> 1) then
6064 exit;
6065 end;
6066 exit;
6067 end;
6068
6069 incode := code;
6070
6071 if (code >= MaxCode) then
6072 begin
6073 Source^ := firstcode;
6074 Inc(Source);
6075 code := oldcode;
6076 end;
6077
6078 ASSERT(Code < TableSize, 'Code too large');
6079 while (code >= ClearCode) do
6080 begin
6081 Source^ := table1[code];
6082 Inc(Source);
6083 if (code = table0[code]) then
6084 Error(sDecodeCircular);
6085 code := table0[code];
6086 ASSERT(Code < TableSize, 'Code too large');
6087 end;
6088
6089 firstcode := table1[code];
6090 Source^ := firstcode;
6091 Inc(Source);
6092
6093 code := MaxCode;
6094 if (code <= GIFCodeMax) then
6095 begin
6096 table0[code] := oldcode;
6097 table1[code] := firstcode;
6098 Inc(MaxCode);
6099 if ((MaxCode >= MaxCodeSize) and (MaxCodeSize <= GIFCodeMax)) then
6100 begin
6101 MaxCodeSize := MaxCodeSize * 2;
6102 Inc(BitsPerCode);
6103 end;
6104 end;
6105
6106 oldcode := incode;
6107
6108 if (longInt(Source) > longInt(@stack)) then
6109 begin
6110 Dec(Source);
6111 Result := Source^;
6112 exit;
6113 end
6114 end;
6115 Result := code;
6116 end;
6117
6118 function readLZW: integer;
6119 begin
6120 if (longInt(Source) > longInt(@stack)) then
6121 begin
6122 Dec(Source);
6123 Result := Source^;
6124 end else
6125 Result := NextLZW;
6126 end;
6127
6128 begin
6129 NewImage;
6130
6131 // Clear image data in case decompress doesn't complete
6132 if (Transparent) then
6133 // Clear to transparent color
6134 ClearValue := GraphicControlExtension.GetTransparentColorIndex
6135 else
6136 // Clear to first color
6137 ClearValue := 0;
6138
6139 FillChar(FData^, FDataSize, ClearValue);
6140
6141 {$ifdef DEBUG_DECOMPRESSPERFORMANCE}
6142 TimeStartDecompress := timeGetTime;
6143 {$endif}
6144
6145 (*
6146 ** Read initial code size in bits from stream
6147 *)
6148 if (Stream.Read(InitialBitsPerCode, 1) <> 1) then
6149 exit;
6150 // 2006.07.29 ->
6151 if InitialBitsPerCode > 8 then
6152 InitialBitsPerCode := 8;
6153 // 2006.07.29 <-
6154 (*
6155 ** Initialize the Compression routines
6156 *)
6157 BitsPerCode := InitialBitsPerCode + 1;
6158 ClearCode := 1 SHL InitialBitsPerCode;
6159 EOFCode := ClearCode + 1;
6160 MaxCodeSize := 2 * ClearCode;
6161 MaxCode := ClearCode + 2;
6162
6163 StartBit := 0;
6164 LastBit := 0;
6165 LastByte := 2;
6166
6167 ZeroBlock := False;
6168 get_done := False;
6169 return_clear := TRUE;
6170
6171 Source := @stack;
6172
6173 try
6174 if (Interlaced) then
6175 begin
6176 ypos := 0;
6177 pass := 0;
6178 step := 8;
6179
6180 for i := 0 to Height-1 do
6181 begin
6182 Dest := FData + Width * ypos;
6183 for xpos := 0 to width-1 do
6184 begin
6185 v := readLZW;
6186 if (v < 0) then
6187 exit;
6188 Dest^ := char(v);
6189 Inc(Dest);
6190 end;
6191 Inc(ypos, step);
6192 if (ypos >= height) then
6193 repeat
6194 if (pass > 0) then
6195 step := step DIV 2;
6196 Inc(pass);
6197 ypos := step DIV 2;
6198 until (ypos < height);
6199 end;
6200 end else
6201 begin
6202 Dest := FData;
6203 for ypos := 0 to (height * width)-1 do
6204 begin
6205 v := readLZW;
6206 if (v < 0) then
6207 exit;
6208 Dest^ := char(v);
6209 Inc(Dest);
6210 end;
6211 end;
6212 finally
6213 if (readLZW >= 0) then
6214 ;
6215 // raise GIFException.Create('Too much input data, ignoring extra...');
6216 end;
6217 {$ifdef DEBUG_DECOMPRESSPERFORMANCE}
6218 TimeStopDecompress := timeGetTime;
6219 ShowMessage(format('Decompressed %d pixels in %d mS, Rate %d pixels/mS',
6220 [Height*Width, TimeStopDecompress-TimeStartDecompress,
6221 (Height*Width) DIV (TimeStopDecompress-TimeStartDecompress+1)]));
6222 {$endif}
6223 end;
6224
6225 ////////////////////////////////////////////////////////////////////////////////
6226 //
6227 // LZW Encoder stuff
6228 //
6229 ////////////////////////////////////////////////////////////////////////////////
6230
6231 ////////////////////////////////////////////////////////////////////////////////
6232 // LZW Encoder THashTable
6233 ////////////////////////////////////////////////////////////////////////////////
6234 const
6235 HashKeyBits = 13; // Max number of bits per Hash Key
6236
6237 HashSize = 8009; // Size of hash table
6238 // Must be prime
6239 // Must be > than HashMaxCode
6240 // Must be < than HashMaxKey
6241
6242 HashKeyMax = (1 SHL HashKeyBits)-1;// Max hash key value
6243 // 13 bits = 8191
6244
6245 HashKeyMask = HashKeyMax; // $1FFF
6246 GIFCodeMask = GIFCodeMax; // $0FFF
6247
6248 HashEmpty = $000FFFFF; // 20 bits
6249
6250 type
6251 // A Hash Key is 20 bits wide.
6252 // - The lower 8 bits are the postfix character (the new pixel).
6253 // - The upper 12 bits are the prefix code (the GIF token).
6254 // A KeyInt must be able to represent the integer values -1..(2^20)-1
6255 KeyInt = longInt; // 32 bits
6256 CodeInt = SmallInt; // 16 bits
6257
6258 THashArray = array[0..HashSize-1] of KeyInt;
6259 PHashArray = ^THashArray;
6260
6261 THashTable = class
6262 {$ifdef DEBUG_HASHPERFORMANCE}
6263 CountLookupFound : longInt;
6264 CountMissFound : longInt;
6265 CountLookupNotFound : longInt;
6266 CountMissNotFound : longInt;
6267 {$endif}
6268 HashTable: PHashArray;
6269 public
6270 constructor Create;
6271 destructor Destroy; override;
6272 procedure Clear;
6273 procedure Insert(Key: KeyInt; Code: CodeInt);
Lookupnull6274 function Lookup(Key: KeyInt): CodeInt;
6275 end;
6276
HashKeynull6277 function HashKey(Key: KeyInt): CodeInt;
6278 begin
6279 Result := ((Key SHR (GIFCodeBits-8)) XOR Key) MOD HashSize;
6280 end;
6281
NextHashKeynull6282 function NextHashKey(HKey: CodeInt): CodeInt;
6283 var
6284 disp : CodeInt;
6285 begin
6286 (*
6287 ** secondary hash (after G. Knott)
6288 *)
6289 disp := HashSize - HKey;
6290 if (HKey = 0) then
6291 disp := 1;
6292 // disp := 13; // disp should be prime relative to HashSize, but
6293 // it doesn't seem to matter here...
6294 dec(HKey, disp);
6295 if (HKey < 0) then
6296 inc(HKey, HashSize);
6297 Result := HKey;
6298 end;
6299
6300
6301 constructor THashTable.Create;
6302 begin
6303 ASSERT(longInt($FFFFFFFF) = -1, 'TGIFImage implementation assumes $FFFFFFFF = -1');
6304
6305 inherited Create;
6306 GetMem(HashTable, sizeof(THashArray));
6307 Clear;
6308 {$ifdef DEBUG_HASHPERFORMANCE}
6309 CountLookupFound := 0;
6310 CountMissFound := 0;
6311 CountLookupNotFound := 0;
6312 CountMissNotFound := 0;
6313 {$endif}
6314 end;
6315
6316 destructor THashTable.Destroy;
6317 begin
6318 {$ifdef DEBUG_HASHPERFORMANCE}
6319 ShowMessage(
6320 Format('Found: %d HitRate: %.2f',
6321 [CountLookupFound, (CountLookupFound+1)/(CountMissFound+1)])+#13+
6322 Format('Not found: %d HitRate: %.2f',
6323 [CountLookupNotFound, (CountLookupNotFound+1)/(CountMissNotFound+1)]));
6324 {$endif}
6325 FreeMem(HashTable);
6326 inherited Destroy;
6327 end;
6328
6329 // Clear hash table and fill with empty slots (doh!)
6330 procedure THashTable.Clear;
6331 {$ifdef DEBUG_HASHFILLFACTOR}
6332 var
6333 i ,
6334 Count : longInt;
6335 {$endif}
6336 begin
6337 {$ifdef DEBUG_HASHFILLFACTOR}
6338 Count := 0;
6339 for i := 0 to HashSize-1 do
6340 if (HashTable[i] SHR GIFCodeBits <> HashEmpty) then
6341 inc(Count);
6342 ShowMessage(format('Size: %d, Filled: %d, Rate %.4f',
6343 [HashSize, Count, Count/HashSize]));
6344 {$endif}
6345
6346 FillChar(HashTable^, sizeof(THashArray), $FF);
6347 end;
6348
6349 // Insert new key/value pair into hash table
6350 procedure THashTable.Insert(Key: KeyInt; Code: CodeInt);
6351 var
6352 HKey : CodeInt;
6353 begin
6354 // Create hash key from prefix string
6355 HKey := HashKey(Key);
6356
6357 // Scan for empty slot
6358 // while (HashTable[HKey] SHR GIFCodeBits <> HashEmpty) do { Unoptimized }
6359 while (HashTable[HKey] AND (HashEmpty SHL GIFCodeBits) <> (HashEmpty SHL GIFCodeBits)) do { Optimized }
6360 HKey := NextHashKey(HKey);
6361 // Fill slot with key/value pair
6362 HashTable[HKey] := (Key SHL GIFCodeBits) OR (Code AND GIFCodeMask);
6363 end;
6364
6365 // Search for key in hash table.
6366 // Returns value if found or -1 if not
Lookupnull6367 function THashTable.Lookup(Key: KeyInt): CodeInt;
6368 var
6369 HKey : CodeInt;
6370 HTKey : KeyInt;
6371 {$ifdef DEBUG_HASHPERFORMANCE}
6372 n : LongInt;
6373 {$endif}
6374 begin
6375 // Create hash key from prefix string
6376 HKey := HashKey(Key);
6377
6378 {$ifdef DEBUG_HASHPERFORMANCE}
6379 n := 0;
6380 {$endif}
6381 // Scan table for key
6382 // HTKey := HashTable[HKey] SHR GIFCodeBits; { Unoptimized }
6383 Key := Key SHL GIFCodeBits; { Optimized }
6384 HTKey := HashTable[HKey] AND (HashEmpty SHL GIFCodeBits); { Optimized }
6385 // while (HTKey <> HashEmpty) do { Unoptimized }
6386 while (HTKey <> HashEmpty SHL GIFCodeBits) do { Optimized }
6387 begin
6388 if (Key = HTKey) then
6389 begin
6390 // Extract and return value
6391 Result := HashTable[HKey] AND GIFCodeMask;
6392 {$ifdef DEBUG_HASHPERFORMANCE}
6393 inc(CountLookupFound);
6394 inc(CountMissFound, n);
6395 {$endif}
6396 exit;
6397 end;
6398 {$ifdef DEBUG_HASHPERFORMANCE}
6399 inc(n);
6400 {$endif}
6401 // Try next slot
6402 HKey := NextHashKey(HKey);
6403 // HTKey := HashTable[HKey] SHR GIFCodeBits; { Unoptimized }
6404 HTKey := HashTable[HKey] AND (HashEmpty SHL GIFCodeBits); { Optimized }
6405 end;
6406 // Found empty slot - key doesn't exist
6407 Result := -1;
6408 {$ifdef DEBUG_HASHPERFORMANCE}
6409 inc(CountLookupNotFound);
6410 inc(CountMissNotFound, n);
6411 {$endif}
6412 end;
6413
6414 ////////////////////////////////////////////////////////////////////////////////
6415 // TGIFStream - Abstract GIF block stream
6416 //
6417 // Descendants from TGIFStream either reads or writes data in blocks
6418 // of up to 255 bytes. These blocks are organized as a leading byte
6419 // containing the number of bytes in the block (exclusing the count
6420 // byte itself), followed by the data (up to 254 bytes of data).
6421 ////////////////////////////////////////////////////////////////////////////////
6422 type
6423 TGIFStream = class(TStream)
6424 private
6425 FOnWarning : TGIFWarning;
6426 FStream : TStream;
6427 FOnProgress : TNotifyEvent;
6428 FBuffer : array [BYTE] of Char;
6429 FBufferCount : integer;
6430
6431 protected
6432 constructor Create(Stream: TStream);
6433
Readnull6434 function Read(var Buffer; Count: Longint): Longint; override;
Writenull6435 function Write(const Buffer; Count: Longint): Longint; override;
Seeknull6436 function Seek(Offset: Longint; Origin: Word): Longint; override;
6437
6438 procedure Progress(Sender: TObject); dynamic;
6439 property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
6440 public
6441 property Warning: TGIFWarning read FOnWarning write FOnWarning;
6442 end;
6443
6444 constructor TGIFStream.Create(Stream: TStream);
6445 begin
6446 inherited Create;
6447 FStream := Stream;
6448 FBufferCount := 1; // Reserve first byte of buffer for length
6449 end;
6450
6451 procedure TGIFStream.Progress(Sender: TObject);
6452 begin
6453 if Assigned(FOnProgress) then
6454 FOnProgress(Sender);
6455 end;
6456
Writenull6457 function TGIFStream.Write(const Buffer; Count: Longint): Longint;
6458 begin
6459 raise Exception.Create(sInvalidStream);
6460 end;
6461
Readnull6462 function TGIFStream.Read(var Buffer; Count: Longint): Longint;
6463 begin
6464 raise Exception.Create(sInvalidStream);
6465 end;
6466
TGIFStream.Seeknull6467 function TGIFStream.Seek(Offset: Longint; Origin: Word): Longint;
6468 begin
6469 raise Exception.Create(sInvalidStream);
6470 end;
6471
6472 ////////////////////////////////////////////////////////////////////////////////
6473 // TGIFReader - GIF block reader
6474 ////////////////////////////////////////////////////////////////////////////////
6475 type
6476 TGIFReader = class(TGIFStream)
6477 public
6478 constructor Create(Stream: TStream);
6479
Readnull6480 function Read(var Buffer; Count: Longint): Longint; override;
6481 end;
6482
6483 constructor TGIFReader.Create(Stream: TStream);
6484 begin
6485 inherited Create(Stream);
6486 FBufferCount := 0;
6487 end;
6488
Readnull6489 function TGIFReader.Read(var Buffer; Count: Longint): Longint;
6490 var
6491 n : integer;
6492 Dst : PChar;
6493 size : BYTE;
6494 begin
6495 Dst := @Buffer;
6496 Result := 0;
6497
6498 while (Count > 0) do
6499 begin
6500 // Get data from buffer
6501 while (FBufferCount > 0) and (Count > 0) do
6502 begin
6503 if (FBufferCount > Count) then
6504 n := Count
6505 else
6506 n := FBufferCount;
6507 Move(FBuffer, Dst^, n);
6508 dec(FBufferCount, n);
6509 dec(Count, n);
6510 inc(Result, n);
6511 inc(Dst, n);
6512 end;
6513
6514 // Refill buffer when it becomes empty
6515 if (FBufferCount <= 0) then
6516 begin
6517 FStream.Read(size, 1);
6518 { TODO -oanme -cImprovement : Should be handled as a warning instead of an error. }
6519 if (size >= 255) then
6520 Error('GIF block too large');
6521 FBufferCount := size;
6522 if (FBufferCount > 0) then
6523 begin
6524 n := FStream.Read(FBuffer, size);
6525 if (n = FBufferCount) then
6526 begin
6527 Warning(self, gsWarning, sOutOfData);
6528 break;
6529 end;
6530 end else
6531 break;
6532 end;
6533 end;
6534 end;
6535
6536 ////////////////////////////////////////////////////////////////////////////////
6537 // TGIFWriter - GIF block writer
6538 ////////////////////////////////////////////////////////////////////////////////
6539 type
6540 TGIFWriter = class(TGIFStream)
6541 private
6542 FOutputDirty : boolean;
6543
6544 protected
6545 procedure FlushBuffer;
6546
6547 public
6548 constructor Create(Stream: TStream);
6549 destructor Destroy; override;
6550
Writenull6551 function Write(const Buffer; Count: Longint): Longint; override;
WriteBytenull6552 function WriteByte(Value: BYTE): Longint;
6553 end;
6554
6555 constructor TGIFWriter.Create(Stream: TStream);
6556 begin
6557 inherited Create(Stream);
6558 FBufferCount := 1; // Reserve first byte of buffer for length
6559 FOutputDirty := False;
6560 end;
6561
6562 destructor TGIFWriter.Destroy;
6563 begin
6564 inherited Destroy;
6565 if (FOutputDirty) then
6566 FlushBuffer;
6567 end;
6568
6569 procedure TGIFWriter.FlushBuffer;
6570 begin
6571 if (FBufferCount <= 0) then
6572 exit;
6573
6574 FBuffer[0] := char(FBufferCount-1); // Block size excluding the count
6575 FStream.WriteBuffer(FBuffer, FBufferCount);
6576 FBufferCount := 1; // Reserve first byte of buffer for length
6577 FOutputDirty := False;
6578 end;
6579
Writenull6580 function TGIFWriter.Write(const Buffer; Count: Longint): Longint;
6581 var
6582 n : integer;
6583 Src : PChar;
6584 begin
6585 Result := Count;
6586 FOutputDirty := True;
6587 Src := @Buffer;
6588 while (Count > 0) do
6589 begin
6590 // Move data to the internal buffer in 255 byte chunks
6591 while (FBufferCount < sizeof(FBuffer)) and (Count > 0) do
6592 begin
6593 n := sizeof(FBuffer) - FBufferCount;
6594 if (n > Count) then
6595 n := Count;
6596 Move(Src^, FBuffer[FBufferCount], n);
6597 inc(Src, n);
6598 inc(FBufferCount, n);
6599 dec(Count, n);
6600 end;
6601
6602 // Flush the buffer when it is full
6603 if (FBufferCount >= sizeof(FBuffer)) then
6604 FlushBuffer;
6605 end;
6606 end;
6607
WriteBytenull6608 function TGIFWriter.WriteByte(Value: BYTE): Longint;
6609 begin
6610 Result := Write(Value, 1);
6611 end;
6612
6613 ////////////////////////////////////////////////////////////////////////////////
6614 // TGIFEncoder - Abstract encoder
6615 ////////////////////////////////////////////////////////////////////////////////
6616 type
6617 TGIFEncoder = class(TObject)
6618 protected
6619 FOnWarning : TGIFWarning;
6620 MaxColor : integer;
6621 BitsPerPixel : BYTE; // Bits per pixel of image
6622 Stream : TStream; // Output stream
6623 Width , // Width of image in pixels
6624 Height : integer; // height of image in pixels
6625 Interlace : boolean; // Interlace flag (True = interlaced image)
6626 Data : PChar; // Pointer to pixel data
6627 GIFStream : TGIFWriter; // Output buffer
6628
6629 OutputBucket : longInt; // Output bit bucket
6630 OutputBits : integer; // Current # of bits in bucket
6631
6632 ClearFlag : Boolean; // True if dictionary has just been cleared
6633 BitsPerCode , // Current # of bits per code
6634 InitialBitsPerCode : integer; // Initial # of bits per code after
6635 // dictionary has been cleared
6636 MaxCode : CodeInt; // maximum code, given BitsPerCode
6637 ClearCode : CodeInt; // Special output code to signal "Clear table"
6638 EOFCode : CodeInt; // Special output code to signal EOF
6639 BaseCode : CodeInt; // ...
6640
6641 Pixel : PChar; // Pointer to current pixel
6642
6643 cX , // Current X counter (Width - X)
6644 Y : integer; // Current Y
6645 Pass : integer; // Interlace pass
6646
MaxCodesFromBitsnull6647 function MaxCodesFromBits(Bits: integer): CodeInt;
6648 procedure Output(Value: integer); virtual;
6649 procedure Clear; virtual;
BumpPixelnull6650 function BumpPixel: boolean;
6651 procedure DoCompress; virtual; abstract;
6652 public
6653 procedure Compress(AStream: TStream; ABitsPerPixel: integer;
6654 AWidth, AHeight: integer; AInterlace: boolean; AData: PChar; AMaxColor: integer);
6655 property Warning: TGIFWarning read FOnWarning write FOnWarning;
6656 end;
6657
6658 // Calculate the maximum number of codes that a given number of bits can represent
6659 // MaxCodes := (1^bits)-1
MaxCodesFromBitsnull6660 function TGIFEncoder.MaxCodesFromBits(Bits: integer): CodeInt;
6661 begin
6662 Result := (CodeInt(1) SHL Bits) - 1;
6663 end;
6664
6665 // Stuff bits (variable sized codes) into a buffer and output them
6666 // a byte at a time
6667 procedure TGIFEncoder.Output(Value: integer);
6668 const
6669 BitBucketMask: array[0..16] of longInt =
6670 ($0000,
6671 $0001, $0003, $0007, $000F,
6672 $001F, $003F, $007F, $00FF,
6673 $01FF, $03FF, $07FF, $0FFF,
6674 $1FFF, $3FFF, $7FFF, $FFFF);
6675 begin
6676 if (OutputBits > 0) then
6677 OutputBucket :=
6678 (OutputBucket AND BitBucketMask[OutputBits]) OR (longInt(Value) SHL OutputBits)
6679 else
6680 OutputBucket := Value;
6681
6682 inc(OutputBits, BitsPerCode);
6683
6684 while (OutputBits >= 8) do
6685 begin
6686 GIFStream.WriteByte(OutputBucket AND $FF);
6687 OutputBucket := OutputBucket SHR 8;
6688 dec(OutputBits, 8);
6689 end;
6690
6691 if (Value = EOFCode) then
6692 begin
6693 // At EOF, write the rest of the buffer.
6694 while (OutputBits > 0) do
6695 begin
6696 GIFStream.WriteByte(OutputBucket AND $FF);
6697 OutputBucket := OutputBucket SHR 8;
6698 dec(OutputBits, 8);
6699 end;
6700 end;
6701 end;
6702
6703 procedure TGIFEncoder.Clear;
6704 begin
6705 // just_cleared = 1;
6706 ClearFlag := TRUE;
6707 Output(ClearCode);
6708 end;
6709
6710 // Bump (X,Y) and data pointer to point to the next pixel
BumpPixelnull6711 function TGIFEncoder.BumpPixel: boolean;
6712 begin
6713 // Bump the current X position
6714 dec(cX);
6715
6716 // If we are at the end of a scan line, set cX back to the beginning
6717 // If we are interlaced, bump Y to the appropriate spot, otherwise,
6718 // just increment it.
6719 if (cX <= 0) then
6720 begin
6721
6722 if not(Interlace) then
6723 begin
6724 // Done - no more data
6725 Result := False;
6726 exit;
6727 end;
6728
6729 cX := Width;
6730 case (Pass) of
6731 0:
6732 begin
6733 inc(Y, 8);
6734 if (Y >= Height) then
6735 begin
6736 inc(Pass);
6737 Y := 4;
6738 end;
6739 end;
6740 1:
6741 begin
6742 inc(Y, 8);
6743 if (Y >= Height) then
6744 begin
6745 inc(Pass);
6746 Y := 2;
6747 end;
6748 end;
6749 2:
6750 begin
6751 inc(Y, 4);
6752 if (Y >= Height) then
6753 begin
6754 inc(Pass);
6755 Y := 1;
6756 end;
6757 end;
6758 3:
6759 inc(Y, 2);
6760 end;
6761
6762 if (Y >= height) then
6763 begin
6764 // Done - No more data
6765 Result := False;
6766 exit;
6767 end;
6768 Pixel := Data + (Y * Width);
6769 end;
6770 Result := True;
6771 end;
6772
6773
6774 procedure TGIFEncoder.Compress(AStream: TStream; ABitsPerPixel: integer;
6775 AWidth, AHeight: integer; AInterlace: boolean; AData: PChar; AMaxColor: integer);
6776 const
6777 EndBlockByte = $00; // End of block marker
6778 {$ifdef DEBUG_COMPRESSPERFORMANCE}
6779 var
6780 TimeStartCompress ,
6781 TimeStopCompress : DWORD;
6782 {$endif}
6783 begin
6784 MaxColor := AMaxColor;
6785 Stream := AStream;
6786 BitsPerPixel := ABitsPerPixel;
6787 Width := AWidth;
6788 Height := AHeight;
6789 Interlace := AInterlace;
6790 Data := AData;
6791
6792 if (BitsPerPixel <= 1) then
6793 BitsPerPixel := 2;
6794
6795 InitialBitsPerCode := BitsPerPixel + 1;
6796 Stream.Write(BitsPerPixel, 1);
6797
6798 // out_bits_init = init_bits;
6799 BitsPerCode := InitialBitsPerCode;
6800 MaxCode := MaxCodesFromBits(BitsPerCode);
6801
6802 ClearCode := (1 SHL (InitialBitsPerCode - 1));
6803 EOFCode := ClearCode + 1;
6804 BaseCode := EOFCode + 1;
6805
6806 // Clear bit bucket
6807 OutputBucket := 0;
6808 OutputBits := 0;
6809
6810 // Reset pixel counter
6811 if (Interlace) then
6812 cX := Width
6813 else
6814 cX := Width*Height;
6815 // Reset row counter
6816 Y := 0;
6817 Pass := 0;
6818
6819 GIFStream := TGIFWriter.Create(AStream);
6820 try
6821 GIFStream.Warning := Warning;
6822 if (Data <> nil) and (Height > 0) and (Width > 0) then
6823 begin
6824 {$ifdef DEBUG_COMPRESSPERFORMANCE}
6825 TimeStartCompress := timeGetTime;
6826 {$endif}
6827
6828 // Call compress implementation
6829 DoCompress;
6830
6831 {$ifdef DEBUG_COMPRESSPERFORMANCE}
6832 TimeStopCompress := timeGetTime;
6833 ShowMessage(format('Compressed %d pixels in %d mS, Rate %d pixels/mS',
6834 [Height*Width, TimeStopCompress-TimeStartCompress,
6835 DWORD(Height*Width) DIV (TimeStopCompress-TimeStartCompress+1)]));
6836 {$endif}
6837 // Output the final code.
6838 Output(EOFCode);
6839 end else
6840 // Output the final code (and nothing else).
6841 TGIFEncoder(self).Output(EOFCode);
6842 finally
6843 GIFStream.Free;
6844 end;
6845
6846 WriteByte(Stream, EndBlockByte);
6847 end;
6848
6849 ////////////////////////////////////////////////////////////////////////////////
6850 // TRLEEncoder - RLE encoder
6851 ////////////////////////////////////////////////////////////////////////////////
6852 type
6853 TRLEEncoder = class(TGIFEncoder)
6854 private
6855 MaxCodes : integer;
6856 OutBumpInit ,
6857 OutClearInit : integer;
6858 Prefix : integer; // Current run color
6859 RunLengthTableMax ,
6860 RunLengthTablePixel ,
6861 OutCount ,
6862 OutClear ,
6863 OutBump : integer;
6864 protected
ComputeTriangleCountnull6865 function ComputeTriangleCount(count: integer; nrepcodes: integer): integer;
6866 procedure MaxOutClear;
6867 procedure ResetOutClear;
6868 procedure FlushFromClear(Count: integer);
6869 procedure FlushClearOrRepeat(Count: integer);
6870 procedure FlushWithTable(Count: integer);
6871 procedure Flush(RunLengthCount: integer);
6872 procedure OutputPlain(Value: integer);
6873 procedure Clear; override;
6874 procedure DoCompress; override;
6875 end;
6876
6877
6878 procedure TRLEEncoder.Clear;
6879 begin
6880 OutBump := OutBumpInit;
6881 OutClear := OutClearInit;
6882 OutCount := 0;
6883 RunLengthTableMax := 0;
6884
6885 inherited Clear;
6886
6887 BitsPerCode := InitialBitsPerCode;
6888 end;
6889
6890 procedure TRLEEncoder.OutputPlain(Value: integer);
6891 begin
6892 ClearFlag := False;
6893 Output(Value);
6894 inc(OutCount);
6895
6896 if (OutCount >= OutBump) then
6897 begin
6898 inc(BitsPerCode);
6899 inc(OutBump, 1 SHL (BitsPerCode - 1));
6900 end;
6901
6902 if (OutCount >= OutClear) then
6903 Clear;
6904 end;
6905
TRLEEncoder.ComputeTriangleCountnull6906 function TRLEEncoder.ComputeTriangleCount(count: integer; nrepcodes: integer): integer;
6907 var
6908 PerRepeat : integer;
6909 n : integer;
6910
iSqrtnull6911 function iSqrt(x: integer): integer;
6912 var
6913 r, v : integer;
6914 begin
6915 if (x < 2) then
6916 begin
6917 Result := x;
6918 exit;
6919 end else
6920 begin
6921 v := x;
6922 r := 1;
6923 while (v > 0) do
6924 begin
6925 v := v DIV 4;
6926 r := r * 2;
6927 end;
6928 end;
6929
6930 while (True) do
6931 begin
6932 v := ((x DIV r) + r) DIV 2;
6933 if ((v = r) or (v = r+1)) then
6934 begin
6935 Result := r;
6936 exit;
6937 end;
6938 r := v;
6939 end;
6940 end;
6941
6942 begin
6943 Result := 0;
6944 PerRepeat := (nrepcodes * (nrepcodes+1)) DIV 2;
6945
6946 while (Count >= PerRepeat) do
6947 begin
6948 inc(Result, nrepcodes);
6949 dec(Count, PerRepeat);
6950 end;
6951
6952 if (Count > 0) then
6953 begin
6954 n := iSqrt(Count);
6955 while ((n * (n+1)) >= 2*Count) do
6956 dec(n);
6957 while ((n * (n+1)) < 2*Count) do
6958 inc(n);
6959 inc(Result, n);
6960 end;
6961 end;
6962
6963 procedure TRLEEncoder.MaxOutClear;
6964 begin
6965 OutClear := MaxCodes;
6966 end;
6967
6968 procedure TRLEEncoder.ResetOutClear;
6969 begin
6970 OutClear := OutClearInit;
6971 if (OutCount >= OutClear) then
6972 Clear;
6973 end;
6974
6975 procedure TRLEEncoder.FlushFromClear(Count: integer);
6976 var
6977 n : integer;
6978 begin
6979 MaxOutClear;
6980 RunLengthTablePixel := Prefix;
6981 n := 1;
6982 while (Count > 0) do
6983 begin
6984 if (n = 1) then
6985 begin
6986 RunLengthTableMax := 1;
6987 OutputPlain(Prefix);
6988 dec(Count);
6989 end else
6990 if (Count >= n) then
6991 begin
6992 RunLengthTableMax := n;
6993 OutputPlain(BaseCode + n - 2);
6994 dec(Count, n);
6995 end else
6996 if (Count = 1) then
6997 begin
6998 inc(RunLengthTableMax);
6999 OutputPlain(Prefix);
7000 break;
7001 end else
7002 begin
7003 inc(RunLengthTableMax);
7004 OutputPlain(BaseCode + Count - 2);
7005 break;
7006 end;
7007
7008 if (OutCount = 0) then
7009 n := 1
7010 else
7011 inc(n);
7012 end;
7013 ResetOutClear;
7014 end;
7015
7016 procedure TRLEEncoder.FlushClearOrRepeat(Count: integer);
7017 var
7018 WithClear : integer;
7019 begin
7020 WithClear := 1 + ComputeTriangleCount(Count, MaxCodes);
7021
7022 if (WithClear < Count) then
7023 begin
7024 Clear;
7025 FlushFromClear(Count);
7026 end else
7027 while (Count > 0) do
7028 begin
7029 OutputPlain(Prefix);
7030 dec(Count);
7031 end;
7032 end;
7033
7034 procedure TRLEEncoder.FlushWithTable(Count: integer);
7035 var
7036 RepeatMax ,
7037 RepeatLeft ,
7038 LeftOver : integer;
7039 begin
7040 RepeatMax := Count DIV RunLengthTableMax;
7041 LeftOver := Count MOD RunLengthTableMax;
7042 if (LeftOver <> 0) then
7043 RepeatLeft := 1
7044 else
7045 RepeatLeft := 0;
7046
7047 if (OutCount + RepeatMax + RepeatLeft > MaxCodes) then
7048 begin
7049 RepeatMax := MaxCodes - OutCount;
7050 LeftOver := Count - (RepeatMax * RunLengthTableMax);
7051 RepeatLeft := 1 + ComputeTriangleCount(LeftOver, MaxCodes);
7052 end;
7053
7054 if (1 + ComputeTriangleCount(Count, MaxCodes) < RepeatMax + RepeatLeft) then
7055 begin
7056 Clear;
7057 FlushFromClear(Count);
7058 exit;
7059 end;
7060 MaxOutClear;
7061
7062 while (RepeatMax > 0) do
7063 begin
7064 OutputPlain(BaseCode + RunLengthTableMax-2);
7065 dec(RepeatMax);
7066 end;
7067
7068 if (LeftOver > 0) then
7069 begin
7070 if (ClearFlag) then
7071 FlushFromClear(LeftOver)
7072 else if (LeftOver = 1) then
7073 OutputPlain(Prefix)
7074 else
7075 OutputPlain(BaseCode + LeftOver - 2);
7076 end;
7077 ResetOutClear;
7078 end;
7079
7080 procedure TRLEEncoder.Flush(RunLengthCount: integer);
7081 begin
7082 if (RunLengthCount = 1) then
7083 begin
7084 OutputPlain(Prefix);
7085 exit;
7086 end;
7087
7088 if (ClearFlag) then
7089 FlushFromClear(RunLengthCount)
7090 else if ((RunLengthTableMax < 2) or (RunLengthTablePixel <> Prefix)) then
7091 FlushClearOrRepeat(RunLengthCount)
7092 else
7093 FlushWithTable(RunLengthCount);
7094 end;
7095
7096 procedure TRLEEncoder.DoCompress;
7097 var
7098 Color : CodeInt;
7099 RunLengthCount : integer;
7100
7101 begin
7102 OutBumpInit := ClearCode - 1;
7103
7104 // For images with a lot of runs, making OutClearInit larger will
7105 // give better compression.
7106 if (BitsPerPixel <= 3) then
7107 OutClearInit := 9
7108 else
7109 OutClearInit := OutBumpInit - 1;
7110
7111 // max_ocodes = (1 << GIFBITS) - ((1 << (out_bits_init - 1)) + 3);
7112 // <=> MaxCodes := (1 SHL GIFCodeBits) - ((1 SHL (BitsPerCode - 1)) + 3);
7113 // <=> MaxCodes := (1 SHL GIFCodeBits) - ((1 SHL (InitialBitsPerCode - 1)) + 3);
7114 // <=> MaxCodes := (1 SHL GIFCodeBits) - (ClearCode + 3);
7115 // <=> MaxCodes := (1 SHL GIFCodeBits) - (EOFCode + 2);
7116 // <=> MaxCodes := (1 SHL GIFCodeBits) - (BaseCode + 1);
7117 // <=> MaxCodes := MaxCodesFromBits(GIFCodeBits) - BaseCode;
7118 MaxCodes := MaxCodesFromBits(GIFCodeBits) - BaseCode;
7119
7120 Clear;
7121 RunLengthCount := 0;
7122
7123 Pixel := Data;
7124 Prefix := -1; // Dummy value to make Color <> Prefix
7125 repeat
7126 // Fetch the next pixel
7127 Color := CodeInt(Pixel^);
7128 inc(Pixel);
7129
7130 if (Color >= MaxColor) then
7131 Error(sInvalidColor);
7132
7133 if (RunLengthCount > 0) and (Color <> Prefix) then
7134 begin
7135 // End of current run
7136 Flush(RunLengthCount);
7137 RunLengthCount := 0;
7138 end;
7139
7140 if (Color = Prefix) then
7141 // Increment run length
7142 inc(RunLengthCount)
7143 else
7144 begin
7145 // Start new run
7146 Prefix := Color;
7147 RunLengthCount := 1;
7148 end;
7149 until not(BumpPixel);
7150 Flush(RunLengthCount);
7151 end;
7152
7153 ////////////////////////////////////////////////////////////////////////////////
7154 // TLZWEncoder - LZW encoder
7155 ////////////////////////////////////////////////////////////////////////////////
7156 const
7157 TableMaxMaxCode = (1 SHL GIFCodeBits); //
7158 TableMaxFill = TableMaxMaxCode-1; // Clear table when it fills to
7159 // this point.
7160 // Note: Must be <= GIFCodeMax
7161 type
7162 TLZWEncoder = class(TGIFEncoder)
7163 private
7164 Prefix : CodeInt; // Current run color
7165 FreeEntry : CodeInt; // next unused code in table
7166 HashTable : THashTable;
7167 protected
7168 procedure Output(Value: integer); override;
7169 procedure Clear; override;
7170 procedure DoCompress; override;
7171 end;
7172
7173
7174 procedure TLZWEncoder.Output(Value: integer);
7175 begin
7176 inherited Output(Value);
7177
7178 // If the next entry is going to be too big for the code size,
7179 // then increase it, if possible.
7180 if (FreeEntry > MaxCode) or (ClearFlag) then
7181 begin
7182 if (ClearFlag) then
7183 begin
7184 BitsPerCode := InitialBitsPerCode;
7185 MaxCode := MaxCodesFromBits(BitsPerCode);
7186 ClearFlag := False;
7187 end else
7188 begin
7189 inc(BitsPerCode);
7190 if (BitsPerCode = GIFCodeBits) then
7191 MaxCode := TableMaxMaxCode
7192 else
7193 MaxCode := MaxCodesFromBits(BitsPerCode);
7194 end;
7195 end;
7196 end;
7197
7198 procedure TLZWEncoder.Clear;
7199 begin
7200 inherited Clear;
7201 HashTable.Clear;
7202 FreeEntry := ClearCode + 2;
7203 end;
7204
7205
7206 procedure TLZWEncoder.DoCompress;
7207 var
7208 Color : char;
7209 NewKey : KeyInt;
7210 NewCode : CodeInt;
7211
7212 begin
7213 HashTable := THashTable.Create;
7214 try
7215 // clear hash table and sync decoder
7216 Clear;
7217
7218 Pixel := Data;
7219 Prefix := CodeInt(Pixel^);
7220 inc(Pixel);
7221 if (Prefix >= MaxColor) then
7222 Error(sInvalidColor);
7223 while (BumpPixel) do
7224 begin
7225 // Fetch the next pixel
7226 Color := Pixel^;
7227 inc(Pixel);
7228 if (ord(Color) >= MaxColor) then
7229 Error(sInvalidColor);
7230
7231 // Append Postfix to Prefix and lookup in table...
7232 NewKey := (KeyInt(Prefix) SHL 8) OR ord(Color);
7233 NewCode := HashTable.Lookup(NewKey);
7234 if (NewCode >= 0) then
7235 begin
7236 // ...if found, get next pixel
7237 Prefix := NewCode;
7238 continue;
7239 end;
7240
7241 // ...if not found, output and start over
7242 Output(Prefix);
7243 Prefix := CodeInt(Color);
7244
7245 if (FreeEntry < TableMaxFill) then
7246 begin
7247 HashTable.Insert(NewKey, FreeEntry);
7248 inc(FreeEntry);
7249 end else
7250 Clear;
7251 end;
7252 Output(Prefix);
7253 finally
7254 HashTable.Free;
7255 end;
7256 end;
7257
7258 ////////////////////////////////////////////////////////////////////////////////
7259 //
7260 // TGIFSubImage
7261 //
7262 ////////////////////////////////////////////////////////////////////////////////
7263
7264 /////////////////////////////////////////////////////////////////////////
7265 // TGIFSubImage.Compress
7266 /////////////////////////////////////////////////////////////////////////
7267 procedure TGIFSubImage.Compress(Stream: TStream);
7268 var
7269 Encoder : TGIFEncoder;
7270 BitsPerPixel : BYTE;
7271 MaxColors : integer;
7272 begin
7273 if (ColorMap.Count > 0) then
7274 begin
7275 MaxColors := ColorMap.Count;
7276 BitsPerPixel := ColorMap.BitsPerPixel
7277 end else
7278 begin
7279 BitsPerPixel := Image.BitsPerPixel;
7280 MaxColors := 1 SHL BitsPerPixel;
7281 end;
7282
7283 // Create a RLE or LZW GIF encoder
7284 if (Image.Compression = gcRLE) then
7285 Encoder := TRLEEncoder.Create
7286 else
7287 Encoder := TLZWEncoder.Create;
7288 try
7289 Encoder.Warning := Image.Warning;
7290 Encoder.Compress(Stream, BitsPerPixel, Width, Height, Interlaced, FData, MaxColors);
7291 finally
7292 Encoder.Free;
7293 end;
7294 end;
7295
GetExtensionnull7296 function TGIFExtensionList.GetExtension(Index: Integer): TGIFExtension;
7297 begin
7298 Result := TGIFExtension(Items[Index]);
7299 end;
7300
7301 procedure TGIFExtensionList.SetExtension(Index: Integer; Extension: TGIFExtension);
7302 begin
7303 Items[Index] := Extension;
7304 end;
7305
7306 procedure TGIFExtensionList.LoadFromStream(Stream: TStream; Parent: TObject);
7307 var
7308 b : BYTE;
7309 Extension : TGIFExtension;
7310 ExtensionClass : TGIFExtensionClass;
7311 begin
7312 // Peek ahead to determine block type
7313 if (Stream.Read(b, 1) <> 1) then
7314 exit;
7315 while not(b in [bsTrailer, bsImageDescriptor]) do
7316 begin
7317 if (b = bsExtensionIntroducer) then
7318 begin
7319 ExtensionClass := TGIFExtension.FindExtension(Stream);
7320 if (ExtensionClass = nil) then
7321 Error(sUnknownExtension);
7322 Stream.Seek(-1, soFromCurrent);
7323 Extension := ExtensionClass.Create(Parent as TGIFSubImage);
7324 try
7325 Extension.LoadFromStream(Stream);
7326 Add(Extension);
7327 except
7328 Extension.Free;
7329 raise;
7330 end;
7331 end else
7332 begin
7333 Warning(gsWarning, sBadExtensionLabel);
7334 break;
7335 end;
7336 if (Stream.Read(b, 1) <> 1) then
7337 exit;
7338 end;
7339 Stream.Seek(-1, soFromCurrent);
7340 end;
7341
7342 const
7343 { image descriptor bit masks }
7344 idLocalColorTable = $80; { set if a local color table follows }
7345 idInterlaced = $40; { set if image is interlaced }
7346 idSort = $20; { set if color table is sorted }
7347 idReserved = $0C; { reserved - must be set to $00 }
7348 idColorTableSize = $07; { size of color table as above }
7349
7350 constructor TGIFSubImage.Create(GIFImage: TGIFImage);
7351 begin
7352 inherited Create(GIFImage);
7353 FExtensions := TGIFExtensionList.Create(GIFImage);
7354 FColorMap := TGIFLocalColorMap.Create(self);
7355 FImageDescriptor.Separator := bsImageDescriptor;
7356 FImageDescriptor.Left := 0;
7357 FImageDescriptor.Top := 0;
7358 FImageDescriptor.Width := 0;
7359 FImageDescriptor.Height := 0;
7360 FImageDescriptor.PackedFields := 0;
7361 FBitmap := nil;
7362 FMask := 0;
7363 FNeedMask := True;
7364 FData := nil;
7365 FDataSize := 0;
7366 FTransparent := False;
7367 FGCE := nil;
7368 // Remember to synchronize with TGIFSubImage.Clear
7369 end;
7370
7371 destructor TGIFSubImage.Destroy;
7372 begin
7373 if (FGIFImage <> nil) then
7374 FGIFImage.Images.Remove(self);
7375 Clear;
7376 FExtensions.Free;
7377 FColorMap.Free;
7378 if (FLocalPalette <> 0) then
7379 DeleteObject(FLocalPalette);
7380 inherited Destroy;
7381 end;
7382
7383 procedure TGIFSubImage.Clear;
7384 begin
7385 FExtensions.Clear;
7386 FColorMap.Clear;
7387 FreeImage;
7388 Height := 0;
7389 Width := 0;
7390 FTransparent := False;
7391 FGCE := nil;
7392 FreeBitmap;
7393 FreeMask;
7394 // Remember to synchronize with TGIFSubImage.Create
7395 end;
7396
GetEmptynull7397 function TGIFSubImage.GetEmpty: Boolean;
7398 begin
7399 Result := ((FData = nil) or (FDataSize = 0) or (Height = 0) or (Width = 0));
7400 end;
7401
GetPalettenull7402 function TGIFSubImage.GetPalette: HPALETTE;
7403 begin
7404 if (FBitmap <> nil) and (FBitmap.Palette <> 0) then
7405 // Use bitmaps own palette if possible
7406 Result := FBitmap.Palette
7407 else if (FLocalPalette <> 0) then
7408 // Or a previously exported local palette
7409 Result := FLocalPalette
7410 else if (Image.DoDither) then
7411 begin
7412 // or create a new dither palette
7413 FLocalPalette := WebPalette;
7414 Result := FLocalPalette;
7415 end
7416 else if (ColorMap.Count > 0) then
7417 begin
7418 // or create a new if first time
7419 FLocalPalette := ColorMap.ExportPalette;
7420 Result := FLocalPalette;
7421 end else
7422 // Use global palette if everything else fails
7423 Result := Image.Palette;
7424 end;
7425
7426 procedure TGIFSubImage.SetPalette(Value: HPalette);
7427 var
7428 NeedNewBitmap : boolean;
7429 begin
7430 if (Value <> FLocalPalette) then
7431 begin
7432 // Zap old palette
7433 if (FLocalPalette <> 0) then
7434 DeleteObject(FLocalPalette);
7435 // Zap bitmap unless new palette is same as bitmaps own
7436 NeedNewBitmap := (FBitmap <> nil) and (Value <> FBitmap.Palette);
7437
7438 // Use new palette
7439 FLocalPalette := Value;
7440 if (NeedNewBitmap) then
7441 begin
7442 // Need to create new bitmap and repaint
7443 FreeBitmap;
7444 Image.PaletteModified := True;
7445 Image.Changed(Self);
7446 end;
7447 end;
7448 end;
7449
7450 procedure TGIFSubImage.NeedImage;
7451 begin
7452 if (FData = nil) then
7453 NewImage;
7454 if (FDataSize = 0) then
7455 Error(sEmptyImage);
7456 end;
7457
7458 procedure TGIFSubImage.NewImage;
7459 var
7460 NewSize : longInt;
7461 begin
7462 FreeImage;
7463 NewSize := Height * Width;
7464 if (NewSize <> 0) then
7465 begin
7466 GetMem(FData, NewSize);
7467 FillChar(FData^, NewSize, 0);
7468 end else
7469 FData := nil;
7470 FDataSize := NewSize;
7471 end;
7472
7473 procedure TGIFSubImage.FreeImage;
7474 begin
7475 if (FData <> nil) then
7476 FreeMem(FData);
7477 FDataSize := 0;
7478 FData := nil;
7479 end;
7480
GetHasBitmapnull7481 function TGIFSubImage.GetHasBitmap: boolean;
7482 begin
7483 Result := (FBitmap <> nil);
7484 end;
7485
7486 procedure TGIFSubImage.SetHasBitmap(Value: boolean);
7487 begin
7488 if (Value <> (FBitmap <> nil)) then
7489 begin
7490 if (Value) then
7491 Bitmap // Referencing Bitmap will automatically create it
7492 else
7493 FreeBitmap;
7494 end;
7495 end;
7496
7497 procedure TGIFSubImage.NewBitmap;
7498 begin
7499 FreeBitmap;
7500 FBitmap := TBitmap.Create;
7501 end;
7502
7503 procedure TGIFSubImage.FreeBitmap;
7504 begin
7505 if (FBitmap <> nil) then
7506 begin
7507 FBitmap.Free;
7508 FBitmap := nil;
7509 end;
7510 end;
7511
7512 procedure TGIFSubImage.FreeMask;
7513 begin
7514 if (FMask <> 0) then
7515 begin
7516 DeleteObject(FMask);
7517 FMask := 0;
7518 end;
7519 FNeedMask := True;
7520 end;
7521
TGIFSubImage.HasMasknull7522 function TGIFSubImage.HasMask: boolean;
7523 begin
7524 if (FNeedMask) and (Transparent) then
7525 begin
7526 // Zap old bitmap
7527 FreeBitmap;
7528 // Create new bitmap and mask
7529 GetBitmap;
7530 end;
7531 Result := (FMask <> 0);
7532 end;
7533
TGIFSubImage.GetBoundsnull7534 function TGIFSubImage.GetBounds(Index: integer): WORD;
7535 begin
7536 case (Index) of
7537 1: Result := FImageDescriptor.Left;
7538 2: Result := FImageDescriptor.Top;
7539 3: Result := FImageDescriptor.Width;
7540 4: Result := FImageDescriptor.Height;
7541 else
7542 Result := 0; // To avoid compiler warnings
7543 end;
7544 end;
7545
7546 procedure TGIFSubImage.SetBounds(Index: integer; Value: WORD);
7547 begin
7548 case (Index) of
7549 1: DoSetBounds(Value, FImageDescriptor.Top, FImageDescriptor.Width, FImageDescriptor.Height);
7550 2: DoSetBounds(FImageDescriptor.Left, Value, FImageDescriptor.Width, FImageDescriptor.Height);
7551 3: DoSetBounds(FImageDescriptor.Left, FImageDescriptor.Top, Value, FImageDescriptor.Height);
7552 4: DoSetBounds(FImageDescriptor.Left, FImageDescriptor.Top, FImageDescriptor.Width, Value);
7553 end;
7554 end;
7555
7556 {$IFOPT R+}
7557 {$DEFINE R_PLUS}
7558 {$RANGECHECKS OFF}
7559 {$ENDIF}
DoGetDitherBitmapnull7560 function TGIFSubImage.DoGetDitherBitmap: TBitmap;
7561 var
7562 ColorLookup : TColorLookup;
7563 Ditherer : TDitherEngine;
7564 DIBResult : TDIB;
7565 Src : PChar;
7566 Dst : PChar;
7567
7568 Row : integer;
7569 Color : TGIFColor;
7570 ColMap : PColorMap;
7571 Index : byte;
7572 TransparentIndex : byte;
7573 IsTransparent : boolean;
7574 WasTransparent : boolean;
7575 MappedTransparentIndex: char;
7576
7577 MaskBits : PChar;
7578 MaskDest : PChar;
7579 MaskRow : PChar;
7580 MaskRowWidth ,
7581 MaskRowBitWidth : integer;
7582 Bit ,
7583 RightBit : BYTE;
7584
7585 begin
7586 Result := TBitmap.Create;
7587 try
7588
7589 {$IFNDEF VER9x}
7590 if (Width*Height > BitmapAllocationThreshold) then
7591 SetPixelFormat(Result, pf1bit); // To reduce resource consumption of resize
7592 {$ENDIF}
7593
7594 if (Empty) then
7595 begin
7596 // Set bitmap width and height
7597 Result.Width := Width;
7598 Result.Height := Height;
7599
7600 // Build and copy palette to bitmap
7601 Result.Palette := CopyPalette(Palette);
7602
7603 exit;
7604 end;
7605
7606 ColorLookup := nil;
7607 Ditherer := nil;
7608 DIBResult := nil;
7609 try // Protect above resources
7610 ColorLookup := TNetscapeColorLookup.Create(Palette);
7611 Ditherer := TFloydSteinbergDitherer.Create(Width, ColorLookup);
7612 // Get DIB buffer for scanline operations
7613 // It is assumed that the source palette is the 216 color Netscape palette
7614 DIBResult := TDIBWriter.Create(Result, pf8bit, Width, Height, Palette);
7615
7616 // Determine if this image is transparent
7617 ColMap := ActiveColorMap.Data;
7618 IsTransparent := FNeedMask and Transparent;
7619 WasTransparent := False;
7620 FNeedMask := False;
7621 TransparentIndex := 0;
7622 MappedTransparentIndex := #0;
7623 if (FMask = 0) and (IsTransparent) then
7624 begin
7625 IsTransparent := True;
7626 TransparentIndex := GraphicControlExtension.TransparentColorIndex;
7627 Color := ColMap[ord(TransparentIndex)];
7628 MappedTransparentIndex := char(Color.Blue DIV 51 +
7629 MulDiv(6, Color.Green, 51) + MulDiv(36, Color.Red, 51)+1);
7630 end;
7631
7632 // Allocate bit buffer for transparency mask
7633 MaskDest := nil;
7634 Bit := $00;
7635 if (IsTransparent) then
7636 begin
7637 MaskRowWidth := ((Width+15) DIV 16) * 2;
7638 MaskRowBitWidth := (Width+7) DIV 8;
7639 RightBit := $01 SHL ((8 - (Width AND $0007)) AND $0007);
7640 GetMem(MaskBits, MaskRowWidth * Height);
7641 FillChar(MaskBits^, MaskRowWidth * Height, 0);
7642 end else
7643 begin
7644 MaskBits := nil;
7645 MaskRowWidth := 0;
7646 MaskRowBitWidth := 0;
7647 RightBit := $00;
7648 end;
7649
7650 try
7651 // Process the image
7652 Row := 0;
7653 MaskRow := MaskBits;
7654 Src := FData;
7655 while (Row < Height) do
7656 begin
7657 if ((Row AND $1F) = 0) then
7658 Image.Progress(Self, psRunning, MulDiv(Row, 100, Height),
7659 False, Rect(0,0,0,0), sProgressRendering);
7660
7661 Dst := DIBResult.ScanLine[Row];
7662 if (IsTransparent) then
7663 begin
7664 // Preset all pixels to transparent
7665 FillChar(Dst^, Width, ord(MappedTransparentIndex));
7666 if (Ditherer.Direction = 1) then
7667 begin
7668 MaskDest := MaskRow;
7669 Bit := $80;
7670 end else
7671 begin
7672 MaskDest := MaskRow + MaskRowBitWidth-1;
7673 Bit := RightBit;
7674 end;
7675 end;
7676 inc(Dst, Ditherer.Column);
7677
7678 while (Ditherer.Column < Ditherer.Width) and (Ditherer.Column >= 0) do
7679 begin
7680 Index := ord(Src^);
7681 Color := ColMap[ord(Index)];
7682
7683 if (IsTransparent) and (Index = TransparentIndex) then
7684 begin
7685 MaskDest^ := char(byte(MaskDest^) OR Bit);
7686 WasTransparent := True;
7687 Ditherer.NextColumn;
7688 end else
7689 begin
7690 // Dither and map a single pixel
7691 Dst^ := Ditherer.Dither(Color.Red, Color.Green, Color.Blue,
7692 Color.Red, Color.Green, Color.Blue);
7693 end;
7694
7695 if (IsTransparent) then
7696 begin
7697 if (Ditherer.Direction = 1) then
7698 begin
7699 Bit := Bit SHR 1;
7700 if (Bit = $00) then
7701 begin
7702 Bit := $80;
7703 inc(MaskDest, 1);
7704 end;
7705 end else
7706 begin
7707 Bit := Bit SHL 1;
7708 if (Bit = $00) then
7709 begin
7710 Bit := $01;
7711 dec(MaskDest, 1);
7712 end;
7713 end;
7714 end;
7715
7716 inc(Src, Ditherer.Direction);
7717 inc(Dst, Ditherer.Direction);
7718 end;
7719
7720 if (IsTransparent) then
7721 Inc(MaskRow, MaskRowWidth);
7722 Inc(Row);
7723 inc(Src, Width-Ditherer.Direction);
7724 Ditherer.NextLine;
7725 end;
7726
7727 // Transparent paint needs a mask bitmap
7728 if (IsTransparent) and (WasTransparent) then
7729 FMask := CreateBitmap(Width, Height, 1, 1, MaskBits);
7730 finally
7731 if (MaskBits <> nil) then
7732 FreeMem(MaskBits);
7733 end;
7734 finally
7735 if (ColorLookup <> nil) then
7736 ColorLookup.Free;
7737 if (Ditherer <> nil) then
7738 Ditherer.Free;
7739 if (DIBResult <> nil) then
7740 DIBResult.Free;
7741 end;
7742 except
7743 Result.Free;
7744 raise;
7745 end;
7746 end;
7747 {$IFDEF R_PLUS}
7748 {$RANGECHECKS ON}
7749 {$UNDEF R_PLUS}
7750 {$ENDIF}
7751
DoGetBitmapnull7752 function TGIFSubImage.DoGetBitmap: TBitmap;
7753 var
7754 ScanLineRow : Integer;
7755 DIBResult : TDIB;
7756 DestScanLine ,
7757 Src : PChar;
7758 TransparentIndex : byte;
7759 IsTransparent : boolean;
7760 WasTransparent : boolean;
7761
7762 MaskBits : PChar;
7763 MaskDest : PChar;
7764 MaskRow : PChar;
7765 MaskRowWidth : integer;
7766 Col : integer;
7767 MaskByte : byte;
7768 Bit : byte;
7769 begin
7770 Result := TBitmap.Create;
7771 try
7772
7773 {$IFNDEF VER9x}
7774 if (Width*Height > BitmapAllocationThreshold) then
7775 SetPixelFormat(Result, pf1bit); // To reduce resource consumption of resize
7776 {$ENDIF}
7777
7778 if (Empty) then
7779 begin
7780 // Set bitmap width and height
7781 Result.Width := Width;
7782 Result.Height := Height;
7783
7784 // Build and copy palette to bitmap
7785 Result.Palette := CopyPalette(Palette);
7786
7787 exit;
7788 end;
7789
7790 // Get DIB buffer for scanline operations
7791 DIBResult := TDIBWriter.Create(Result, pf8bit, Width, Height, Palette);
7792 try
7793
7794 // Determine if this image is transparent
7795 IsTransparent := FNeedMask and Transparent;
7796 WasTransparent := False;
7797 FNeedMask := False;
7798 TransparentIndex := 0;
7799 if (FMask = 0) and (IsTransparent) then
7800 begin
7801 IsTransparent := True;
7802 TransparentIndex := GraphicControlExtension.TransparentColorIndex;
7803 end;
7804 // Allocate bit buffer for transparency mask
7805 if (IsTransparent) then
7806 begin
7807 MaskRowWidth := ((Width+15) DIV 16) * 2;
7808 GetMem(MaskBits, MaskRowWidth * Height);
7809 FillChar(MaskBits^, MaskRowWidth * Height, 0);
7810 IsTransparent := (MaskBits <> nil);
7811 end else
7812 begin
7813 MaskBits := nil;
7814 MaskRowWidth := 0;
7815 end;
7816
7817 try
7818 ScanLineRow := 0;
7819 Src := FData;
7820 MaskRow := MaskBits;
7821 while (ScanLineRow < Height) do
7822 begin
7823 DestScanline := DIBResult.ScanLine[ScanLineRow];
7824
7825 if ((ScanLineRow AND $1F) = 0) then
7826 Image.Progress(Self, psRunning, MulDiv(ScanLineRow, 100, Height),
7827 False, Rect(0,0,0,0), sProgressRendering);
7828
7829 Move(Src^, DestScanline^, Width);
7830 Inc(ScanLineRow);
7831
7832 if (IsTransparent) then
7833 begin
7834 Bit := $80;
7835 MaskDest := MaskRow;
7836 MaskByte := 0;
7837 for Col := 0 to Width-1 do
7838 begin
7839 // Set a bit in the mask if the pixel is transparent
7840 if (Src^ = char(TransparentIndex)) then
7841 MaskByte := MaskByte OR Bit;
7842
7843 Bit := Bit SHR 1;
7844 if (Bit = $00) then
7845 begin
7846 // Store a mask byte for each 8 pixels
7847 Bit := $80;
7848 WasTransparent := WasTransparent or (MaskByte <> 0);
7849 MaskDest^ := char(MaskByte);
7850 inc(MaskDest);
7851 MaskByte := 0;
7852 end;
7853 Inc(Src);
7854 end;
7855 // Save the last mask byte in case the width isn't divisable by 8
7856 if (MaskByte <> 0) then
7857 begin
7858 WasTransparent := True;
7859 MaskDest^ := char(MaskByte);
7860 end;
7861 Inc(MaskRow, MaskRowWidth);
7862 end else
7863 Inc(Src, Width);
7864 end;
7865
7866 // Transparent paint needs a mask bitmap
7867 if (IsTransparent) and (WasTransparent) then
7868 FMask := CreateBitmap(Width, Height, 1, 1, MaskBits);
7869 finally
7870 if (MaskBits <> nil) then
7871 FreeMem(MaskBits);
7872 end;
7873 finally
7874 // Free DIB buffer used for scanline operations
7875 DIBResult.Free;
7876 end;
7877 except
7878 Result.Free;
7879 raise;
7880 end;
7881 end;
7882
7883 {$ifdef DEBUG_RENDERPERFORMANCE}
7884 var
7885 ImageCount : DWORD = 0;
7886 RenderTime : DWORD = 0;
7887 {$endif}
GetBitmapnull7888 function TGIFSubImage.GetBitmap: TBitmap;
7889 var
7890 n : integer;
7891 {$ifdef DEBUG_RENDERPERFORMANCE}
7892 RenderStartTime : DWORD;
7893 {$endif}
7894 begin
7895 {$ifdef DEBUG_RENDERPERFORMANCE}
7896 if (GetAsyncKeyState(VK_CONTROL) <> 0) then
7897 begin
7898 ShowMessage(format('Render %d images in %d mS, Rate %d mS/image (%d images/S)',
7899 [ImageCount, RenderTime,
7900 RenderTime DIV (ImageCount+1),
7901 MulDiv(ImageCount, 1000, RenderTime+1)]));
7902 end;
7903 {$endif}
7904 Result := FBitmap;
7905 if (Result <> nil) or (Empty) then
7906 Exit;
7907
7908 {$ifdef DEBUG_RENDERPERFORMANCE}
7909 inc(ImageCount);
7910 RenderStartTime := timeGetTime;
7911 {$endif}
7912 try
7913 Image.Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressRendering);
7914 try
7915
7916 if (Image.DoDither) then
7917 // Create dithered bitmap
7918 FBitmap := DoGetDitherBitmap
7919 else
7920 // Create "regular" bitmap
7921 FBitmap := DoGetBitmap;
7922
7923 Result := FBitmap;
7924
7925 finally
7926 if ExceptObject = nil then
7927 n := 100
7928 else
7929 n := 0;
7930 Image.Progress(Self, psEnding, n, Image.PaletteModified, Rect(0,0,0,0),
7931 sProgressRendering);
7932 // Make sure new palette gets realized, in case OnProgress event didn't.
7933 if Image.PaletteModified then
7934 Image.Changed(Self);
7935 end;
7936 except
7937 on EAbort do ; // OnProgress can raise EAbort to cancel image load
7938 end;
7939 {$ifdef DEBUG_RENDERPERFORMANCE}
7940 inc(RenderTime, timeGetTime-RenderStartTime);
7941 {$endif}
7942 end;
7943
7944 procedure TGIFSubImage.SetBitmap(Value: TBitmap);
7945 begin
7946 FreeBitmap;
7947 if (Value <> nil) then
7948 Assign(Value);
7949 end;
7950
GetActiveColorMapnull7951 function TGIFSubImage.GetActiveColorMap: TGIFColorMap;
7952 begin
7953 if (ColorMap.Count > 0) or (Image.GlobalColorMap.Count = 0) then
7954 Result := ColorMap
7955 else
7956 Result := Image.GlobalColorMap;
7957 end;
7958
TGIFSubImage.GetInterlacednull7959 function TGIFSubImage.GetInterlaced: boolean;
7960 begin
7961 Result := (FImageDescriptor.PackedFields AND idInterlaced) <> 0;
7962 end;
7963
7964 procedure TGIFSubImage.SetInterlaced(Value: boolean);
7965 begin
7966 if (Value) then
7967 FImageDescriptor.PackedFields := FImageDescriptor.PackedFields OR idInterlaced
7968 else
7969 FImageDescriptor.PackedFields := FImageDescriptor.PackedFields AND NOT(idInterlaced);
7970 end;
7971
TGIFSubImage.GetVersionnull7972 function TGIFSubImage.GetVersion: TGIFVersion;
7973 var
7974 v : TGIFVersion;
7975 i : integer;
7976 begin
7977 if (ColorMap.Optimized) then
7978 Result := gv89a
7979 else
7980 Result := inherited GetVersion;
7981 i := 0;
7982 while (Result < high(TGIFVersion)) and (i < FExtensions.Count) do
7983 begin
7984 v := FExtensions[i].Version;
7985 if (v > Result) then
7986 Result := v;
7987 end;
7988 end;
7989
TGIFSubImage.GetColorResolutionnull7990 function TGIFSubImage.GetColorResolution: integer;
7991 begin
7992 Result := ColorMap.BitsPerPixel-1;
7993 end;
7994
GetBitsPerPixelnull7995 function TGIFSubImage.GetBitsPerPixel: integer;
7996 begin
7997 Result := ColorMap.BitsPerPixel;
7998 end;
7999
TGIFSubImage.GetBoundsRectnull8000 function TGIFSubImage.GetBoundsRect: TRect;
8001 begin
8002 Result := Rect(FImageDescriptor.Left,
8003 FImageDescriptor.Top,
8004 FImageDescriptor.Left+FImageDescriptor.Width,
8005 FImageDescriptor.Top+FImageDescriptor.Height);
8006 end;
8007
8008 procedure TGIFSubImage.DoSetBounds(ALeft, ATop, AWidth, AHeight: integer);
8009 var
8010 TooLarge : boolean;
8011 Zap : boolean;
8012 begin
8013 Zap := (FImageDescriptor.Width <> Width) or (FImageDescriptor.Height <> AHeight);
8014 FImageDescriptor.Left := ALeft;
8015 FImageDescriptor.Top := ATop;
8016 FImageDescriptor.Width := AWidth;
8017 FImageDescriptor.Height := AHeight;
8018
8019 // Delete existing image and bitmaps if size has changed
8020 if (Zap) then
8021 begin
8022 FreeBitmap;
8023 FreeMask;
8024 FreeImage;
8025 // ...and allocate a new image
8026 NewImage;
8027 end;
8028
8029 TooLarge := False;
8030 // Set width & height if added image is larger than existing images
8031 {$IFDEF STRICT_MOZILLA}
8032 // From Mozilla source:
8033 // Work around broken GIF files where the logical screen
8034 // size has weird width or height. [...]
8035 if (Image.Width < AWidth) or (Image.Height < AHeight) then
8036 begin
8037 TooLarge := True;
8038 Image.Width := AWidth;
8039 Image.Height := AHeight;
8040 Left := 0;
8041 Top := 0;
8042 end;
8043 {$ELSE}
8044 if (Image.Width < ALeft+AWidth) then
8045 begin
8046 if (Image.Width > 0) then
8047 begin
8048 TooLarge := True;
8049 Warning(gsWarning, sBadWidth)
8050 end;
8051 Image.Width := ALeft+AWidth;
8052 end;
8053 if (Image.Height < ATop+AHeight) then
8054 begin
8055 if (Image.Height > 0) then
8056 begin
8057 TooLarge := True;
8058 Warning(gsWarning, sBadHeight)
8059 end;
8060 Image.Height := ATop+AHeight;
8061 end;
8062 {$ENDIF}
8063
8064 if (TooLarge) then
8065 Warning(gsWarning, sScreenSizeExceeded);
8066 end;
8067
8068 procedure TGIFSubImage.SetBoundsRect(const Value: TRect);
8069 begin
8070 DoSetBounds(Value.Left, Value.Top, Value.Right-Value.Left+1, Value.Bottom-Value.Top+1);
8071 end;
8072
GetClientRectnull8073 function TGIFSubImage.GetClientRect: TRect;
8074 begin
8075 Result := Rect(0, 0, FImageDescriptor.Width, FImageDescriptor.Height);
8076 end;
8077
GetPixelnull8078 function TGIFSubImage.GetPixel(x, y: integer): BYTE;
8079 begin
8080 if (x < 0) or (x > Width-1) then
8081 Error(sBadPixelCoordinates);
8082 Result := BYTE(PChar(longInt(Scanline[y]) + x)^);
8083 end;
8084
8085 // 2006.10.09 ->
8086 procedure TGIFSubImage.SetPixel(x, y: integer; Value: BYTE );
8087 begin
8088 if (x < 0) or (x > Width-1) or (y < 0) or (y > Height-1) then
8089 Error(sBadPixelCoordinates);
8090 if Value >= ActiveColorMap.FCount then
8091 Error(sBadColorIndex);
8092 BYTE(PChar(longInt(Scanline[y]) + x)^) := Value;
8093 end;
8094 // 2006.10.09 <-
8095
TGIFSubImage.GetScanlinenull8096 function TGIFSubImage.GetScanline(y: integer): pointer;
8097 begin
8098 if (y < 0) or (y > Height-1) then
8099 Error(sBadPixelCoordinates);
8100 NeedImage;
8101 Result := pointer(longInt(FData) + y * Width);
8102 end;
8103
8104 procedure TGIFSubImage.Prepare;
8105 var
8106 Pack : BYTE;
8107 begin
8108 Pack := FImageDescriptor.PackedFields;
8109 if (ColorMap.Count > 0) then
8110 begin
8111 Pack := idLocalColorTable;
8112 if (ColorMap.Optimized) then
8113 Pack := Pack OR idSort;
8114 Pack := (Pack AND NOT(idColorTableSize)) OR (ColorResolution AND idColorTableSize);
8115 end else
8116 Pack := Pack AND NOT(idLocalColorTable OR idSort OR idColorTableSize);
8117 FImageDescriptor.PackedFields := Pack;
8118 end;
8119
8120 procedure TGIFSubImage.SaveToStream(Stream: TStream);
8121 begin
8122 FExtensions.SaveToStream(Stream);
8123 if (Empty) then
8124 exit;
8125 Prepare;
8126 Stream.Write(FImageDescriptor, sizeof(TImageDescriptor));
8127 ColorMap.SaveToStream(Stream);
8128 Compress(Stream);
8129 end;
8130
8131 procedure TGIFSubImage.LoadFromStream(Stream: TStream);
8132 var
8133 ColorCount : integer;
8134 b : BYTE;
8135 begin
8136 Clear;
8137 FExtensions.LoadFromStream(Stream, self);
8138 // Check for extension without image
8139 if (Stream.Read(b, 1) <> 1) then
8140 exit;
8141 Stream.Seek(-1, soFromCurrent);
8142 if (b = bsTrailer) or (b = 0) then
8143 exit;
8144
8145 ReadCheck(Stream, FImageDescriptor, sizeof(TImageDescriptor));
8146
8147 // From Mozilla source:
8148 // Work around more broken GIF files that have zero image
8149 // width or height
8150 if (FImageDescriptor.Height = 0) or (FImageDescriptor.Width = 0) then
8151 begin
8152 FImageDescriptor.Height := Image.Height;
8153 FImageDescriptor.Width := Image.Width;
8154 Warning(gsWarning, sScreenSizeExceeded);
8155 end;
8156
8157 if (FImageDescriptor.PackedFields AND idLocalColorTable = idLocalColorTable) then
8158 begin
8159 ColorCount := 2 SHL (FImageDescriptor.PackedFields AND idColorTableSize);
8160 if (ColorCount < 2) or (ColorCount > 256) then
8161 Error(sImageBadColorSize);
8162 ColorMap.LoadFromStream(Stream, ColorCount);
8163 end;
8164
8165 Decompress(Stream);
8166
8167 // On-load rendering
8168 if (GIFImageRenderOnLoad) then
8169 // Touch bitmap to force frame to be rendered
8170 Bitmap;
8171 end;
8172
8173 procedure TGIFSubImage.AssignTo(Dest: TPersistent);
8174 begin
8175 if (Dest is TBitmap) then
8176 Dest.Assign(Bitmap)
8177 else
8178 inherited AssignTo(Dest);
8179 end;
8180
8181 procedure TGIFSubImage.Assign(Source: TPersistent);
8182 var
8183 MemoryStream : TMemoryStream;
8184 i : integer;
8185 PixelFormat : TPixelFormat;
8186 DIBSource : TDIB;
8187 ABitmap : TBitmap;
8188
8189 procedure Import8Bit(Dest: PChar);
8190 var
8191 y : integer;
8192 begin
8193 // Copy colormap
8194 {$ifdef VER10_PLUS}
8195 if (FBitmap.HandleType = bmDIB) then
8196 FColorMap.ImportDIBColors(FBitmap.Canvas.Handle)
8197 else
8198 {$ENDIF}
8199 FColorMap.ImportPalette(FBitmap.Palette);
8200 // Copy pixels
8201 for y := 0 to Height-1 do
8202 begin
8203 if ((y AND $1F) = 0) then
8204 Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
8205 Move(DIBSource.Scanline[y]^, Dest^, Width);
8206 inc(Dest, Width);
8207 end;
8208 end;
8209
8210 procedure Import4Bit(Dest: PChar);
8211 var
8212 x, y : integer;
8213 Scanline : PChar;
8214 begin
8215 // Copy colormap
8216 FColorMap.ImportPalette(FBitmap.Palette);
8217 // Copy pixels
8218 for y := 0 to Height-1 do
8219 begin
8220 if ((y AND $1F) = 0) then
8221 Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
8222 ScanLine := DIBSource.Scanline[y];
8223 for x := 0 to Width-1 do
8224 begin
8225 if (x AND $01 = 0) then
8226 Dest^ := chr(ord(ScanLine^) SHR 4)
8227 else
8228 begin
8229 Dest^ := chr(ord(ScanLine^) AND $0F);
8230 inc(ScanLine);
8231 end;
8232 inc(Dest);
8233 end;
8234 end;
8235 end;
8236
8237 procedure Import1Bit(Dest: PChar);
8238 var
8239 x, y : integer;
8240 Scanline : PChar;
8241 Bit : integer;
8242 Byte : integer;
8243 begin
8244 // Copy colormap
8245 FColorMap.ImportPalette(FBitmap.Palette);
8246 // Copy pixels
8247 for y := 0 to Height-1 do
8248 begin
8249 if ((y AND $1F) = 0) then
8250 Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
8251 ScanLine := DIBSource.Scanline[y];
8252 x := Width;
8253 Bit := 0;
8254 Byte := 0; // To avoid compiler warning
8255 while (x > 0) do
8256 begin
8257 if (Bit = 0) then
8258 begin
8259 Bit := 8;
8260 Byte := ord(ScanLine^);
8261 inc(Scanline);
8262 end;
8263 Dest^ := chr((Byte AND $80) SHR 7);
8264 Byte := Byte SHL 1;
8265 inc(Dest);
8266 dec(Bit);
8267 dec(x);
8268 end;
8269 end;
8270 end;
8271
8272 procedure Import24Bit(Dest: PChar);
8273 type
8274 TCacheEntry = record
8275 Color : TColor;
8276 Index : integer;
8277 end;
8278 const
8279 // Size of palette cache. Must be 2^n.
8280 // The cache holds the palette index of the last "CacheSize" colors
8281 // processed. Hopefully the cache can speed things up a bit... Initial
8282 // testing shows that this is indeed the case at least for non-dithered
8283 // bitmaps.
8284 // All the same, a small hash table would probably be much better.
8285 CacheSize = 8;
8286 var
8287 i : integer;
8288 Cache : array[0..CacheSize-1] of TCacheEntry;
8289 LastEntry : integer;
8290 Scanline : PRGBTriple;
8291 Pixel : TColor;
8292 RGBTriple : TRGBTriple absolute Pixel;
8293 x, y : integer;
8294 ColorMap : PColorMap;
8295 t : byte;
8296 label
8297 NextPixel;
8298 begin
8299 for i := 0 to CacheSize-1 do
8300 Cache[i].Index := -1;
8301 LastEntry := 0;
8302
8303 // Copy all pixels and build colormap
8304 for y := 0 to Height-1 do
8305 begin
8306 if ((y AND $1F) = 0) then
8307 Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
8308 ScanLine := DIBSource.Scanline[y];
8309 for x := 0 to Width-1 do
8310 begin
8311 Pixel := 0;
8312 RGBTriple := Scanline^;
8313 // Scan cache for color from most recently processed color to last
8314 // recently processed. This is done because TColorMap.AddUnique is very slow.
8315 i := LastEntry;
8316 repeat
8317 if (Cache[i].Index = -1) then
8318 break;
8319 if (Cache[i].Color = Pixel) then
8320 begin
8321 Dest^ := chr(Cache[i].Index);
8322 LastEntry := i;
8323 goto NextPixel;
8324 end;
8325 if (i = 0) then
8326 i := CacheSize-1
8327 else
8328 dec(i);
8329 until (i = LastEntry);
8330 // Color not found in cache, do it the slow way instead
8331 Dest^ := chr(FColorMap.AddUnique(Pixel));
8332 // Add color and index to cache
8333 LastEntry := (LastEntry + 1) AND (CacheSize-1);
8334 Cache[LastEntry].Color := Pixel;
8335 Cache[LastEntry].Index := ord(Dest^);
8336
8337 NextPixel:
8338 Inc(Dest);
8339 Inc(Scanline);
8340 end;
8341 end;
8342 // Convert colors in colormap from BGR to RGB
8343 ColorMap := FColorMap.Data;
8344 i := FColorMap.Count;
8345 while (i > 0) do
8346 begin
8347 t := ColorMap^[0].Red;
8348 ColorMap^[0].Red := ColorMap^[0].Blue;
8349 ColorMap^[0].Blue := t;
8350 inc(integer(ColorMap), sizeof(TGIFColor));
8351 dec(i);
8352 end;
8353 end;
8354
8355 procedure ImportViaDraw(ABitmap: TBitmap; Graphic: TGraphic);
8356 begin
8357 ABitmap.Height := Graphic.Height;
8358 ABitmap.Width := Graphic.Width;
8359
8360 // Note: Disable the call to SafeSetPixelFormat below to import
8361 // in max number of colors with the risk of having to use
8362 // TCanvas.Pixels to do it (very slow).
8363
8364 // Make things a little easier for TGIFSubImage.Assign by converting
8365 // pfDevice to a more import friendly format
8366 {$ifdef SLOW_BUT_SAFE}
8367 SafeSetPixelFormat(ABitmap, pf8bit);
8368 {$else}
8369 {$ifndef VER9x}
8370 SetPixelFormat(ABitmap, pf24bit);
8371 {$endif}
8372 {$endif}
8373 ABitmap.Canvas.Draw(0, 0, Graphic);
8374 end;
8375
8376 procedure AddMask(Mask: TBitmap);
8377 var
8378 DIBReader : TDIBReader;
8379 TransparentIndex : integer;
8380 i ,
8381 j : integer;
8382 GIFPixel ,
8383 MaskPixel : PChar;
8384 WasTransparent : boolean;
8385 GCE : TGIFGraphicControlExtension;
8386 begin
8387 // Optimize colormap to make room for transparent color
8388 ColorMap.Optimize;
8389 // Can't make transparent if no color or colormap full
8390 if (ColorMap.Count = 0) or (ColorMap.Count = 256) then
8391 exit;
8392
8393 // Add the transparent color to the color map
8394 TransparentIndex := ColorMap.Add(TColor(0));
8395 WasTransparent := False;
8396
8397 DIBReader := TDIBReader.Create(Mask, pf8bit);
8398 try
8399 for i := 0 to Height-1 do
8400 begin
8401 MaskPixel := DIBReader.Scanline[i];
8402 GIFPixel := Scanline[i];
8403 for j := 0 to Width-1 do
8404 begin
8405 // Change all unmasked pixels to transparent
8406 if (MaskPixel^ <> #0) then
8407 begin
8408 GIFPixel^ := chr(TransparentIndex);
8409 WasTransparent := True;
8410 end;
8411 inc(MaskPixel);
8412 inc(GIFPixel);
8413 end;
8414 end;
8415 finally
8416 DIBReader.Free;
8417 end;
8418
8419 // Add a Graphic Control Extension if any part of the mask was transparent
8420 if (WasTransparent) then
8421 begin
8422 GCE := TGIFGraphicControlExtension.Create(self);
8423 GCE.Transparent := True;
8424 GCE.TransparentColorIndex := TransparentIndex;
8425 Extensions.Add(GCE);
8426 end else
8427 // Otherwise removed the transparency color since it wasn't used
8428 ColorMap.Delete(TransparentIndex);
8429 end;
8430
8431 procedure AddMaskOnly(hMask: hBitmap);
8432 var
8433 Mask : TBitmap;
8434 begin
8435 if (hMask = 0) then
8436 exit;
8437
8438 // Encapsulate the mask
8439 Mask := TBitmap.Create;
8440 try
8441 // Mask.Handle := hMask; // 2003.08.04
8442 Mask.Handle := Windows.CopyImage(hMask, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG); // 2003.08.04
8443 AddMask(Mask);
8444 finally
8445 // Mask.ReleaseHandle; // 2003.08.04
8446 Mask.Free;
8447 end;
8448 end;
8449
8450 procedure AddIconMask(Icon: TIcon);
8451 var
8452 IconInfo : TIconInfo;
8453 begin
8454 if (not GetIconInfo(Icon.Handle, IconInfo)) then
8455 exit;
8456
8457 // Extract the icon mask
8458 AddMaskOnly(IconInfo.hbmMask);
8459 end;
8460
8461 procedure AddMetafileMask(Metafile: TMetaFile);
8462 var
8463 Mask1 ,
8464 Mask2 : TBitmap;
8465
8466 procedure DrawMetafile(ABitmap: TBitmap; Background: TColor);
8467 begin
8468 ABitmap.Width := Metafile.Width;
8469 ABitmap.Height := Metafile.Height;
8470 {$ifndef VER9x}
8471 SetPixelFormat(ABitmap, pf24bit);
8472 {$endif}
8473 ABitmap.Canvas.Brush.Color := Background;
8474 ABitmap.Canvas.Brush.Style := bsSolid;
8475 ABitmap.Canvas.FillRect(ABitmap.Canvas.ClipRect);
8476 ABitmap.Canvas.Draw(0,0, Metafile);
8477 end;
8478
8479 begin
8480 // Create the metafile mask
8481 Mask1 := TBitmap.Create;
8482 try
8483 Mask2 := TBitmap.Create;
8484 try
8485 DrawMetafile(Mask1, clWhite);
8486 DrawMetafile(Mask2, clBlack);
8487 Mask1.Canvas.CopyMode := cmSrcInvert;
8488 Mask1.Canvas.Draw(0,0, Mask2);
8489 AddMask(Mask1);
8490 finally
8491 Mask2.Free;
8492 end;
8493 finally
8494 Mask1.Free;
8495 end;
8496 end;
8497
8498 begin
8499 if (Source = self) then
8500 exit;
8501 if (Source = nil) then
8502 begin
8503 Clear;
8504 end else
8505 //
8506 // TGIFSubImage import
8507 //
8508 if (Source is TGIFSubImage) then
8509 begin
8510 // Zap existing colormap, extensions and bitmap
8511 Clear;
8512 if (TGIFSubImage(Source).Empty) then
8513 exit;
8514 // Copy source data
8515 FImageDescriptor := TGIFSubImage(Source).FImageDescriptor;
8516 FTransparent := TGIFSubImage(Source).Transparent;
8517 // Copy image data
8518 NewImage;
8519 if (FData <> nil) and (TGIFSubImage(Source).Data <> nil) then
8520 Move(TGIFSubImage(Source).Data^, FData^, FDataSize);
8521 // Copy palette
8522 FColorMap.Assign(TGIFSubImage(Source).ColorMap);
8523 // Copy extensions
8524 if (TGIFSubImage(Source).Extensions.Count > 0) then
8525 begin
8526 MemoryStream := TMemoryStream.Create;
8527 try
8528 TGIFSubImage(Source).Extensions.SaveToStream(MemoryStream);
8529 MemoryStream.Seek(0, soFromBeginning);
8530 Extensions.LoadFromStream(MemoryStream, Self);
8531 finally
8532 MemoryStream.Free;
8533 end;
8534 end;
8535
8536 // Copy bitmap representation
8537 // (Not really nescessary but improves performance if the bitmap is needed
8538 // later on)
8539 if (TGIFSubImage(Source).HasBitmap) then
8540 begin
8541 NewBitmap;
8542 FBitmap.Assign(TGIFSubImage(Source).Bitmap);
8543 end;
8544 end else
8545 //
8546 // Bitmap import
8547 //
8548 if (Source is TBitmap) then
8549 begin
8550 // Zap existing colormap, extensions and bitmap
8551 Clear;
8552 if (TBitmap(Source).Empty) then
8553 exit;
8554
8555 Width := TBitmap(Source).Width;
8556 Height := TBitmap(Source).Height;
8557
8558 PixelFormat := GetPixelFormat(TBitmap(Source));
8559 {$ifdef VER9x}
8560 // Delphi 2 TBitmaps are always DDBs. This means that if a 24 bit
8561 // bitmap is loaded in 8 bit device mode, TBitmap.PixelFormat will
8562 // be pf8bit, but TBitmap.Palette will be 0!
8563 if (TBitmap(Source).Palette = 0) then
8564 PixelFormat := pfDevice;
8565 {$endif}
8566 if (PixelFormat > pf8bit) or (PixelFormat = pfDevice) then
8567 begin
8568 // Convert image to 8 bits/pixel or less
8569 FBitmap := ReduceColors(TBitmap(Source), Image.ColorReduction,
8570 Image.DitherMode, Image.ReductionBits, 0);
8571 PixelFormat := GetPixelFormat(FBitmap);
8572 end else
8573 begin
8574 // Create new bitmap and copy
8575 NewBitmap;
8576 FBitmap.Assign(TBitmap(Source));
8577 end;
8578
8579 // Allocate new buffer
8580 NewImage;
8581
8582 Image.Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressConverting);
8583 try
8584 {$ifdef VER9x}
8585 // This shouldn't happen, but better safe...
8586 if (FBitmap.Palette = 0) then
8587 PixelFormat := pf24bit;
8588 {$endif}
8589 if (not(PixelFormat in [pf1bit, pf4bit, pf8bit, pf24bit])) then
8590 PixelFormat := pf24bit;
8591 DIBSource := TDIBReader.Create(FBitmap, PixelFormat);
8592 try
8593 // Copy pixels
8594 case (PixelFormat) of
8595 pf8bit: Import8Bit(Fdata);
8596 pf4bit: Import4Bit(Fdata);
8597 pf1bit: Import1Bit(Fdata);
8598 else
8599 // Error(sUnsupportedBitmap);
8600 Import24Bit(Fdata);
8601 end;
8602
8603 finally
8604 DIBSource.Free;
8605 end;
8606
8607 {$ifdef VER10_PLUS}
8608 // Add mask for transparent bitmaps
8609 if (TBitmap(Source).Transparent) then
8610 AddMaskOnly(TBitmap(Source).MaskHandle);
8611 {$endif}
8612
8613 finally
8614 if ExceptObject = nil then
8615 i := 100
8616 else
8617 i := 0;
8618 Image.Progress(Self, psEnding, i, Image.PaletteModified, Rect(0,0,0,0), sProgressConverting);
8619 end;
8620 end else
8621 //
8622 // TGraphic import
8623 //
8624 if (Source is TGraphic) then
8625 begin
8626 // Zap existing colormap, extensions and bitmap
8627 Clear;
8628 if (TGraphic(Source).Empty) then
8629 exit;
8630
8631 ABitmap := TBitmap.Create;
8632 try
8633 // Import TIcon and TMetafile by drawing them onto a bitmap...
8634 // ...and then importing the bitmap recursively
8635 if (Source is TIcon) or (Source is TMetafile) then
8636 begin
8637 try
8638 ImportViaDraw(ABitmap, TGraphic(Source))
8639 except
8640 // If import via TCanvas.Draw fails (which it shouldn't), we try the
8641 // Assign mechanism instead
8642 ABitmap.Assign(Source);
8643 end;
8644 end else
8645 try
8646 ABitmap.Assign(Source);
8647 except
8648 // If automatic conversion to bitmap fails, we try and draw the
8649 // graphic on the bitmap instead
8650 ImportViaDraw(ABitmap, TGraphic(Source));
8651 end;
8652 // Convert the bitmap to a GIF frame recursively
8653 Assign(ABitmap);
8654 finally
8655 ABitmap.Free;
8656 end;
8657
8658 // Import transparency mask
8659 if (Source is TIcon) then
8660 AddIconMask(TIcon(Source));
8661 if (Source is TMetaFile) then
8662 AddMetafileMask(TMetaFile(Source));
8663
8664 end else
8665 //
8666 // TPicture import
8667 //
8668 if (Source is TPicture) then
8669 begin
8670 // Recursively import TGraphic
8671 Assign(TPicture(Source).Graphic);
8672 end else
8673 // Unsupported format - fall back to Source.AssignTo
8674 inherited Assign(Source);
8675 end;
8676
8677 // Copied from D3 graphics.pas
8678 // Fixed by Brian Lowe of Acro Technology Inc. 30Jan98
TransparentStretchBltnull8679 function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
8680 SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
8681 MaskY: Integer): Boolean;
8682 const
8683 ROP_DstCopy = $00AA0029;
8684 var
8685 MemDC ,
8686 OrMaskDC : HDC;
8687 MemBmp ,
8688 OrMaskBmp : HBITMAP;
8689 Save ,
8690 OrMaskSave : THandle;
8691 crText, crBack : TColorRef;
8692 SavePal : HPALETTE;
8693
8694 begin
8695 Result := True;
8696 if (Win32Platform = VER_PLATFORM_WIN32_NT) and (SrcW = DstW) and (SrcH = DstH) then
8697 begin
8698 MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, 1, 1));
8699 MemBmp := SelectObject(MaskDC, MemBmp);
8700 try
8701 MaskBlt(DstDC, DstX, DstY, DstW, DstH, SrcDC, SrcX, SrcY, MemBmp, MaskX,
8702 MaskY, MakeRop4(ROP_DstCopy, SrcCopy));
8703 finally
8704 MemBmp := SelectObject(MaskDC, MemBmp);
8705 DeleteObject(MemBmp);
8706 end;
8707 Exit;
8708 end;
8709
8710 SavePal := 0;
8711 MemDC := GDICheck(CreateCompatibleDC(DstDC));
8712 try
8713 { Color bitmap for combining OR mask with source bitmap }
8714 MemBmp := GDICheck(CreateCompatibleBitmap(DstDC, SrcW, SrcH));
8715 try
8716 Save := SelectObject(MemDC, MemBmp);
8717 try
8718 { This bitmap needs the size of the source but DC of the dest }
8719 OrMaskDC := GDICheck(CreateCompatibleDC(DstDC));
8720 try
8721 { Need a monochrome bitmap for OR mask!! }
8722 OrMaskBmp := GDICheck(CreateBitmap(SrcW, SrcH, 1, 1, nil));
8723 try
8724 OrMaskSave := SelectObject(OrMaskDC, OrMaskBmp);
8725 try
8726
8727 // OrMask := 1
8728 // Original: BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, OrMaskDC, SrcX, SrcY, WHITENESS);
8729 // Replacement, but not needed: PatBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, WHITENESS);
8730 // OrMask := OrMask XOR Mask
8731 // Not needed: BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, MaskDC, SrcX, SrcY, SrcInvert);
8732 // OrMask := NOT Mask
8733 BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, MaskDC, SrcX, SrcY, NotSrcCopy);
8734
8735 // Retrieve source palette (with dummy select)
8736 SavePal := SelectPalette(SrcDC, SystemPalette16, False);
8737 // Restore source palette
8738 SelectPalette(SrcDC, SavePal, False);
8739 // Select source palette into memory buffer
8740 if SavePal <> 0 then
8741 SavePal := SelectPalette(MemDC, SavePal, True)
8742 else
8743 SavePal := SelectPalette(MemDC, SystemPalette16, True);
8744 RealizePalette(MemDC);
8745
8746 // Mem := OrMask
8747 BitBlt(MemDC, SrcX, SrcY, SrcW, SrcH, OrMaskDC, SrcX, SrcY, SrcCopy);
8748 // Mem := Mem AND Src
8749 {$IFNDEF GIF_TESTMASK} // Define GIF_TESTMASK if you want to know what it does...
8750 BitBlt(MemDC, SrcX, SrcY, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcAnd);
8751 {$ELSE}
8752 StretchBlt(DstDC, DstX, DstY, DstW DIV 2, DstH, MemDC, SrcX, SrcY, SrcW, SrcH, SrcCopy);
8753 StretchBlt(DstDC, DstX+DstW DIV 2, DstY, DstW DIV 2, DstH, SrcDC, SrcX, SrcY, SrcW, SrcH, SrcCopy);
8754 exit;
8755 {$ENDIF}
8756 finally
8757 if (OrMaskSave <> 0) then
8758 SelectObject(OrMaskDC, OrMaskSave);
8759 end;
8760 finally
8761 DeleteObject(OrMaskBmp);
8762 end;
8763 finally
8764 DeleteDC(OrMaskDC);
8765 end;
8766
8767 crText := SetTextColor(DstDC, $00000000);
8768 crBack := SetBkColor(DstDC, $00FFFFFF);
8769
8770 { All color rendering is done at 1X (no stretching),
8771 then final 2 masks are stretched to dest DC }
8772 // Neat trick!
8773 // Dst := Dst AND Mask
8774 StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, SrcX, SrcY, SrcW, SrcH, SrcAnd);
8775 // Dst := Dst OR Mem
8776 StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, SrcX, SrcY, SrcW, SrcH, SrcPaint);
8777
8778 SetTextColor(DstDC, crText);
8779 SetTextColor(DstDC, crBack);
8780
8781 finally
8782 if (Save <> 0) then
8783 SelectObject(MemDC, Save);
8784 end;
8785 finally
8786 DeleteObject(MemBmp);
8787 end;
8788 finally
8789 if (SavePal <> 0) then
8790 SelectPalette(MemDC, SavePal, False);
8791 DeleteDC(MemDC);
8792 end;
8793 end;
8794
8795 procedure TGIFSubImage.Draw(ACanvas: TCanvas; const Rect: TRect;
8796 DoTransparent, DoTile: boolean);
8797 begin
8798 if (DoTile) then
8799 StretchDraw(ACanvas, Rect, DoTransparent, DoTile)
8800 else
8801 StretchDraw(ACanvas, ScaleRect(Rect), DoTransparent, DoTile);
8802 end;
8803
8804 type
8805 // Dummy class used to gain access to protected method TCanvas.Changed
8806 TChangableCanvas = class(TCanvas)
8807 end;
8808
8809 procedure TGIFSubImage.StretchDraw(ACanvas: TCanvas; const Rect: TRect;
8810 DoTransparent, DoTile: boolean);
8811 var
8812 MaskDC : HDC;
8813 Save : THandle;
8814 Tile : TRect;
8815 {$ifdef DEBUG_DRAWPERFORMANCE}
8816 ImageCount ,
8817 TimeStart ,
8818 TimeStop : DWORD;
8819 {$endif}
8820
8821 begin
8822 {$ifdef DEBUG_DRAWPERFORMANCE}
8823 TimeStart := timeGetTime;
8824 ImageCount := 0;
8825 {$endif}
8826 if (DoTransparent) and (Transparent) and (HasMask) then
8827 begin
8828 // Draw transparent using mask
8829 Save := 0;
8830 MaskDC := 0;
8831 try
8832 MaskDC := GDICheck(CreateCompatibleDC(0));
8833 Save := SelectObject(MaskDC, FMask);
8834
8835 if (DoTile) then
8836 begin
8837 Tile.Left := Rect.Left+Left;
8838 Tile.Right := Tile.Left + Width;
8839 while (Tile.Left < Rect.Right) do
8840 begin
8841 Tile.Top := Rect.Top+Top;
8842 Tile.Bottom := Tile.Top + Height;
8843 while (Tile.Top < Rect.Bottom) do
8844 begin
8845 TransparentStretchBlt(ACanvas.Handle, Tile.Left, Tile.Top, Width, Height,
8846 Bitmap.Canvas.Handle, 0, 0, Width, Height, MaskDC, 0, 0);
8847 Tile.Top := Tile.Top + Image.Height;
8848 Tile.Bottom := Tile.Bottom + Image.Height;
8849 {$ifdef DEBUG_DRAWPERFORMANCE}
8850 inc(ImageCount);
8851 {$endif}
8852 end;
8853 Tile.Left := Tile.Left + Image.Width;
8854 Tile.Right := Tile.Right + Image.Width;
8855 end;
8856 end else
8857 TransparentStretchBlt(ACanvas.Handle, Rect.Left, Rect.Top,
8858 Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
8859 Bitmap.Canvas.Handle, 0, 0, Width, Height, MaskDC, 0, 0);
8860
8861 // Since we are not using any of the TCanvas functions (only handle)
8862 // we need to fire the TCanvas.Changed method "manually".
8863 TChangableCanvas(ACanvas).Changed;
8864
8865 finally
8866 if (Save <> 0) then
8867 SelectObject(MaskDC, Save);
8868 if (MaskDC <> 0) then
8869 DeleteDC(MaskDC);
8870 end;
8871 end else
8872 begin
8873 if (DoTile) then
8874 begin
8875 Tile.Left := Rect.Left+Left;
8876 Tile.Right := Tile.Left + Width;
8877 while (Tile.Left < Rect.Right) do
8878 begin
8879 Tile.Top := Rect.Top+Top;
8880 Tile.Bottom := Tile.Top + Height;
8881 while (Tile.Top < Rect.Bottom) do
8882 begin
8883 ACanvas.StretchDraw(Tile, Bitmap);
8884 Tile.Top := Tile.Top + Image.Height;
8885 Tile.Bottom := Tile.Bottom + Image.Height;
8886 {$ifdef DEBUG_DRAWPERFORMANCE}
8887 inc(ImageCount);
8888 {$endif}
8889 end;
8890 Tile.Left := Tile.Left + Image.Width;
8891 Tile.Right := Tile.Right + Image.Width;
8892 end;
8893 end else
8894 ACanvas.StretchDraw(Rect, Bitmap);
8895 end;
8896 {$ifdef DEBUG_DRAWPERFORMANCE}
8897 if (GetAsyncKeyState(VK_CONTROL) <> 0) then
8898 begin
8899 TimeStop := timeGetTime;
8900 ShowMessage(format('Draw %d images in %d mS, Rate %d images/mS (%d images/S)',
8901 [ImageCount, TimeStop-TimeStart,
8902 ImageCount DIV (TimeStop-TimeStart+1),
8903 MulDiv(ImageCount, 1000, TimeStop-TimeStart+1)]));
8904 end;
8905 {$endif}
8906 end;
8907
8908 // Given a destination rect (DestRect) calculates the
8909 // area covered by this sub image
TGIFSubImage.ScaleRectnull8910 function TGIFSubImage.ScaleRect(DestRect: TRect): TRect;
8911 var
8912 HeightMul ,
8913 HeightDiv : integer;
8914 WidthMul ,
8915 WidthDiv : integer;
8916 begin
8917 HeightDiv := Image.Height;
8918 HeightMul := DestRect.Bottom-DestRect.Top;
8919 WidthDiv := Image.Width;
8920 WidthMul := DestRect.Right-DestRect.Left;
8921
8922 Result.Left := DestRect.Left + muldiv(Left, WidthMul, WidthDiv);
8923 Result.Top := DestRect.Top + muldiv(Top, HeightMul, HeightDiv);
8924 Result.Right := DestRect.Left + muldiv(Left+Width, WidthMul, WidthDiv);
8925 Result.Bottom := DestRect.Top + muldiv(Top+Height, HeightMul, HeightDiv);
8926 end;
8927
8928 procedure TGIFSubImage.Crop;
8929 var
8930 TransparentColorIndex : byte;
8931 CropLeft ,
8932 CropTop ,
8933 CropRight ,
8934 CropBottom : integer;
8935 WasTransparent : boolean;
8936 i : integer;
8937 NewSize : integer;
8938 NewData : PChar;
8939 NewWidth ,
8940 NewHeight : integer;
8941 pSource ,
8942 pDest : PChar;
8943 begin
8944 if (Empty) or (not Transparent) then
8945 exit;
8946 TransparentColorIndex := GraphicControlExtension.TransparentColorIndex;
8947 CropLeft := 0;
8948 CropRight := Width - 1;
8949 CropTop := 0;
8950 CropBottom := Height - 1;
8951 // Find left edge
8952 WasTransparent := True;
8953 while (CropLeft <= CropRight) and (WasTransparent) do
8954 begin
8955 for i := CropTop to CropBottom do
8956 if (Pixels[CropLeft, i] <> TransparentColorIndex) then
8957 begin
8958 WasTransparent := False;
8959 break;
8960 end;
8961 if (WasTransparent) then
8962 inc(CropLeft);
8963 end;
8964 // Find right edge
8965 WasTransparent := True;
8966 while (CropLeft <= CropRight) and (WasTransparent) do
8967 begin
8968 for i := CropTop to CropBottom do
8969 if (pixels[CropRight, i] <> TransparentColorIndex) then
8970 begin
8971 WasTransparent := False;
8972 break;
8973 end;
8974 if (WasTransparent) then
8975 dec(CropRight);
8976 end;
8977 if (CropLeft <= CropRight) then
8978 begin
8979 // Find top edge
8980 WasTransparent := True;
8981 while (CropTop <= CropBottom) and (WasTransparent) do
8982 begin
8983 for i := CropLeft to CropRight do
8984 if (pixels[i, CropTop] <> TransparentColorIndex) then
8985 begin
8986 WasTransparent := False;
8987 break;
8988 end;
8989 if (WasTransparent) then
8990 inc(CropTop);
8991 end;
8992 // Find bottom edge
8993 WasTransparent := True;
8994 while (CropTop <= CropBottom) and (WasTransparent) do
8995 begin
8996 for i := CropLeft to CropRight do
8997 if (pixels[i, CropBottom] <> TransparentColorIndex) then
8998 begin
8999 WasTransparent := False;
9000 break;
9001 end;
9002 if (WasTransparent) then
9003 dec(CropBottom);
9004 end;
9005 end;
9006
9007 if (CropLeft > CropRight) or (CropTop > CropBottom) then
9008 begin
9009 // Cropped to nothing - frame is invisible
9010 Clear;
9011 end else
9012 begin
9013 // Crop frame - move data
9014 NewWidth := CropRight - CropLeft + 1;
9015 Newheight := CropBottom - CropTop + 1;
9016 NewSize := NewWidth * NewHeight;
9017 GetMem(NewData, NewSize);
9018 pSource := PChar(integer(FData) + CropTop * Width + CropLeft);
9019 pDest := NewData;
9020 for i := 0 to NewHeight-1 do
9021 begin
9022 Move(pSource^, pDest^, NewWidth);
9023 inc(pSource, Width);
9024 inc(pDest, NewWidth);
9025 end;
9026 FreeImage;
9027 FData := NewData;
9028 FDataSize := NewSize;
9029 inc(FImageDescriptor.Left, CropLeft);
9030 inc(FImageDescriptor.Top, CropTop);
9031 FImageDescriptor.Width := NewWidth;
9032 FImageDescriptor.Height := NewHeight;
9033 FreeBitmap;
9034 FreeMask
9035 end;
9036 end;
9037
9038 procedure TGIFSubImage.Merge(Previous: TGIFSubImage);
9039 var
9040 SourceIndex ,
9041 DestIndex : byte;
9042 SourceTransparent : boolean;
9043 NeedTransparentColorIndex: boolean;
9044 PreviousRect ,
9045 ThisRect ,
9046 MergeRect : TRect;
9047 PreviousY ,
9048 X ,
9049 Y : integer;
9050 pSource ,
9051 pDest : PChar;
9052 pSourceMap ,
9053 pDestMap : PColorMap;
9054 GCE : TGIFGraphicControlExtension;
9055
CanMakeTransparentnull9056 function CanMakeTransparent: boolean;
9057 begin
9058 // Is there a local color map...
9059 if (ColorMap.Count > 0) then
9060 // ...and is there room in it?
9061 Result := (ColorMap.Count < 256)
9062 // Is there a global color map...
9063 else if (Image.GlobalColorMap.Count > 0) then
9064 // ...and is there room in it?
9065 Result := (Image.GlobalColorMap.Count < 256)
9066 else
9067 Result := False;
9068 end;
9069
GetTransparentColorIndexnull9070 function GetTransparentColorIndex: byte;
9071 var
9072 i : integer;
9073 begin
9074 if (ColorMap.Count > 0) then
9075 begin
9076 // Get the transparent color from the local color map
9077 Result := ColorMap.Add(TColor(0));
9078 end else
9079 begin
9080 // Are any other frames using the global color map for transparency
9081 for i := 0 to Image.Images.Count-1 do
9082 if (Image.Images[i] <> self) and (Image.Images[i].Transparent) and
9083 (Image.Images[i].ColorMap.Count = 0) then
9084 begin
9085 // Use the same transparency color as the other frame
9086 Result := Image.Images[i].GraphicControlExtension.TransparentColorIndex;
9087 exit;
9088 end;
9089 // Get the transparent color from the global color map
9090 Result := Image.GlobalColorMap.Add(TColor(0));
9091 end;
9092 end;
9093
9094 begin
9095 // Determine if it is possible to merge this frame
9096 if (Empty) or (Previous = nil) or (Previous.Empty) or
9097 ((Previous.GraphicControlExtension <> nil) and
9098 (Previous.GraphicControlExtension.Disposal in [dmBackground, dmPrevious])) then
9099 exit;
9100
9101 PreviousRect := Previous.BoundsRect;
9102 ThisRect := BoundsRect;
9103
9104 // Cannot merge unless the frames intersect
9105 if (not IntersectRect(MergeRect, PreviousRect, ThisRect)) then
9106 exit;
9107
9108 // If the frame isn't already transparent, determine
9109 // if it is possible to make it so
9110 if (Transparent) then
9111 begin
9112 DestIndex := GraphicControlExtension.TransparentColorIndex;
9113 NeedTransparentColorIndex := False;
9114 end else
9115 begin
9116 if (not CanMakeTransparent) then
9117 exit;
9118 DestIndex := 0; // To avoid compiler warning
9119 NeedTransparentColorIndex := True;
9120 end;
9121
9122 SourceTransparent := Previous.Transparent;
9123 if (SourceTransparent) then
9124 SourceIndex := Previous.GraphicControlExtension.TransparentColorIndex
9125 else
9126 SourceIndex := 0; // To avoid compiler warning
9127
9128 PreviousY := MergeRect.Top - Previous.Top;
9129
9130 pSourceMap := Previous.ActiveColorMap.Data;
9131 pDestMap := ActiveColorMap.Data;
9132
9133 for Y := MergeRect.Top - Top to MergeRect.Bottom - Top-1 do
9134 begin
9135 pSource := PChar(integer(Previous.Scanline[PreviousY]) + MergeRect.Left - Previous.Left);
9136 pDest := PChar(integer(Scanline[Y]) + MergeRect.Left - Left);
9137
9138 for X := MergeRect.Left to MergeRect.Right-1 do
9139 begin
9140 // Ignore pixels if either this frame's or the previous frame's pixel is transparent
9141 if (
9142 not(
9143 ((not NeedTransparentColorIndex) and (pDest^ = char(DestIndex))) or
9144 ((SourceTransparent) and (pSource^ = char(SourceIndex)))
9145 )
9146 ) and (
9147 // Replace same colored pixels with transparency
9148 ((pDestMap = pSourceMap) and (pDest^ = pSource^)) or
9149 (CompareMem(@(pDestMap^[ord(pDest^)]), @(pSourceMap^[ord(pSource^)]), sizeof(TGIFColor)))
9150 ) then
9151 begin
9152 if (NeedTransparentColorIndex) then
9153 begin
9154 NeedTransparentColorIndex := False;
9155 DestIndex := GetTransparentColorIndex;
9156 end;
9157 pDest^ := char(DestIndex);
9158 end;
9159 inc(pDest);
9160 inc(pSource);
9161 end;
9162 inc(PreviousY);
9163 end;
9164
9165 (*
9166 ** Create a GCE if the frame wasn't already transparent and any
9167 ** pixels were made transparent
9168 *)
9169 if (not Transparent) and (not NeedTransparentColorIndex) then
9170 begin
9171 if (GraphicControlExtension = nil) then
9172 begin
9173 GCE := TGIFGraphicControlExtension.Create(self);
9174 Extensions.Add(GCE);
9175 end else
9176 GCE := GraphicControlExtension;
9177 GCE.Transparent := True;
9178 GCE.TransparentColorIndex := DestIndex;
9179 end;
9180
9181 FreeBitmap;
9182 FreeMask
9183 end;
9184
9185 ////////////////////////////////////////////////////////////////////////////////
9186 //
9187 // TGIFTrailer
9188 //
9189 ////////////////////////////////////////////////////////////////////////////////
9190 procedure TGIFTrailer.SaveToStream(Stream: TStream);
9191 begin
9192 WriteByte(Stream, bsTrailer);
9193 end;
9194
9195 procedure TGIFTrailer.LoadFromStream(Stream: TStream);
9196 var
9197 b : BYTE;
9198 begin
9199 if (Stream.Read(b, 1) <> 1) then
9200 exit;
9201 if (b <> bsTrailer) then
9202 Warning(gsWarning, sBadTrailer);
9203 end;
9204
9205 ////////////////////////////////////////////////////////////////////////////////
9206 //
9207 // TGIFExtension registration database
9208 //
9209 ////////////////////////////////////////////////////////////////////////////////
9210 type
9211 TExtensionLeadIn = packed record
9212 Introducer: byte; { always $21 }
9213 ExtensionLabel: byte;
9214 end;
9215
9216 PExtRec = ^TExtRec;
9217 TExtRec = record
9218 ExtClass: TGIFExtensionClass;
9219 ExtLabel: BYTE;
9220 end;
9221
9222 TExtensionList = class(TList)
9223 public
9224 constructor Create;
9225 destructor Destroy; override;
9226 procedure Add(eLabel: BYTE; eClass: TGIFExtensionClass);
FindExtnull9227 function FindExt(eLabel: BYTE): TGIFExtensionClass;
9228 procedure Remove(eClass: TGIFExtensionClass);
9229 end;
9230
9231 constructor TExtensionList.Create;
9232 begin
9233 inherited Create;
9234 Add(bsPlainTextExtension, TGIFTextExtension);
9235 Add(bsGraphicControlExtension, TGIFGraphicControlExtension);
9236 Add(bsCommentExtension, TGIFCommentExtension);
9237 Add(bsApplicationExtension, TGIFApplicationExtension);
9238 end;
9239
9240 destructor TExtensionList.Destroy;
9241 var
9242 I: Integer;
9243 begin
9244 for I := 0 to Count-1 do
9245 Dispose(PExtRec(Items[I]));
9246 inherited Destroy;
9247 end;
9248
9249 procedure TExtensionList.Add(eLabel: BYTE; eClass: TGIFExtensionClass);
9250 var
9251 NewRec: PExtRec;
9252 begin
9253 New(NewRec);
9254 with NewRec^ do
9255 begin
9256 ExtLabel := eLabel;
9257 ExtClass := eClass;
9258 end;
9259 inherited Add(NewRec);
9260 end;
9261
TExtensionList.FindExtnull9262 function TExtensionList.FindExt(eLabel: BYTE): TGIFExtensionClass;
9263 var
9264 I: Integer;
9265 begin
9266 for I := Count-1 downto 0 do
9267 with PExtRec(Items[I])^ do
9268 if ExtLabel = eLabel then
9269 begin
9270 Result := ExtClass;
9271 Exit;
9272 end;
9273 Result := nil;
9274 end;
9275
9276 procedure TExtensionList.Remove(eClass: TGIFExtensionClass);
9277 var
9278 I: Integer;
9279 P: PExtRec;
9280 begin
9281 for I := Count-1 downto 0 do
9282 begin
9283 P := PExtRec(Items[I]);
9284 if P^.ExtClass.InheritsFrom(eClass) then
9285 begin
9286 Dispose(P);
9287 Delete(I);
9288 end;
9289 end;
9290 end;
9291
9292 var
9293 ExtensionList: TExtensionList = nil;
9294
GetExtensionListnull9295 function GetExtensionList: TExtensionList;
9296 begin
9297 if (ExtensionList = nil) then
9298 ExtensionList := TExtensionList.Create;
9299 Result := ExtensionList;
9300 end;
9301
9302 ////////////////////////////////////////////////////////////////////////////////
9303 //
9304 // TGIFExtension
9305 //
9306 ////////////////////////////////////////////////////////////////////////////////
GetVersionnull9307 function TGIFExtension.GetVersion: TGIFVersion;
9308 begin
9309 Result := gv89a;
9310 end;
9311
9312 class procedure TGIFExtension.RegisterExtension(eLabel: BYTE; eClass: TGIFExtensionClass);
9313 begin
9314 GetExtensionList.Add(eLabel, eClass);
9315 end;
9316
TGIFExtension.FindExtensionnull9317 class function TGIFExtension.FindExtension(Stream: TStream): TGIFExtensionClass;
9318 var
9319 eLabel : BYTE;
9320 SubClass : TGIFExtensionClass;
9321 Pos : LongInt;
9322 begin
9323 Pos := Stream.Position;
9324 if (Stream.Read(eLabel, 1) <> 1) then
9325 begin
9326 Result := nil;
9327 exit;
9328 end;
9329 Result := GetExtensionList.FindExt(eLabel);
9330 while (Result <> nil) do
9331 begin
9332 SubClass := Result.FindSubExtension(Stream);
9333 if (SubClass = Result) then
9334 break;
9335 Result := SubClass;
9336 end;
9337 Stream.Position := Pos;
9338 end;
9339
TGIFExtension.FindSubExtensionnull9340 class function TGIFExtension.FindSubExtension(Stream: TStream): TGIFExtensionClass;
9341 begin
9342 Result := self;
9343 end;
9344
9345 constructor TGIFExtension.Create(ASubImage: TGIFSubImage);
9346 begin
9347 inherited Create(ASubImage.Image);
9348 FSubImage := ASubImage;
9349 end;
9350
9351 destructor TGIFExtension.Destroy;
9352 begin
9353 if (FSubImage <> nil) then
9354 FSubImage.Extensions.Remove(self);
9355 inherited Destroy;
9356 end;
9357
9358 procedure TGIFExtension.SaveToStream(Stream: TStream);
9359 var
9360 ExtensionLeadIn : TExtensionLeadIn;
9361 begin
9362 ExtensionLeadIn.Introducer := bsExtensionIntroducer;
9363 ExtensionLeadIn.ExtensionLabel := ExtensionType;
9364 Stream.Write(ExtensionLeadIn, sizeof(ExtensionLeadIn));
9365 end;
9366
TGIFExtension.DoReadFromStreamnull9367 function TGIFExtension.DoReadFromStream(Stream: TStream): TGIFExtensionType;
9368 var
9369 ExtensionLeadIn : TExtensionLeadIn;
9370 begin
9371 ReadCheck(Stream, ExtensionLeadIn, sizeof(ExtensionLeadIn));
9372 if (ExtensionLeadIn.Introducer <> bsExtensionIntroducer) then
9373 Error(sBadExtensionLabel);
9374 Result := ExtensionLeadIn.ExtensionLabel;
9375 end;
9376
9377 procedure TGIFExtension.LoadFromStream(Stream: TStream);
9378 begin
9379 // Seek past lead-in
9380 // Stream.Seek(sizeof(TExtensionLeadIn), soFromCurrent);
9381 if (DoReadFromStream(Stream) <> ExtensionType) then
9382 Error(sBadExtensionInstance);
9383 end;
9384
9385 ////////////////////////////////////////////////////////////////////////////////
9386 //
9387 // TGIFGraphicControlExtension
9388 //
9389 ////////////////////////////////////////////////////////////////////////////////
9390 const
9391 { Extension flag bit masks }
9392 efInputFlag = $02; { 00000010 }
9393 efDisposal = $1C; { 00011100 }
9394 efTransparent = $01; { 00000001 }
9395 efReserved = $E0; { 11100000 }
9396
9397 constructor TGIFGraphicControlExtension.Create(ASubImage: TGIFSubImage);
9398 begin
9399 inherited Create(ASubImage);
9400
9401 FGCExtension.BlockSize := 4;
9402 FGCExtension.PackedFields := $00;
9403 FGCExtension.DelayTime := 0;
9404 FGCExtension.TransparentColorIndex := 0;
9405 FGCExtension.Terminator := 0;
9406 if (ASubImage.FGCE = nil) then
9407 ASubImage.FGCE := self;
9408 end;
9409
9410 destructor TGIFGraphicControlExtension.Destroy;
9411 begin
9412 // Clear transparent flag in sub image
9413 if (Transparent) then
9414 SubImage.FTransparent := False;
9415
9416 if (SubImage.FGCE = self) then
9417 SubImage.FGCE := nil;
9418
9419 inherited Destroy;
9420 end;
9421
GetExtensionTypenull9422 function TGIFGraphicControlExtension.GetExtensionType: TGIFExtensionType;
9423 begin
9424 Result := bsGraphicControlExtension;
9425 end;
9426
GetTransparentnull9427 function TGIFGraphicControlExtension.GetTransparent: boolean;
9428 begin
9429 Result := (FGCExtension.PackedFields AND efTransparent) <> 0;
9430 end;
9431
9432 procedure TGIFGraphicControlExtension.SetTransparent(Value: boolean);
9433 begin
9434 // Set transparent flag in sub image
9435 SubImage.FTransparent := Value;
9436 if (Value) then
9437 FGCExtension.PackedFields := FGCExtension.PackedFields OR efTransparent
9438 else
9439 FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efTransparent);
9440 end;
9441
TGIFGraphicControlExtension.GetTransparentColornull9442 function TGIFGraphicControlExtension.GetTransparentColor: TColor;
9443 begin
9444 Result := SubImage.ActiveColorMap[TransparentColorIndex];
9445 end;
9446
9447 procedure TGIFGraphicControlExtension.SetTransparentColor(Color: TColor);
9448 begin
9449 FGCExtension.TransparentColorIndex := Subimage.ActiveColorMap.AddUnique(Color);
9450 end;
9451
GetTransparentColorIndexnull9452 function TGIFGraphicControlExtension.GetTransparentColorIndex: BYTE;
9453 begin
9454 Result := FGCExtension.TransparentColorIndex;
9455 end;
9456
9457 procedure TGIFGraphicControlExtension.SetTransparentColorIndex(Value: BYTE);
9458 begin
9459 if ((Value >= SubImage.ActiveColorMap.Count) and (SubImage.ActiveColorMap.Count > 0)) then
9460 begin
9461 Warning(gsWarning, sBadColorIndex);
9462 Value := 0;
9463 end;
9464 FGCExtension.TransparentColorIndex := Value;
9465 end;
9466
GetDelaynull9467 function TGIFGraphicControlExtension.GetDelay: WORD;
9468 begin
9469 Result := FGCExtension.DelayTime;
9470 end;
9471 procedure TGIFGraphicControlExtension.SetDelay(Value: WORD);
9472 begin
9473 FGCExtension.DelayTime := Value;
9474 end;
9475
TGIFGraphicControlExtension.GetUserInputnull9476 function TGIFGraphicControlExtension.GetUserInput: boolean;
9477 begin
9478 Result := (FGCExtension.PackedFields AND efInputFlag) <> 0;
9479 end;
9480
9481 procedure TGIFGraphicControlExtension.SetUserInput(Value: boolean);
9482 begin
9483 if (Value) then
9484 FGCExtension.PackedFields := FGCExtension.PackedFields OR efInputFlag
9485 else
9486 FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efInputFlag);
9487 end;
9488
GetDisposalnull9489 function TGIFGraphicControlExtension.GetDisposal: TDisposalMethod;
9490 begin
9491 Result := TDisposalMethod((FGCExtension.PackedFields AND efDisposal) SHR 2);
9492 end;
9493
9494 procedure TGIFGraphicControlExtension.SetDisposal(Value: TDisposalMethod);
9495 begin
9496 FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efDisposal)
9497 OR ((ord(Value) SHL 2) AND efDisposal);
9498 end;
9499
9500 procedure TGIFGraphicControlExtension.SaveToStream(Stream: TStream);
9501 begin
9502 inherited SaveToStream(Stream);
9503 Stream.Write(FGCExtension, sizeof(FGCExtension));
9504 end;
9505
9506 procedure TGIFGraphicControlExtension.LoadFromStream(Stream: TStream);
9507 begin
9508 inherited LoadFromStream(Stream);
9509 if (Stream.Read(FGCExtension, sizeof(FGCExtension)) <> sizeof(FGCExtension)) then
9510 begin
9511 Warning(gsWarning, sOutOfData);
9512 exit;
9513 end;
9514 // Set transparent flag in sub image
9515 if (Transparent) then
9516 SubImage.FTransparent := True;
9517 end;
9518
9519 ////////////////////////////////////////////////////////////////////////////////
9520 //
9521 // TGIFTextExtension
9522 //
9523 ////////////////////////////////////////////////////////////////////////////////
9524 constructor TGIFTextExtension.Create(ASubImage: TGIFSubImage);
9525 begin
9526 inherited Create(ASubImage);
9527 FText := TStringList.Create;
9528 FPlainTextExtension.BlockSize := 12;
9529 FPlainTextExtension.Left := 0;
9530 FPlainTextExtension.Top := 0;
9531 FPlainTextExtension.Width := 0;
9532 FPlainTextExtension.Height := 0;
9533 FPlainTextExtension.CellWidth := 0;
9534 FPlainTextExtension.CellHeight := 0;
9535 FPlainTextExtension.TextFGColorIndex := 0;
9536 FPlainTextExtension.TextBGColorIndex := 0;
9537 end;
9538
9539 destructor TGIFTextExtension.Destroy;
9540 begin
9541 FText.Free;
9542 inherited Destroy;
9543 end;
9544
GetExtensionTypenull9545 function TGIFTextExtension.GetExtensionType: TGIFExtensionType;
9546 begin
9547 Result := bsPlainTextExtension;
9548 end;
9549
GetForegroundColornull9550 function TGIFTextExtension.GetForegroundColor: TColor;
9551 begin
9552 Result := SubImage.ColorMap[ForegroundColorIndex];
9553 end;
9554
9555 procedure TGIFTextExtension.SetForegroundColor(Color: TColor);
9556 begin
9557 ForegroundColorIndex := SubImage.ActiveColorMap.AddUnique(Color);
9558 end;
9559
TGIFTextExtension.GetBackgroundColornull9560 function TGIFTextExtension.GetBackgroundColor: TColor;
9561 begin
9562 Result := SubImage.ActiveColorMap[BackgroundColorIndex];
9563 end;
9564
9565 procedure TGIFTextExtension.SetBackgroundColor(Color: TColor);
9566 begin
9567 BackgroundColorIndex := SubImage.ColorMap.AddUnique(Color);
9568 end;
9569
GetBoundsnull9570 function TGIFTextExtension.GetBounds(Index: integer): WORD;
9571 begin
9572 case (Index) of
9573 1: Result := FPlainTextExtension.Left;
9574 2: Result := FPlainTextExtension.Top;
9575 3: Result := FPlainTextExtension.Width;
9576 4: Result := FPlainTextExtension.Height;
9577 else
9578 Result := 0; // To avoid compiler warnings
9579 end;
9580 end;
9581
9582 procedure TGIFTextExtension.SetBounds(Index: integer; Value: WORD);
9583 begin
9584 case (Index) of
9585 1: FPlainTextExtension.Left := Value;
9586 2: FPlainTextExtension.Top := Value;
9587 3: FPlainTextExtension.Width := Value;
9588 4: FPlainTextExtension.Height := Value;
9589 end;
9590 end;
9591
TGIFTextExtension.GetCharWidthHeightnull9592 function TGIFTextExtension.GetCharWidthHeight(Index: integer): BYTE;
9593 begin
9594 case (Index) of
9595 1: Result := FPlainTextExtension.CellWidth;
9596 2: Result := FPlainTextExtension.CellHeight;
9597 else
9598 Result := 0; // To avoid compiler warnings
9599 end;
9600 end;
9601
9602 procedure TGIFTextExtension.SetCharWidthHeight(Index: integer; Value: BYTE);
9603 begin
9604 case (Index) of
9605 1: FPlainTextExtension.CellWidth := Value;
9606 2: FPlainTextExtension.CellHeight := Value;
9607 end;
9608 end;
9609
GetColorIndexnull9610 function TGIFTextExtension.GetColorIndex(Index: integer): BYTE;
9611 begin
9612 case (Index) of
9613 1: Result := FPlainTextExtension.TextFGColorIndex;
9614 2: Result := FPlainTextExtension.TextBGColorIndex;
9615 else
9616 Result := 0; // To avoid compiler warnings
9617 end;
9618 end;
9619
9620 procedure TGIFTextExtension.SetColorIndex(Index: integer; Value: BYTE);
9621 begin
9622 case (Index) of
9623 1: FPlainTextExtension.TextFGColorIndex := Value;
9624 2: FPlainTextExtension.TextBGColorIndex := Value;
9625 end;
9626 end;
9627
9628 procedure TGIFTextExtension.SaveToStream(Stream: TStream);
9629 begin
9630 inherited SaveToStream(Stream);
9631 Stream.Write(FPlainTextExtension, sizeof(FPlainTextExtension));
9632 WriteStrings(Stream, FText);
9633 end;
9634
9635 procedure TGIFTextExtension.LoadFromStream(Stream: TStream);
9636 begin
9637 inherited LoadFromStream(Stream);
9638 ReadCheck(Stream, FPlainTextExtension, sizeof(FPlainTextExtension));
9639 ReadStrings(Stream, FText);
9640 end;
9641
9642 ////////////////////////////////////////////////////////////////////////////////
9643 //
9644 // TGIFCommentExtension
9645 //
9646 ////////////////////////////////////////////////////////////////////////////////
9647 constructor TGIFCommentExtension.Create(ASubImage: TGIFSubImage);
9648 begin
9649 inherited Create(ASubImage);
9650 FText := TStringList.Create;
9651 end;
9652
9653 destructor TGIFCommentExtension.Destroy;
9654 begin
9655 FText.Free;
9656 inherited Destroy;
9657 end;
9658
TGIFCommentExtension.GetExtensionTypenull9659 function TGIFCommentExtension.GetExtensionType: TGIFExtensionType;
9660 begin
9661 Result := bsCommentExtension;
9662 end;
9663
9664 procedure TGIFCommentExtension.SaveToStream(Stream: TStream);
9665 begin
9666 inherited SaveToStream(Stream);
9667 WriteStrings(Stream, FText);
9668 end;
9669
9670 procedure TGIFCommentExtension.LoadFromStream(Stream: TStream);
9671 begin
9672 inherited LoadFromStream(Stream);
9673 ReadStrings(Stream, FText);
9674 end;
9675
9676 ////////////////////////////////////////////////////////////////////////////////
9677 //
9678 // TGIFApplicationExtension registration database
9679 //
9680 ////////////////////////////////////////////////////////////////////////////////
9681 type
9682 PAppExtRec = ^TAppExtRec;
9683 TAppExtRec = record
9684 AppClass: TGIFAppExtensionClass;
9685 Ident: TGIFApplicationRec;
9686 end;
9687
9688 TAppExtensionList = class(TList)
9689 public
9690 constructor Create;
9691 destructor Destroy; override;
9692 procedure Add(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
FindExtnull9693 function FindExt(eIdent: TGIFApplicationRec): TGIFAppExtensionClass;
9694 procedure Remove(eClass: TGIFAppExtensionClass);
9695 end;
9696
9697 constructor TAppExtensionList.Create;
9698 const
9699 NSLoopIdent: array[0..1] of TGIFApplicationRec =
9700 ((Identifier: 'NETSCAPE'; Authentication: '2.0'),
9701 (Identifier: 'ANIMEXTS'; Authentication: '1.0'));
9702 begin
9703 inherited Create;
9704 Add(NSLoopIdent[0], TGIFAppExtNSLoop);
9705 Add(NSLoopIdent[1], TGIFAppExtNSLoop);
9706 end;
9707
9708 destructor TAppExtensionList.Destroy;
9709 var
9710 I: Integer;
9711 begin
9712 for I := 0 to Count-1 do
9713 Dispose(PAppExtRec(Items[I]));
9714 inherited Destroy;
9715 end;
9716
9717 procedure TAppExtensionList.Add(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
9718 var
9719 NewRec: PAppExtRec;
9720 begin
9721 New(NewRec);
9722 NewRec^.Ident := eIdent;
9723 NewRec^.AppClass := eClass;
9724 inherited Add(NewRec);
9725 end;
9726
FindExtnull9727 function TAppExtensionList.FindExt(eIdent: TGIFApplicationRec): TGIFAppExtensionClass;
9728 var
9729 I: Integer;
9730 begin
9731 for I := Count-1 downto 0 do
9732 with PAppExtRec(Items[I])^ do
9733 if CompareMem(@Ident, @eIdent, sizeof(TGIFApplicationRec)) then
9734 begin
9735 Result := AppClass;
9736 Exit;
9737 end;
9738 Result := nil;
9739 end;
9740
9741 procedure TAppExtensionList.Remove(eClass: TGIFAppExtensionClass);
9742 var
9743 I: Integer;
9744 P: PAppExtRec;
9745 begin
9746 for I := Count-1 downto 0 do
9747 begin
9748 P := PAppExtRec(Items[I]);
9749 if P^.AppClass.InheritsFrom(eClass) then
9750 begin
9751 Dispose(P);
9752 Delete(I);
9753 end;
9754 end;
9755 end;
9756
9757 var
9758 AppExtensionList: TAppExtensionList = nil;
9759
GetAppExtensionListnull9760 function GetAppExtensionList: TAppExtensionList;
9761 begin
9762 if (AppExtensionList = nil) then
9763 AppExtensionList := TAppExtensionList.Create;
9764 Result := AppExtensionList;
9765 end;
9766
9767 class procedure TGIFApplicationExtension.RegisterExtension(eIdent: TGIFApplicationRec;
9768 eClass: TGIFAppExtensionClass);
9769 begin
9770 GetAppExtensionList.Add(eIdent, eClass);
9771 end;
9772
TGIFApplicationExtension.FindSubExtensionnull9773 class function TGIFApplicationExtension.FindSubExtension(Stream: TStream): TGIFExtensionClass;
9774 var
9775 eIdent : TGIFApplicationRec;
9776 OldPos : longInt;
9777 Size : BYTE;
9778 begin
9779 OldPos := Stream.Position;
9780 Result := nil;
9781 if (Stream.Read(Size, 1) <> 1) then
9782 exit;
9783
9784 // Some old Adobe export filters mistakenly uses a value of 10
9785 if (Size = 10) then
9786 begin
9787 { TODO -oanme -cImprovement : replace with seek or read and check contents = 'Adobe' }
9788 if (Stream.Read(eIdent, 10) <> 10) then
9789 exit;
9790 Result := TGIFUnknownAppExtension;
9791 exit;
9792 end else
9793 if (Size <> sizeof(TGIFApplicationRec)) or
9794 (Stream.Read(eIdent, sizeof(eIdent)) <> sizeof(eIdent)) then
9795 begin
9796 Stream.Position := OldPos;
9797 Result := inherited FindSubExtension(Stream);
9798 end else
9799 begin
9800 Result := GetAppExtensionList.FindExt(eIdent);
9801 if (Result = nil) then
9802 Result := TGIFUnknownAppExtension;
9803 end;
9804 end;
9805
9806 ////////////////////////////////////////////////////////////////////////////////
9807 //
9808 // TGIFApplicationExtension
9809 //
9810 ////////////////////////////////////////////////////////////////////////////////
9811 constructor TGIFApplicationExtension.Create(ASubImage: TGIFSubImage);
9812 begin
9813 inherited Create(ASubImage);
9814 FillChar(FIdent, sizeof(FIdent), 0);
9815 end;
9816
9817 destructor TGIFApplicationExtension.Destroy;
9818 begin
9819 inherited Destroy;
9820 end;
9821
GetExtensionTypenull9822 function TGIFApplicationExtension.GetExtensionType: TGIFExtensionType;
9823 begin
9824 Result := bsApplicationExtension;
9825 end;
9826
GetAuthenticationnull9827 function TGIFApplicationExtension.GetAuthentication: string;
9828 begin
9829 Result := FIdent.Authentication;
9830 end;
9831
9832 procedure TGIFApplicationExtension.SetAuthentication(const Value: string);
9833 begin
9834 if (Length(Value) < sizeof(TGIFAuthenticationCode)) then
9835 FillChar(FIdent.Authentication, sizeof(TGIFAuthenticationCode), 32);
9836 StrLCopy(@(FIdent.Authentication[0]), PChar(Value), sizeof(TGIFAuthenticationCode));
9837 end;
9838
GetIdentifiernull9839 function TGIFApplicationExtension.GetIdentifier: string;
9840 begin
9841 Result := FIdent.Identifier;
9842 end;
9843
9844 procedure TGIFApplicationExtension.SetIdentifier(const Value: string);
9845 begin
9846 if (Length(Value) < sizeof(TGIFIdentifierCode)) then
9847 FillChar(FIdent.Identifier, sizeof(TGIFIdentifierCode), 32);
9848 StrLCopy(@(FIdent.Identifier[0]), PChar(Value), sizeof(TGIFIdentifierCode));
9849 end;
9850
9851 procedure TGIFApplicationExtension.SaveToStream(Stream: TStream);
9852 begin
9853 inherited SaveToStream(Stream);
9854 WriteByte(Stream, sizeof(FIdent)); // Block size
9855 Stream.Write(FIdent, sizeof(FIdent));
9856 SaveData(Stream);
9857 end;
9858
9859 procedure TGIFApplicationExtension.LoadFromStream(Stream: TStream);
9860 var
9861 i : integer;
9862 begin
9863 inherited LoadFromStream(Stream);
9864 i := ReadByte(Stream);
9865 // Some old Adobe export filters mistakenly uses a value of 10
9866 if (i = 10) then
9867 FillChar(FIdent, sizeOf(FIdent), 0)
9868 else
9869 if (i < 11) then
9870 Error(sBadBlockSize);
9871
9872 ReadCheck(Stream, FIdent, sizeof(FIdent));
9873
9874 Dec(i, sizeof(FIdent));
9875 // Ignore extra data
9876 Stream.Seek(i, soFromCurrent);
9877
9878 // ***FIXME***
9879 // If self class is TGIFApplicationExtension, this will cause an "abstract
9880 // error".
9881 // TGIFApplicationExtension.LoadData should read and ignore rest of block.
9882 LoadData(Stream);
9883 end;
9884
9885 ////////////////////////////////////////////////////////////////////////////////
9886 //
9887 // TGIFUnknownAppExtension
9888 //
9889 ////////////////////////////////////////////////////////////////////////////////
9890 constructor TGIFBlock.Create(ASize: integer);
9891 begin
9892 inherited Create;
9893 FSize := ASize;
9894 GetMem(FData, FSize);
9895 FillChar(FData^, FSize, 0);
9896 end;
9897
9898 destructor TGIFBlock.Destroy;
9899 begin
9900 FreeMem(FData);
9901 inherited Destroy;
9902 end;
9903
9904 procedure TGIFBlock.SaveToStream(Stream: TStream);
9905 begin
9906 Stream.Write(FSize, 1);
9907 Stream.Write(FData^, FSize);
9908 end;
9909
9910 procedure TGIFBlock.LoadFromStream(Stream: TStream);
9911 begin
9912 ReadCheck(Stream, FData^, FSize);
9913 end;
9914
9915 constructor TGIFUnknownAppExtension.Create(ASubImage: TGIFSubImage);
9916 begin
9917 inherited Create(ASubImage);
9918 FBlocks := TList.Create;
9919 end;
9920
9921 destructor TGIFUnknownAppExtension.Destroy;
9922 var
9923 i : integer;
9924 begin
9925 for i := 0 to FBlocks.Count-1 do
9926 TGIFBlock(FBlocks[i]).Free;
9927 FBlocks.Free;
9928 inherited Destroy;
9929 end;
9930
9931
9932 procedure TGIFUnknownAppExtension.SaveData(Stream: TStream);
9933 var
9934 i : integer;
9935 begin
9936 for i := 0 to FBlocks.Count-1 do
9937 TGIFBlock(FBlocks[i]).SaveToStream(Stream);
9938 // Terminating zero
9939 WriteByte(Stream, 0);
9940 end;
9941
9942 procedure TGIFUnknownAppExtension.LoadData(Stream: TStream);
9943 var
9944 b : BYTE;
9945 Block : TGIFBlock;
9946 i : integer;
9947 begin
9948 // Zap old blocks
9949 for i := 0 to FBlocks.Count-1 do
9950 TGIFBlock(FBlocks[i]).Free;
9951 FBlocks.Clear;
9952
9953 // Read blocks
9954 if (Stream.Read(b, 1) <> 1) then
9955 exit;
9956 while (b <> 0) do
9957 begin
9958 Block := TGIFBlock.Create(b);
9959 try
9960 Block.LoadFromStream(Stream);
9961 except
9962 Block.Free;
9963 raise;
9964 end;
9965 FBlocks.Add(Block);
9966 if (Stream.Read(b, 1) <> 1) then
9967 exit;
9968 end;
9969 end;
9970
9971 ////////////////////////////////////////////////////////////////////////////////
9972 //
9973 // TGIFAppExtNSLoop
9974 //
9975 ////////////////////////////////////////////////////////////////////////////////
9976 const
9977 // Netscape sub block types
9978 nbLoopExtension = 1;
9979 nbBufferExtension = 2;
9980
9981 constructor TGIFAppExtNSLoop.Create(ASubImage: TGIFSubImage);
9982 const
9983 NSLoopIdent: TGIFApplicationRec = (Identifier: 'NETSCAPE'; Authentication: '2.0');
9984 begin
9985 inherited Create(ASubImage);
9986 FIdent := NSLoopIdent;
9987 end;
9988
9989 procedure TGIFAppExtNSLoop.SaveData(Stream: TStream);
9990 begin
9991 // Write loop count
9992 WriteByte(Stream, 1 + sizeof(FLoops)); // Size of block
9993 WriteByte(Stream, nbLoopExtension); // Identify sub block as looping extension data
9994 Stream.Write(FLoops, sizeof(FLoops)); // Loop count
9995
9996 // Write buffer size if specified
9997 if (FBufferSize > 0) then
9998 begin
9999 WriteByte(Stream, 1 + sizeof(FBufferSize)); // Size of block
10000 WriteByte(Stream, nbBufferExtension); // Identify sub block as buffer size data
10001 Stream.Write(FBufferSize, sizeof(FBufferSize)); // Buffer size
10002 end;
10003
10004 WriteByte(Stream, 0); // Terminating zero
10005 end;
10006
10007 procedure TGIFAppExtNSLoop.LoadData(Stream: TStream);
10008 var
10009 BlockSize : integer;
10010 BlockType : integer;
10011 begin
10012 // Read size of first block or terminating zero
10013 BlockSize := ReadByte(Stream);
10014 while (BlockSize <> 0) do
10015 begin
10016 BlockType := ReadByte(Stream);
10017 dec(BlockSize);
10018
10019 case (BlockType AND $07) of
10020 nbLoopExtension:
10021 begin
10022 if (BlockSize < sizeof(FLoops)) then
10023 Error(sInvalidData);
10024 // Read loop count
10025 ReadCheck(Stream, FLoops, sizeof(FLoops));
10026 dec(BlockSize, sizeof(FLoops));
10027 end;
10028 nbBufferExtension:
10029 begin
10030 if (BlockSize < sizeof(FBufferSize)) then
10031 Error(sInvalidData);
10032 // Read buffer size
10033 ReadCheck(Stream, FBufferSize, sizeof(FBufferSize));
10034 dec(BlockSize, sizeof(FBufferSize));
10035 end;
10036 end;
10037
10038 // Skip/ignore unread data
10039 if (BlockSize > 0) then
10040 Stream.Seek(BlockSize, soFromCurrent);
10041
10042 // Read size of next block or terminating zero
10043 BlockSize := ReadByte(Stream);
10044 end;
10045 end;
10046
10047
10048 ////////////////////////////////////////////////////////////////////////////////
10049 //
10050 // TGIFImageList
10051 //
10052 ////////////////////////////////////////////////////////////////////////////////
TGIFImageList.GetImagenull10053 function TGIFImageList.GetImage(Index: Integer): TGIFSubImage;
10054 begin
10055 Result := TGIFSubImage(Items[Index]);
10056 end;
10057
10058 procedure TGIFImageList.SetImage(Index: Integer; SubImage: TGIFSubImage);
10059 begin
10060 Items[Index] := SubImage;
10061 end;
10062
10063 procedure TGIFImageList.LoadFromStream(Stream: TStream; Parent: TObject);
10064 var
10065 b : BYTE;
10066 SubImage : TGIFSubImage;
10067 begin
10068 // Peek ahead to determine block type
10069 repeat
10070 if (Stream.Read(b, 1) <> 1) then
10071 exit;
10072 until (b <> 0); // Ignore 0 padding (non-compliant)
10073
10074 while (b <> bsTrailer) do
10075 begin
10076 Stream.Seek(-1, soFromCurrent);
10077 if (b in [bsExtensionIntroducer, bsImageDescriptor]) then
10078 begin
10079 SubImage := TGIFSubImage.Create(Parent as TGIFImage);
10080 try
10081 SubImage.LoadFromStream(Stream);
10082 Add(SubImage);
10083 Image.Progress(Self, psRunning, MulDiv(Stream.Position, 100, Stream.Size),
10084 GIFImageRenderOnLoad, Rect(0,0,0,0), sProgressLoading);
10085 except
10086 SubImage.Free;
10087 raise;
10088 end;
10089 end else
10090 begin
10091 Warning(gsWarning, sBadBlock);
10092 break;
10093 end;
10094 repeat
10095 if (Stream.Read(b, 1) <> 1) then
10096 exit;
10097 until (b <> 0); // Ignore 0 padding (non-compliant)
10098 end;
10099 Stream.Seek(-1, soFromCurrent);
10100 end;
10101
10102 procedure TGIFImageList.SaveToStream(Stream: TStream);
10103 var
10104 i : integer;
10105 begin
10106 for i := 0 to Count-1 do
10107 begin
10108 TGIFItem(Items[i]).SaveToStream(Stream);
10109 Image.Progress(Self, psRunning, MulDiv((i+1), 100, Count), False, Rect(0,0,0,0), sProgressSaving);
10110 end;
10111 end;
10112
10113 ////////////////////////////////////////////////////////////////////////////////
10114 //
10115 // TGIFPainter
10116 //
10117 ////////////////////////////////////////////////////////////////////////////////
10118 constructor TGIFPainter.CreateRef(Painter: PGIFPainter; AImage: TGIFImage;
10119 ACanvas: TCanvas; ARect: TRect; Options: TGIFDrawOptions);
10120 begin
10121 Create(AImage, ACanvas, ARect, Options);
10122 PainterRef := Painter;
10123 if (PainterRef <> nil) then
10124 PainterRef^ := self;
10125 end;
10126
10127 constructor TGIFPainter.Create(AImage: TGIFImage; ACanvas: TCanvas; ARect: TRect;
10128 Options: TGIFDrawOptions);
10129 var
10130 i : integer;
10131 BackgroundColor : TColor;
10132 Disposals : set of TDisposalMethod;
10133 begin
10134 inherited Create(True);
10135 FreeOnTerminate := True;
10136 Onterminate := DoOnTerminate;
10137 FImage := AImage;
10138 FCanvas := ACanvas;
10139 FRect := ARect;
10140 FActiveImage := -1;
10141 FDrawOptions := Options;
10142 FStarted := False;
10143 BackupBuffer := nil;
10144 FrameBuffer := nil;
10145 Background := nil;
10146 FEventHandle := 0;
10147 // This should be a parameter, but I think I've got enough of them already...
10148 FAnimationSpeed := FImage.AnimationSpeed;
10149
10150 // An event handle is used for animation delays
10151 if (FDrawOptions >= [goAnimate, goAsync]) and (FImage.Images.Count > 1) and
10152 (FAnimationSpeed >= 0) then
10153 FEventHandle := CreateEvent(nil, False, False, nil);
10154
10155 // Preprocessing of extensions to determine if we need frame buffers
10156 Disposals := [];
10157 if (FImage.DrawBackgroundColor = clNone) then
10158 begin
10159 if (FImage.GlobalColorMap.Count > 0) then
10160 BackgroundColor := FImage.BackgroundColor
10161 else
10162 BackgroundColor := ColorToRGB(clWindow);
10163 end else
10164 BackgroundColor := ColorToRGB(FImage.DrawBackgroundColor);
10165
10166 // Need background buffer to clear on loop
10167 if (goClearOnLoop in FDrawOptions) then
10168 Include(Disposals, dmBackground);
10169
10170 for i := 0 to FImage.Images.Count-1 do
10171 if (FImage.Images[i].GraphicControlExtension <> nil) then
10172 with (FImage.Images[i].GraphicControlExtension) do
10173 Include(Disposals, Disposal);
10174
10175 // Need background buffer to draw transparent on background
10176 if (dmBackground in Disposals) and (goTransparent in FDrawOptions) then
10177 begin
10178 Background := TBitmap.Create;
10179 Background.Height := FRect.Bottom-FRect.Top;
10180 Background.Width := FRect.Right-FRect.Left;
10181 // Copy background immediately
10182 Background.Canvas.CopyMode := cmSrcCopy;
10183 Background.Canvas.CopyRect(Background.Canvas.ClipRect, FCanvas, FRect);
10184 end;
10185 // Need frame- and backup buffer to restore to previous and background
10186 if ((Disposals * [dmPrevious, dmBackground]) <> []) then
10187 begin
10188 BackupBuffer := TBitmap.Create;
10189 BackupBuffer.Height := FRect.Bottom-FRect.Top;
10190 BackupBuffer.Width := FRect.Right-FRect.Left;
10191 BackupBuffer.Canvas.CopyMode := cmSrcCopy;
10192 BackupBuffer.Canvas.Brush.Color := BackgroundColor;
10193 BackupBuffer.Canvas.Brush.Style := bsSolid;
10194 {$IFDEF DEBUG}
10195 BackupBuffer.Canvas.Brush.Color := clBlack;
10196 BackupBuffer.Canvas.Brush.Style := bsDiagCross;
10197 {$ENDIF}
10198 // Step 1: Copy destination to backup buffer
10199 // Always executed before first frame and only once.
10200 BackupBuffer.Canvas.CopyRect(BackupBuffer.Canvas.ClipRect, FCanvas, FRect);
10201 FrameBuffer := TBitmap.Create;
10202 FrameBuffer.Height := FRect.Bottom-FRect.Top;
10203 FrameBuffer.Width := FRect.Right-FRect.Left;
10204 FrameBuffer.Canvas.CopyMode := cmSrcCopy;
10205 FrameBuffer.Canvas.Brush.Color := BackgroundColor;
10206 FrameBuffer.Canvas.Brush.Style := bsSolid;
10207 {$IFDEF DEBUG}
10208 FrameBuffer.Canvas.Brush.Color := clBlack;
10209 FrameBuffer.Canvas.Brush.Style := bsDiagCross;
10210 {$ENDIF}
10211 end;
10212 end;
10213
10214 destructor TGIFPainter.Destroy;
10215 begin
10216 // OnTerminate isn't called if we are running in main thread, so we must call
10217 // it manually
10218 if not(goAsync in DrawOptions) then
10219 DoOnTerminate(self);
10220 // Reraise any exptions that were eaten in the Execute method
10221 if (ExceptObject <> nil) then
10222 raise ExceptObject at ExceptAddress;
10223 inherited Destroy;
10224 end;
10225
10226 procedure TGIFPainter.SetAnimationSpeed(Value: integer);
10227 begin
10228 if (Value < 0) then
10229 Value := 0
10230 else if (Value > 1000) then
10231 Value := 1000;
10232 if (Value <> FAnimationSpeed) then
10233 begin
10234 FAnimationSpeed := Value;
10235 // Signal WaitForSingleObject delay to abort
10236 if (FEventHandle <> 0) then
10237 SetEvent(FEventHandle)
10238 else
10239 DoRestart := True;
10240 end;
10241 end;
10242
10243 procedure TGIFPainter.SetActiveImage(const Value: integer);
10244 begin
10245 if (Value >= 0) and (Value < FImage.Images.Count) then
10246 FActiveImage := Value;
10247 end;
10248
10249 // Conditional Synchronize
10250 procedure TGIFPainter.DoSynchronize(Method: TThreadMethod);
10251 begin
10252 if (Terminated) then
10253 exit;
10254 if (goAsync in FDrawOptions) then
10255 // Execute Synchronized if requested...
10256 Synchronize(Method)
10257 else
10258 // ...Otherwise just execute in current thread (probably main thread)
10259 Method;
10260 end;
10261
10262 // Delete frame buffers - Executed in main thread
10263 procedure TGIFPainter.DoOnTerminate(Sender: TObject);
10264 begin
10265 // It shouldn't really be nescessary to protect PainterRef in this manner
10266 // since we are running in the main thread at this point, but I'm a little
10267 // paranoid about the way PainterRef is being used...
10268 if Image <> nil then // 2001.02.23
10269 begin // 2001.02.23
10270 with Image.Painters.LockList do
10271 try
10272 // Zap pointer to self and remove from painter list
10273 if (PainterRef <> nil) and (PainterRef^ = self) then
10274 PainterRef^ := nil;
10275 finally
10276 Image.Painters.UnLockList;
10277 end;
10278 Image.Painters.Remove(self);
10279 FImage := nil;
10280 end; // 2001.02.23
10281
10282 // Free buffers
10283 if (BackupBuffer <> nil) then
10284 BackupBuffer.Free;
10285 if (FrameBuffer <> nil) then
10286 FrameBuffer.Free;
10287 if (Background <> nil) then
10288 Background.Free;
10289
10290 // Delete event handle
10291 if (FEventHandle <> 0) then
10292 CloseHandle(FEventHandle);
10293 end;
10294
10295 // Event "dispatcher" - Executed in main thread
10296 procedure TGIFPainter.DoEvent;
10297 begin
10298 if (Assigned(FEvent)) then
10299 FEvent(self);
10300 end;
10301
10302 // Non-buffered paint - Executed in main thread
10303 procedure TGIFPainter.DoPaint;
10304 begin
10305 FImage.Images[ActiveImage].Draw(FCanvas, FRect, (goTransparent in FDrawOptions),
10306 (goTile in FDrawOptions));
10307 FStarted := True;
10308 end;
10309
10310 // Buffered paint - Executed in main thread
10311 procedure TGIFPainter.DoPaintFrame;
10312 var
10313 DrawDestination : TCanvas;
10314 DrawRect : TRect;
10315 DoStep2 ,
10316 DoStep3 ,
10317 DoStep5 ,
10318 DoStep6 : boolean;
10319 SavePal ,
10320 SourcePal : HPALETTE;
10321
10322 procedure ClearBackup;
10323 var
10324 r ,
10325 Tile : TRect;
10326 FrameTop ,
10327 FrameHeight : integer;
10328 ImageWidth ,
10329 ImageHeight : integer;
10330 begin
10331
10332 if (goTransparent in FDrawOptions) then
10333 begin
10334 // If the frame is transparent, we must remove it by copying the
10335 // background buffer over it
10336 if (goTile in FDrawOptions) then
10337 begin
10338 FrameTop := FImage.Images[ActiveImage].Top;
10339 FrameHeight := FImage.Images[ActiveImage].Height;
10340 ImageWidth := FImage.Width;
10341 ImageHeight := FImage.Height;
10342
10343 Tile.Left := FRect.Left + FImage.Images[ActiveImage].Left;
10344 Tile.Right := Tile.Left + FImage.Images[ActiveImage].Width;
10345 while (Tile.Left < FRect.Right) do
10346 begin
10347 Tile.Top := FRect.Top + FrameTop;
10348 Tile.Bottom := Tile.Top + FrameHeight;
10349 while (Tile.Top < FRect.Bottom) do
10350 begin
10351 BackupBuffer.Canvas.CopyRect(Tile, Background.Canvas, Tile);
10352 Tile.Top := Tile.Top + ImageHeight;
10353 Tile.Bottom := Tile.Bottom + ImageHeight;
10354 end;
10355 Tile.Left := Tile.Left + ImageWidth;
10356 Tile.Right := Tile.Right + ImageWidth;
10357 end;
10358 end else
10359 begin
10360 r := FImage.Images[ActiveImage].ScaleRect(BackupBuffer.Canvas.ClipRect);
10361 BackupBuffer.Canvas.CopyRect(r, Background.Canvas, r)
10362 end;
10363 end else
10364 begin
10365 // If the frame isn't transparent, we just clear the area covered by
10366 // it to the background color.
10367 // Tile the background unless the frame covers all of the image
10368 if (goTile in FDrawOptions) and
10369 ((FImage.Width <> FImage.Images[ActiveImage].Width) and
10370 (FImage.height <> FImage.Images[ActiveImage].Height)) then
10371 begin
10372 FrameTop := FImage.Images[ActiveImage].Top;
10373 FrameHeight := FImage.Images[ActiveImage].Height;
10374 ImageWidth := FImage.Width;
10375 ImageHeight := FImage.Height;
10376 // ***FIXME*** I don't think this does any difference
10377 BackupBuffer.Canvas.Brush.Color := FImage.DrawBackgroundColor;
10378
10379 Tile.Left := FRect.Left + FImage.Images[ActiveImage].Left;
10380 Tile.Right := Tile.Left + FImage.Images[ActiveImage].Width;
10381 while (Tile.Left < FRect.Right) do
10382 begin
10383 Tile.Top := FRect.Top + FrameTop;
10384 Tile.Bottom := Tile.Top + FrameHeight;
10385 while (Tile.Top < FRect.Bottom) do
10386 begin
10387 BackupBuffer.Canvas.FillRect(Tile);
10388
10389 Tile.Top := Tile.Top + ImageHeight;
10390 Tile.Bottom := Tile.Bottom + ImageHeight;
10391 end;
10392 Tile.Left := Tile.Left + ImageWidth;
10393 Tile.Right := Tile.Right + ImageWidth;
10394 end;
10395 end else
10396 BackupBuffer.Canvas.FillRect(FImage.Images[ActiveImage].ScaleRect(FRect));
10397 end;
10398 end;
10399
10400 begin
10401 if (goValidateCanvas in FDrawOptions) then
10402 if (GetObjectType(ValidateDC) <> OBJ_DC) then
10403 begin
10404 Terminate;
10405 exit;
10406 end;
10407
10408 DrawDestination := nil;
10409 DoStep2 := (goClearOnLoop in FDrawOptions) and (FActiveImage = 0);
10410 DoStep3 := False;
10411 DoStep5 := False;
10412 DoStep6 := False;
10413 {
10414 Disposal mode algorithm:
10415
10416 Step 1: Copy destination to backup buffer
10417 Always executed before first frame and only once.
10418 Done in constructor.
10419 Step 2: Clear previous frame (implementation is same as step 6)
10420 Done implicitly by implementation.
10421 Only done explicitly on first frame if goClearOnLoop option is set.
10422 Step 3: Copy backup buffer to frame buffer
10423 Step 4: Draw frame
10424 Step 5: Copy buffer to destination
10425 Step 6: Clear frame from backup buffer
10426 +------------+------------------+---------------------+------------------------+
10427 |New \ Old | dmNone | dmBackground | dmPrevious |
10428 +------------+------------------+---------------------+------------------------+
10429 |dmNone | | | |
10430 | |4. Paint on backup|4. Paint on backup |4. Paint on backup |
10431 | |5. Restore |5. Restore |5. Restore |
10432 +------------+------------------+---------------------+------------------------+
10433 |dmBackground| | | |
10434 | |4. Paint on backup|4. Paint on backup |4. Paint on backup |
10435 | |5. Restore |5. Restore |5. Restore |
10436 | |6. Clear backup |6. Clear backup |6. Clear backup |
10437 +------------+------------------+---------------------+------------------------+
10438 |dmPrevious | | | |
10439 | | |3. Copy backup to buf|3. Copy backup to buf |
10440 | |4. Paint on dest |4. Paint on buf |4. Paint on buf |
10441 | | |5. Copy buf to dest |5. Copy buf to dest |
10442 +------------+------------------+---------------------+------------------------+
10443 }
10444 case (Disposal) of
10445 dmNone, dmNoDisposal:
10446 begin
10447 DrawDestination := BackupBuffer.Canvas;
10448 DrawRect := BackupBuffer.Canvas.ClipRect;
10449 DoStep5 := True;
10450 end;
10451 dmBackground:
10452 begin
10453 DrawDestination := BackupBuffer.Canvas;
10454 DrawRect := BackupBuffer.Canvas.ClipRect;
10455 DoStep5 := True;
10456 DoStep6 := True;
10457 end;
10458 dmPrevious:
10459 case (OldDisposal) of
10460 dmNone, dmNoDisposal:
10461 begin
10462 DrawDestination := FCanvas;
10463 DrawRect := FRect;
10464 end;
10465 dmBackground, dmPrevious:
10466 begin
10467 DrawDestination := FrameBuffer.Canvas;
10468 DrawRect := FrameBuffer.Canvas.ClipRect;
10469 DoStep3 := True;
10470 DoStep5 := True;
10471 end;
10472 end;
10473 end;
10474
10475 // Find source palette
10476 SourcePal := FImage.Images[ActiveImage].Palette;
10477 if (SourcePal = 0) then
10478 SourcePal := SystemPalette16; // This should never happen
10479
10480 SavePal := SelectPalette(DrawDestination.Handle, SourcePal, False);
10481 RealizePalette(DrawDestination.Handle);
10482
10483 // Step 2: Clear previous frame
10484 if (DoStep2) then
10485 ClearBackup;
10486
10487 // Step 3: Copy backup buffer to frame buffer
10488 if (DoStep3) then
10489 FrameBuffer.Canvas.CopyRect(FrameBuffer.Canvas.ClipRect,
10490 BackupBuffer.Canvas, BackupBuffer.Canvas.ClipRect);
10491
10492 // Step 4: Draw frame
10493 if (DrawDestination <> nil) then
10494 FImage.Images[ActiveImage].Draw(DrawDestination, DrawRect,
10495 (goTransparent in FDrawOptions), (goTile in FDrawOptions));
10496
10497 // Step 5: Copy buffer to destination
10498 if (DoStep5) then
10499 begin
10500 FCanvas.CopyMode := cmSrcCopy;
10501 FCanvas.CopyRect(FRect, DrawDestination, DrawRect);
10502 end;
10503
10504 if (SavePal <> 0) then
10505 SelectPalette(DrawDestination.Handle, SavePal, False);
10506
10507 // Step 6: Clear frame from backup buffer
10508 if (DoStep6) then
10509 ClearBackup;
10510
10511 FStarted := True;
10512 end;
10513
10514 // Prefetch bitmap
10515 // Used to force the GIF image to be rendered as a bitmap
10516 {$ifdef SERIALIZE_RENDER}
10517 procedure TGIFPainter.PrefetchBitmap;
10518 begin
10519 // Touch current bitmap to force bitmap to be rendered
10520 if not((FImage.Images[ActiveImage].Empty) or (FImage.Images[ActiveImage].HasBitmap)) then
10521 FImage.Images[ActiveImage].Bitmap;
10522 end;
10523 {$endif}
10524
10525 // Main thread execution loop - This is where it all happens...
10526 procedure TGIFPainter.Execute;
10527 var
10528 i : integer;
10529 LoopCount ,
10530 LoopPoint : integer;
10531 Looping : boolean;
10532 Ext : TGIFExtension;
10533 Msg : TMsg;
10534 Delay ,
10535 OldDelay ,
10536 DelayUsed : longInt;
10537 DelayStart ,
10538 NewDelayStart : DWORD;
10539
10540 procedure FireEvent(Event: TNotifyEvent);
10541 begin
10542 if not(Assigned(Event)) then
10543 exit;
10544 FEvent := Event;
10545 try
10546 DoSynchronize(DoEvent);
10547 finally
10548 FEvent := nil;
10549 end;
10550 end;
10551
10552 begin
10553 {
10554 Disposal:
10555 dmNone: Same as dmNodisposal
10556 dmNoDisposal: Do not dispose
10557 dmBackground: Clear with background color *)
10558 dmPrevious: Previous image
10559 *) Note: Background color should either be a BROWSER SPECIFIED Background
10560 color (DrawBackgroundColor) or the background image if any frames are
10561 transparent.
10562 }
10563 try
10564 try
10565 if (goValidateCanvas in FDrawOptions) then
10566 ValidateDC := FCanvas.Handle;
10567 DoRestart := True;
10568
10569 // Loop to restart paint
10570 while (DoRestart) and not(Terminated) do
10571 begin
10572 FActiveImage := 0;
10573 // Fire OnStartPaint event
10574 // Note: ActiveImage may be altered by the event handler
10575 FireEvent(FOnStartPaint);
10576
10577 FStarted := False;
10578 DoRestart := False;
10579 LoopCount := 1;
10580 LoopPoint := FActiveImage;
10581 Looping := False;
10582 if (goAsync in DrawOptions) then
10583 Delay := 0
10584 else
10585 Delay := 1; // Dummy to process messages
10586 OldDisposal := dmNoDisposal;
10587 // Fetch delay start time
10588 DelayStart := timeGetTime;
10589 OldDelay := 0;
10590
10591 // Loop to loop - duh!
10592 while ((LoopCount <> 0) or (goLoopContinously in DrawOptions)) and
10593 not(Terminated or DoRestart) do
10594 begin
10595 FActiveImage := LoopPoint;
10596
10597 // Fire OnLoopPaint event
10598 // Note: ActiveImage may be altered by the event handler
10599 if (FStarted) then
10600 FireEvent(FOnLoop);
10601
10602 // Loop to animate
10603 while (ActiveImage < FImage.Images.Count) and not(Terminated or DoRestart) do
10604 begin
10605 // Ignore empty images
10606 if (FImage.Images[ActiveImage].Empty) then
10607 break;
10608 // Delay from previous image
10609 if (Delay > 0) then
10610 begin
10611 // Prefetch frame bitmap
10612 {$ifdef SERIALIZE_RENDER}
10613 DoSynchronize(PrefetchBitmap);
10614 {$else}
10615 FImage.Images[ActiveImage].Bitmap;
10616 {$endif}
10617
10618 // Calculate inter frame delay
10619 NewDelayStart := timeGetTime;
10620 if (FAnimationSpeed > 0) then
10621 begin
10622 // Calculate number of mS used in prefetch and display
10623 try
10624 DelayUsed := integer(NewDelayStart-DelayStart)-OldDelay;
10625 // Prevent feedback oscillations caused by over/undercompensation.
10626 DelayUsed := DelayUsed DIV 2;
10627 // Convert delay value to mS and...
10628 // ...Adjust for time already spent converting GIF to bitmap and...
10629 // ...Adjust for Animation Speed factor.
10630 Delay := MulDiv(Delay * GIFDelayExp - DelayUsed, 100, FAnimationSpeed);
10631 OldDelay := Delay;
10632 except
10633 Delay := GIFMaximumDelay * GIFDelayExp;
10634 OldDelay := 0;
10635 end;
10636 end else
10637 begin
10638 if (goAsync in DrawOptions) then
10639 Delay := longInt(INFINITE)
10640 else
10641 Delay := GIFMaximumDelay * GIFDelayExp;
10642 end;
10643 // Fetch delay start time
10644 DelayStart := NewDelayStart;
10645
10646 // Sleep in one chunk if we are running in a thread
10647 if (goAsync in DrawOptions) then
10648 begin
10649 // Use of WaitForSingleObject allows TGIFPainter.Stop to wake us up
10650 if (Delay > 0) or (FAnimationSpeed = 0) then
10651 begin
10652 if (WaitForSingleObject(FEventHandle, DWORD(Delay)) <> WAIT_TIMEOUT) then
10653 begin
10654 // Don't use interframe delay feedback adjustment if delay
10655 // were prematurely aborted (e.g. because the animation
10656 // speed were changed)
10657 OldDelay := 0;
10658 DelayStart := longInt(timeGetTime);
10659 end;
10660 end;
10661 end else
10662 begin
10663 if (Delay <= 0) then
10664 Delay := 1;
10665 // Fetch start time
10666 NewDelayStart := timeGetTime;
10667 // If we are not running in a thread we Sleep in small chunks
10668 // and give the user a chance to abort
10669 while (Delay > 0) and not(Terminated or DoRestart) do
10670 begin
10671 if (Delay < 100) then
10672 Sleep(Delay)
10673 else
10674 Sleep(100);
10675 // Calculate number of mS delayed in this chunk
10676 DelayUsed := integer(timeGetTime - NewDelayStart);
10677 dec(Delay, DelayUsed);
10678 // Reset start time for chunk
10679 NewDelaySTart := timeGetTime;
10680 // Application.ProcessMessages wannabe
10681 while (not(Terminated or DoRestart)) and
10682 (PeekMessage(Msg, 0, 0, 0, PM_REMOVE)) do
10683 begin
10684 if (Msg.Message <> WM_QUIT) then
10685 begin
10686 TranslateMessage(Msg);
10687 DispatchMessage(Msg);
10688 end else
10689 begin
10690 // Put WM_QUIT back in queue and get out of here fast
10691 PostQuitMessage(Msg.WParam);
10692 Terminate;
10693 end;
10694 end;
10695 end;
10696 end;
10697 end else
10698 Sleep(0); // Yield
10699 if (Terminated) then
10700 break;
10701
10702 // Fire OnPaint event
10703 // Note: ActiveImage may be altered by the event handler
10704 FireEvent(FOnPaint);
10705 if (Terminated) then
10706 break;
10707
10708 // Pre-draw processing of extensions
10709 Disposal := dmNoDisposal;
10710 for i := 0 to FImage.Images[ActiveImage].Extensions.Count-1 do
10711 begin
10712 Ext := FImage.Images[ActiveImage].Extensions[i];
10713 if (Ext is TGIFAppExtNSLoop) then
10714 begin
10715 // Recursive loops not supported (or defined)
10716 if (Looping) then
10717 continue;
10718 Looping := True;
10719 LoopCount := TGIFAppExtNSLoop(Ext).Loops;
10720 if ((LoopCount = 0) or (goLoopContinously in DrawOptions)) and
10721 (goAsync in DrawOptions) then
10722 LoopCount := -1; // Infinite if running in separate thread
10723 {$IFNDEF STRICT_MOZILLA}
10724 // Loop from this image and on
10725 // Note: This is not standard behavior
10726 LoopPoint := ActiveImage;
10727 {$ENDIF}
10728 end else
10729 if (Ext is TGIFGraphicControlExtension) then
10730 Disposal := TGIFGraphicControlExtension(Ext).Disposal;
10731 end;
10732
10733 // Paint the image
10734 if (BackupBuffer <> nil) then
10735 DoSynchronize(DoPaintFrame)
10736 else
10737 DoSynchronize(DoPaint);
10738 OldDisposal := Disposal;
10739
10740 if (Terminated) then
10741 break;
10742
10743 Delay := GIFDefaultDelay; // Default delay
10744 // Post-draw processing of extensions
10745 if (FImage.Images[ActiveImage].GraphicControlExtension <> nil) then
10746 if (FImage.Images[ActiveImage].GraphicControlExtension.Delay > 0) then
10747 begin
10748 Delay := FImage.Images[ActiveImage].GraphicControlExtension.Delay;
10749
10750 // Enforce minimum animation delay in compliance with Mozilla
10751 if (Delay < GIFMinimumDelay) then
10752 Delay := GIFMinimumDelay;
10753
10754 // Do not delay more than 10 seconds if running in main thread
10755 if (Delay > GIFMaximumDelay) and not(goAsync in DrawOptions) then
10756 Delay := GIFMaximumDelay; // Max 10 seconds
10757 end;
10758 // Fire OnAfterPaint event
10759 // Note: ActiveImage may be altered by the event handler
10760 i := FActiveImage;
10761 FireEvent(FOnAfterPaint);
10762 if (Terminated) then
10763 break;
10764 // Don't increment frame counter if event handler modified
10765 // current frame
10766 if (FActiveImage = i) then
10767 Inc(FActiveImage);
10768 // Nothing more to do unless we are animating
10769 if not(goAnimate in DrawOptions) then
10770 break;
10771 end;
10772
10773 if (LoopCount > 0) then
10774 Dec(LoopCount);
10775 if ([goAnimate, goLoop] * DrawOptions <> [goAnimate, goLoop]) then
10776 break;
10777 end;
10778 if (Terminated) then // 2001.07.23
10779 break; // 2001.07.23
10780 end;
10781 FActiveImage := -1;
10782 // Fire OnEndPaint event
10783 FireEvent(FOnEndPaint);
10784 finally
10785 // If we are running in the main thread we will have to zap our self
10786 if not(goAsync in DrawOptions) then
10787 Free;
10788 end;
10789 except
10790 on E: Exception do
10791 begin
10792 // Eat exception and terminate thread...
10793 // If we allow the exception to abort the thread at this point, the
10794 // application will hang since the thread destructor will never be called
10795 // and the application will wait forever for the thread to die!
10796 Terminate;
10797 // Clone exception
10798 ExceptObject := E.Create(E.Message);
10799 ExceptAddress := ExceptAddr;
10800 end;
10801 end;
10802 end;
10803
10804 procedure TGIFPainter.Start;
10805 begin
10806 if (goAsync in FDrawOptions) then
10807 Resume;
10808 end;
10809
10810 procedure TGIFPainter.Stop;
10811 begin
10812 Terminate;
10813 if (goAsync in FDrawOptions) then
10814 begin
10815 // Signal WaitForSingleObject delay to abort
10816 if (FEventHandle <> 0) then
10817 SetEvent(FEventHandle);
10818 Priority := tpNormal;
10819 if (Suspended) then
10820 Resume; // Must be running before we can terminate
10821 end;
10822 end;
10823
10824 procedure TGIFPainter.Restart;
10825 begin
10826 DoRestart := True;
10827 if (Suspended) and (goAsync in FDrawOptions) then
10828 Resume; // Must be running before we can terminate
10829 end;
10830
10831 ////////////////////////////////////////////////////////////////////////////////
10832 //
10833 // TColorMapOptimizer
10834 //
10835 ////////////////////////////////////////////////////////////////////////////////
10836 // Used by TGIFImage to optimize local color maps to a single global color map.
10837 // The following algorithm is used:
10838 // 1) Build a histogram for each image
10839 // 2) Merge histograms
10840 // 3) Sum equal colors and adjust max # of colors
10841 // 4) Map entries > max to entries <= 256
10842 // 5) Build new color map
10843 // 6) Map images to new color map
10844 ////////////////////////////////////////////////////////////////////////////////
10845
10846 type
10847
10848 POptimizeEntry = ^TOptimizeEntry;
10849 TColorRec = record
10850 case byte of
10851 0: (Value: integer);
10852 1: (Color: TGIFColor);
10853 2: (SameAs: POptimizeEntry); // Used if TOptimizeEntry.Count = 0
10854 end;
10855
10856 TOptimizeEntry = record
10857 Count : integer; // Usage count
10858 OldIndex : integer; // Color OldIndex
10859 NewIndex : integer; // NewIndex color OldIndex
10860 Color : TColorRec; // Color value
10861 end;
10862
10863 TOptimizeEntries = array[0..255] of TOptimizeEntry;
10864 POptimizeEntries = ^TOptimizeEntries;
10865
10866 THistogram = class(TObject)
10867 private
10868 PHistogram : POptimizeEntries;
10869 FCount : integer;
10870 FColorMap : TGIFColorMap;
10871 FList : TList;
10872 FImages : TList;
10873 public
10874 constructor Create(AColorMap: TGIFColorMap);
10875 destructor Destroy; override;
ProcessSubImagenull10876 function ProcessSubImage(Image: TGIFSubImage): boolean;
Prunenull10877 function Prune: integer;
10878 procedure MapImages(UseTransparency: boolean; NewTransparentColorIndex: byte);
10879 property Count: integer read FCount;
10880 property ColorMap: TGIFColorMap read FColorMap;
10881 property List: TList read FList;
10882 end;
10883
10884 TColorMapOptimizer = class(TObject)
10885 private
10886 FImage : TGIFImage;
10887 FHistogramList : TList;
10888 FHistogram : TList;
10889 FColorMap : TColorMap;
10890 FFinalCount : integer;
10891 FUseTransparency : boolean;
10892 FNewTransparentColorIndex: byte;
10893 protected
10894 procedure ProcessImage;
10895 procedure MergeColors;
10896 procedure MapColors;
10897 procedure ReplaceColorMaps;
10898 public
10899 constructor Create(AImage: TGIFImage);
10900 destructor Destroy; override;
10901 procedure Optimize;
10902 end;
10903
CompareColornull10904 function CompareColor(Item1, Item2: Pointer): integer;
10905 begin
10906 Result := POptimizeEntry(Item2)^.Color.Value - POptimizeEntry(Item1)^.Color.Value;
10907 end;
10908
CompareCountnull10909 function CompareCount(Item1, Item2: Pointer): integer;
10910 begin
10911 Result := POptimizeEntry(Item2)^.Count - POptimizeEntry(Item1)^.Count;
10912 end;
10913
10914 constructor THistogram.Create(AColorMap: TGIFColorMap);
10915 var
10916 i : integer;
10917 begin
10918 inherited Create;
10919
10920 FCount := AColorMap.Count;
10921 FColorMap := AColorMap;
10922
10923 FImages := TList.Create;
10924
10925 // Allocate memory for histogram
10926 GetMem(PHistogram, FCount * sizeof(TOptimizeEntry));
10927 FList := TList.Create;
10928
10929 FList.Capacity := FCount;
10930
10931 // Move data to histogram and initialize
10932 for i := 0 to FCount-1 do
10933 with PHistogram^[i] do
10934 begin
10935 FList.Add(@PHistogram^[i]);
10936 OldIndex := i;
10937 Count := 0;
10938 Color.Value := 0;
10939 Color.Color := AColorMap.Data^[i];
10940 NewIndex := 256; // Used to signal unmapped
10941 end;
10942 end;
10943
10944 destructor THistogram.Destroy;
10945 begin
10946 FImages.Free;
10947 FList.Free;
10948 FreeMem(PHistogram);
10949 inherited Destroy;
10950 end;
10951
10952 //: Build a color histogram
ProcessSubImagenull10953 function THistogram.ProcessSubImage(Image: TGIFSubImage): boolean;
10954 var
10955 Size : integer;
10956 Pixel : PChar;
10957 IsTransparent ,
10958 WasTransparent : boolean;
10959 OldTransparentColorIndex: byte;
10960 begin
10961 Result := False;
10962 if (Image.Empty) then
10963 exit;
10964
10965 FImages.Add(Image);
10966
10967 Pixel := Image.data;
10968 Size := Image.Width * Image.Height;
10969
10970 IsTransparent := Image.Transparent;
10971 if (IsTransparent) then
10972 OldTransparentColorIndex := Image.GraphicControlExtension.TransparentColorIndex
10973 else
10974 OldTransparentColorIndex := 0; // To avoid compiler warning
10975 WasTransparent := False;
10976
10977 (*
10978 ** Sum up usage count for each color
10979 *)
10980 while (Size > 0) do
10981 begin
10982 // Ignore transparent pixels
10983 if (not IsTransparent) or (ord(Pixel^) <> OldTransparentColorIndex) then
10984 begin
10985 // Check for invalid color index
10986 if (ord(Pixel^) >= FCount) then
10987 begin
10988 Pixel^ := #0; // ***FIXME*** Isn't this an error condition?
10989 Image.Warning(gsWarning, sInvalidColor);
10990 end;
10991
10992 with PHistogram^[ord(Pixel^)] do
10993 begin
10994 // Stop if any color reaches the max count
10995 if (Count = high(integer)) then
10996 break;
10997 inc(Count);
10998 end;
10999 end else
11000 WasTransparent := WasTransparent or IsTransparent;
11001 inc(Pixel);
11002 dec(Size);
11003 end;
11004
11005 (*
11006 ** Clear frames transparency flag if the frame claimed to
11007 ** be transparent, but wasn't
11008 *)
11009 if (IsTransparent and not WasTransparent) then
11010 begin
11011 Image.GraphicControlExtension.TransparentColorIndex := 0;
11012 Image.GraphicControlExtension.Transparent := False;
11013 end;
11014
11015 Result := WasTransparent;
11016 end;
11017
11018 //: Removed unused color entries from the histogram
THistogram.Prunenull11019 function THistogram.Prune: integer;
11020 var
11021 i, j : integer;
11022 begin
11023 (*
11024 ** Sort by usage count
11025 *)
11026 FList.Sort(CompareCount);
11027
11028 (*
11029 ** Determine number of used colors
11030 *)
11031 for i := 0 to FCount-1 do
11032 // Find first unused color entry
11033 if (POptimizeEntry(FList[i])^.Count = 0) then
11034 begin
11035 // Zap unused colors
11036 for j := i to FCount-1 do
11037 POptimizeEntry(FList[j])^.Count := -1; // Use -1 to signal unused entry
11038 // Remove unused entries
11039 FCount := i;
11040 FList.Count := FCount;
11041 break;
11042 end;
11043
11044 Result := FCount;
11045 end;
11046
11047 //: Convert images from old color map to new color map
11048 procedure THistogram.MapImages(UseTransparency: boolean; NewTransparentColorIndex: byte);
11049 var
11050 i : integer;
11051 Size : integer;
11052 Pixel : PChar;
11053 ReverseMap : array[byte] of byte;
11054 IsTransparent : boolean;
11055 OldTransparentColorIndex: byte;
11056 begin
11057 (*
11058 ** Build NewIndex map
11059 *)
11060 for i := 0 to List.Count-1 do
11061 ReverseMap[POptimizeEntry(List[i])^.OldIndex] := POptimizeEntry(List[i])^.NewIndex;
11062
11063 (*
11064 ** Reorder all images using this color map
11065 *)
11066 for i := 0 to FImages.Count-1 do
11067 with TGIFSubImage(FImages[i]) do
11068 begin
11069 Pixel := Data;
11070 Size := Width * Height;
11071
11072 // Determine frame transparency
11073 IsTransparent := (Transparent) and (UseTransparency);
11074 if (IsTransparent) then
11075 begin
11076 OldTransparentColorIndex := GraphicControlExtension.TransparentColorIndex;
11077 // Map transparent color
11078 GraphicControlExtension.TransparentColorIndex := NewTransparentColorIndex;
11079 end else
11080 OldTransparentColorIndex := 0; // To avoid compiler warning
11081
11082 // Map all pixels to new color map
11083 while (Size > 0) do
11084 begin
11085 // Map transparent pixels to the new transparent color index and...
11086 if (IsTransparent) and (ord(Pixel^) = OldTransparentColorIndex) then
11087 Pixel^ := char(NewTransparentColorIndex)
11088 else
11089 // ... all other pixels to their new color index
11090 Pixel^ := char(ReverseMap[ord(Pixel^)]);
11091 dec(size);
11092 inc(Pixel);
11093 end;
11094 end;
11095 end;
11096
11097 constructor TColorMapOptimizer.Create(AImage: TGIFImage);
11098 begin
11099 inherited Create;
11100 FImage := AImage;
11101 FHistogramList := TList.Create;
11102 FHistogram := TList.Create;
11103 end;
11104
11105 destructor TColorMapOptimizer.Destroy;
11106 var
11107 i : integer;
11108 begin
11109 FHistogram.Free;
11110
11111 for i := FHistogramList.Count-1 downto 0 do
11112 THistogram(FHistogramList[i]).Free;
11113 FHistogramList.Free;
11114
11115 inherited Destroy;
11116 end;
11117
11118 procedure TColorMapOptimizer.ProcessImage;
11119 var
11120 Hist : THistogram;
11121 i : integer;
11122 ProcessedImage : boolean;
11123 begin
11124 FUseTransparency := False;
11125 (*
11126 ** First process images using global color map
11127 *)
11128 if (FImage.GlobalColorMap.Count > 0) then
11129 begin
11130 Hist := THistogram.Create(FImage.GlobalColorMap);
11131 ProcessedImage := False;
11132 // Process all images that are using the global color map
11133 for i := 0 to FImage.Images.Count-1 do
11134 if (FImage.Images[i].ColorMap.Count = 0) and (not FImage.Images[i].Empty) then
11135 begin
11136 ProcessedImage := True;
11137 // Note: Do not change order of statements. Shortcircuit evaluation not desired!
11138 FUseTransparency := Hist.ProcessSubImage(FImage.Images[i]) or FUseTransparency;
11139 end;
11140 // Keep the histogram if any images used the global color map...
11141 if (ProcessedImage) then
11142 FHistogramList.Add(Hist)
11143 else // ... otherwise delete it
11144 Hist.Free;
11145 end;
11146
11147 (*
11148 ** Next process images that have a local color map
11149 *)
11150 for i := 0 to FImage.Images.Count-1 do
11151 if (FImage.Images[i].ColorMap.Count > 0) and (not FImage.Images[i].Empty) then
11152 begin
11153 Hist := THistogram.Create(FImage.Images[i].ColorMap);
11154 FHistogramList.Add(Hist);
11155 // Note: Do not change order of statements. Shortcircuit evaluation not desired!
11156 FUseTransparency := Hist.ProcessSubImage(FImage.Images[i]) or FUseTransparency;
11157 end;
11158 end;
11159
11160 procedure TColorMapOptimizer.MergeColors;
11161 var
11162 Entry, SameEntry : POptimizeEntry;
11163 i : integer;
11164 begin
11165 (*
11166 ** Sort by color value
11167 *)
11168 FHistogram.Sort(CompareColor);
11169
11170 (*
11171 ** Merge same colors
11172 *)
11173 SameEntry := POptimizeEntry(FHistogram[0]);
11174 for i := 1 to FHistogram.Count-1 do
11175 begin
11176 Entry := POptimizeEntry(FHistogram[i]);
11177 ASSERT(Entry^.Count > 0, 'Unused entry exported from THistogram');
11178 if (Entry^.Color.Value = SameEntry^.Color.Value) then
11179 begin
11180 // Transfer usage count to first entry
11181 inc(SameEntry^.Count, Entry^.Count);
11182 Entry^.Count := 0; // Use 0 to signal merged entry
11183 Entry^.Color.SameAs := SameEntry; // Point to master
11184 end else
11185 SameEntry := Entry;
11186 end;
11187 end;
11188
11189 procedure TColorMapOptimizer.MapColors;
11190 var
11191 i, j : integer;
11192 Delta, BestDelta : integer;
11193 BestIndex : integer;
11194 MaxColors : integer;
11195 begin
11196 (*
11197 ** Sort by usage count
11198 *)
11199 FHistogram.Sort(CompareCount);
11200
11201 (*
11202 ** Handle transparency
11203 *)
11204 if (FUseTransparency) then
11205 MaxColors := 255
11206 else
11207 MaxColors := 256;
11208
11209 (*
11210 ** Determine number of colors used (max 256)
11211 *)
11212 FFinalCount := FHistogram.Count;
11213 for i := 0 to FFinalCount-1 do
11214 if (i >= MaxColors) or (POptimizeEntry(FHistogram[i])^.Count = 0) then
11215 begin
11216 FFinalCount := i;
11217 break;
11218 end;
11219
11220 (*
11221 ** Build color map and reverse map for final entries
11222 *)
11223 for i := 0 to FFinalCount-1 do
11224 begin
11225 POptimizeEntry(FHistogram[i])^.NewIndex := i;
11226 FColorMap[i] := POptimizeEntry(FHistogram[i])^.Color.Color;
11227 end;
11228
11229 (*
11230 ** Map colors > 256 to colors <= 256 and build NewIndex color map
11231 *)
11232 for i := FFinalCount to FHistogram.Count-1 do
11233 with POptimizeEntry(FHistogram[i])^ do
11234 begin
11235 // Entries with a usage count of -1 is unused
11236 ASSERT(Count <> -1, 'Internal error: Unused entry exported');
11237 // Entries with a usage count of 0 has been merged with another entry
11238 if (Count = 0) then
11239 begin
11240 // Use mapping of master entry
11241 ASSERT(Color.SameAs.NewIndex < 256, 'Internal error: Mapping to unmapped color');
11242 NewIndex := Color.SameAs.NewIndex;
11243 end else
11244 begin
11245 // Search for entry with nearest color value
11246 BestIndex := 0;
11247 BestDelta := 255*3;
11248 for j := 0 to FFinalCount-1 do
11249 begin
11250 Delta := ABS((POptimizeEntry(FHistogram[j])^.Color.Color.Red - Color.Color.Red) +
11251 (POptimizeEntry(FHistogram[j])^.Color.Color.Green - Color.Color.Green) +
11252 (POptimizeEntry(FHistogram[j])^.Color.Color.Blue - Color.Color.Blue));
11253 if (Delta < BestDelta) then
11254 begin
11255 BestDelta := Delta;
11256 BestIndex := j;
11257 end;
11258 end;
11259 NewIndex := POptimizeEntry(FHistogram[BestIndex])^.NewIndex;;
11260 end;
11261 end;
11262
11263 (*
11264 ** Add transparency color to new color map
11265 *)
11266 if (FUseTransparency) then
11267 begin
11268 FNewTransparentColorIndex := FFinalCount;
11269 FColorMap[FFinalCount].Red := 0;
11270 FColorMap[FFinalCount].Green := 0;
11271 FColorMap[FFinalCount].Blue := 0;
11272 inc(FFinalCount);
11273 end;
11274 end;
11275
11276 procedure TColorMapOptimizer.ReplaceColorMaps;
11277 var
11278 i : integer;
11279 begin
11280 // Zap all local color maps
11281 for i := 0 to FImage.Images.Count-1 do
11282 if (FImage.Images[i].ColorMap <> nil) then
11283 FImage.Images[i].ColorMap.Clear;
11284 // Store optimized global color map
11285 FImage.GlobalColorMap.ImportColorMap(FColorMap, FFinalCount);
11286 FImage.GlobalColorMap.Optimized := True;
11287 end;
11288
11289 procedure TColorMapOptimizer.Optimize;
11290 var
11291 Total : integer;
11292 i, j : integer;
11293 begin
11294 // Stop all painters during optimize...
11295 FImage.PaintStop;
11296 // ...and prevent any new from starting while we are doing our thing
11297 FImage.Painters.LockList;
11298 try
11299
11300 (*
11301 ** Process all sub images
11302 *)
11303 ProcessImage;
11304
11305 // Prune histograms and calculate total number of colors
11306 Total := 0;
11307 for i := 0 to FHistogramList.Count-1 do
11308 inc(Total, THistogram(FHistogramList[i]).Prune);
11309
11310 // Allocate global histogram
11311 FHistogram.Clear;
11312 FHistogram.Capacity := Total;
11313
11314 // Move data pointers from local histograms to global histogram
11315 for i := 0 to FHistogramList.Count-1 do
11316 with THistogram(FHistogramList[i]) do
11317 for j := 0 to Count-1 do
11318 begin
11319 ASSERT(POptimizeEntry(List[j])^.Count > 0, 'Unused entry exported from THistogram');
11320 FHistogram.Add(List[j]);
11321 end;
11322
11323 (*
11324 ** Merge same colors
11325 *)
11326 MergeColors;
11327
11328 (*
11329 ** Build color map and NewIndex map for final entries
11330 *)
11331 MapColors;
11332
11333 (*
11334 ** Replace local colormaps with global color map
11335 *)
11336 ReplaceColorMaps;
11337
11338 (*
11339 ** Process images for each color map
11340 *)
11341 for i := 0 to FHistogramList.Count-1 do
11342 THistogram(FHistogramList[i]).MapImages(FUseTransparency, FNewTransparentColorIndex);
11343
11344 (*
11345 ** Delete the frame's old bitmaps and palettes
11346 *)
11347 for i := 0 to FImage.Images.Count-1 do
11348 begin
11349 FImage.Images[i].HasBitmap := False;
11350 FImage.Images[i].Palette := 0;
11351 end;
11352
11353 finally
11354 FImage.Painters.UnlockList;
11355 end;
11356 end;
11357
11358 ////////////////////////////////////////////////////////////////////////////////
11359 //
11360 // TGIFImage
11361 //
11362 ////////////////////////////////////////////////////////////////////////////////
11363 constructor TGIFImage.Create;
11364 begin
11365 inherited Create;
11366 FImages := TGIFImageList.Create(self);
11367 FHeader := TGIFHeader.Create(self);
11368 FPainters := TThreadList.Create;
11369 FGlobalPalette := 0;
11370 // Load defaults
11371 FDrawOptions := GIFImageDefaultDrawOptions;
11372 ColorReduction := GIFImageDefaultColorReduction;
11373 FReductionBits := GIFImageDefaultColorReductionBits;
11374 FDitherMode := GIFImageDefaultDitherMode;
11375 FCompression := GIFImageDefaultCompression;
11376 FThreadPriority := GIFImageDefaultThreadPriority;
11377 FAnimationSpeed := GIFImageDefaultAnimationSpeed;
11378
11379 FDrawBackgroundColor := clNone;
11380 IsDrawing := False;
11381 IsInsideGetPalette := False;
11382 FForceFrame := -1; // 2004.03.09
11383 NewImage;
11384 end;
11385
11386 destructor TGIFImage.Destroy;
11387 var
11388 i : integer;
11389 begin
11390 PaintStop;
11391 with FPainters.LockList do
11392 try
11393 for i := Count-1 downto 0 do
11394 TGIFPainter(Items[i]).FImage := nil;
11395 finally
11396 FPainters.UnLockList;
11397 end;
11398
11399 Clear;
11400 FPainters.Free;
11401 FImages.Free;
11402 FHeader.Free;
11403 inherited Destroy;
11404 end;
11405
11406 procedure TGIFImage.Clear;
11407 begin
11408 PaintStop;
11409 FreeBitmap;
11410 FImages.Clear;
11411 FHeader.ColorMap.Clear;
11412 FHeader.Height := 0;
11413 FHeader.Width := 0;
11414 FHeader.Prepare;
11415 Palette := 0;
11416 end;
11417
11418 procedure TGIFImage.NewImage;
11419 begin
11420 Clear;
11421 end;
11422
GetVersionnull11423 function TGIFImage.GetVersion: TGIFVersion;
11424 var
11425 v : TGIFVersion;
11426 i : integer;
11427 begin
11428 Result := gvUnknown;
11429 for i := 0 to FImages.Count-1 do
11430 begin
11431 v := FImages[i].Version;
11432 if (v > Result) then
11433 Result := v;
11434 if (v >= high(TGIFVersion)) then
11435 break;
11436 end;
11437 end;
11438
TGIFImage.GetColorResolutionnull11439 function TGIFImage.GetColorResolution: integer;
11440 var
11441 i : integer;
11442 begin
11443 Result := FHeader.ColorResolution;
11444 for i := 0 to FImages.Count-1 do
11445 if (FImages[i].ColorResolution > Result) then
11446 Result := FImages[i].ColorResolution;
11447 end;
11448
GetBitsPerPixelnull11449 function TGIFImage.GetBitsPerPixel: integer;
11450 var
11451 i : integer;
11452 begin
11453 Result := FHeader.BitsPerPixel;
11454 for i := 0 to FImages.Count-1 do
11455 if (FImages[i].BitsPerPixel > Result) then
11456 Result := FImages[i].BitsPerPixel;
11457 end;
11458
TGIFImage.GetBackgroundColorIndexnull11459 function TGIFImage.GetBackgroundColorIndex: BYTE;
11460 begin
11461 Result := FHeader.BackgroundColorIndex;
11462 end;
11463
11464 procedure TGIFImage.SetBackgroundColorIndex(const Value: BYTE);
11465 begin
11466 FHeader.BackgroundColorIndex := Value;
11467 end;
11468
GetBackgroundColornull11469 function TGIFImage.GetBackgroundColor: TColor;
11470 begin
11471 Result := FHeader.BackgroundColor;
11472 end;
11473
11474 procedure TGIFImage.SetBackgroundColor(const Value: TColor);
11475 begin
11476 FHeader.BackgroundColor := Value;
11477 end;
11478
TGIFImage.GetAspectRationull11479 function TGIFImage.GetAspectRatio: BYTE;
11480 begin
11481 Result := FHeader.AspectRatio;
11482 end;
11483
11484 procedure TGIFImage.SetAspectRatio(const Value: BYTE);
11485 begin
11486 FHeader.AspectRatio := Value;
11487 end;
11488
11489 procedure TGIFImage.SetDrawOptions(Value: TGIFDrawOptions);
11490 begin
11491 if (FDrawOptions = Value) then
11492 exit;
11493
11494 if (DrawPainter <> nil) then
11495 DrawPainter.Stop;
11496
11497 FDrawOptions := Value;
11498 // Zap all bitmaps
11499 Pack;
11500 Changed(self);
11501 end;
11502
GetAnimatenull11503 function TGIFImage.GetAnimate: Boolean;
11504 begin // 2002.07.07
11505 Result:= goAnimate in DrawOptions;
11506 end;
11507
11508 procedure TGIFImage.SetAnimate(const Value: Boolean);
11509 begin // 2002.07.07
11510 if Value then
11511 DrawOptions:= DrawOptions + [goAnimate]
11512 else
11513 DrawOptions:= DrawOptions - [goAnimate];
11514 end;
11515
11516 procedure TGIFImage.SetForceFrame(const Value: Integer);
11517 begin // 2004.03.09
11518 FForceFrame := Value;
11519 Changed(Self);
11520 end;
11521
11522 procedure TGIFImage.SetAnimationSpeed(Value: integer);
11523 begin
11524 if (Value < 0) then
11525 Value := 0
11526 else if (Value > 1000) then
11527 Value := 1000;
11528 if (Value <> FAnimationSpeed) then
11529 begin
11530 FAnimationSpeed := Value;
11531 // Use the FPainters threadlist to protect FDrawPainter from being modified
11532 // by the thread while we mess with it
11533 with FPainters.LockList do
11534 try
11535 if (FDrawPainter <> nil) then
11536 FDrawPainter.AnimationSpeed := FAnimationSpeed;
11537 finally
11538 // Release the lock on FPainters to let paint thread kill itself
11539 FPainters.UnLockList;
11540 end;
11541 end;
11542 end;
11543
11544 procedure TGIFImage.SetReductionBits(Value: integer);
11545 begin
11546 if (Value < 3) or (Value > 8) then
11547 Error(sInvalidBitSize);
11548 FReductionBits := Value;
11549 end;
11550
11551 procedure TGIFImage.OptimizeColorMap;
11552 var
11553 ColorMapOptimizer : TColorMapOptimizer;
11554 begin
11555 ColorMapOptimizer := TColorMapOptimizer.Create(self);
11556 try
11557 ColorMapOptimizer.Optimize;
11558 finally
11559 ColorMapOptimizer.Free;
11560 end;
11561 end;
11562
11563 procedure TGIFImage.Optimize(Options: TGIFOptimizeOptions;
11564 ColorReduction: TColorReduction; DitherMode: TDitherMode;
11565 ReductionBits: integer);
11566 var
11567 i ,
11568 j : integer;
11569 Delay : integer;
11570 GCE : TGIFGraphicControlExtension;
11571 ThisRect ,
11572 NextRect ,
11573 MergeRect : TRect;
11574 Prog ,
11575 MaxProg : integer;
11576
Scannull11577 function Scan(Buf: PChar; Value: Byte; Count: integer): boolean; assembler;
11578 asm
11579 PUSH EDI
11580 MOV EDI, Buf
11581 MOV ECX, Count
11582 MOV AL, Value
11583 REPNE SCASB
11584 MOV EAX, False
11585 JNE @@1
11586 MOV EAX, True
11587 @@1:POP EDI
11588 end;
11589
11590 begin
11591 if (Empty) then
11592 exit;
11593 // Stop all painters during optimize...
11594 PaintStop;
11595 // ...and prevent any new from starting while we are doing our thing
11596 FPainters.LockList;
11597 try
11598 Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressOptimizing);
11599 try
11600
11601 Prog := 0;
11602 MaxProg := Images.Count*6;
11603
11604 // Sort color map by usage and remove unused entries
11605 if (ooColorMap in Options) then
11606 begin
11607 // Optimize global color map
11608 if (GlobalColorMap.Count > 0) then
11609 GlobalColorMap.Optimize;
11610 // Optimize local color maps
11611 for i := 0 to Images.Count-1 do
11612 begin
11613 inc(Prog);
11614 if (Images[i].ColorMap.Count > 0) then
11615 begin
11616 Images[i].ColorMap.Optimize;
11617 Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
11618 Rect(0,0,0,0), sProgressOptimizing);
11619 end;
11620 end;
11621 end;
11622
11623 // Remove passive elements, pass 1
11624 if (ooCleanup in Options) then
11625 begin
11626 // Check for transparency flag without any transparent pixels
11627 for i := 0 to Images.Count-1 do
11628 begin
11629 inc(Prog);
11630 if (Images[i].Transparent) then
11631 begin
11632 if not(Scan(Images[i].Data,
11633 Images[i].GraphicControlExtension.TransparentColorIndex,
11634 Images[i].DataSize)) then
11635 begin
11636 Images[i].GraphicControlExtension.Transparent := False;
11637 Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
11638 Rect(0,0,0,0), sProgressOptimizing);
11639 end;
11640 end;
11641 end;
11642
11643 // Change redundant disposal modes
11644 for i := 0 to Images.Count-2 do
11645 begin
11646 inc(Prog);
11647 if (Images[i].GraphicControlExtension <> nil) and
11648 (Images[i].GraphicControlExtension.Disposal in [dmPrevious, dmBackground]) and
11649 (not Images[i+1].Transparent) then
11650 begin
11651 ThisRect := Images[i].BoundsRect;
11652 NextRect := Images[i+1].BoundsRect;
11653 if (not IntersectRect(MergeRect, ThisRect, NextRect)) then
11654 continue;
11655 // If the next frame completely covers the current frame,
11656 // change the disposal mode to dmNone
11657 if (EqualRect(MergeRect, NextRect)) then
11658 Images[i].GraphicControlExtension.Disposal := dmNone;
11659 Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
11660 Rect(0,0,0,0), sProgressOptimizing);
11661 end;
11662 end;
11663 end else
11664 inc(Prog, 2*Images.Count);
11665
11666 // Merge layers of equal pixels (remove redundant pixels)
11667 if (ooMerge in Options) then
11668 begin
11669 // Merge from last to first to avoid intefering with merge
11670 for i := Images.Count-1 downto 1 do
11671 begin
11672 inc(Prog);
11673 j := i-1;
11674 // If the "previous" frames uses dmPrevious disposal mode, we must
11675 // instead merge with the frame before the previous
11676 while (j > 0) and
11677 ((Images[j].GraphicControlExtension <> nil) and
11678 (Images[j].GraphicControlExtension.Disposal = dmPrevious)) do
11679 dec(j);
11680 // Merge
11681 Images[i].Merge(Images[j]);
11682 Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
11683 Rect(0,0,0,0), sProgressOptimizing);
11684 end;
11685 end else
11686 inc(Prog, Images.Count);
11687
11688 // Crop transparent areas
11689 if (ooCrop in Options) then
11690 begin
11691 for i := Images.Count-1 downto 0 do
11692 begin
11693 inc(Prog);
11694 if (not Images[i].Empty) and (Images[i].Transparent) then
11695 begin
11696 // Remember frames delay in case frame is deleted
11697 Delay := Images[i].GraphicControlExtension.Delay;
11698 // Crop
11699 Images[i].Crop;
11700 // If the frame was completely transparent we remove it
11701 if (Images[i].Empty) then
11702 begin
11703 // Transfer delay to previous frame in case frame was deleted
11704 if (i > 0) and (Images[i-1].Transparent) then
11705 Images[i-1].GraphicControlExtension.Delay :=
11706 Images[i-1].GraphicControlExtension.Delay + Delay;
11707 Images.Delete(i);
11708 end;
11709 Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
11710 Rect(0,0,0,0), sProgressOptimizing);
11711 end;
11712 end;
11713 end else
11714 inc(Prog, Images.Count);
11715
11716 // Remove passive elements, pass 2
11717 inc(Prog, Images.Count);
11718 if (ooCleanup in Options) then
11719 begin
11720 for i := Images.Count-1 downto 0 do
11721 begin
11722 // Remove comments and application extensions
11723 for j := Images[i].Extensions.Count-1 downto 0 do
11724 if (Images[i].Extensions[j] is TGIFCommentExtension) or
11725 (Images[i].Extensions[j] is TGIFTextExtension) or
11726 (Images[i].Extensions[j] is TGIFUnknownAppExtension) or
11727 ((Images[i].Extensions[j] is TGIFAppExtNSLoop) and
11728 ((i > 0) or (Images.Count = 1))) then
11729 Images[i].Extensions.Delete(j);
11730 if (Images[i].GraphicControlExtension <> nil) then
11731 begin
11732 GCE := Images[i].GraphicControlExtension;
11733 // Zap GCE if all of the following are true:
11734 // * No delay or only one image
11735 // * Not transparent
11736 // * No prompt
11737 // * No disposal or only one image
11738 if ((GCE.Delay = 0) or (Images.Count = 1)) and
11739 (not GCE.Transparent) and
11740 (not GCE.UserInput) and
11741 ((GCE.Disposal in [dmNone, dmNoDisposal]) or (Images.Count = 1)) then
11742 begin
11743 GCE.Free;
11744 end;
11745 end;
11746 // Zap frame if it has become empty
11747 if (Images[i].Empty) and (Images[i].Extensions.Count = 0) then
11748 Images[i].Free;
11749 end;
11750 Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
11751 Rect(0,0,0,0), sProgressOptimizing);
11752 end else
11753
11754 // Reduce color depth
11755 if (ooReduceColors in Options) then
11756 begin
11757 if (ColorReduction = rmPalette) then
11758 Error(sInvalidReduction);
11759 { TODO -oanme -cFeature : Implement ooReduceColors option. }
11760 // Not implemented!
11761 end;
11762 finally
11763 if ExceptObject = nil then
11764 i := 100
11765 else
11766 i := 0;
11767 Progress(Self, psEnding, i, False, Rect(0,0,0,0), sProgressOptimizing);
11768 end;
11769 finally
11770 FPainters.UnlockList;
11771 end;
11772 end;
11773
11774 procedure TGIFImage.Pack;
11775 var
11776 i : integer;
11777 begin
11778 // Zap bitmaps and palettes
11779 FreeBitmap;
11780 Palette := 0;
11781 for i := 0 to FImages.Count-1 do
11782 begin
11783 FImages[i].Bitmap := nil;
11784 FImages[i].Palette := 0;
11785 end;
11786
11787 // Only pack if no global colormap and a single image
11788 if (FHeader.ColorMap.Count > 0) or (FImages.Count <> 1) then
11789 exit;
11790
11791 // Copy local colormap to global
11792 FHeader.ColorMap.Assign(FImages[0].ColorMap);
11793 // Zap local colormap
11794 FImages[0].ColorMap.Clear;
11795 end;
11796
11797 procedure TGIFImage.SaveToStream(Stream: TStream);
11798 var
11799 n : Integer;
11800 begin
11801 Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressSaving);
11802 try
11803 // Write header
11804 FHeader.SaveToStream(Stream);
11805 // Write images
11806 FImages.SaveToStream(Stream);
11807 // Write trailer
11808 with TGIFTrailer.Create(self) do
11809 try
11810 SaveToStream(Stream);
11811 finally
11812 Free;
11813 end;
11814 finally
11815 if ExceptObject = nil then
11816 n := 100
11817 else
11818 n := 0;
11819 Progress(Self, psEnding, n, True, Rect(0,0,0,0), sProgressSaving);
11820 end;
11821 end;
11822
11823 // 2006.07.09 ->
11824 {$IFDEF FIXHEADER_WIDTHHEIGHT_SILENT}
11825 procedure TGIFImage.FixHeaderWidthHeight;
11826 var
11827 i, w, h: Integer;
11828 begin
11829 for i := 0 to Images.Count - 1 do
11830 begin
11831 w := Images.SubImages[i].Left + Images.SubImages[i].Width;
11832 h := Images.SubImages[i].Top + Images.SubImages[i].Height;
11833 if w > Header.Width then
11834 Header.Width := w;
11835 if h > Header.Height then
11836 Header.Height := h;
11837 end;
11838 end;
11839 {$ENDIF}
11840 // 2006.07.09 <-
11841
11842 procedure TGIFImage.LoadFromStream(Stream: TStream);
11843 var
11844 n : Integer;
11845 Position : integer;
11846 begin
11847 Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressLoading);
11848 try
11849 // Zap old image
11850 Clear;
11851 Position := Stream.Position;
11852 try
11853 // Read header
11854 FHeader.LoadFromStream(Stream);
11855 // Read images
11856 FImages.LoadFromStream(Stream, self);
11857 {$IFDEF FIXHEADER_WIDTHHEIGHT_SILENT}
11858 FixHeaderWidthHeight; // 2006.07.09
11859 {$ENDIF}
11860 // Read trailer
11861 with TGIFTrailer.Create(self) do
11862 try
11863 LoadFromStream(Stream);
11864 finally
11865 Free;
11866 end;
11867 except
11868 // Restore stream position in case of error.
11869 // Not required, but "a nice thing to do"
11870 Stream.Position := Position;
11871 raise;
11872 end;
11873 finally
11874 if ExceptObject = nil then
11875 n := 100
11876 else
11877 n := 0;
11878 Progress(Self, psEnding, n, True, Rect(0,0,0,0), sProgressLoading);
11879 end;
11880 end;
11881
11882 procedure TGIFImage.LoadFromResourceName(Instance: THandle; const ResName: String);
11883 // 2002.07.07
11884 var
11885 Stream: TCustomMemoryStream;
11886 begin
11887 Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA);
11888 try
11889 LoadFromStream(Stream);
11890 finally
11891 Stream.Free;
11892 end;
11893 end;
11894
GetBitmapnull11895 function TGIFImage.GetBitmap: TBitmap;
11896 begin
11897 if not(Empty) then
11898 begin
11899 Result := FBitmap;
11900 if (Result <> nil) then
11901 exit;
11902 FBitmap := TBitmap.Create;
11903 Result := FBitmap;
11904 FBitmap.OnChange := Changed;
11905 // Use first image as default
11906 if (Images.Count > 0) then
11907 begin
11908 if (Images[0].Width = Width) and (Images[0].Height = Height) then
11909 begin
11910 // Use first image as it has same dimensions
11911 FBitmap.Assign(Images[0].Bitmap);
11912 end else
11913 begin
11914 // Draw first image on bitmap
11915 FBitmap.Palette := CopyPalette(Palette);
11916 FBitmap.Height := Height;
11917 FBitmap.Width := Width;
11918 Images[0].Draw(FBitmap.Canvas, FBitmap.Canvas.ClipRect, False, False);
11919 end;
11920 end;
11921 end else
11922 Result := nil
11923 end;
11924
11925 // Create a new (empty) bitmap
NewBitmapnull11926 function TGIFImage.NewBitmap: TBitmap;
11927 begin
11928 Result := FBitmap;
11929 if (Result <> nil) then
11930 exit;
11931 FBitmap := TBitmap.Create;
11932 Result := FBitmap;
11933 FBitmap.OnChange := Changed;
11934 // Draw first image on bitmap
11935 FBitmap.Palette := CopyPalette(Palette);
11936 FBitmap.Height := Height;
11937 FBitmap.Width := Width;
11938 end;
11939
11940 procedure TGIFImage.FreeBitmap;
11941 begin
11942 if (DrawPainter <> nil) then
11943 DrawPainter.Stop;
11944
11945 if (FBitmap <> nil) then
11946 begin
11947 FBitmap.Free;
11948 FBitmap := nil;
11949 end;
11950 end;
11951
Addnull11952 function TGIFImage.Add(Source: TPersistent): integer;
11953 var
11954 Image : TGIFSubImage;
11955 begin
11956 Image := nil; // To avoid compiler warning - not needed.
11957 if (Source is TGraphic) then
11958 begin
11959 Image := TGIFSubImage.Create(self);
11960 try
11961 Image.Assign(Source);
11962 // ***FIXME*** Documentation should explain the inconsistency here:
11963 // TGIFimage does not take ownership of Source after TGIFImage.Add() and
11964 // therefore does not delete Source.
11965 except
11966 Image.Free;
11967 raise;
11968 end;
11969 end else
11970 if (Source is TGIFSubImage) then
11971 Image := TGIFSubImage(Source)
11972 else
11973 Error(sUnsupportedClass);
11974
11975 Result := FImages.Add(Image);
11976
11977 FreeBitmap;
11978 Changed(self);
11979 end;
11980
TGIFImage.GetEmptynull11981 function TGIFImage.GetEmpty: Boolean;
11982 begin
11983 Result := (FImages.Count = 0);
11984 end;
11985
TGIFImage.GetHeightnull11986 function TGIFImage.GetHeight: Integer;
11987 begin
11988 Result := FHeader.Height;
11989 end;
11990
GetWidthnull11991 function TGIFImage.GetWidth: Integer;
11992 begin
11993 Result := FHeader.Width;
11994 end;
11995
TGIFImage.GetIsTransparentnull11996 function TGIFImage.GetIsTransparent: Boolean;
11997 var
11998 i : integer;
11999 begin
12000 Result := False;
12001 for i := 0 to Images.Count-1 do
12002 if (Images[i].GraphicControlExtension <> nil) and
12003 (Images[i].GraphicControlExtension.Transparent) then
12004 begin
12005 Result := True;
12006 exit;
12007 end;
12008 end;
12009
Equalsnull12010 function TGIFImage.Equals(Graphic: TGraphic): Boolean;
12011 begin
12012 Result := (Graphic = self);
12013 end;
12014
TGIFImage.GetPalettenull12015 function TGIFImage.GetPalette: HPALETTE;
12016 begin
12017 // Check for recursion
12018 // (TGIFImage.GetPalette->TGIFSubImage.GetPalette->TGIFImage.GetPalette etc...)
12019 if (IsInsideGetPalette) then
12020 Error(sNoColorTable);
12021 IsInsideGetPalette := True;
12022 try
12023 Result := 0;
12024 if (FBitmap <> nil) and (FBitmap.Palette <> 0) then
12025 // Use bitmaps own palette if possible
12026 Result := FBitmap.Palette
12027 else if (FGlobalPalette <> 0) then
12028 // Or a previously exported global palette
12029 Result := FGlobalPalette
12030 else if (DoDither) then
12031 begin
12032 // or create a new dither palette
12033 FGlobalPalette := WebPalette;
12034 Result := FGlobalPalette;
12035 end else
12036 if (FHeader.ColorMap.Count > 0) then
12037 begin
12038 // or create a new if first time
12039 FGlobalPalette := FHeader.ColorMap.ExportPalette;
12040 Result := FGlobalPalette;
12041 end else
12042 if (FImages.Count > 0) then
12043 // This can cause a recursion if no global palette exist and image[0]
12044 // hasn't got one either. Checked by the IsInsideGetPalette semaphor.
12045 Result := FImages[0].Palette;
12046 finally
12047 IsInsideGetPalette := False;
12048 end;
12049 end;
12050
12051 procedure TGIFImage.SetPalette(Value: HPalette);
12052 var
12053 NeedNewBitmap : boolean;
12054 begin
12055 if (Value <> FGlobalPalette) then
12056 begin
12057 // Zap old palette
12058 if (FGlobalPalette <> 0) then
12059 DeleteObject(FGlobalPalette);
12060
12061 // Zap bitmap unless new palette is same as bitmaps own
12062 NeedNewBitmap := (FBitmap <> nil) and (Value <> FBitmap.Palette);
12063
12064 // Use new palette
12065 FGlobalPalette := Value;
12066
12067 if (NeedNewBitmap) then
12068 begin
12069 // Need to create new bitmap and repaint
12070 FreeBitmap;
12071 PaletteModified := True;
12072 Changed(Self);
12073 end;
12074 end;
12075 end;
12076
12077 // Obsolete
12078 // procedure TGIFImage.Changed(Sender: TObject);
12079 // begin
12080 // inherited Changed(Sender);
12081 // end;
12082
12083 procedure TGIFImage.SetHeight(Value: Integer);
12084 var
12085 i : integer;
12086 begin
12087 for i := 0 to Images.Count-1 do
12088 if (Images[i].Top + Images[i].Height > Value) then
12089 Error(sBadHeight);
12090 if (Value <> Header.Height) then
12091 begin
12092 Header.Height := Value;
12093 FreeBitmap;
12094 Changed(self);
12095 end;
12096 end;
12097
12098 procedure TGIFImage.SetWidth(Value: Integer);
12099 var
12100 i : integer;
12101 begin
12102 for i := 0 to Images.Count-1 do
12103 if (Images[i].Left + Images[i].Width > Value) then
12104 Error(sBadWidth);
12105 if (Value <> Header.Width) then
12106 begin
12107 Header.Width := Value;
12108 FreeBitmap;
12109 Changed(self);
12110 end;
12111 end;
12112
12113 procedure TGIFImage.WriteData(Stream: TStream);
12114 begin
12115 if (GIFImageOptimizeOnStream) then
12116 Optimize([ooCrop, ooMerge, ooCleanup, ooColorMap, ooReduceColors], rmNone, dmNearest, 8);
12117
12118 inherited WriteData(Stream);
12119 end;
12120
12121 procedure TGIFImage.AssignTo(Dest: TPersistent);
12122 begin
12123 if (Dest is TBitmap) then
12124 Dest.Assign(Bitmap)
12125 else
12126 inherited AssignTo(Dest);
12127 end;
12128
12129 { TODO 1 -oanme -cImprovement : Better handling of TGIFImage.Assign(Empty TBitmap). }
12130 procedure TGIFImage.Assign(Source: TPersistent);
12131 var
12132 i : integer;
12133 Image : TGIFSubImage;
12134 begin
12135 if (Source = self) then
12136 exit;
12137 if (Source = nil) then
12138 begin
12139 Clear;
12140 end else
12141 //
12142 // TGIFImage import
12143 //
12144 if (Source is TGIFImage) then
12145 begin
12146 Clear;
12147 // Temporarily copy event handlers to be able to generate progress events
12148 // during the copy and handle copy errors
12149 OnProgress := TGIFImage(Source).OnProgress;
12150 try
12151 FOnWarning := TGIFImage(Source).OnWarning;
12152 Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressCopying);
12153 try
12154 FHeader.Assign(TGIFImage(Source).Header);
12155 FThreadPriority := TGIFImage(Source).ThreadPriority;
12156 FDrawBackgroundColor := TGIFImage(Source).DrawBackgroundColor;
12157 FDrawOptions := TGIFImage(Source).DrawOptions;
12158 FColorReduction := TGIFImage(Source).ColorReduction;
12159 FDitherMode := TGIFImage(Source).DitherMode;
12160 FForceFrame := TGIFImage(Source).ForceFrame; // 2004.03.09
12161 // 2002.07.07 ->
12162 FOnWarning:= TGIFImage(Source).FOnWarning;
12163 FOnStartPaint:= TGIFImage(Source).FOnStartPaint;
12164 FOnPaint:= TGIFImage(Source).FOnPaint;
12165 FOnEndPaint:= TGIFImage(Source).FOnEndPaint;
12166 FOnAfterPaint:= TGIFImage(Source).FOnAfterPaint;
12167 FOnLoop:= TGIFImage(Source).FOnLoop;
12168 // 2002.07.07 <-
12169 for i := 0 to TGIFImage(Source).Images.Count-1 do
12170 begin
12171 Image := TGIFSubImage.Create(self);
12172 Image.Assign(TGIFImage(Source).Images[i]);
12173 Add(Image);
12174 Progress(Self, psRunning, MulDiv((i+1), 100, TGIFImage(Source).Images.Count),
12175 False, Rect(0,0,0,0), sProgressCopying);
12176 end;
12177 {$IFDEF FIXHEADER_WIDTHHEIGHT_SILENT}
12178 FixHeaderWidthHeight; // 2006.07.09
12179 {$ENDIF}
12180 finally
12181 if ExceptObject = nil then
12182 i := 100
12183 else
12184 i := 0;
12185 Progress(Self, psEnding, i, False, Rect(0,0,0,0), sProgressCopying);
12186 end;
12187 finally
12188 // Reset event handlers
12189 FOnWarning := nil;
12190 OnProgress := nil;
12191 end;
12192 end else
12193 //
12194 // Import via TGIFSubImage.Assign
12195 //
12196 begin
12197 Clear;
12198 Image := TGIFSubImage.Create(self);
12199 try
12200 Image.Assign(Source);
12201 Add(Image);
12202 except
12203 on E: EConvertError do
12204 begin
12205 Image.Free;
12206 // Unsupported format - fall back to Source.AssignTo
12207 inherited Assign(Source);
12208 end;
12209 else
12210 // Unknown conversion error
12211 Image.Free;
12212 raise;
12213 end;
12214 end;
12215 end;
12216
12217 procedure TGIFImage.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
12218 APalette: HPALETTE);
12219 {$IFDEF REGISTER_TGIFIMAGE}
12220 var
12221 Size : Longint;
12222 Buffer : Pointer;
12223 Stream : TMemoryStream;
12224 Bmp : TBitmap;
12225 {$ENDIF} // 2002.07.07
12226 begin // 2002.07.07
12227 {$IFDEF REGISTER_TGIFIMAGE} // 2002.07.07
12228 if (AData = 0) then
12229 AData := GetClipboardData(AFormat);
12230 if (AData <> 0) and (AFormat = CF_GIF) then
12231 begin
12232 // Get size and pointer to data
12233 Size := GlobalSize(AData);
12234 Buffer := GlobalLock(AData);
12235 try
12236 Stream := TMemoryStream.Create;
12237 try
12238 // Copy data to a stream
12239 Stream.SetSize(Size);
12240 Move(Buffer^, Stream.Memory^, Size);
12241 // Load GIF from stream
12242 LoadFromStream(Stream);
12243 finally
12244 Stream.Free;
12245 end;
12246 finally
12247 GlobalUnlock(AData);
12248 end;
12249 end else
12250 if (AData <> 0) and (AFormat = CF_BITMAP) then
12251 begin
12252 // No GIF on clipboard - try loading a bitmap instead
12253 Bmp := TBitmap.Create;
12254 try
12255 Bmp.LoadFromClipboardFormat(AFormat, AData, APalette);
12256 Assign(Bmp);
12257 finally
12258 Bmp.Free;
12259 end;
12260 end else
12261 Error(sUnknownClipboardFormat);
12262 {$ELSE} // 2002.07.07
12263 Error(sGIFToClipboard); // 2002.07.07
12264 {$ENDIF} // 2002.07.07
12265 end;
12266
12267 procedure TGIFImage.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
12268 var APalette: HPALETTE);
12269 {$IFDEF REGISTER_TGIFIMAGE}
12270 var
12271 Stream : TMemoryStream;
12272 Data : THandle;
12273 Buffer : Pointer;
12274 {$ENDIF} // 2002.07.07
12275 begin // 2002.07.07
12276 {$IFDEF REGISTER_TGIFIMAGE} // 2002.07.07
12277 if (Empty) then
12278 exit;
12279 // First store a bitmap version on the clipboard...
12280 Bitmap.SaveToClipboardFormat(AFormat, AData, APalette);
12281 // ...then store a GIF
12282 Stream := TMemoryStream.Create;
12283 try
12284 // Save the GIF to a memory stream
12285 SaveToStream(Stream);
12286 Stream.Position := 0;
12287 // Allocate some memory for the GIF data
12288 Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
12289 try
12290 if (Data <> 0) then
12291 begin
12292 Buffer := GlobalLock(Data);
12293 try
12294 // Copy GIF data from stream memory to clipboard memory
12295 Move(Stream.Memory^, Buffer^, Stream.Size);
12296 finally
12297 GlobalUnlock(Data);
12298 end;
12299 // Transfer data to clipboard
12300 if (SetClipboardData(CF_GIF, Data) = 0) then
12301 Error(sFailedPaste);
12302 end;
12303 except
12304 GlobalFree(Data);
12305 raise;
12306 end;
12307 finally
12308 Stream.Free;
12309 end;
12310 {$ELSE} // 2002.07.07
12311 Error(sGIFToClipboard); // 2002.07.07
12312 {$ENDIF} // 2002.07.07
12313 end;
12314
GetColorMapnull12315 function TGIFImage.GetColorMap: TGIFColorMap;
12316 begin
12317 Result := FHeader.ColorMap;
12318 end;
12319
GetDoDithernull12320 function TGIFImage.GetDoDither: boolean;
12321 begin
12322 Result := (goDither in DrawOptions) and
12323 (((goAutoDither in DrawOptions) and DoAutoDither) or
12324 not(goAutoDither in DrawOptions));
12325 end;
12326
12327 {$IFDEF VER9x}
12328 procedure TGIFImage.Progress(Sender: TObject; Stage: TProgressStage;
12329 PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
12330 begin
12331 if Assigned(FOnProgress) then
12332 FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
12333 end;
12334 {$ENDIF}
12335
12336 procedure TGIFImage.StopDraw;
12337 {$IFNDEF VER14_PLUS} // 2001.07.23
12338 var
12339 Msg : TMsg;
12340 ThreadWindow : HWND;
12341 {$ENDIF} // 2001.07.23
12342 begin
12343 repeat
12344 // Use the FPainters threadlist to protect FDrawPainter from being modified
12345 // by the thread while we mess with it
12346 with FPainters.LockList do
12347 try
12348 if (FDrawPainter = nil) then
12349 break;
12350
12351 // Tell thread to terminate
12352 FDrawPainter.Stop;
12353
12354 // No need to wait for "thread" to terminate if running in main thread
12355 if not(goAsync in FDrawPainter.DrawOptions) then
12356 break;
12357
12358 finally
12359 // Release the lock on FPainters to let paint thread kill itself
12360 FPainters.UnLockList;
12361 end;
12362
12363 {$IFDEF VER14_PLUS}
12364 // 2002.07.07
12365 if (GetCurrentThreadID = MainThreadID) then
12366 while CheckSynchronize do {loop};
12367 {$ELSE}
12368 // Process Messages to make Synchronize work
12369 // (Instead of Application.ProcessMessages)
12370 //{$IFDEF VER14_PLUS} // 2001.07.23
12371 // Break; // 2001.07.23
12372 // Sleep(0); // Yield // 2001.07.23
12373 //{$ELSE} // 2001.07.23
12374 ThreadWindow := FindWindow('TThreadWindow', nil);
12375 while PeekMessage(Msg, ThreadWindow, CM_DESTROYWINDOW, CM_EXECPROC, PM_REMOVE) do
12376 begin
12377 if (Msg.Message <> WM_QUIT) then
12378 begin
12379 TranslateMessage(Msg);
12380 DispatchMessage(Msg);
12381 end else
12382 begin
12383 PostQuitMessage(Msg.WParam);
12384 exit;
12385 end;
12386 end;
12387 {$ENDIF} // 2001.07.23
12388 Sleep(0); // Yield
12389
12390 until (False);
12391 FreeBitmap;
12392 end;
12393
12394 procedure TGIFImage.Draw(ACanvas: TCanvas; const Rect: TRect);
12395 var
12396 Canvas : TCanvas;
12397 DestRect : TRect;
12398 {$IFNDEF VER14_PLUS} // 2001.07.23
12399 Msg : TMsg;
12400 ThreadWindow : HWND;
12401 {$ENDIF} // 2001.07.23
12402
12403 procedure DrawTile(Rect: TRect; Bitmap: TBitmap);
12404 var
12405 Tile : TRect;
12406 begin
12407 if (goTile in FDrawOptions) then
12408 begin
12409 // Note: This design does not handle transparency correctly!
12410 Tile.Left := Rect.Left;
12411 Tile.Right := Tile.Left + Width;
12412 while (Tile.Left < Rect.Right) do
12413 begin
12414 Tile.Top := Rect.Top;
12415 Tile.Bottom := Tile.Top + Height;
12416 while (Tile.Top < Rect.Bottom) do
12417 begin
12418 ACanvas.StretchDraw(Tile, Bitmap);
12419 Tile.Top := Tile.Top + Height;
12420 Tile.Bottom := Tile.Top + Height;
12421 end;
12422 Tile.Left := Tile.Left + Width;
12423 Tile.Right := Tile.Left + Width;
12424 end;
12425 end else
12426 ACanvas.StretchDraw(Rect, Bitmap);
12427 end;
12428
12429 begin
12430 // Prevent recursion(s(s(s)))
12431 if (IsDrawing) or (FImages.Count = 0) then
12432 exit;
12433
12434 IsDrawing := True;
12435 try
12436 // Copy bitmap to canvas if we are already drawing
12437 // (or have drawn but are finished)
12438 if (FImages.Count = 1) or // Only one image
12439 (not (goAnimate in FDrawOptions)) then // Don't animate
12440 begin
12441 // 2004.03.09 ->
12442 if (FForceFrame >= 0) and (FForceFrame < FImages.Count) then
12443 FImages[FForceFrame].Draw(ACanvas, Rect, (goTransparent in FDrawOptions), (goTile in FDrawOptions))
12444 else
12445 // 2004.03.09 <-
12446 FImages[0].Draw(ACanvas, Rect, (goTransparent in FDrawOptions), (goTile in FDrawOptions));
12447 exit;
12448 end else
12449 if (FBitmap <> nil) and not(goDirectDraw in FDrawOptions) then
12450 begin
12451 DrawTile(Rect, Bitmap);
12452 exit;
12453 end;
12454
12455 // Use the FPainters threadlist to protect FDrawPainter from being modified
12456 // by the thread while we mess with it
12457 with FPainters.LockList do
12458 try
12459 // If we are already painting on the canvas in goDirectDraw mode
12460 // and at the same location, just exit and let the painter do
12461 // its thing when it's ready
12462 if (FDrawPainter <> nil) and (FDrawPainter.Canvas = ACanvas) and
12463 EqualRect(FDrawPainter.Rect, Rect) then
12464 exit;
12465
12466 // Kill the current paint thread
12467 StopDraw;
12468
12469 if not(goDirectDraw in FDrawOptions) then
12470 begin
12471 // Create a bitmap to draw on
12472 NewBitmap;
12473 Canvas := FBitmap.Canvas;
12474 DestRect := Canvas.ClipRect;
12475 // Initialize bitmap canvas with background image
12476 Canvas.CopyRect(DestRect, ACanvas, Rect);
12477 end else
12478 begin
12479 Canvas := ACanvas;
12480 DestRect := Rect;
12481 end;
12482
12483 // Create new paint thread
12484 InternalPaint(@FDrawPainter, Canvas, DestRect, FDrawOptions);
12485
12486 if (FDrawPainter <> nil) then
12487 begin
12488 // Launch thread
12489 FDrawPainter.Start;
12490
12491 if not(goDirectDraw in FDrawOptions) then
12492 begin
12493 {$IFDEF VER14_PLUS}
12494 // 2002.07.07
12495 while (FDrawPainter <> nil) and (not FDrawPainter.Terminated) and
12496 (not FDrawPainter.Started) do
12497 begin
12498 if not CheckSynchronize then
12499 Sleep(0); // Yield
12500 end;
12501 {$ELSE}
12502 //{$IFNDEF VER14_PLUS} // 2001.07.23
12503 ThreadWindow := FindWindow('TThreadWindow', nil);
12504 // Wait for thread to render first frame
12505 while (FDrawPainter <> nil) and (not FDrawPainter.Terminated) and
12506 (not FDrawPainter.Started) do
12507 // Process Messages to make Synchronize work
12508 // (Instead of Application.ProcessMessages)
12509 if PeekMessage(Msg, ThreadWindow, CM_DESTROYWINDOW, CM_EXECPROC, PM_REMOVE) then
12510 begin
12511 if (Msg.Message <> WM_QUIT) then
12512 begin
12513 TranslateMessage(Msg);
12514 DispatchMessage(Msg);
12515 end else
12516 begin
12517 PostQuitMessage(Msg.WParam);
12518 exit;
12519 end;
12520 end else
12521 Sleep(0); // Yield
12522 {$ENDIF} // 2001.07.23
12523 // Draw frame to destination
12524 DrawTile(Rect, Bitmap);
12525 end;
12526 end;
12527 finally
12528 FPainters.UnLockList;
12529 end;
12530
12531 finally
12532 IsDrawing := False;
12533 end;
12534 end;
12535
12536 // Internal pain(t) routine used by Draw()
InternalPaintnull12537 function TGIFImage.InternalPaint(Painter: PGifPainter; ACanvas: TCanvas;
12538 const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
12539 begin
12540 if (Empty) or (Rect.Left >= Rect.Right) or (Rect.Top >= Rect.Bottom) then
12541 begin
12542 Result := nil;
12543 if (Painter <> nil) then
12544 Painter^ := Result;
12545 exit;
12546 end;
12547
12548 // Draw in main thread if only one image
12549 if (Images.Count = 1) then
12550 Options := Options - [goAsync, goAnimate];
12551
12552 Result := TGIFPainter.CreateRef(Painter, self, ACanvas, Rect, Options);
12553 FPainters.Add(Result);
12554 Result.OnStartPaint := FOnStartPaint;
12555 Result.OnPaint := FOnPaint;
12556 Result.OnAfterPaint := FOnAfterPaint;
12557 Result.OnLoop := FOnLoop;
12558 Result.OnEndPaint := FOnEndPaint;
12559
12560 if not(goAsync in Options) then
12561 begin
12562 // Run in main thread
12563 Result.Execute;
12564 // Note: Painter threads executing in the main thread are freed upon exit
12565 // from the Execute method, so no need to do it here.
12566 Result := nil;
12567 if (Painter <> nil) then
12568 Painter^ := Result;
12569 end else
12570 Result.Priority := FThreadPriority;
12571 end;
12572
Paintnull12573 function TGIFImage.Paint(ACanvas: TCanvas; const Rect: TRect;
12574 Options: TGIFDrawOptions): TGIFPainter;
12575 begin
12576 Result := InternalPaint(nil, ACanvas, Rect, Options);
12577 if (Result <> nil) then
12578 // Run in separate thread
12579 Result.Start;
12580 end;
12581
12582 procedure TGIFImage.PaintStart;
12583 var
12584 i : integer;
12585 begin
12586 with FPainters.LockList do
12587 try
12588 for i := 0 to Count-1 do
12589 TGIFPainter(Items[i]).Start;
12590 finally
12591 FPainters.UnLockList;
12592 end;
12593 end;
12594
12595 procedure TGIFImage.PaintStop;
12596 var
12597 Ghosts : integer;
12598 i : integer;
12599 {$IFNDEF VER14_PLUS} // 2001.07.23
12600 Msg : TMsg;
12601 ThreadWindow : HWND;
12602 {$ENDIF} // 2001.07.23
12603
12604 {$IFNDEF VER14_PLUS} // 2001.07.23
12605 procedure KillThreads;
12606 var
12607 i : integer;
12608 begin
12609 with FPainters.LockList do
12610 try
12611 for i := Count-1 downto 0 do
12612 if (goAsync in TGIFPainter(Items[i]).DrawOptions) then
12613 begin
12614 TerminateThread(TGIFPainter(Items[i]).Handle, 0);
12615 Delete(i);
12616 end;
12617 finally
12618 FPainters.UnLockList;
12619 end;
12620 end;
12621 {$ENDIF} // 2001.07.23
12622
12623 begin
12624 try
12625 // Loop until all have died
12626 repeat
12627 with FPainters.LockList do
12628 try
12629 if (Count = 0) then
12630 exit;
12631
12632 // Signal painters to terminate
12633 // Painters will attempt to remove them self from the
12634 // painter list when they die
12635 Ghosts := Count;
12636 for i := Ghosts-1 downto 0 do
12637 begin
12638 if not(goAsync in TGIFPainter(Items[i]).DrawOptions) then
12639 dec(Ghosts);
12640 TGIFPainter(Items[i]).Stop;
12641 end;
12642 finally
12643 FPainters.UnLockList;
12644 end;
12645
12646 // If all painters were synchronous, there's no purpose waiting for them
12647 // to terminate, because they are running in the main thread.
12648 if (Ghosts = 0) then
12649 exit;
12650 {$IFDEF VER14_PLUS}
12651 // 2002.07.07
12652 if (GetCurrentThreadID = MainThreadID) then
12653 while CheckSynchronize do {loop};
12654 {$ELSE}
12655 // Process Messages to make TThread.Synchronize work
12656 // (Instead of Application.ProcessMessages)
12657 //{$IFDEF VER14_PLUS} // 2001.07.23
12658 // Exit; // 2001.07.23
12659 //{$ELSE} // 2001.07.23
12660 ThreadWindow := FindWindow('TThreadWindow', nil);
12661 if (ThreadWindow = 0) then
12662 begin
12663 KillThreads;
12664 Exit;
12665 end;
12666 while PeekMessage(Msg, ThreadWindow, CM_DESTROYWINDOW, CM_EXECPROC, PM_REMOVE) do
12667 begin
12668 if (Msg.Message <> WM_QUIT) then
12669 begin
12670 TranslateMessage(Msg);
12671 DispatchMessage(Msg);
12672 end else
12673 begin
12674 KillThreads;
12675 Exit;
12676 end;
12677 end;
12678 {$ENDIF} // 2001.07.23
12679 Sleep(0);
12680 until (False);
12681 finally
12682 FreeBitmap;
12683 end;
12684 end;
12685
12686 procedure TGIFImage.PaintPause;
12687 var
12688 i : integer;
12689 begin
12690 with FPainters.LockList do
12691 try
12692 for i := 0 to Count-1 do
12693 TGIFPainter(Items[i]).Suspend;
12694 finally
12695 FPainters.UnLockList;
12696 end;
12697 end;
12698
12699 procedure TGIFImage.PaintResume;
12700 var
12701 i : integer;
12702 begin
12703 // Implementation is currently same as PaintStart, but don't call PaintStart
12704 // in case its implementation changes
12705 with FPainters.LockList do
12706 try
12707 for i := 0 to Count-1 do
12708 TGIFPainter(Items[i]).Start;
12709 finally
12710 FPainters.UnLockList;
12711 end;
12712 end;
12713
12714 procedure TGIFImage.PaintRestart;
12715 var
12716 i : integer;
12717 begin
12718 with FPainters.LockList do
12719 try
12720 for i := 0 to Count-1 do
12721 TGIFPainter(Items[i]).Restart;
12722 finally
12723 FPainters.UnLockList;
12724 end;
12725 end;
12726
12727 procedure TGIFImage.Warning(Sender: TObject; Severity: TGIFSeverity; Message: string);
12728 begin
12729 if (Assigned(FOnWarning)) then
12730 FOnWarning(Sender, Severity, Message);
12731 end;
12732
12733 {$IFDEF VER12_PLUS}
12734 {$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up // 2001.07.23
12735 type
12736 TDummyThread = class(TThread)
12737 protected
12738 procedure Execute; override;
12739 end;
12740 procedure TDummyThread.Execute;
12741 begin
12742 end;
12743 {$ENDIF} // 2001.07.23
12744 {$ENDIF}
12745
12746 var
12747 DesktopDC: HDC;
12748 {$IFDEF VER12_PLUS}
12749 {$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up // 2001.07.23
12750 DummyThread: TThread;
12751 {$ENDIF} // 2001.07.23
12752 {$ENDIF}
12753
12754 ////////////////////////////////////////////////////////////////////////////////
12755 //
12756 // Initialization
12757 //
12758 ////////////////////////////////////////////////////////////////////////////////
12759
12760 initialization
12761 {$IFDEF REGISTER_TGIFIMAGE}
12762 TPicture.RegisterFileFormat('GIF', sGIFImageFile, TGIFImage);
12763 CF_GIF := RegisterClipboardFormat(PChar(sGIFImageFile));
12764 TPicture.RegisterClipboardFormat(CF_GIF, TGIFImage);
12765 {$ENDIF}
12766 DesktopDC := GetDC(0);
12767 try
12768 PaletteDevice := (GetDeviceCaps(DesktopDC, BITSPIXEL) * GetDeviceCaps(DesktopDC, PLANES) <= 8);
12769 DoAutoDither := PaletteDevice;
12770 finally
12771 ReleaseDC(0, DesktopDC);
12772 end;
12773
12774 {$IFDEF VER9x}
12775 // Note: This doesn't return the same palette as the Delphi 3 system palette
12776 // since the true system palette contains 20 entries and the Delphi 3 system
12777 // palette only contains 16.
12778 // For our purpose this doesn't matter since we do not care about the actual
12779 // colors (or their number) in the palette.
12780 // Stock objects doesn't have to be deleted.
12781 SystemPalette16 := GetStockObject(DEFAULT_PALETTE);
12782 {$ENDIF}
12783 {$IFDEF VER12_PLUS}
12784 // Make sure that at least one thread always exist.
12785 // This is done to circumvent a race condition bug in Delphi 4.x and later:
12786 // When threads are deleted and created in rapid succesion, a situation might
12787 // arise where the thread window is deleted *after* the threads it controls
12788 // has been created. See the Delphi Bug Lists for more information.
12789 {$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up // 2001.07.23
12790 DummyThread := TDummyThread.Create(True);
12791 {$ENDIF} // 2001.07.23
12792 {$ENDIF}
12793
12794 ////////////////////////////////////////////////////////////////////////////////
12795 //
12796 // Finalization
12797 //
12798 ////////////////////////////////////////////////////////////////////////////////
12799 finalization
12800 ExtensionList.Free;
12801 AppExtensionList.Free;
12802 {$IFNDEF VER9x}
12803 {$IFDEF REGISTER_TGIFIMAGE}
12804 TPicture.UnregisterGraphicClass(TGIFImage);
12805 {$ENDIF}
12806 {$IFDEF VER100}
12807 if (pf8BitBitmap <> nil) then
12808 pf8BitBitmap.Free;
12809 {$ENDIF}
12810 {$ENDIF}
12811 {$IFDEF VER12_PLUS}
12812 {$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up // 2001.07.23
12813 if (DummyThread <> nil) then
12814 // 2006.10.16 ->
12815 // DummyThread.Free;
12816 begin
12817 DummyThread.Resume;
12818 DummyThread.WaitFor;
12819 DummyThread.Free;
12820 end;
12821 // 2006.10.16 <-
12822 {$ENDIF} // 2001.07.23
12823 {$ENDIF}
12824 end.
12825
12826