source: trunk/Packages/bgrabitmap/bgraanimatedgif.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 35.4 KB
Line 
1unit BGRAAnimatedGif;
2
3{$mode objfpc}{$H+}
4{$i bgrabitmap.inc}
5
6interface
7
8uses
9 Classes, SysUtils, BGRAGraphics, FPImage, BGRABitmap, BGRABitmapTypes,
10 BGRAPalette, BGRAGifFormat;
11
12type
13 TDisposeMode = BGRAGifFormat.TDisposeMode;
14 TGifSubImage = BGRAGifFormat.TGifSubImage;
15 TGifSubImageArray = BGRAGifFormat.TGifSubImageArray;
16
17 //how to deal with the background under the GIF animation
18 TGifBackgroundMode = (gbmSimplePaint, gbmEraseBackground,
19 gbmSaveBackgroundOnce, gbmUpdateBackgroundContinuously);
20
21 { TBGRAAnimatedGif }
22
23 TBGRAAnimatedGif = class(TGraphic)
24 private
25 FAspectRatio: single;
26 FWidth, FHeight: integer;
27 FBackgroundColor: TColor;
28
29 FPrevDate: TDateTime;
30 FPaused: boolean;
31 FTimeAccumulator: double;
32 FCurrentImage, FWantedImage: integer;
33 FTotalAnimationTime: int64;
34 FPreviousDisposeMode: TDisposeMode;
35
36 FBackgroundImage, FPreviousVirtualScreen, FStretchedVirtualScreen,
37 FInternalVirtualScreen, FRestoreImage: TBGRABitmap;
38 FImageChanged: boolean;
39
40 procedure CheckFrameIndex(AIndex: integer);
41 function GetAverageDelayMs: integer;
42 function GetCount: integer;
43 function GetFrameDelayMs(AIndex: integer): integer;
44 function GetFrameDisposeMode(AIndex: integer): TDisposeMode;
45 function GetFrameHasLocalPalette(AIndex: integer): boolean;
46 function GetFrameImage(AIndex: integer): TBGRABitmap;
47 function GetFrameImagePos(AIndex: integer): TPoint;
48 function GetTimeUntilNextImage: integer;
49 procedure Render(StretchWidth, StretchHeight: integer);
50 procedure SetAspectRatio(AValue: single);
51 procedure SetBackgroundColor(AValue: TColor);
52 procedure SetFrameDelayMs(AIndex: integer; AValue: integer);
53 procedure SetFrameDisposeMode(AIndex: integer; AValue: TDisposeMode);
54 procedure SetFrameHasLocalPalette(AIndex: integer; AValue: boolean);
55 procedure SetFrameImage(AIndex: integer; AValue: TBGRABitmap);
56 procedure SetFrameImagePos(AIndex: integer; AValue: TPoint);
57 procedure UpdateSimple(Canvas: TCanvas; ARect: TRect;
58 DrawOnlyIfChanged: boolean = True);
59 procedure UpdateEraseBackground(Canvas: TCanvas; ARect: TRect;
60 DrawOnlyIfChanged: boolean = True);
61 procedure Init;
62 function GetBitmap: TBitmap;
63 function GetMemBitmap: TBGRABitmap;
64 procedure SaveBackgroundOnce(Canvas: TCanvas; ARect: TRect);
65 procedure SetCurrentImage(Index: integer);
66
67 protected
68 FImages: TGifSubImageArray;
69
70 {TGraphic}
71 procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
72 function GetEmpty: boolean; override;
73 function GetHeight: integer; override;
74 function GetTransparent: boolean; override;
75 function GetWidth: integer; override;
76 procedure SetHeight({%H-}Value: integer); override;
77 procedure SetTransparent({%H-}Value: boolean); override;
78 procedure SetWidth({%H-}Value: integer); override;
79 procedure ClearViewer; virtual;
80
81 public
82 EraseColor: TColor;
83 BackgroundMode: TGifBackgroundMode;
84 LoopCount: Word;
85 LoopDone: Integer;
86
87 constructor Create(filenameUTF8: string); overload;
88 constructor Create(stream: TStream); overload;
89 constructor Create(stream: TStream; AMaxImageCount: integer); overload;
90 constructor Create; overload; override;
91 function Duplicate: TBGRAAnimatedGif;
92 function AddFrame(AImage: TFPCustomImage; X,Y: integer; ADelayMs: integer;
93 ADisposeMode: TDisposeMode = dmErase; AHasLocalPalette: boolean = false) : integer;
94 procedure InsertFrame(AIndex: integer; AImage: TFPCustomImage; X,Y: integer; ADelayMs: integer;
95 ADisposeMode: TDisposeMode = dmErase; AHasLocalPalette: boolean = false);
96 procedure DeleteFrame(AIndex: integer; AEnsureNextFrameDoesNotChange: boolean);
97
98 //add a frame that replaces completely the previous one
99 function AddFullFrame(AImage: TFPCustomImage; ADelayMs: integer;
100 AHasLocalPalette: boolean = true): integer;
101 procedure InsertFullFrame(AIndex: integer;
102 AImage: TFPCustomImage; ADelayMs: integer;
103 AHasLocalPalette: boolean = true);
104 procedure ReplaceFullFrame(AIndex: integer;
105 AImage: TFPCustomImage; ADelayMs: integer;
106 AHasLocalPalette: boolean = true);
107
108 {TGraphic}
109 procedure LoadFromStream(Stream: TStream); overload; override;
110 procedure LoadFromStream(Stream: TStream; AMaxImageCount: integer); overload;
111 procedure LoadFromResource(AFilename: string);
112 procedure SaveToStream(Stream: TStream); overload; override;
113 procedure LoadFromFile(const AFilenameUTF8: string); override;
114 procedure SaveToFile(const AFilenameUTF8: string); override;
115 class function GetFileExtensions: string; override;
116
117 procedure SetSize(AWidth,AHeight: integer); virtual;
118 procedure SaveToStream(Stream: TStream; AQuantizer: TBGRAColorQuantizerAny;
119 ADitheringAlgorithm: TDitheringAlgorithm); overload; virtual;
120 procedure Clear; override;
121 destructor Destroy; override;
122 procedure Pause;
123 procedure Resume;
124
125 procedure Show(Canvas: TCanvas; ARect: TRect); overload;
126 procedure Update(Canvas: TCanvas; ARect: TRect); overload;
127 procedure Hide(Canvas: TCanvas; ARect: TRect); overload;
128
129 property BackgroundColor: TColor Read FBackgroundColor write SetBackgroundColor;
130 property Count: integer Read GetCount;
131 property Width: integer Read FWidth;
132 property Height: integer Read FHeight;
133 property Paused: boolean Read FPaused;
134 property Bitmap: TBitmap Read GetBitmap;
135 property MemBitmap: TBGRABitmap Read GetMemBitmap;
136 property CurrentImage: integer Read FCurrentImage Write SetCurrentImage;
137 property TimeUntilNextImageMs: integer read GetTimeUntilNextImage;
138 property FrameImage[AIndex: integer]: TBGRABitmap read GetFrameImage write SetFrameImage;
139 property FrameHasLocalPalette[AIndex: integer]: boolean read GetFrameHasLocalPalette write SetFrameHasLocalPalette;
140 property FrameImagePos[AIndex: integer]: TPoint read GetFrameImagePos write SetFrameImagePos;
141 property FrameDelayMs[AIndex: integer]: integer read GetFrameDelayMs write SetFrameDelayMs;
142 property FrameDisposeMode[AIndex: integer]: TDisposeMode read GetFrameDisposeMode write SetFrameDisposeMode;
143 property AspectRatio: single read FAspectRatio write SetAspectRatio;
144 property TotalAnimationTimeMs: Int64 read FTotalAnimationTime;
145 property AverageDelayMs: integer read GetAverageDelayMs;
146 end;
147
148 { TBGRAReaderGIF }
149
150 TBGRAReaderGIF = class(TFPCustomImageReader)
151 protected
152 procedure InternalRead(Str: TStream; Img: TFPCustomImage); override;
153 function InternalCheck(Str: TStream): boolean; override;
154 end;
155
156 { TBGRAWriterGIF }
157
158 TBGRAWriterGIF = class(TFPCustomImageWriter)
159 protected
160 procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override;
161 end;
162
163const
164 GifBackgroundModeStr: array[TGifBackgroundMode] of string =
165 ('gbmSimplePaint', 'gbmEraseBackground', 'gbmSaveBackgroundOnce',
166 'gbmUpdateBackgroundContinuously');
167
168implementation
169
170uses BGRABlend, BGRAUTF8{$IFDEF BGRABITMAP_USE_LCL}, Graphics{$ENDIF};
171
172const
173 {$IFDEF ENDIAN_LITTLE}
174 AlphaMask = $FF000000;
175 {$ELSE}
176 AlphaMask = $000000FF;
177 {$ENDIF}
178
179
180{ TBGRAAnimatedGif }
181
182class function TBGRAAnimatedGif.GetFileExtensions: string;
183begin
184 Result := 'gif';
185end;
186
187procedure TBGRAAnimatedGif.SetSize(AWidth, AHeight: integer);
188begin
189 ClearViewer;
190 FWidth := AWidth;
191 FHeight := AHeight;
192end;
193
194procedure TBGRAAnimatedGif.SaveToStream(Stream: TStream;
195 AQuantizer: TBGRAColorQuantizerAny;
196 ADitheringAlgorithm: TDitheringAlgorithm);
197var data: TGIFData;
198begin
199 data.Height:= Height;
200 data.Width := Width;
201 data.AspectRatio := 1;
202 data.BackgroundColor := BackgroundColor;
203 data.Images := FImages;
204 data.LoopCount := LoopCount;
205 GIFSaveToStream(data, Stream, AQuantizer, ADitheringAlgorithm);
206end;
207
208procedure TBGRAAnimatedGif.Render(StretchWidth, StretchHeight: integer);
209var
210 curDate: TDateTime;
211 previousImage, nextImage: integer;
212
213begin
214 if FInternalVirtualScreen = nil then
215 begin
216 FInternalVirtualScreen := TBGRABitmap.Create(FWidth, FHeight);
217 if (Count = 0) and (BackgroundColor <> clNone) then
218 FInternalVirtualScreen.Fill(BackgroundColor)
219 else
220 FInternalVirtualScreen.Fill(BGRAPixelTransparent);
221 FImageChanged := True;
222 end;
223
224 if Count = 0 then
225 exit;
226
227 previousImage := FCurrentImage;
228
229 curDate := Now;
230 if FWantedImage <> -1 then
231 begin
232 nextImage := FWantedImage;
233 FTimeAccumulator := 0;
234 FWantedImage := -1;
235 end
236 else
237 if FCurrentImage = -1 then
238 begin
239 nextImage := 0;
240 FTimeAccumulator := 0;
241 FPreviousDisposeMode := dmNone;
242 end
243 else
244 begin
245 if not FPaused then
246 FTimeAccumulator += (curDate - FPrevDate) * 24 * 60 * 60 * 1000;
247 if FTotalAnimationTime > 0 then FTimeAccumulator:= frac(FTimeAccumulator/FTotalAnimationTime)*FTotalAnimationTime;
248 nextImage := FCurrentImage;
249 while FTimeAccumulator > FImages[nextImage].DelayMs do
250 begin
251 FTimeAccumulator -= FImages[nextImage].DelayMs;
252 Inc(nextImage);
253 if nextImage >= Count then
254 begin
255 if (LoopCount > 0) and (LoopDone >= LoopCount-1) then
256 begin
257 LoopDone := LoopCount;
258 dec(nextImage);
259 break;
260 end else
261 begin
262 nextImage := 0;
263 inc(LoopDone);
264 end;
265 end;
266
267 if nextImage = previousImage then
268 begin
269 if not ((LoopCount > 0) and (LoopDone >= LoopCount-1)) then
270 begin
271 Inc(nextImage);
272 if nextImage >= Count then
273 nextImage := 0;
274 end;
275 break;
276 end;
277 end;
278 end;
279 FPrevDate := curDate;
280
281 while FCurrentImage <> nextImage do
282 begin
283 Inc(FCurrentImage);
284 if FCurrentImage >= Count then
285 begin
286 FCurrentImage := 0;
287 FPreviousDisposeMode := dmErase;
288 end;
289
290 case FPreviousDisposeMode of
291 dmErase: FInternalVirtualScreen.Fill(BGRAPixelTransparent);
292 dmRestore: if FRestoreImage <> nil then
293 FInternalVirtualScreen.PutImage(0, 0, FRestoreImage, dmSet);
294 end;
295
296 with FImages[FCurrentImage] do
297 begin
298 if disposeMode = dmRestore then
299 begin
300 if FRestoreImage = nil then
301 FRestoreImage := TBGRABitmap.Create(FWidth, FHeight);
302 FRestoreImage.PutImage(0, 0, FInternalVirtualScreen, dmSet);
303 end;
304
305 if Image <> nil then
306 FInternalVirtualScreen.PutImage(Position.X, Position.Y, Image,
307 dmSetExceptTransparent);
308 FPreviousDisposeMode := DisposeMode;
309 end;
310
311 FImageChanged := True;
312 previousImage := FCurrentImage;
313 FInternalVirtualScreen.InvalidateBitmap;
314 end;
315
316 if FStretchedVirtualScreen <> nil then
317 FStretchedVirtualScreen.FreeReference;
318 if (FInternalVirtualScreen.Width = StretchWidth) and
319 (FInternalVirtualScreen.Height = StretchHeight) then
320 FStretchedVirtualScreen := TBGRABitmap(FInternalVirtualScreen.NewReference)
321 else
322 FStretchedVirtualScreen :=
323 TBGRABitmap(FInternalVirtualScreen.Resample(StretchWidth, StretchHeight));
324end;
325
326procedure TBGRAAnimatedGif.SetAspectRatio(AValue: single);
327begin
328 if AValue < 0.25 then AValue := 0.25;
329 if AValue > 4 then AValue := 4;
330 if FAspectRatio=AValue then Exit;
331 FAspectRatio:=AValue;
332end;
333
334procedure TBGRAAnimatedGif.SetBackgroundColor(AValue: TColor);
335begin
336 if FBackgroundColor=AValue then Exit;
337 FBackgroundColor:=AValue;
338end;
339
340procedure TBGRAAnimatedGif.SetFrameDelayMs(AIndex: integer; AValue: integer);
341begin
342 CheckFrameIndex(AIndex);
343 if AValue < 0 then AValue := 0;
344 FTotalAnimationTime := FTotalAnimationTime + AValue - FImages[AIndex].DelayMs;
345 FImages[AIndex].DelayMs := AValue;
346end;
347
348procedure TBGRAAnimatedGif.SetFrameDisposeMode(AIndex: integer;
349 AValue: TDisposeMode);
350begin
351 CheckFrameIndex(AIndex);
352 FImages[AIndex].DisposeMode := AValue;
353end;
354
355procedure TBGRAAnimatedGif.SetFrameHasLocalPalette(AIndex: integer;
356 AValue: boolean);
357begin
358 CheckFrameIndex(AIndex);
359 FImages[AIndex].HasLocalPalette := AValue;
360
361end;
362
363procedure TBGRAAnimatedGif.SetFrameImage(AIndex: integer; AValue: TBGRABitmap);
364var ACopy: TBGRABitmap;
365begin
366 CheckFrameIndex(AIndex);
367 ACopy := AValue.Duplicate as TBGRABitmap;
368 FImages[AIndex].Image.FreeReference;
369 FImages[AIndex].Image := ACopy;
370end;
371
372procedure TBGRAAnimatedGif.SetFrameImagePos(AIndex: integer; AValue: TPoint);
373begin
374 CheckFrameIndex(AIndex);
375 FImages[AIndex].Position := AValue;
376end;
377
378procedure TBGRAAnimatedGif.UpdateSimple(Canvas: TCanvas; ARect: TRect;
379 DrawOnlyIfChanged: boolean = True);
380begin
381 if FPreviousVirtualScreen <> nil then
382 begin
383 FPreviousVirtualScreen.FreeReference;
384 FPreviousVirtualScreen := nil;
385 end;
386
387 Render(ARect.Right - ARect.Left, ARect.Bottom - ARect.Top);
388 if FImageChanged then
389 begin
390 FStretchedVirtualScreen.Draw(Canvas, ARect.Left, ARect.Top, False);
391 FImageChanged := False;
392 end
393 else
394 if not DrawOnlyIfChanged then
395 FStretchedVirtualScreen.Draw(Canvas, ARect.Left, ARect.Top, False);
396
397 FPreviousVirtualScreen := TBGRABitmap(FStretchedVirtualScreen.NewReference);
398end;
399
400procedure TBGRAAnimatedGif.CheckFrameIndex(AIndex: integer);
401begin
402 if (AIndex < 0) or (AIndex >= Count) then Raise ERangeError.Create('Index out of bounds');
403end;
404
405function TBGRAAnimatedGif.GetAverageDelayMs: integer;
406var sum: int64;
407 i: Integer;
408begin
409 if Count > 0 then
410 begin
411 sum := 0;
412 for i := 0 to Count-1 do
413 inc(sum, FrameDelayMs[i]);
414 result := sum div Count;
415 end else
416 result := 100; //default
417end;
418
419function TBGRAAnimatedGif.GetCount: integer;
420begin
421 Result := length(FImages);
422end;
423
424function TBGRAAnimatedGif.GetFrameDelayMs(AIndex: integer): integer;
425begin
426 CheckFrameIndex(AIndex);
427 result := FImages[AIndex].DelayMs;
428end;
429
430function TBGRAAnimatedGif.GetFrameDisposeMode(AIndex: integer): TDisposeMode;
431begin
432 CheckFrameIndex(AIndex);
433 result := FImages[AIndex].DisposeMode;
434end;
435
436function TBGRAAnimatedGif.GetFrameHasLocalPalette(AIndex: integer): boolean;
437begin
438 CheckFrameIndex(AIndex);
439 result := FImages[AIndex].HasLocalPalette;
440end;
441
442function TBGRAAnimatedGif.GetFrameImage(AIndex: integer): TBGRABitmap;
443begin
444 CheckFrameIndex(AIndex);
445 result := FImages[AIndex].Image;
446end;
447
448function TBGRAAnimatedGif.GetFrameImagePos(AIndex: integer): TPoint;
449begin
450 CheckFrameIndex(AIndex);
451 result := FImages[AIndex].Position;
452end;
453
454function TBGRAAnimatedGif.GetTimeUntilNextImage: integer;
455var
456 acc: double;
457begin
458 if Count <= 1 then result := 60*1000 else
459 if (FWantedImage <> -1) or (FCurrentImage = -1) then
460 result := 0
461 else
462 begin
463 acc := FTimeAccumulator;
464 if not FPaused then acc += (Now- FPrevDate) * 24 * 60 * 60 * 1000;
465 if acc >= FImages[FCurrentImage].DelayMs then
466 result := 0
467 else
468 result := round(FImages[FCurrentImage].DelayMs-FTimeAccumulator);
469 end;
470end;
471
472constructor TBGRAAnimatedGif.Create(filenameUTF8: string);
473begin
474 inherited Create;
475 Init;
476 LoadFromFile(filenameUTF8);
477end;
478
479constructor TBGRAAnimatedGif.Create(stream: TStream);
480begin
481 inherited Create;
482 Init;
483 LoadFromStream(stream);
484end;
485
486constructor TBGRAAnimatedGif.Create(stream: TStream; AMaxImageCount: integer);
487begin
488 inherited Create;
489 Init;
490 LoadFromStream(stream, AMaxImageCount);
491end;
492
493constructor TBGRAAnimatedGif.Create;
494begin
495 inherited Create;
496 Init;
497 LoadFromStream(nil);
498end;
499
500function TBGRAAnimatedGif.Duplicate: TBGRAAnimatedGif;
501var
502 i: integer;
503begin
504 Result := TBGRAAnimatedGif.Create;
505 setlength(Result.FImages, length(FImages));
506 for i := 0 to high(FImages) do
507 begin
508 Result.FImages[i] := FImages[i];
509 FImages[i].Image.NewReference;
510 end;
511 Result.FWidth := FWidth;
512 Result.FHeight := FHeight;
513 Result.FBackgroundColor := FBackgroundColor;
514end;
515
516function TBGRAAnimatedGif.AddFrame(AImage: TFPCustomImage; X, Y: integer;
517 ADelayMs: integer; ADisposeMode: TDisposeMode; AHasLocalPalette: boolean
518 ): integer;
519begin
520 result := length(FImages);
521 setlength(FImages, length(FImages)+1);
522 if ADelayMs < 0 then ADelayMs:= 0;
523 with FImages[result] do
524 begin
525 Image := TBGRABitmap.Create(AImage);
526 Position := Point(x,y);
527 DelayMs := ADelayMs;
528 HasLocalPalette := AHasLocalPalette;
529 DisposeMode := ADisposeMode;
530 end;
531 inc(FTotalAnimationTime, ADelayMs);
532end;
533
534procedure TBGRAAnimatedGif.InsertFrame(AIndex: integer; AImage: TFPCustomImage; X,
535 Y: integer; ADelayMs: integer; ADisposeMode: TDisposeMode;
536 AHasLocalPalette: boolean);
537var i: integer;
538begin
539 if (AIndex < 0) or (AIndex > Count) then
540 raise ERangeError.Create('Index out of bounds');
541 setlength(FImages, length(FImages)+1);
542 if ADelayMs < 0 then ADelayMs:= 0;
543 for i := high(FImages) downto AIndex+1 do
544 FImages[i] := FImages[i-1];
545 with FImages[AIndex] do
546 begin
547 Image := TBGRABitmap.Create(AImage);
548 Position := Point(x,y);
549 DelayMs := ADelayMs;
550 HasLocalPalette := AHasLocalPalette;
551 DisposeMode := ADisposeMode;
552 end;
553 inc(FTotalAnimationTime, ADelayMs);
554end;
555
556function TBGRAAnimatedGif.AddFullFrame(AImage: TFPCustomImage;
557 ADelayMs: integer; AHasLocalPalette: boolean): integer;
558begin
559 if (AImage.Width <> Width) or (AImage.Height <> Height) then
560 raise exception.Create('Size mismatch');
561 if Count > 0 then
562 FrameDisposeMode[Count-1] := dmErase;
563 result := AddFrame(AImage, 0,0, ADelayMs, dmErase, AHasLocalPalette);
564end;
565
566procedure TBGRAAnimatedGif.InsertFullFrame(AIndex: integer;
567 AImage: TFPCustomImage; ADelayMs: integer; AHasLocalPalette: boolean);
568var nextImage: TBGRABitmap;
569begin
570 if (AIndex < 0) or (AIndex > Count) then
571 raise ERangeError.Create('Index out of bounds');
572
573 if AIndex = Count then
574 AddFullFrame(AImage, ADelayMs, AHasLocalPalette)
575 else
576 begin
577 //if previous image did not clear up, ensure that
578 //next image will stay the same
579 if (AIndex > 0) and (FrameDisposeMode[AIndex-1] <> dmErase) then
580 begin
581 CurrentImage := AIndex;
582 nextImage := MemBitmap.Duplicate as TBGRABitmap;
583 FrameImagePos[AIndex] := Point(0,0);
584 FrameImage[AIndex] := nextImage;
585 FrameHasLocalPalette[AIndex] := true;
586 FreeAndNil(nextImage);
587
588 FrameDisposeMode[AIndex-1] := dmErase;
589 end;
590
591 InsertFrame(AIndex, AImage, 0,0, ADelayMs, dmErase, AHasLocalPalette);
592 end;
593end;
594
595procedure TBGRAAnimatedGif.ReplaceFullFrame(AIndex: integer;
596 AImage: TFPCustomImage; ADelayMs: integer; AHasLocalPalette: boolean);
597begin
598 DeleteFrame(AIndex, True);
599 if AIndex > 0 then FrameDisposeMode[AIndex-1] := dmErase;
600 InsertFrame(AIndex, AImage, 0,0, ADelayMs, dmErase, AHasLocalPalette);
601end;
602
603procedure TBGRAAnimatedGif.DeleteFrame(AIndex: integer;
604 AEnsureNextFrameDoesNotChange: boolean);
605var
606 nextImage: TBGRABitmap;
607 i: Integer;
608begin
609 CheckFrameIndex(AIndex);
610
611 //if this frame did not clear up, ensure that
612 //next image will stay the same
613 if AEnsureNextFrameDoesNotChange and
614 ((AIndex < Count-1) and (FrameDisposeMode[AIndex] <> dmErase)) then
615 begin
616 CurrentImage := AIndex+1;
617 nextImage := MemBitmap.Duplicate as TBGRABitmap;
618 FrameImagePos[AIndex+1] := Point(0,0);
619 FrameImage[AIndex+1] := nextImage;
620 FrameHasLocalPalette[AIndex+1] := true;
621 FreeAndNil(nextImage);
622 end;
623
624 dec(FTotalAnimationTime, FImages[AIndex].DelayMs);
625
626 FImages[AIndex].Image.FreeReference;
627 for i := AIndex to Count-2 do
628 FImages[i] := FImages[i+1];
629 SetLength(FImages, Count-1);
630
631 if (CurrentImage >= Count) then
632 CurrentImage := 0;
633end;
634
635procedure TBGRAAnimatedGif.LoadFromStream(Stream: TStream);
636begin
637 LoadFromStream(Stream, maxLongint);
638end;
639
640procedure TBGRAAnimatedGif.LoadFromStream(Stream: TStream;
641 AMaxImageCount: integer);
642var data: TGIFData;
643 i: integer;
644begin
645 data := GIFLoadFromStream(Stream, AMaxImageCount);
646
647 ClearViewer;
648 Clear;
649 FWidth := data.Width;
650 FHeight := data.Height;
651 FBackgroundColor := data.BackgroundColor;
652 FAspectRatio:= data.AspectRatio;
653 LoopDone := 0;
654 LoopCount := data.LoopCount;
655
656 SetLength(FImages, length(data.Images));
657 FTotalAnimationTime:= 0;
658 for i := 0 to high(FImages) do
659 begin
660 FImages[i] := data.Images[i];
661 FTotalAnimationTime += FImages[i].DelayMs;
662 end;
663end;
664
665procedure TBGRAAnimatedGif.LoadFromResource(AFilename: string);
666var
667 stream: TStream;
668begin
669 stream := BGRAResource.GetResourceStream(AFilename);
670 try
671 LoadFromStream(stream);
672 finally
673 stream.Free;
674 end;
675end;
676
677procedure TBGRAAnimatedGif.SaveToStream(Stream: TStream);
678begin
679 SaveToStream(Stream, BGRAColorQuantizerFactory, daFloydSteinberg);
680end;
681
682procedure TBGRAAnimatedGif.LoadFromFile(const AFilenameUTF8: string);
683var stream: TFileStreamUTF8;
684begin
685 stream := TFileStreamUTF8.Create(AFilenameUTF8,fmOpenRead or fmShareDenyWrite);
686 try
687 LoadFromStream(stream);
688 finally
689 Stream.Free;
690 end;
691end;
692
693procedure TBGRAAnimatedGif.SaveToFile(const AFilenameUTF8: string);
694var
695 Stream: TFileStreamUTF8;
696begin
697 Stream := TFileStreamUTF8.Create(AFilenameUTF8, fmCreate);
698 try
699 SaveToStream(Stream);
700 finally
701 Stream.Free;
702 end;
703end;
704
705procedure TBGRAAnimatedGif.Draw(ACanvas: TCanvas; const Rect: TRect);
706begin
707 if FBackgroundImage <> nil then
708 FreeAndNil(FBackgroundImage);
709 SaveBackgroundOnce(ACanvas, Rect);
710
711 if FPreviousVirtualScreen <> nil then
712 begin
713 FPreviousVirtualScreen.FreeReference;
714 FPreviousVirtualScreen := nil;
715 end;
716
717 Render(Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
718 FStretchedVirtualScreen.Draw(ACanvas, Rect.Left, Rect.Top, false);
719 FImageChanged := False;
720
721 FPreviousVirtualScreen := TBGRABitmap(FStretchedVirtualScreen.Duplicate);
722end;
723
724function TBGRAAnimatedGif.GetEmpty: boolean;
725begin
726 Result := (length(FImages) = 0);
727end;
728
729function TBGRAAnimatedGif.GetHeight: integer;
730begin
731 Result := FHeight;
732end;
733
734function TBGRAAnimatedGif.GetTransparent: boolean;
735begin
736 Result := True;
737end;
738
739function TBGRAAnimatedGif.GetWidth: integer;
740begin
741 Result := FWidth;
742end;
743
744procedure TBGRAAnimatedGif.SetHeight(Value: integer);
745begin
746 //not implemented
747end;
748
749procedure TBGRAAnimatedGif.SetTransparent(Value: boolean);
750begin
751 //not implemented
752end;
753
754procedure TBGRAAnimatedGif.SetWidth(Value: integer);
755begin
756 //not implemented
757end;
758
759procedure TBGRAAnimatedGif.ClearViewer;
760begin
761 FCurrentImage := -1;
762 FWantedImage := -1;
763 FTimeAccumulator := 0;
764
765 if FStretchedVirtualScreen <> nil then
766 FStretchedVirtualScreen.FreeReference;
767 if FPreviousVirtualScreen <> nil then
768 FPreviousVirtualScreen.FreeReference;
769 FInternalVirtualScreen.Free;
770 FRestoreImage.Free;
771 FBackgroundImage.Free;
772
773 FInternalVirtualScreen := nil;
774 FStretchedVirtualScreen := nil;
775 FRestoreImage := nil;
776 FBackgroundImage := nil;
777 FPreviousVirtualScreen := nil;
778
779 FPreviousDisposeMode := dmNone;
780end;
781
782procedure TBGRAAnimatedGif.SaveBackgroundOnce(Canvas: TCanvas; ARect: TRect);
783begin
784 if (FBackgroundImage <> nil) and
785 ((FBackgroundImage.Width <> ARect.Right - ARect.Left) or
786 (FBackgroundImage.Height <> ARect.Bottom - ARect.Top)) then
787 FreeAndNil(FBackgroundImage);
788
789 if (BackgroundMode in [gbmSaveBackgroundOnce, gbmUpdateBackgroundContinuously]) and
790 (FBackgroundImage = nil) then
791 begin
792 FBackgroundImage := TBGRABitmap.Create(ARect.Right - ARect.Left,
793 ARect.Bottom - ARect.Top);
794 FBackgroundImage.GetImageFromCanvas(Canvas, ARect.Left, ARect.Top);
795 end;
796end;
797
798procedure TBGRAAnimatedGif.SetCurrentImage(Index: integer);
799begin
800 if (Index >= 0) and (Index < Length(FImages)) then
801 FWantedImage := Index;
802end;
803
804procedure TBGRAAnimatedGif.Clear;
805var
806 i: integer;
807begin
808 inherited Clear;
809
810 for i := 0 to Count - 1 do
811 FImages[i].Image.FreeReference;
812 FImages := nil;
813 LoopDone := 0;
814 LoopCount := 0;
815end;
816
817destructor TBGRAAnimatedGif.Destroy;
818begin
819 Clear;
820
821 if FStretchedVirtualScreen <> nil then
822 FStretchedVirtualScreen.FreeReference;
823 if FPreviousVirtualScreen <> nil then
824 FPreviousVirtualScreen.FreeReference;
825 FInternalVirtualScreen.Free;
826 FRestoreImage.Free;
827 FBackgroundImage.Free;
828 inherited Destroy;
829end;
830
831procedure TBGRAAnimatedGif.Pause;
832begin
833 FPaused := True;
834end;
835
836procedure TBGRAAnimatedGif.Resume;
837begin
838 FPaused := False;
839end;
840
841procedure TBGRAAnimatedGif.Show(Canvas: TCanvas; ARect: TRect);
842begin
843 Canvas.StretchDraw(ARect, self);
844end;
845
846procedure TBGRAAnimatedGif.Update(Canvas: TCanvas; ARect: TRect);
847var
848 n: integer;
849 PChangePix, PNewPix, PBackground, PNewBackground: PLongWord;
850 oldpix, newpix, newbackpix: longword;
851 NewBackgroundImage: TBGRABitmap;
852begin
853 if (BackgroundMode = gbmUpdateBackgroundContinuously) and
854 (FBackgroundImage = nil) then
855 BackgroundMode := gbmSaveBackgroundOnce;
856
857 SaveBackgroundOnce(Canvas, ARect);
858
859 case BackgroundMode of
860 gbmSimplePaint:
861 begin
862 UpdateSimple(Canvas, ARect);
863 exit;
864 end;
865 gbmEraseBackground:
866 begin
867 UpdateEraseBackground(Canvas, ARect);
868 exit;
869 end;
870 gbmSaveBackgroundOnce, gbmUpdateBackgroundContinuously:
871 begin
872 if FPreviousVirtualScreen <> nil then
873 begin
874 if (FPreviousVirtualScreen.Width <> ARect.Right - ARect.Left) or
875 (FPreviousVirtualScreen.Height <> ARect.Bottom - ARect.Top) then
876 begin
877 FPreviousVirtualScreen.FreeReference;
878 FPreviousVirtualScreen := nil;
879 end
880 else
881 FPreviousVirtualScreen := TBGRABitmap(FPreviousVirtualScreen.GetUnique);
882 end;
883
884 Render(ARect.Right - ARect.Left, ARect.Bottom - ARect.Top);
885
886 if FImageChanged then
887 begin
888 if BackgroundMode = gbmUpdateBackgroundContinuously then
889 begin
890 NewBackgroundImage :=
891 TBGRABitmap.Create(FStretchedVirtualScreen.Width,
892 FStretchedVirtualScreen.Height);
893 NewBackgroundImage.GetImageFromCanvas(Canvas, ARect.Left, ARect.Top);
894
895 if FPreviousVirtualScreen = nil then
896 begin
897 FPreviousVirtualScreen := TBGRABitmap.Create(FWidth, FHeight);
898 FPreviousVirtualScreen.Fill(BGRAPixelTransparent);
899 end;
900
901 PChangePix := PLongWord(FPreviousVirtualScreen.Data);
902 PNewPix := PLongWord(FStretchedVirtualScreen.Data);
903 PBackground := PLongWord(FBackgroundImage.Data);
904 PNewBackground := PLongWord(NewBackgroundImage.Data);
905 for n := FStretchedVirtualScreen.NbPixels - 1 downto 0 do
906 begin
907 oldpix := PChangePix^;
908
909 if (oldpix and AlphaMask = AlphaMask) then //pixel opaque précédent
910 begin
911 newbackpix := PNewBackground^;
912 if (newbackpix <> oldpix) then //stocke nouveau fond
913 PBackground^ := newbackpix;
914 end;
915
916 newpix := PNewPix^;
917
918 if newpix and AlphaMask = AlphaMask then
919 PChangePix^ := newpix //pixel opaque
920 else if newpix and AlphaMask > 0 then
921 begin
922 PChangePix^ := PBackground^;
923 DrawPixelInlineNoAlphaCheck(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);
924 end
925 else if PChangePix^ and AlphaMask <> 0 then
926 PChangePix^ := PBackground^; //efface précédent
927
928{ if newpix and AlphaMask > AlphaLimit then PChangePix^ := newpix or AlphaMask //pixel opaque
929 else if PChangePix^ and AlphaMask <> 0 then PChangePix^ := PBackground^; //efface précédent}
930
931 Inc(PNewPix);
932 Inc(PChangePix);
933 Inc(PBackground);
934 Inc(PNewBackground);
935 end;
936 NewBackgroundImage.Free;
937 FPreviousVirtualScreen.InvalidateBitmap;
938 FPreviousVirtualScreen.Draw(Canvas, ARect.Left, ARect.Top, false);
939 FPreviousVirtualScreen.PutImage(0, 0, FStretchedVirtualScreen, dmSet);
940 end
941 else
942 begin
943 if FPreviousVirtualScreen = nil then
944 begin
945 FStretchedVirtualScreen.Draw(Canvas, ARect.Left, ARect.Top, false);
946 FPreviousVirtualScreen :=
947 TBGRABitmap(FStretchedVirtualScreen.NewReference);
948 end
949 else
950 begin
951 PChangePix := PLongWord(FPreviousVirtualScreen.Data);
952 PNewPix := PLongWord(FStretchedVirtualScreen.Data);
953 PBackground := PLongWord(FBackgroundImage.Data);
954 for n := FStretchedVirtualScreen.NbPixels - 1 downto 0 do
955 begin
956 newpix := PNewPix^;
957
958 if newpix and AlphaMask = AlphaMask then
959 PChangePix^ := newpix //pixel opaque
960 else if newpix and AlphaMask > 0 then
961 begin
962 PChangePix^ := PBackground^;
963 DrawPixelInlineNoAlphaCheck(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);
964 end
965 else if PChangePix^ and AlphaMask <> 0 then
966 PChangePix^ := PBackground^; //efface précédent
967
968{ if newpix and AlphaMask > AlphaLimit then PChangePix^ := newpix or AlphaMask //pixel opaque
969 else if PChangePix^ and AlphaMask <> 0 then PChangePix^ := PBackground^; //efface précédent}
970
971 Inc(PNewPix);
972 Inc(PChangePix);
973 Inc(PBackground);
974 end;
975 FPreviousVirtualScreen.InvalidateBitmap;
976 FPreviousVirtualScreen.Draw(Canvas, ARect.Left, ARect.Top, false);
977 FPreviousVirtualScreen.PutImage(0, 0, FStretchedVirtualScreen, dmSet);
978 end;
979 end;
980 FImageChanged := False;
981 end;
982 end;
983 end;
984end;
985
986procedure TBGRAAnimatedGif.Hide(Canvas: TCanvas; ARect: TRect);
987var
988 shape: TBGRABitmap;
989 p, pback: PBGRAPixel;
990 MemEraseColor: TBGRAPixel;
991 n: integer;
992begin
993 MemEraseColor := ColorToBGRA(EraseColor);
994 if FPreviousVirtualScreen <> nil then
995 begin
996 if (FPreviousVirtualScreen.Width <> ARect.Right - ARect.Left) or
997 (FPreviousVirtualScreen.Height <> ARect.Bottom - ARect.Top) then
998 begin
999 FPreviousVirtualScreen.FreeReference;
1000 FPreviousVirtualScreen := nil;
1001 end;
1002 end;
1003
1004 case BackgroundMode of
1005 gbmEraseBackground, gbmSimplePaint:
1006 begin
1007 if FPreviousVirtualScreen <> nil then
1008 begin
1009 shape := TBGRABitmap(FPreviousVirtualScreen.Duplicate);
1010 p := shape.Data;
1011 for n := shape.NbPixels - 1 downto 0 do
1012 begin
1013 if p^.alpha <> 0 then
1014 p^ := MemEraseColor
1015 else
1016 p^ := BGRAPixelTransparent;
1017 Inc(p);
1018 end;
1019 shape.Draw(Canvas, ARect.Left, ARect.Top, false);
1020 shape.FreeReference;
1021 end;
1022 end;
1023 gbmSaveBackgroundOnce, gbmUpdateBackgroundContinuously:
1024 begin
1025 if (FPreviousVirtualScreen <> nil) and (FBackgroundImage <> nil) then
1026 begin
1027 shape := TBGRABitmap(FPreviousVirtualScreen.Duplicate);
1028 p := shape.Data;
1029 pback := FBackgroundImage.Data;
1030 for n := shape.NbPixels - 1 downto 0 do
1031 begin
1032 if p^.alpha <> 0 then
1033 p^ := pback^
1034 else
1035 p^ := BGRAPixelTransparent;
1036 Inc(p);
1037 Inc(pback);
1038 end;
1039 shape.Draw(Canvas, ARect.Left, ARect.Top, false);
1040 shape.FreeReference;
1041 end;
1042 end;
1043 end;
1044end;
1045
1046procedure TBGRAAnimatedGif.UpdateEraseBackground(Canvas: TCanvas;
1047 ARect: TRect; DrawOnlyIfChanged: boolean);
1048var
1049 n: integer;
1050 PChangePix, PNewPix: PLongWord;
1051 newpix: longword;
1052 MemPixEraseColor: longword;
1053begin
1054 if EraseColor = clNone then
1055 begin
1056 UpdateSimple(Canvas, ARect, DrawOnlyIfChanged);
1057 exit;
1058 end;
1059
1060 if FPreviousVirtualScreen <> nil then
1061 begin
1062 if (FPreviousVirtualScreen.Width <> ARect.Right - ARect.Left) or
1063 (FPreviousVirtualScreen.Height <> ARect.Bottom - ARect.Top) then
1064 begin
1065 FPreviousVirtualScreen.FreeReference;
1066 FPreviousVirtualScreen := nil;
1067 end
1068 else
1069 FPreviousVirtualScreen := TBGRABitmap(FPreviousVirtualScreen.GetUnique);
1070 end;
1071
1072 Render(ARect.Right - ARect.Left, ARect.Bottom - ARect.Top);
1073 if FImageChanged then
1074 begin
1075 PBGRAPixel(@MemPixEraseColor)^ := ColorToBGRA(EraseColor);
1076 if FPreviousVirtualScreen = nil then
1077 begin
1078 FStretchedVirtualScreen.Draw(Canvas, ARect.Left, ARect.Top, false);
1079 FPreviousVirtualScreen := TBGRABitmap(FStretchedVirtualScreen.NewReference);
1080 end
1081 else
1082 begin
1083 PChangePix := PLongWord(FPreviousVirtualScreen.Data);
1084 PNewPix := PLongWord(FStretchedVirtualScreen.Data);
1085 for n := FStretchedVirtualScreen.NbPixels - 1 downto 0 do
1086 begin
1087 newpix := PNewPix^;
1088
1089 if newpix and AlphaMask = AlphaMask then
1090 PChangePix^ := newpix //pixel opaque
1091 else if newpix and AlphaMask > 0 then
1092 begin
1093 PChangePix^ := MemPixEraseColor;
1094 DrawPixelInlineNoAlphaCheck(PBGRAPixel(PChangePix), PBGRAPixel(@newpix)^);
1095 end
1096 else if PChangePix^ and AlphaMask <> 0 then
1097 PChangePix^ := MemPixEraseColor; //efface précédent
1098{ if newpix and AlphaMask > AlphaLimit then PChangePix^ := newpix or AlphaMask //pixel opaque
1099 else if PChangePix^ and AlphaMask <> 0 then PChangePix^ := MemPixEraseColor; //efface précédent}
1100
1101 Inc(PNewPix);
1102 Inc(PChangePix);
1103 end;
1104 FPreviousVirtualScreen.InvalidateBitmap;
1105 FPreviousVirtualScreen.Draw(Canvas, ARect.Left, ARect.Top, false);
1106 FPreviousVirtualScreen.PutImage(0, 0, FStretchedVirtualScreen, dmSet);
1107 end;
1108
1109 FImageChanged := False;
1110 end;
1111end;
1112
1113procedure TBGRAAnimatedGif.Init;
1114begin
1115 BackgroundMode := gbmSaveBackgroundOnce;
1116 LoopCount := 0;
1117 LoopDone := 0;
1118end;
1119
1120function TBGRAAnimatedGif.GetBitmap: TBitmap;
1121begin
1122 Render(FWidth, FHeight);
1123 Result := FStretchedVirtualScreen.Bitmap;
1124end;
1125
1126function TBGRAAnimatedGif.GetMemBitmap: TBGRABitmap;
1127begin
1128 Render(FWidth, FHeight);
1129 Result := FStretchedVirtualScreen;
1130end;
1131
1132{ TBGRAReaderGIF }
1133
1134procedure TBGRAReaderGIF.InternalRead(Str: TStream; Img: TFPCustomImage);
1135var
1136 gif: TBGRAAnimatedGif;
1137 x, y: integer;
1138 Mem: TBGRABitmap;
1139begin
1140 gif := TBGRAAnimatedGif.Create(Str, 1);
1141 Mem := gif.MemBitmap;
1142 if Img is TBGRABitmap then
1143 begin
1144 TBGRABitmap(Img).Assign(Mem);
1145 end
1146 else
1147 begin
1148 Img.SetSize(gif.Width, gif.Height);
1149 for y := 0 to gif.Height - 1 do
1150 for x := 0 to gif.Width - 1 do
1151 with Mem.GetPixel(x, y) do
1152 Img.Colors[x, y] := FPColor(red * $101, green * $101, blue *
1153 $101, alpha * $101);
1154 end;
1155 gif.Free;
1156end;
1157
1158function TBGRAReaderGIF.InternalCheck(Str: TStream): boolean;
1159var
1160 GIFSignature: TGIFSignature;
1161 savepos: int64;
1162begin
1163 savepos := str.Position;
1164 try
1165 fillchar({%H-}GIFSignature, sizeof(GIFSignature), 0);
1166 str.Read(GIFSignature, sizeof(GIFSignature));
1167 if (GIFSignature[1] = 'G') and (GIFSignature[2] = 'I') and
1168 (GIFSignature[3] = 'F') then
1169 begin
1170 Result := True;
1171 end
1172 else
1173 Result := False;
1174 except
1175 on ex: Exception do
1176 Result := False;
1177 end;
1178 str.Position := savepos;
1179end;
1180
1181{ TBGRAWriterGIF }
1182
1183procedure TBGRAWriterGIF.InternalWrite(Str: TStream; Img: TFPCustomImage);
1184var
1185 gif: TBGRAAnimatedGif;
1186begin
1187 gif := TBGRAAnimatedGif.Create;
1188 try
1189 gif.SetSize(Img.Width,Img.Height);
1190 gif.AddFrame(Img, 0,0,0);
1191 gif.SaveToStream(Str, BGRAColorQuantizerFactory, daFloydSteinberg);
1192 except
1193 on ex: EColorQuantizerMissing do
1194 begin
1195 FreeAndNil(gif);
1196 raise EColorQuantizerMissing.Create('Please define the color quantizer factory. You can do that with the following statements: Uses BGRAPalette, BGRAColorQuantization; BGRAColorQuantizerFactory:= TBGRAColorQuantizer;');
1197 end;
1198 on ex: Exception do
1199 begin
1200 FreeAndNil(gif);
1201 raise ex;
1202 end;
1203 end;
1204 FreeAndNil(gif);
1205end;
1206
1207initialization
1208
1209 DefaultBGRAImageReader[ifGif] := TBGRAReaderGIF;
1210 DefaultBGRAImageWriter[ifGif] := TBGRAWriterGIF;
1211
1212 //Free Pascal Image
1213 ImageHandlers.RegisterImageReader('Animated GIF', TBGRAAnimatedGif.GetFileExtensions,
1214 TBGRAReaderGIF);
1215 ImageHandlers.RegisterImageWriter('Animated GIF', TBGRAAnimatedGif.GetFileExtensions,
1216 TBGRAWriterGIF);
1217
1218 {$IFDEF BGRABITMAP_USE_LCL}
1219 //Lazarus Picture
1220 TPicture.RegisterFileFormat(TBGRAAnimatedGif.GetFileExtensions, 'Animated GIF',
1221 TBGRAAnimatedGif);
1222 {$ENDIF}
1223end.
1224
Note: See TracBrowser for help on using the repository browser.