Changeset 521 for GraphicTest/Packages/bgrabitmap/bgraanimatedgif.pas

Timestamp:

Apr 17, 2019, 12:58:41 AM (5 years ago)

Author:

chronos

Message:

• Modified: Propagate project build mode options to used packages.
• Added: Check memory leaks using heaptrc.
• Modified: Update BGRABitmap package.

Location:

GraphicTest

Files:

• . (modified) (1 prop)
• Packages/bgrabitmap/bgraanimatedgif.pas (modified) (16 diffs)

GraphicTest

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc

GraphicTest/Packages/bgrabitmap/bgraanimatedgif.pas

@@ -39 +39 @@
 
     procedure CheckFrameIndex(AIndex: integer);
+    function GetAverageDelayMs: integer;
     function GetCount: integer;
     function GetFrameDelayMs(AIndex: integer): integer;
@@ -81 +82 @@
     EraseColor:     TColor;
     BackgroundMode: TGifBackgroundMode;
-
-    constructor Create(filenameUTF8: string);
-    constructor Create(stream: TStream);
-    constructor Create; override;
+    LoopCount:      Word;
+    LoopDone:       Integer;
+
+    constructor Create(filenameUTF8: string); overload;
+    constructor Create(stream: TStream); overload;
+    constructor Create(stream: TStream; AMaxImageCount: integer); overload;
+    constructor Create; overload; override;
     function Duplicate: TBGRAAnimatedGif;
     function AddFrame(AImage: TFPCustomImage; X,Y: integer; ADelayMs: integer;
       ADisposeMode: TDisposeMode = dmErase; AHasLocalPalette: boolean = false) : integer;
-    procedure InsertFrame(AIndex: integer; AImage: TBGRABitmap; X,Y: integer; ADelayMs: integer;
+    procedure InsertFrame(AIndex: integer; AImage: TFPCustomImage; X,Y: integer; ADelayMs: integer;
       ADisposeMode: TDisposeMode = dmErase; AHasLocalPalette: boolean = false);
+    procedure DeleteFrame(AIndex: integer; AEnsureNextFrameDoesNotChange: boolean);
+
+    //add a frame that replaces completely the previous one
+    function AddFullFrame(AImage: TFPCustomImage; ADelayMs: integer;
+                          AHasLocalPalette: boolean = true): integer;
+    procedure InsertFullFrame(AIndex: integer;
+                              AImage: TFPCustomImage; ADelayMs: integer;
+                              AHasLocalPalette: boolean = true);
+    procedure ReplaceFullFrame(AIndex: integer;
+                              AImage: TFPCustomImage; ADelayMs: integer;
+                              AHasLocalPalette: boolean = true);
 
     {TGraphic}
-    procedure LoadFromStream(Stream: TStream); override;
-    procedure SaveToStream(Stream: TStream); override;
+    procedure LoadFromStream(Stream: TStream); overload; override;
+    procedure LoadFromStream(Stream: TStream; AMaxImageCount: integer); overload;
+    procedure LoadFromResource(AFilename: string);
+    procedure SaveToStream(Stream: TStream); overload; override;
     procedure LoadFromFile(const AFilenameUTF8: string); override;
     procedure SaveToFile(const AFilenameUTF8: string); override;
@@ -100 +117 @@
     procedure SetSize(AWidth,AHeight: integer); virtual;
     procedure SaveToStream(Stream: TStream; AQuantizer: TBGRAColorQuantizerAny;
-      ADitheringAlgorithm: TDitheringAlgorithm); virtual; overload;
+      ADitheringAlgorithm: TDitheringAlgorithm); overload; virtual;
     procedure Clear; override;
     destructor Destroy; override;
@@ -126 +143 @@
     property AspectRatio: single read FAspectRatio write SetAspectRatio;
     property TotalAnimationTimeMs: Int64 read FTotalAnimationTime;
+    property AverageDelayMs: integer read GetAverageDelayMs;
   end;
 
@@ -184 +202 @@
   data.BackgroundColor := BackgroundColor;
   data.Images := FImages;
+  data.LoopCount := LoopCount;
   GIFSaveToStream(data, Stream, AQuantizer, ADitheringAlgorithm);
 end;
@@ -233 +252 @@
       Inc(nextImage);
       if nextImage >= Count then
-        nextImage := 0;
+      begin
+        if (LoopCount > 0) and (LoopDone >= LoopCount-1) then
+        begin
+          LoopDone := LoopCount;
+          dec(nextImage);
+          break;
+        end else
+        begin
+          nextImage := 0;
+          inc(LoopDone);
+        end;
+      end;
 
       if nextImage = previousImage then
       begin
-        Inc(nextImage);
-        if nextImage >= Count then
-          nextImage := 0;
+        if not ((LoopCount > 0) and (LoopDone >= LoopCount-1)) then
+        begin
+          Inc(nextImage);
+          if nextImage >= Count then
+            nextImage := 0;
+        end;
         break;
       end;
@@ -370 +403 @@
 end;
 
+function TBGRAAnimatedGif.GetAverageDelayMs: integer;
+var sum: int64;
+  i: Integer;
+begin
+  if Count > 0 then
+  begin
+    sum := 0;
+    for i := 0 to Count-1 do
+      inc(sum, FrameDelayMs[i]);
+    result := sum div Count;
+  end else
+    result := 100; //default
+end;
+
 function TBGRAAnimatedGif.GetCount: integer;
 begin
@@ -437 +484 @@
 end;
 
+constructor TBGRAAnimatedGif.Create(stream: TStream; AMaxImageCount: integer);
+begin
+  inherited Create;
+  Init;
+  LoadFromStream(stream, AMaxImageCount);
+end;
+
 constructor TBGRAAnimatedGif.Create;
 begin
@@ -478 +532 @@
 end;
 
-procedure TBGRAAnimatedGif.InsertFrame(AIndex: integer; AImage: TBGRABitmap; X,
+procedure TBGRAAnimatedGif.InsertFrame(AIndex: integer; AImage: TFPCustomImage; X,
   Y: integer; ADelayMs: integer; ADisposeMode: TDisposeMode;
   AHasLocalPalette: boolean);
@@ -491 +545 @@
   with FImages[AIndex] do
   begin
-    Image := AImage.Duplicate as TBGRABitmap;
+    Image := TBGRABitmap.Create(AImage);
     Position := Point(x,y);
     DelayMs := ADelayMs;
@@ -500 +554 @@
 end;
 
+function TBGRAAnimatedGif.AddFullFrame(AImage: TFPCustomImage;
+  ADelayMs: integer; AHasLocalPalette: boolean): integer;
+begin
+  if (AImage.Width <> Width) or (AImage.Height <> Height) then
+    raise exception.Create('Size mismatch');
+  if Count > 0 then
+    FrameDisposeMode[Count-1] := dmErase;
+  result := AddFrame(AImage, 0,0, ADelayMs, dmErase, AHasLocalPalette);
+end;
+
+procedure TBGRAAnimatedGif.InsertFullFrame(AIndex: integer;
+  AImage: TFPCustomImage; ADelayMs: integer; AHasLocalPalette: boolean);
+var nextImage: TBGRABitmap;
+begin
+  if (AIndex < 0) or (AIndex > Count) then
+    raise ERangeError.Create('Index out of bounds');
+
+  if AIndex = Count then
+    AddFullFrame(AImage, ADelayMs, AHasLocalPalette)
+  else
+  begin
+    //if previous image did not clear up, ensure that
+    //next image will stay the same
+    if (AIndex > 0) and (FrameDisposeMode[AIndex-1] <> dmErase) then
+    begin
+      CurrentImage := AIndex;
+      nextImage := MemBitmap.Duplicate as TBGRABitmap;
+      FrameImagePos[AIndex] := Point(0,0);
+      FrameImage[AIndex] := nextImage;
+      FrameHasLocalPalette[AIndex] := true;
+      FreeAndNil(nextImage);
+
+      FrameDisposeMode[AIndex-1] := dmErase;
+    end;
+
+    InsertFrame(AIndex, AImage, 0,0, ADelayMs, dmErase, AHasLocalPalette);
+  end;
+end;
+
+procedure TBGRAAnimatedGif.ReplaceFullFrame(AIndex: integer;
+  AImage: TFPCustomImage; ADelayMs: integer; AHasLocalPalette: boolean);
+begin
+  DeleteFrame(AIndex, True);
+  if AIndex > 0 then FrameDisposeMode[AIndex-1] := dmErase;
+  InsertFrame(AIndex, AImage, 0,0, ADelayMs, dmErase, AHasLocalPalette);
+end;
+
+procedure TBGRAAnimatedGif.DeleteFrame(AIndex: integer;
+  AEnsureNextFrameDoesNotChange: boolean);
+var
+  nextImage: TBGRABitmap;
+  i: Integer;
+begin
+  CheckFrameIndex(AIndex);
+
+  //if this frame did not clear up, ensure that
+  //next image will stay the same
+  if AEnsureNextFrameDoesNotChange and
+    ((AIndex < Count-1) and (FrameDisposeMode[AIndex] <> dmErase)) then
+  begin
+    CurrentImage := AIndex+1;
+    nextImage := MemBitmap.Duplicate as TBGRABitmap;
+    FrameImagePos[AIndex+1] := Point(0,0);
+    FrameImage[AIndex+1] := nextImage;
+    FrameHasLocalPalette[AIndex+1] := true;
+    FreeAndNil(nextImage);
+  end;
+
+  dec(FTotalAnimationTime, FImages[AIndex].DelayMs);
+
+  FImages[AIndex].Image.FreeReference;
+  for i := AIndex to Count-2 do
+    FImages[i] := FImages[i+1];
+  SetLength(FImages, Count-1);
+
+  if (CurrentImage >= Count) then
+    CurrentImage := 0;
+end;
+
 procedure TBGRAAnimatedGif.LoadFromStream(Stream: TStream);
+begin
+  LoadFromStream(Stream, maxLongint);
+end;
+
+procedure TBGRAAnimatedGif.LoadFromStream(Stream: TStream;
+  AMaxImageCount: integer);
 var data: TGIFData;
   i: integer;
 begin
-  data := GIFLoadFromStream(Stream);
+  data := GIFLoadFromStream(Stream, AMaxImageCount);
 
   ClearViewer;
@@ -512 +651 @@
   FBackgroundColor := data.BackgroundColor;
   FAspectRatio:= data.AspectRatio;
+  LoopDone := 0;
+  LoopCount := data.LoopCount;
 
   SetLength(FImages, length(data.Images));
@@ -519 +660 @@
     FImages[i] := data.Images[i];
     FTotalAnimationTime += FImages[i].DelayMs;
+  end;
+end;
+
+procedure TBGRAAnimatedGif.LoadFromResource(AFilename: string);
+var
+  stream: TStream;
+begin
+  stream := BGRAResource.GetResourceStream(AFilename);
+  try
+    LoadFromStream(stream);
+  finally
+    stream.Free;
   end;
 end;
@@ -658 +811 @@
     FImages[i].Image.FreeReference;
   FImages := nil;
+  LoopDone := 0;
+  LoopCount := 0;
 end;
 
@@ -959 +1114 @@
 begin
   BackgroundMode := gbmSaveBackgroundOnce;
+  LoopCount := 0;
+  LoopDone := 0;
 end;
 
@@ -981 +1138 @@
   Mem:  TBGRABitmap;
 begin
-  gif := TBGRAAnimatedGif.Create(Str);
+  gif := TBGRAAnimatedGif.Create(Str, 1);
   Mem := gif.MemBitmap;
   if Img is TBGRABitmap then

@@ -8 +8 @@
 GraphicTest.lps
 GraphicTest.dbg
+heaptrclog.trc