forked from dim-s/soulengine
-
Notifications
You must be signed in to change notification settings - Fork 2
/
GifImage2.pas
12330 lines (11190 loc) · 341 KB
/
GifImage2.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 GIFImage2;
{$ifdef BCB}
{$ObjExportAll On}
{$endif}
interface
{$DEFINE REGISTER_TGIFIMAGE}
{$DEFINE PIXELFORMAT_TOO_SLOW}
{$DEFINE CREATEDIBSECTION_SLOW}
{$DEFINE FIXHEADER_WIDTHHEIGHT_SILENT}
{$DEFINE DEFAULT_GOCLEARLOOP}
{$IFDEF VER130}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE VER13_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
{$IFDEF VER140}
{$WARN SYMBOL_PLATFORM OFF}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE VER13_PLUS}
{$DEFINE VER14_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
{$IFDEF VER150}
{$WARN SYMBOL_PLATFORM OFF}
{$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}
{$IFNDEF VER9x}
{$IFNDEF VER10_PLUS}
{$WARN SYMBOL_PLATFORM OFF}
{$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}
{$ENDIF}
{$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}
{$IFDEF VER230} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER330} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER320} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER310} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER300} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER290} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER280} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER270} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER260} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER250} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER240} {$DEFINE isVER230} {$ENDIF}
uses
sysutils,
Windows,
AnsiStrings,
Graphics,
Types,
Classes;
const
GIFVersion = $0202;
GIFVersionMajor = 2;
GIFVersionMinor = 2;
GIFVersionRelease = 5;
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}
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}
GIFMaximumDelay: integer = 1000; // * GIFMaximumDelay:
type
TGIFVersion = (gvUnknown, gv87a, gv89a);
TGIFVersionRec = array[0..2] of ansichar;
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);
{$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}
type
TGIFImage = class;
TGIFSubImage = class;
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 = 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;
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;
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;
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;
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 : PAnsiChar;
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;
// 2006.10.09 ->
procedure SetPixel(x, y: integer; Value: BYTE);
// 2006.10.09 <-
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: PAnsiChar 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;
// 2006.10.09 ->
// property Pixels[x, y: integer]: BYTE read GetPixel;
property Pixels[x, y: integer]: BYTE read GetPixel write SetPixel;
// 2006.10.09 <-
property Scanline[y: integer]: pointer read GetScanline;
end;
TGIFTrailer = class(TGIFItem)
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromStream(Stream: TStream); override;
end;
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;
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 = 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;
TGIFIdentifierCode = array[0..7] of ansichar;
TGIFAuthenticationCode = array[0..2] of ansichar;
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;
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 = 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;
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;
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
rmMonochrome, // Reduce to a black/white monochrome palette
rmGrayScale, // Reduce to a uniform 256 shade grayscale palette
rmNetscape, // Reduce to the Netscape 216 color palette
rmQuantize, // Reduce to optimal 2^n color palette
rmQuantizeWindows, // Reduce to optimal 256 color windows palette
rmPalette // Reduce to custom palette
);
TDitherMode =
(dmNearest, // Nearest color matching w/o error correction
dmFloydSteinberg, // Floyd Steinberg Error Diffusion dithering
dmStucki, // Stucki Error Diffusion dithering
dmSierra, // Sierra Error Diffusion dithering
dmJaJuNI, // Jarvis, Judice & Ninke Error Diffusion dithering
dmSteveArche, // Stevenson & Arche Error Diffusion dithering
dmBurkes // Burkes Error Diffusion dithering
// dmOrdered, // Ordered dither
);
// Optimization options
TGIFOptimizeOption =
(ooCrop, // Crop animated GIF frames
ooMerge, // Merge pixels of same color
ooCleanup, // Remove comments and application extensions
ooColorMap, // Sort color map by usage and remove unused entries
ooReduceColors // Reduce color depth ***NOT IMPLEMENTED***
);
TGIFOptimizeOptions = set of TGIFOptimizeOption;
TGIFDrawOption =
(goAsync, // Asyncronous draws (paint in thread)
goTransparent, // Transparent draws
goAnimate, // Animate draws
goLoop, // Loop animations
goLoopContinously, // Ignore loop count and loop forever
goValidateCanvas, // Validate canvas in threaded paint ***NOT IMPLEMENTED***
goDirectDraw, // Draw() directly on canvas
goClearOnLoop, // Clear animation on loop
goTile, // Tiled display
goDither, // Dither to Netscape palette
goAutoDither // Only dither on 256 color systems
);
TGIFDrawOptions = set of TGIFDrawOption;
// Note: if goAsync is not set then goDirectDraw should be set. Otherwise
// the image will not be displayed.
PGIFPainter = ^TGIFPainter;
TGIFPainter = class(TThread)
private
{$IFDEF isVER230}
FsSuspended: boolean; //The suspended state directive
{$ENDIF}
FImage : TGIFImage; // The TGIFImage that owns this painter
FCanvas : TCanvas; // Destination canvas
FRect : TRect; // Destination rect
FDrawOptions : TGIFDrawOptions;// Paint options
FAnimationSpeed : integer; // Animation speed %
FActiveImage : integer; // Current frame
Disposal , // Used by synchronized paint
OldDisposal : TDisposalMethod;// Used by synchronized paint
BackupBuffer : TBitmap; // Used by synchronized paint
FrameBuffer : TBitmap; // Used by synchronized paint
Background : TBitmap; // Used by synchronized paint
ValidateDC : HDC;
DoRestart : boolean; // Flag used to restart animation
FStarted : boolean; // Flag used to signal start of paint
PainterRef : PGIFPainter; // Pointer to var referencing painter
FEventHandle : THandle; // Animation delay event
ExceptObject : Exception; // Eaten exception
ExceptAddress : pointer; // Eaten exceptions address
FEvent : TNotifyEvent; // Used by synchronized events
FOnStartPaint : TNotifyEvent;
FOnPaint : TNotifyEvent;
FOnAfterPaint : TNotifyEvent;
FOnLoop : TNotifyEvent;
FOnEndPaint : TNotifyEvent;
procedure DoOnTerminate(Sender: TObject);// Sync. shutdown procedure
procedure DoSynchronize(Method: TThreadMethod);// Conditional sync stub
{$ifdef SERIALIZE_RENDER}
procedure PrefetchBitmap; // Sync. bitmap prefetch
{$endif}
procedure DoPaintFrame; // Sync. buffered paint procedure
procedure DoPaint; // Sync. paint procedure
procedure DoEvent;
procedure SetActiveImage(const Value: integer);// Sync. event procedure
protected
procedure Execute; override;
procedure SetAnimationSpeed(Value: integer);
public
constructor Create(AImage: TGIFImage; ACanvas: TCanvas; ARect: TRect;
Options: TGIFDrawOptions);
constructor CreateRef(Painter: PGIFPainter; AImage: TGIFImage; ACanvas: TCanvas; ARect: TRect;
Options: TGIFDrawOptions);
destructor Destroy; override;
procedure Start;
procedure Stop;
procedure Restart;
property Image: TGIFImage read FImage;
property Canvas: TCanvas read FCanvas;
property Rect: TRect read FRect write FRect;
property DrawOptions: TGIFDrawOptions read FDrawOptions write FDrawOptions;
property AnimationSpeed: integer read FAnimationSpeed write SetAnimationSpeed;
property Started: boolean read FStarted;
property ActiveImage: integer read FActiveImage write SetActiveImage;
property OnStartPaint: TNotifyEvent read FOnStartPaint write FOnStartPaint;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
property OnAfterPaint: TNotifyEvent read FOnAfterPaint write FOnAfterPaint;
property OnLoop: TNotifyEvent read FOnLoop write FOnLoop;
property OnEndPaint : TNotifyEvent read FOnEndPaint write FOnEndPaint ;
property EventHandle: THandle read FEventHandle;
{$IFDEF isVER230}
procedure Suspenden;
procedure Resumenden;
{$ENDIF}
end;
TGIFWarning = procedure(Sender: TObject; Severity: TGIFSeverity; Message: string) of object;
TGIFImage = class(TGraphic)
private
IsDrawing : Boolean;
IsInsideGetPalette : boolean;
FImages : TGIFImageList;
FHeader : TGIFHeader;
FGlobalPalette : HPalette;
FPainters : TThreadList;
FDrawOptions : TGIFDrawOptions;
FColorReduction : TColorReduction;
FReductionBits : integer;
FDitherMode : TDitherMode;
FCompression : TGIFCompression;
FOnWarning : TGIFWarning;
FBitmap : TBitmap;
FDrawPainter : TGIFPainter;
FThreadPriority : TThreadPriority;
FAnimationSpeed : integer;
FForceFrame: Integer; // 2004.03.09
FDrawBackgroundColor: TColor;
FOnStartPaint : TNotifyEvent;
FOnPaint : TNotifyEvent;
FOnAfterPaint : TNotifyEvent;
FOnLoop : TNotifyEvent;
FOnEndPaint : TNotifyEvent;
{$IFDEF VER9x}
FPaletteModified : Boolean;
FOnProgress : TProgressEvent;
{$ENDIF}
function GetAnimate: Boolean; // 2002.07.07
procedure SetAnimate(const Value: Boolean); // 2002.07.07
procedure SetForceFrame(const Value: Integer); // 2004.03.09
protected
// Obsolete: procedure Changed(Sender: TObject); {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
function GetHeight: Integer; override;
procedure SetHeight(Value: Integer); override;
function GetWidth: Integer; override;
procedure SetWidth(Value: Integer); override;
procedure AssignTo(Dest: TPersistent); override;
function InternalPaint(Painter: PGIFPainter; ACanvas: TCanvas; const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
function Equals(Graphic: TGraphic): Boolean; override;
function GetPalette: HPALETTE; {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
procedure SetPalette(Value: HPalette); {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
function GetEmpty: Boolean; override;
procedure WriteData(Stream: TStream); override;
function GetIsTransparent: Boolean;
function GetVersion: TGIFVersion;
function GetColorResolution: integer;
function GetBitsPerPixel: integer;
function GetBackgroundColorIndex: BYTE;
procedure SetBackgroundColorIndex(const Value: BYTE);
function GetBackgroundColor: TColor;
procedure SetBackgroundColor(const Value: TColor);
function GetAspectRatio: BYTE;
procedure SetAspectRatio(const Value: BYTE);
procedure SetDrawOptions(Value: TGIFDrawOptions);
procedure SetAnimationSpeed(Value: integer);
procedure SetReductionBits(Value: integer);
procedure NewImage;
function GetBitmap: TBitmap;
function NewBitmap: TBitmap;
procedure FreeBitmap;
function GetColorMap: TGIFColorMap;
function GetDoDither: boolean;
property DrawPainter: TGIFPainter read FDrawPainter; // Extremely volatile
property DoDither: boolean read GetDoDither;
{$IFDEF VER9x}
procedure Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
{$ENDIF}
{$IFDEF FIXHEADER_WIDTHHEIGHT_SILENT}
procedure FixHeaderWidthHeight; // 2006.07.09
{$ENDIF}
public
constructor Create; override;
destructor Destroy; override;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromStream(Stream: TStream); override;
procedure LoadFromResourceName(Instance: THandle; const ResName: String); // 2002.07.07
function Add(Source: TPersistent): integer;
procedure Pack;
procedure OptimizeColorMap;
procedure Optimize(Options: TGIFOptimizeOptions;
ColorReduction: TColorReduction; DitherMode: TDitherMode;
ReductionBits: integer);
procedure Clear;
procedure StopDraw;
function Paint(ACanvas: TCanvas; const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
procedure PaintStart;
procedure PaintPause;
procedure PaintStop;
procedure PaintResume;
procedure PaintRestart;
procedure Warning(Sender: TObject; Severity: TGIFSeverity; Message: string); virtual;
procedure Assign(Source: TPersistent); override;
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE); override;
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE); override;
property GlobalColorMap: TGIFColorMap read GetColorMap;
property Version: TGIFVersion read GetVersion;
property Images: TGIFImageList read FImages;
property ColorResolution: integer read GetColorResolution;
property BitsPerPixel: integer read GetBitsPerPixel;
property BackgroundColorIndex: BYTE read GetBackgroundColorIndex write SetBackgroundColorIndex;
property BackgroundColor: TColor read GetBackgroundColor write SetBackgroundColor;
property AspectRatio: BYTE read GetAspectRatio write SetAspectRatio;
property Header: TGIFHeader read FHeader; // ***OBSOLETE***
property IsTransparent: boolean read GetIsTransparent;
property DrawOptions: TGIFDrawOptions read FDrawOptions write SetDrawOptions;
property DrawBackgroundColor: TColor read FDrawBackgroundColor write FDrawBackgroundColor;
property ColorReduction: TColorReduction read FColorReduction write FColorReduction;
property ReductionBits: integer read FReductionBits write SetReductionBits;
property DitherMode: TDitherMode read FDitherMode write FDitherMode;
property Compression: TGIFCompression read FCompression write FCompression;
property AnimationSpeed: integer read FAnimationSpeed write SetAnimationSpeed;
property Animate: Boolean read GetAnimate write SetAnimate; // 2002.07.07
property ForceFrame: Integer read FForceFrame write SetForceFrame; // 2004.03.09
property Painters: TThreadList read FPainters;
property ThreadPriority: TThreadPriority read FThreadPriority write FThreadPriority;
property Bitmap: TBitmap read GetBitmap; // Volatile - beware!
property OnWarning: TGIFWarning read FOnWarning write FOnWarning;
property OnStartPaint: TNotifyEvent read FOnStartPaint write FOnStartPaint;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
property OnAfterPaint: TNotifyEvent read FOnAfterPaint write FOnAfterPaint;
property OnLoop: TNotifyEvent read FOnLoop write FOnLoop;
property OnEndPaint : TNotifyEvent read FOnEndPaint write FOnEndPaint ;
{$IFDEF VER9x}
property Palette: HPALETTE read GetPalette write SetPalette;
property PaletteModified: Boolean read FPaletteModified write FPaletteModified;
property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
{$ENDIF}
end;
////////////////////////////////////////////////////////////////////////////////
//
// Utility routines
//
////////////////////////////////////////////////////////////////////////////////
// WebPalette creates a 216 color uniform palette a.k.a. the Netscape Palette
function WebPalette: HPalette;
// ReduceColors
// Map colors in a bitmap to their nearest representation in a palette using
// the methods specified by the ColorReduction and DitherMode parameters.
// The ReductionBits parameter specifies the desired number of colors (bits
// per pixel) when the reduction method is rmQuantize. The CustomPalette
// specifies the palette when the rmPalette reduction method is used.
function ReduceColors(Bitmap: TBitmap; ColorReduction: TColorReduction;
DitherMode: TDitherMode; ReductionBits: integer; CustomPalette: hPalette): TBitmap;
// CreateOptimizedPaletteFromManyBitmaps
//: Performs Color Quantization on multiple bitmaps.
// The Bitmaps parameter is a list of bitmaps. Returns an optimized palette.
function CreateOptimizedPaletteFromManyBitmaps(Bitmaps: TList; Colors, ColorBits: integer;
Windows: boolean): hPalette;
{$IFDEF VER9x}
// From Delphi 3 graphics.pas
type
TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom);
{$ENDIF}
procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
var ImageSize: longInt; PixelFormat: TPixelFormat);
function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;
////////////////////////////////////////////////////////////////////////////////
//
// Global variables
//
////////////////////////////////////////////////////////////////////////////////
// GIF Clipboard format identifier for use by LoadFromClipboardFormat and
// SaveToClipboardFormat.
// Set in Initialization section.
var
CF_GIF: WORD;
////////////////////////////////////////////////////////////////////////////////
//
// Library defaults
//
////////////////////////////////////////////////////////////////////////////////
var
//: Default options for TGIFImage.DrawOptions.
GIFImageDefaultDrawOptions : TGIFDrawOptions =
[goAsync, goLoop, goTransparent, goAnimate, goDither, goAutoDither
{$IFDEF STRICT_MOZILLA}
,goClearOnLoop
{$ENDIF}
{$IFDEF DEFAULT_GOCLEARLOOP} // 2006.07.10
,goClearOnLoop
{$ENDIF}
];
// WARNING! Do not use goAsync and goDirectDraw unless you have absolute
// control of the destination canvas.
// TGIFPainter will continue to write on the canvas even after the canvas has
// been deleted, unless *you* prevent it.
// The goValidateCanvas option will fix this problem if it is ever implemented.
//: Default color reduction methods for bitmap import.
// These are the fastest settings, but also the ones that gives the
// worst result (in most cases).
GIFImageDefaultColorReduction: TColorReduction = rmNetscape;
GIFImageDefaultColorReductionBits: integer = 8; // Range 3 - 8
GIFImageDefaultDitherMode: TDitherMode = dmNearest;
//: Default encoder compression method.
GIFImageDefaultCompression: TGIFCompression = gcLZW;
//: Default painter thread priority
GIFImageDefaultThreadPriority: TThreadPriority = tpNormal;
//: Default animation speed in % of normal speed (range 0 - 1000)