-
Notifications
You must be signed in to change notification settings - Fork 14
/
rpGifImage.pas
12548 lines (11372 loc) · 351 KB
/
rpGifImage.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
unit rpGIFImage;
////////////////////////////////////////////////////////////////////////////////
// //
// Project: GIF Graphics Object //
// Module: gifimage //
// Description: TGraphic implementation of the GIF89a graphics format //
// Version: 2.2 //
// Release: 5 //
// Date: 23-MAY-1999 //
// Target: Win32, Delphi 2, 3, 4 & 5, C++ Builder 3 & 4 //
// Author(s): anme: Anders Melander, anders@melander.dk //
// fila: Filip Larsen //
// rps: Reinier Sterkenburg //
// Copyright: (c) 1997-99 Anders Melander. //
// All rights reserved. //
// Formatting: 2 space indent, 8 space tabs, 80 columns. //
// //
////////////////////////////////////////////////////////////////////////////////
// Delphi 6 updates and modifications by Alexey Barkovoy (clootie@reactor.ru) //
// Date: 22-Dec-2001 //
// Date: 13-Jun-2003 - Updated for Delphi7 and (possible) up //
// Download from: http://clootie.narod.ru/delphi/download_vcl.html //
////////////////////////////////////////////////////////////////////////////////
// //
// Please read the "Conditions of use" in the release notes. //
// //
////////////////////////////////////////////////////////////////////////////////
// Known problems:
//
// * The combination of buffered, tiled and transparent draw will display the
// background incorrectly (scaled).
// If this is a problem for you, use non-buffered (goDirectDraw) drawing
// instead.
//
// * The combination of non-buffered, transparent and stretched draw is
// sometimes distorted with a pattern effect when the image is displayed
// smaller than the real size (shrinked).
//
// * Buffered display flickers when TGIFImage is used by a transparent TImage
// component.
// This is a problem with TImage caused by the fact that TImage was designed
// with static images in mind. Not much I can do about it.
//
////////////////////////////////////////////////////////////////////////////////
// To do (in rough order of priority):
// { TODO -oanme -cFeature : TImage hook for destroy notification. }
// { TODO -oanme -cFeature : TBitmap pool to limit resource consumption on Win95/98. }
// { TODO -oanme -cImprovement : Make BitsPerPixel property writable. }
// { TODO -oanme -cFeature : Visual GIF component. }
// { TODO -oanme -cImprovement : Easier method to determine DrawPainter status. }
// { TODO -oanme -cFeature : Import to 256+ color GIF. }
// { TODO -oanme -cFeature : Make some of TGIFImage's properties persistent (DrawOptions etc). }
// { TODO -oanme -cFeature : Add TGIFImage.Persistent property. Should save published properties in application extension when this options is set. }
// { TODO -oanme -cBugFix : Solution for background buffering in scrollbox. }
//
//////////////////////////////////////////////////////////////////////////////////
{$ifdef BCB}
{$ObjExportAll On}
{$endif}
interface
////////////////////////////////////////////////////////////////////////////////
//
// Conditional Compiler Symbols
//
////////////////////////////////////////////////////////////////////////////////
(*
DEBUG Must be defined if any of the DEBUG_xxx
symbols are defined.
If the symbol is defined the source will not be
optimized and overflow- and range checks will be
enabled.
DEBUG_HASHPERFORMANCE Calculates hash table performance data.
DEBUG_HASHFILLFACTOR Calculates fill factor of hash table -
Interferes with DEBUG_HASHPERFORMANCE.
DEBUG_COMPRESSPERFORMANCE Calculates LZW compressor performance data.
DEBUG_DECOMPRESSPERFORMANCE Calculates LZW decompressor performance data.
DEBUG_DITHERPERFORMANCE Calculates color reduction performance data.
DEBUG_DRAWPERFORMANCE Calculates low level drawing performance data.
The performance data for DEBUG_DRAWPERFORMANCE
will be displayed when you press the Ctrl key.
DEBUG_RENDERPERFORMANCE Calculates performance data for the GIF to
bitmap converter.
The performance data for DEBUG_DRAWPERFORMANCE
will be displayed when you press the Ctrl key.
GIF_NOSAFETY Define this symbol to disable overflow- and
range checks.
Ignored if the DEBUG symbol is defined.
STRICT_MOZILLA Define to mimic Mozilla as closely as possible.
If not defined, a slightly more "optimal"
implementation is used (IMHO).
FAST_AS_HELL Define this symbol to use strictly GIF compliant
(but too fast) animation timing.
Since our paint routines are much faster and
more precise timed than Mozilla's, the standard
GIF and Mozilla values causes animations to loop
faster than they would in Mozilla.
If the symbol is _not_ defined, an alternative
set of tweaked timing values will be used.
The tweaked values are not optimal but are based
on tests performed on my reference system:
- Windows 95
- 133 MHz Pentium
- 64Mb RAM
- Diamond Stealth64/V3000
- 1600*1200 in 256 colors
The alternate values can be modified if you are
not satisfied with my defaults (they can be
found a few pages down).
REGISTER_TGIFIMAGE Define this symbol to register TGIFImage with
the TPicture class and integrate with TImage.
This is required to be able to display GIFs in
the TImage component.
The symbol is defined by default.
Undefine if you use another GIF library to
provide GIF support for TImage.
PIXELFORMAT_TOO_SLOW When this symbol is defined, the internal
PixelFormat routines are used in some places
instead of TBitmap.PixelFormat.
The current implementation (Delphi4, Builder 3)
of TBitmap.PixelFormat can in some situation
degrade performance.
The symbol is defined by default.
CREATEDIBSECTION_SLOW If this symbol is defined, TDIBWriter will
use global memory as scanline storage, instead
of a DIB section.
Benchmarks have shown that a DIB section is
twice as slow as global memory.
The symbol is defined by default.
The symbol requires that PIXELFORMAT_TOO_SLOW
is defined.
SERIALIZE_RENDER Define this symbol to serialize threaded
GIF to bitmap rendering.
When a GIF is displayed with the goAsync option
(the default), the GIF to bitmap rendering is
executed in the context of the draw thread.
If more than one thread is drawing the same GIF
or the GIF is being modified while it is
animating, the GIF to bitmap rendering should be
serialized to guarantee that the bitmap isn't
modified by more than one thread at a time. If
SERIALIZE_RENDER is defined, the draw threads
uses TThread.Synchronize to serialize GIF to
bitmap rendering.
*)
{$DEFINE REGISTER_TGIFIMAGE}
{$DEFINE PIXELFORMAT_TOO_SLOW}
{$DEFINE CREATEDIBSECTION_SLOW}
////////////////////////////////////////////////////////////////////////////////
//
// Determine Delphi and C++ Builder version
//
////////////////////////////////////////////////////////////////////////////////
// Delphi 1.x
{$IFDEF VER80}
'Error: TGIFImage does not support Delphi 1.x'
{$ENDIF}
// Delphi 2.x
{$IFDEF VER90}
{$DEFINE VER9x}
{$ENDIF}
// C++ Builder 1.x
{$IFDEF VER93}
// Good luck...
{$DEFINE VER9x}
{$ENDIF}
// Delphi 3.x
{$IFDEF VER100}
{$DEFINE VER10_PLUS}
{$DEFINE D3_BCB3}
{$ENDIF}
// C++ Builder 3.x
{$IFDEF VER110}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE D3_BCB3}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
// Delphi 4.x
{$IFDEF VER120}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
// C++ Builder 4.x
{$IFDEF VER125}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
// Delphi 5.x
{$IFDEF VER130}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE VER13_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
// Delphi 6.x
{$IFDEF VER140}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE VER13_PLUS}
{$DEFINE VER14_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
// Delphi 7.x
{$IFDEF VER150}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE VER13_PLUS}
{$DEFINE VER14_PLUS}
{$DEFINE VER15_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
{$IFDEF conditionalexpressions}
{$IF RTLVersion >= 14.0} // Should be Delphi6 and up
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE VER13_PLUS}
{$DEFINE VER14_PLUS}
{$DEFINE VER15_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT} // Not sure is this still needed
{$IFEND}
{$ENDIF}
// Unknown compiler version - assume D4 compatible
{$IFNDEF VER9x}
{$IFNDEF VER10_PLUS}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
{$ENDIF}
////////////////////////////////////////////////////////////////////////////////
//
// Compiler Options required to compile this library
//
////////////////////////////////////////////////////////////////////////////////
{$A+,B-,H+,J+,K-,M-,T-,X+}
// Debug control - You can safely change these settings
{$IFDEF DEBUG}
{$C+} // ASSERTIONS
{$O-} // OPTIMIZATION
{$Q+} // OVERFLOWCHECKS
{$R+} // RANGECHECKS
{$ELSE}
{$C-} // ASSERTIONS
{$IFDEF GIF_NOSAFETY}
{$Q-}// OVERFLOWCHECKS
{$R-}// RANGECHECKS
{$ENDIF}
{$ENDIF}
// Special options for Time2Help parser
{$ifdef TIME2HELP}
{$UNDEF PIXELFORMAT_TOO_SLOW}
{$endif}
////////////////////////////////////////////////////////////////////////////////
//
// External dependecies
//
////////////////////////////////////////////////////////////////////////////////
uses
sysutils,
Windows,
Graphics,
Classes;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFImage library version
//
////////////////////////////////////////////////////////////////////////////////
const
GIFVersion = $0202;
GIFVersionMajor = 2;
GIFVersionMinor = 2;
GIFVersionRelease = 5;
////////////////////////////////////////////////////////////////////////////////
//
// Misc constants and support types
//
////////////////////////////////////////////////////////////////////////////////
const
GIFMaxColors = 256; // Max number of colors supported by GIF
// Don't bother changing this value!
BitmapAllocationThreshold = 500000; // Bitmap pixel count limit at which
// a newly allocated bitmap will be
// converted to 1 bit format before
// being resized and converted to 8 bit.
var
{$IFDEF FAST_AS_HELL}
GIFDelayExp: integer = 10; // Delay multiplier in mS.
{$ELSE}
GIFDelayExp: integer = 12; // Delay multiplier in mS. Tweaked.
{$ENDIF}
// * GIFDelayExp:
// The following delay values should all
// be multiplied by this value to
// calculate the effective time (in mS).
// According to the GIF specs, this
// value should be 10.
// Since our paint routines are much
// faster than Mozilla's, you might need
// to increase this value if your
// animations loops too fast. The
// optimal value is impossible to
// determine since it depends on the
// speed of the CPU, the viceo card,
// memory and many other factors.
GIFDefaultDelay: integer = 10; // * GIFDefaultDelay:
// Default animation delay.
// This value is used if no GCE is
// defined.
// (10 = 100 mS)
{$IFDEF FAST_AS_HELL}
GIFMinimumDelay: integer = 1; // Minimum delay (from Mozilla source).
// (1 = 10 mS)
{$ELSE}
GIFMinimumDelay: integer = 3; // Minimum delay - Tweaked.
{$ENDIF}
// * GIFMinimumDelay:
// The minumum delay used in the Mozilla
// source is 10mS. This corresponds to a
// value of 1. However, since our paint
// routines are much faster than
// Mozilla's, a value of 3 or 4 gives
// better results.
GIFMaximumDelay: integer = 1000; // * GIFMaximumDelay:
// Maximum delay when painter is running
// in main thread (goAsync is not set).
// This value guarantees that a very
// long and slow GIF does not hang the
// system.
// (1000 = 10000 mS = 10 Seconds)
type
TGIFVersion = (gvUnknown, gv87a, gv89a);
TGIFVersionRec = array[0..2] of char;
const
GIFVersions : array[gv87a..gv89a] of TGIFVersionRec = ('87a', '89a');
type
// TGIFImage mostly throws exceptions of type GIFException
GIFException = class(EInvalidGraphic);
// Severity level as indicated in the Warning methods and the OnWarning event
TGIFSeverity = (gsInfo, gsWarning, gsError);
////////////////////////////////////////////////////////////////////////////////
//
// Delphi 2.x support
//
////////////////////////////////////////////////////////////////////////////////
{$IFDEF VER9x}
// Delphi 2 doesn't support TBitmap.PixelFormat
{$DEFINE PIXELFORMAT_TOO_SLOW}
type
// TThreadList from Delphi 3 classes.pas
TThreadList = class
private
FList: TList;
FLock: TRTLCriticalSection;
public
constructor Create;
destructor Destroy; override;
procedure Add(Item: Pointer);
procedure Clear;
function LockList: TList;
procedure Remove(Item: Pointer);
procedure UnlockList;
end;
// From Delphi 3 sysutils.pas
EOutOfMemory = class(Exception);
// From Delphi 3 classes.pas
EOutOfResources = class(EOutOfMemory);
// From Delphi 3 windows.pas
PMaxLogPalette = ^TMaxLogPalette;
TMaxLogPalette = packed record
palVersion: Word;
palNumEntries: Word;
palPalEntry: array [Byte] of TPaletteEntry;
end; { TMaxLogPalette }
// From Delphi 3 graphics.pas. Used by the D3 TGraphic class.
TProgressStage = (psStarting, psRunning, psEnding);
TProgressEvent = procedure (Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string) of object;
// From Delphi 3 windows.pas
PRGBTriple = ^TRGBTriple;
{$ENDIF}
////////////////////////////////////////////////////////////////////////////////
//
// Forward declarations
//
////////////////////////////////////////////////////////////////////////////////
type
TGIFImage = class;
TGIFSubImage = class;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFItem
//
////////////////////////////////////////////////////////////////////////////////
TGIFItem = class(TPersistent)
private
FGIFImage: TGIFImage;
protected
function GetVersion: TGIFVersion; virtual;
procedure Warning(Severity: TGIFSeverity; Message: string); virtual;
public
constructor Create(GIFImage: TGIFImage); virtual;
procedure SaveToStream(Stream: TStream); virtual; abstract;
procedure LoadFromStream(Stream: TStream); virtual; abstract;
procedure SaveToFile(const Filename: string); virtual;
procedure LoadFromFile(const Filename: string); virtual;
property Version: TGIFVersion read GetVersion;
property Image: TGIFImage read FGIFImage;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFList
//
////////////////////////////////////////////////////////////////////////////////
TGIFList = class(TPersistent)
private
FItems: TList;
FImage: TGIFImage;
protected
function GetItem(Index: Integer): TGIFItem;
procedure SetItem(Index: Integer; Item: TGIFItem);
function GetCount: Integer;
procedure Warning(Severity: TGIFSeverity; Message: string); virtual;
public
constructor Create(Image: TGIFImage);
destructor Destroy; override;
function Add(Item: TGIFItem): Integer;
procedure Clear;
procedure Delete(Index: Integer);
procedure Exchange(Index1, Index2: Integer);
function First: TGIFItem;
function IndexOf(Item: TGIFItem): Integer;
procedure Insert(Index: Integer; Item: TGIFItem);
function Last: TGIFItem;
procedure Move(CurIndex, NewIndex: Integer);
function Remove(Item: TGIFItem): Integer;
procedure SaveToStream(Stream: TStream); virtual;
procedure LoadFromStream(Stream: TStream; Parent: TObject); virtual; abstract;
property Items[Index: Integer]: TGIFItem read GetItem write SetItem; default;
property Count: Integer read GetCount;
property List: TList read FItems;
property Image: TGIFImage read FImage;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFColorMap
//
////////////////////////////////////////////////////////////////////////////////
// One way to do it:
// TBaseColor = (bcRed, bcGreen, bcBlue);
// TGIFColor = array[bcRed..bcBlue] of BYTE;
// Another way:
TGIFColor = packed record
Red: byte;
Green: byte;
Blue: byte;
end;
TColorMap = packed array[0..GIFMaxColors-1] of TGIFColor;
PColorMap = ^TColorMap;
TUsageCount = record
Count : integer; // # of pixels using color index
Index : integer; // Color index
end;
TColormapHistogram = array[0..255] of TUsageCount;
TColormapReverse = array[0..255] of byte;
TGIFColorMap = class(TPersistent)
private
FColorMap : PColorMap;
FCount : integer;
FCapacity : integer;
FOptimized : boolean;
protected
function GetColor(Index: integer): TColor;
procedure SetColor(Index: integer; Value: TColor);
function GetBitsPerPixel: integer;
function DoOptimize: boolean;
procedure SetCapacity(Size: integer);
procedure Warning(Severity: TGIFSeverity; Message: string); virtual; abstract;
procedure BuildHistogram(var Histogram: TColormapHistogram); virtual; abstract;
procedure MapImages(var Map: TColormapReverse); virtual; abstract;
public
constructor Create;
destructor Destroy; override;
class function Color2RGB(Color: TColor): TGIFColor;
class function RGB2Color(Color: TGIFColor): TColor;
procedure SaveToStream(Stream: TStream);
procedure LoadFromStream(Stream: TStream; Count: integer);
procedure Assign(Source: TPersistent); override;
function IndexOf(Color: TColor): integer;
function Add(Color: TColor): integer;
function AddUnique(Color: TColor): integer;
procedure Delete(Index: integer);
procedure Clear;
function Optimize: boolean; virtual; abstract;
procedure Changed; virtual; abstract;
procedure ImportPalette(Palette: HPalette);
procedure ImportColorTable(Pal: pointer; Count: integer);
procedure ImportDIBColors(Handle: HDC);
procedure ImportColorMap(Map: TColorMap; Count: integer);
function ExportPalette: HPalette;
property Colors[Index: integer]: TColor read GetColor write SetColor; default;
property Data: PColorMap read FColorMap;
property Count: integer read FCount;
property Optimized: boolean read FOptimized write FOptimized;
property BitsPerPixel: integer read GetBitsPerPixel;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFHeader
//
////////////////////////////////////////////////////////////////////////////////
TLogicalScreenDescriptor = packed record
ScreenWidth: word; { logical screen width }
ScreenHeight: word; { logical screen height }
PackedFields: byte; { packed fields }
BackgroundColorIndex: byte; { index to global color table }
AspectRatio: byte; { actual ratio = (AspectRatio + 15) / 64 }
end;
TGIFHeader = class(TGIFItem)
private
FLogicalScreenDescriptor: TLogicalScreenDescriptor;
FColorMap : TGIFColorMap;
procedure Prepare;
protected
function GetVersion: TGIFVersion; override;
function GetBackgroundColor: TColor;
procedure SetBackgroundColor(Color: TColor);
procedure SetBackgroundColorIndex(Index: BYTE);
function GetBitsPerPixel: integer;
function GetColorResolution: integer;
public
constructor Create(GIFImage: TGIFImage); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromStream(Stream: TStream); override;
procedure Clear;
property Version: TGIFVersion read GetVersion;
property Width: WORD read FLogicalScreenDescriptor.ScreenWidth
write FLogicalScreenDescriptor.ScreenWidth;
property Height: WORD read FLogicalScreenDescriptor.ScreenHeight
write FLogicalScreenDescriptor.Screenheight;
property BackgroundColorIndex: BYTE read FLogicalScreenDescriptor.BackgroundColorIndex
write SetBackgroundColorIndex;
property BackgroundColor: TColor read GetBackgroundColor
write SetBackgroundColor;
property AspectRatio: BYTE read FLogicalScreenDescriptor.AspectRatio
write FLogicalScreenDescriptor.AspectRatio;
property ColorMap: TGIFColorMap read FColorMap;
property BitsPerPixel: integer read GetBitsPerPixel;
property ColorResolution: integer read GetColorResolution;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFExtension
//
////////////////////////////////////////////////////////////////////////////////
TGIFExtensionType = BYTE;
TGIFExtension = class;
TGIFExtensionClass = class of TGIFExtension;
TGIFGraphicControlExtension = class;
TGIFExtension = class(TGIFItem)
private
FSubImage: TGIFSubImage;
protected
function GetExtensionType: TGIFExtensionType; virtual; abstract;
function GetVersion: TGIFVersion; override;
function DoReadFromStream(Stream: TStream): TGIFExtensionType;
class procedure RegisterExtension(elabel: BYTE; eClass: TGIFExtensionClass);
class function FindExtension(Stream: TStream): TGIFExtensionClass;
class function FindSubExtension(Stream: TStream): TGIFExtensionClass; virtual;
public
// Ignore compiler warning about hiding base class constructor
constructor Create(ASubImage: TGIFSubImage); {$IFDEF VER12_PLUS} reintroduce; {$ENDIF} virtual;
destructor Destroy; override;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromStream(Stream: TStream); override;
property ExtensionType: TGIFExtensionType read GetExtensionType;
property SubImage: TGIFSubImage read FSubImage;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFSubImage
//
////////////////////////////////////////////////////////////////////////////////
TGIFExtensionList = class(TGIFList)
protected
function GetExtension(Index: Integer): TGIFExtension;
procedure SetExtension(Index: Integer; Extension: TGIFExtension);
public
procedure LoadFromStream(Stream: TStream; Parent: TObject); override;
property Extensions[Index: Integer]: TGIFExtension read GetExtension write SetExtension; default;
end;
TImageDescriptor = packed record
Separator: byte; { fixed value of ImageSeparator }
Left: word; { Column in pixels in respect to left edge of logical screen }
Top: word; { row in pixels in respect to top of logical screen }
Width: word; { width of image in pixels }
Height: word; { height of image in pixels }
PackedFields: byte; { Bit fields }
end;
TGIFSubImage = class(TGIFItem)
private
FBitmap : TBitmap;
FMask : HBitmap;
FNeedMask : boolean;
FLocalPalette : HPalette;
FData : PChar;
FDataSize : integer;
FColorMap : TGIFColorMap;
FImageDescriptor : TImageDescriptor;
FExtensions : TGIFExtensionList;
FTransparent : boolean;
FGCE : TGIFGraphicControlExtension;
procedure Prepare;
procedure Compress(Stream: TStream);
procedure Decompress(Stream: TStream);
protected
function GetVersion: TGIFVersion; override;
function GetInterlaced: boolean;
procedure SetInterlaced(Value: boolean);
function GetColorResolution: integer;
function GetBitsPerPixel: integer;
procedure AssignTo(Dest: TPersistent); override;
function DoGetBitmap: TBitmap;
function DoGetDitherBitmap: TBitmap;
function GetBitmap: TBitmap;
procedure SetBitmap(Value: TBitmap);
procedure FreeMask;
function GetEmpty: Boolean;
function GetPalette: HPALETTE;
procedure SetPalette(Value: HPalette);
function GetActiveColorMap: TGIFColorMap;
function GetBoundsRect: TRect;
procedure SetBoundsRect(const Value: TRect);
procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer);
function GetClientRect: TRect;
function GetPixel(x, y: integer): BYTE;
function GetScanline(y: integer): pointer;
procedure NewBitmap;
procedure FreeBitmap;
procedure NewImage;
procedure FreeImage;
procedure NeedImage;
function ScaleRect(DestRect: TRect): TRect;
function HasMask: boolean;
function GetBounds(Index: integer): WORD;
procedure SetBounds(Index: integer; Value: WORD);
function GetHasBitmap: boolean;
procedure SetHasBitmap(Value: boolean);
public
constructor Create(GIFImage: TGIFImage); override;
destructor Destroy; override;
procedure Clear;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromStream(Stream: TStream); override;
procedure Assign(Source: TPersistent); override;
procedure Draw(ACanvas: TCanvas; const Rect: TRect;
DoTransparent, DoTile: boolean);
procedure StretchDraw(ACanvas: TCanvas; const Rect: TRect;
DoTransparent, DoTile: boolean);
procedure Crop;
procedure Merge(Previous: TGIFSubImage);
property HasBitmap: boolean read GetHasBitmap write SetHasBitmap;
property Left: WORD index 1 read GetBounds write SetBounds;
property Top: WORD index 2 read GetBounds write SetBounds;
property Width: WORD index 3 read GetBounds write SetBounds;
property Height: WORD index 4 read GetBounds write SetBounds;
property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
property ClientRect: TRect read GetClientRect;
property Interlaced: boolean read GetInterlaced write SetInterlaced;
property ColorMap: TGIFColorMap read FColorMap;
property ActiveColorMap: TGIFColorMap read GetActiveColorMap;
property Data: PChar read FData;
property DataSize: integer read FDataSize;
property Extensions: TGIFExtensionList read FExtensions;
property Version: TGIFVersion read GetVersion;
property ColorResolution: integer read GetColorResolution;
property BitsPerPixel: integer read GetBitsPerPixel;
property Bitmap: TBitmap read GetBitmap write SetBitmap;
property Mask: HBitmap read FMask;
property Palette: HPALETTE read GetPalette write SetPalette;
property Empty: boolean read GetEmpty;
property Transparent: boolean read FTransparent;
property GraphicControlExtension: TGIFGraphicControlExtension read FGCE;
property Pixels[x, y: integer]: BYTE read GetPixel;
property Scanline[y: integer]: pointer read GetScanline;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFTrailer
//
////////////////////////////////////////////////////////////////////////////////
TGIFTrailer = class(TGIFItem)
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromStream(Stream: TStream); override;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFGraphicControlExtension
//
////////////////////////////////////////////////////////////////////////////////
// Graphic Control Extension block a.k.a GCE
TGIFGCERec = packed record
BlockSize: byte; { should be 4 }
PackedFields: Byte;
DelayTime: Word; { in centiseconds }
TransparentColorIndex: Byte;
Terminator: Byte;
end;
TDisposalMethod = (dmNone, dmNoDisposal, dmBackground, dmPrevious);
TGIFGraphicControlExtension = class(TGIFExtension)
private
FGCExtension: TGIFGCERec;
protected
function GetExtensionType: TGIFExtensionType; override;
function GetTransparent: boolean;
procedure SetTransparent(Value: boolean);
function GetTransparentColor: TColor;
procedure SetTransparentColor(Color: TColor);
function GetTransparentColorIndex: BYTE;
procedure SetTransparentColorIndex(Value: BYTE);
function GetDelay: WORD;
procedure SetDelay(Value: WORD);
function GetUserInput: boolean;
procedure SetUserInput(Value: boolean);
function GetDisposal: TDisposalMethod;
procedure SetDisposal(Value: TDisposalMethod);
public
constructor Create(ASubImage: TGIFSubImage); override;
destructor Destroy; override;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromStream(Stream: TStream); override;
property Delay: WORD read GetDelay write SetDelay;
property Transparent: boolean read GetTransparent write SetTransparent;
property TransparentColorIndex: BYTE read GetTransparentColorIndex
write SetTransparentColorIndex;
property TransparentColor: TColor read GetTransparentColor write SetTransparentColor;
property UserInput: boolean read GetUserInput write SetUserInput;
property Disposal: TDisposalMethod read GetDisposal write SetDisposal;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFTextExtension
//
////////////////////////////////////////////////////////////////////////////////
TGIFPlainTextExtensionRec = packed record
BlockSize: byte; { should be 12 }
Left, Top, Width, Height: Word;
CellWidth, CellHeight: Byte;
TextFGColorIndex,
TextBGColorIndex: Byte;
end;
TGIFTextExtension = class(TGIFExtension)
private
FText : TStrings;
FPlainTextExtension : TGIFPlainTextExtensionRec;
protected
function GetExtensionType: TGIFExtensionType; override;
function GetForegroundColor: TColor;
procedure SetForegroundColor(Color: TColor);
function GetBackgroundColor: TColor;
procedure SetBackgroundColor(Color: TColor);
function GetBounds(Index: integer): WORD;
procedure SetBounds(Index: integer; Value: WORD);
function GetCharWidthHeight(Index: integer): BYTE;
procedure SetCharWidthHeight(Index: integer; Value: BYTE);
function GetColorIndex(Index: integer): BYTE;
procedure SetColorIndex(Index: integer; Value: BYTE);
public
constructor Create(ASubImage: TGIFSubImage); override;
destructor Destroy; override;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromStream(Stream: TStream); override;
property Left: WORD index 1 read GetBounds write SetBounds;
property Top: WORD index 2 read GetBounds write SetBounds;
property GridWidth: WORD index 3 read GetBounds write SetBounds;
property GridHeight: WORD index 4 read GetBounds write SetBounds;
property CharWidth: BYTE index 1 read GetCharWidthHeight write SetCharWidthHeight;
property CharHeight: BYTE index 2 read GetCharWidthHeight write SetCharWidthHeight;
property ForegroundColorIndex: BYTE index 1 read GetColorIndex write SetColorIndex;
property ForegroundColor: TColor read GetForegroundColor;
property BackgroundColorIndex: BYTE index 2 read GetColorIndex write SetColorIndex;
property BackgroundColor: TColor read GetBackgroundColor;
property Text: TStrings read FText write FText;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFCommentExtension
//
////////////////////////////////////////////////////////////////////////////////
TGIFCommentExtension = class(TGIFExtension)
private
FText : TStrings;
protected
function GetExtensionType: TGIFExtensionType; override;
public
constructor Create(ASubImage: TGIFSubImage); override;
destructor Destroy; override;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromStream(Stream: TStream); override;
property Text: TStrings read FText;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFApplicationExtension
//
////////////////////////////////////////////////////////////////////////////////
TGIFIdentifierCode = array[0..7] of char;
TGIFAuthenticationCode = array[0..2] of char;
TGIFApplicationRec = packed record
Identifier : TGIFIdentifierCode;
Authentication : TGIFAuthenticationCode;
end;
TGIFApplicationExtension = class;
TGIFAppExtensionClass = class of TGIFApplicationExtension;
TGIFApplicationExtension = class(TGIFExtension)
private
FIdent : TGIFApplicationRec;
function GetAuthentication: string;
function GetIdentifier: string;
protected
function GetExtensionType: TGIFExtensionType; override;
procedure SetAuthentication(const Value: string);
procedure SetIdentifier(const Value: string);
procedure SaveData(Stream: TStream); virtual; abstract;
procedure LoadData(Stream: TStream); virtual; abstract;
public
constructor Create(ASubImage: TGIFSubImage); override;
destructor Destroy; override;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromStream(Stream: TStream); override;
class procedure RegisterExtension(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
class function FindSubExtension(Stream: TStream): TGIFExtensionClass; override;
property Identifier: string read GetIdentifier write SetIdentifier;
property Authentication: string read GetAuthentication write SetAuthentication;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFUnknownAppExtension
//
////////////////////////////////////////////////////////////////////////////////
TGIFBlock = class(TObject)
private
FSize : BYTE;
FData : pointer;
public
constructor Create(ASize: integer);
destructor Destroy; override;
procedure SaveToStream(Stream: TStream);
procedure LoadFromStream(Stream: TStream);
property Size: BYTE read FSize;
property Data: pointer read FData;
end;
TGIFUnknownAppExtension = class(TGIFApplicationExtension)
private
FBlocks : TList;
protected
procedure SaveData(Stream: TStream); override;
procedure LoadData(Stream: TStream); override;
public
constructor Create(ASubImage: TGIFSubImage); override;
destructor Destroy; override;
property Blocks: TList read FBlocks;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFAppExtNSLoop
//
////////////////////////////////////////////////////////////////////////////////
TGIFAppExtNSLoop = class(TGIFApplicationExtension)
private
FLoops : WORD;
FBufferSize : DWORD;
protected
procedure SaveData(Stream: TStream); override;
procedure LoadData(Stream: TStream); override;
public
constructor Create(ASubImage: TGIFSubImage); override;
property Loops: WORD read FLoops write FLoops;
property BufferSize: DWORD read FBufferSize write FBufferSize;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFImage
//
////////////////////////////////////////////////////////////////////////////////
TGIFImageList = class(TGIFList)
protected
function GetImage(Index: Integer): TGIFSubImage;
procedure SetImage(Index: Integer; SubImage: TGIFSubImage);
public
procedure LoadFromStream(Stream: TStream; Parent: TObject); override;
procedure SaveToStream(Stream: TStream); override;
property SubImages[Index: Integer]: TGIFSubImage read GetImage write SetImage; default;
end;
// Compression algorithms
TGIFCompression =
(gcLZW, // Normal LZW compression
gcRLE // GIF compatible RLE compression
);
// Color reduction methods
TColorReduction =
(rmNone, // Do not perform color reduction
rmWindows20, // Reduce to the Windows 20 color system palette
rmWindows256, // Reduce to the Windows 256 color halftone palette (Only works in 256 color display mode)
rmWindowsGray, // Reduce to the Windows 4 grayscale colors