Ignore:
Timestamp:
Dec 22, 2016, 8:49:19 PM (7 years ago)
Author:
chronos
Message:
  • Modified: Updated BGRABitmap package.
File:
1 edited

Legend:

Unmodified
Added
Removed

  • GraphicTest/Packages/bgrabitmap/bgraanimatedgif.pas

    r472 r494  
    22
    33{$mode objfpc}{$H+}
     4{$i bgrabitmap.inc}
    45
    56interface
    67
    78uses
    8   Classes, SysUtils, Graphics, FPImage, BGRABitmap, BGRABitmapTypes;
     9  Classes, SysUtils, BGRAGraphics, FPImage, BGRABitmap, BGRABitmapTypes,
     10  BGRAPalette, BGRAGifFormat;
    911
    1012type
    11   TDisposeMode = (dmNone, dmKeep, dmErase, dmRestore);
    12 
    13   TGifSubImage = record
    14     Image:    TBGRABitmap;
    15     Position: TPoint;
    16     Delay:    integer;
    17     disposeMode: TDisposeMode;
    18     TransparentColor: TBGRAPixel;
    19   end;
    20   TGifSubImageArray = array of TGifSubImage;
    21 
     13  TDisposeMode = BGRAGifFormat.TDisposeMode;
     14  TGifSubImage = BGRAGifFormat.TGifSubImage;
     15  TGifSubImageArray = BGRAGifFormat.TGifSubImageArray;
     16
     17  //how to deal with the background under the GIF animation
    2218  TGifBackgroundMode = (gbmSimplePaint, gbmEraseBackground,
    2319    gbmSaveBackgroundOnce, gbmUpdateBackgroundContinuously);
    … …  
    2723  TBGRAAnimatedGif = class(TGraphic)
    2824  private
     25    FAspectRatio: single;
    2926    FWidth, FHeight:  integer;
    3027    FBackgroundColor: TColor;
    … …  
    3431    FTimeAccumulator: double;
    3532    FCurrentImage, FWantedImage: integer;
    36     FFullAnimationTime: double;
     33    FTotalAnimationTime: int64;
    3734    FPreviousDisposeMode: TDisposeMode;
    3835
    … …  
    4138    FImageChanged: boolean;
    4239
     40    procedure CheckFrameIndex(AIndex: integer);
    4341    function GetCount: integer;
     42    function GetFrameDelayMs(AIndex: integer): integer;
     43    function GetFrameDisposeMode(AIndex: integer): TDisposeMode;
     44    function GetFrameHasLocalPalette(AIndex: integer): boolean;
     45    function GetFrameImage(AIndex: integer): TBGRABitmap;
     46    function GetFrameImagePos(AIndex: integer): TPoint;
    4447    function GetTimeUntilNextImage: integer;
    4548    procedure Render(StretchWidth, StretchHeight: integer);
     49    procedure SetAspectRatio(AValue: single);
     50    procedure SetBackgroundColor(AValue: TColor);
     51    procedure SetFrameDelayMs(AIndex: integer; AValue: integer);
     52    procedure SetFrameDisposeMode(AIndex: integer; AValue: TDisposeMode);
     53    procedure SetFrameHasLocalPalette(AIndex: integer; AValue: boolean);
     54    procedure SetFrameImage(AIndex: integer; AValue: TBGRABitmap);
     55    procedure SetFrameImagePos(AIndex: integer; AValue: TPoint);
    4656    procedure UpdateSimple(Canvas: TCanvas; ARect: TRect;
    4757      DrawOnlyIfChanged: boolean = True);
    … …  
    5666  protected
    5767    FImages: TGifSubImageArray;
    58     procedure LoadImages(stream: TStream);
    5968
    6069    {TGraphic}
    … …  
    6473    function GetTransparent: boolean; override;
    6574    function GetWidth: integer; override;
    66     procedure SetHeight(Value: integer); override;
    67     procedure SetTransparent(Value: boolean); override;
    68     procedure SetWidth(Value: integer); override;
     75    procedure SetHeight({%H-}Value: integer); override;
     76    procedure SetTransparent({%H-}Value: boolean); override;
     77    procedure SetWidth({%H-}Value: integer); override;
     78    procedure ClearViewer; virtual;
    6979
    7080  public
    … …  
    7686    constructor Create; override;
    7787    function Duplicate: TBGRAAnimatedGif;
     88    function AddFrame(AImage: TFPCustomImage; X,Y: integer; ADelayMs: integer;
     89      ADisposeMode: TDisposeMode = dmErase; AHasLocalPalette: boolean = false) : integer;
     90    procedure InsertFrame(AIndex: integer; AImage: TBGRABitmap; X,Y: integer; ADelayMs: integer;
     91      ADisposeMode: TDisposeMode = dmErase; AHasLocalPalette: boolean = false);
    7892
    7993    {TGraphic}
    … …  
    8498    class function GetFileExtensions: string; override;
    8599
     100    procedure SetSize(AWidth,AHeight: integer); virtual;
     101    procedure SaveToStream(Stream: TStream; AQuantizer: TBGRAColorQuantizerAny;
     102      ADitheringAlgorithm: TDitheringAlgorithm); virtual; overload;
    86103    procedure Clear; override;
    87104    destructor Destroy; override;
    … …  
    93110    procedure Hide(Canvas: TCanvas; ARect: TRect); overload;
    94111
    95     property BackgroundColor: TColor Read FBackgroundColor;
     112    property BackgroundColor: TColor Read FBackgroundColor write SetBackgroundColor;
    96113    property Count: integer Read GetCount;
    97114    property Width: integer Read FWidth;
    … …  
    102119    property CurrentImage: integer Read FCurrentImage Write SetCurrentImage;
    103120    property TimeUntilNextImageMs: integer read GetTimeUntilNextImage;
    104   end;
    105 
    106   { TFPReaderGIF }
    107 
    108   TFPReaderGIF = class(TFPCustomImageReader)
     121    property FrameImage[AIndex: integer]: TBGRABitmap read GetFrameImage write SetFrameImage;
     122    property FrameHasLocalPalette[AIndex: integer]: boolean read GetFrameHasLocalPalette write SetFrameHasLocalPalette;
     123    property FrameImagePos[AIndex: integer]: TPoint read GetFrameImagePos write SetFrameImagePos;
     124    property FrameDelayMs[AIndex: integer]: integer read GetFrameDelayMs write SetFrameDelayMs;
     125    property FrameDisposeMode[AIndex: integer]: TDisposeMode read GetFrameDisposeMode write SetFrameDisposeMode;
     126    property AspectRatio: single read FAspectRatio write SetAspectRatio;
     127    property TotalAnimationTimeMs: Int64 read FTotalAnimationTime;
     128  end;
     129
     130  { TBGRAReaderGIF }
     131
     132  TBGRAReaderGIF = class(TFPCustomImageReader)
    109133  protected
    110134    procedure InternalRead(Str: TStream; Img: TFPCustomImage); override;
    111135    function InternalCheck(Str: TStream): boolean; override;
     136  end;
     137
     138  { TBGRAWriterGIF }
     139
     140  TBGRAWriterGIF = class(TFPCustomImageWriter)
     141  protected
     142    procedure InternalWrite(Str: TStream; Img: TFPCustomImage); override;
    112143  end;
    113144
    … …  
    119150implementation
    120151
    121 uses BGRABlend, lazutf8classes;
     152uses BGRABlend, BGRAUTF8{$IFDEF BGRABITMAP_USE_LCL}, Graphics{$ENDIF};
    122153
    123154const
    … …  
    128159  {$ENDIF}
    129160
    130 type
    131   TGIFSignature = packed array[1..6] of char;
    132 
    133   TGIFScreenDescriptor = packed record
    134     Width, Height: word;
    135     flags, background, map: byte;
    136   end;
    137 
    138   TGIFImageDescriptor = packed record
    139     x, y, Width, Height: word;
    140     flags: byte;
    141   end;
    142 
    143   TGIFExtensionBlock = packed record
    144     functioncode: byte;
    145   end;
    146 
    147   TGIFGraphicControlExtension = packed record
    148     flags:      byte;
    149     delaytime:  word;
    150     transcolor: byte;
    151   end;
    152161
    153162{ TBGRAAnimatedGif }
    … …  
    156165begin
    157166  Result := 'gif';
     167end;
     168
     169procedure TBGRAAnimatedGif.SetSize(AWidth, AHeight: integer);
     170begin
     171  ClearViewer;
     172  FWidth := AWidth;
     173  FHeight := AHeight;
     174end;
     175
     176procedure TBGRAAnimatedGif.SaveToStream(Stream: TStream;
     177      AQuantizer: TBGRAColorQuantizerAny;
     178      ADitheringAlgorithm: TDitheringAlgorithm);
     179var data: TGIFData;
     180begin
     181  data.Height:= Height;
     182  data.Width := Width;
     183  data.AspectRatio := 1;
     184  data.BackgroundColor := BackgroundColor;
     185  data.Images := FImages;
     186  GIFSaveToStream(data, Stream, AQuantizer, ADitheringAlgorithm);
    158187end;
    159188
    … …  
    167196  begin
    168197    FInternalVirtualScreen := TBGRABitmap.Create(FWidth, FHeight);
    169     if Count = 0 then
     198    if (Count = 0) and (BackgroundColor <> clNone) then
    170199      FInternalVirtualScreen.Fill(BackgroundColor)
    171200    else
    … …  
    197226    if not FPaused then
    198227      FTimeAccumulator += (curDate - FPrevDate) * 24 * 60 * 60 * 1000;
    199     if FFullAnimationTime > 0 then FTimeAccumulator:= frac(FTimeAccumulator/FFullAnimationTime)*FFullAnimationTime;
     228    if FTotalAnimationTime > 0 then FTimeAccumulator:= frac(FTimeAccumulator/FTotalAnimationTime)*FTotalAnimationTime;
    200229    nextImage := FCurrentImage;
    201     while FTimeAccumulator > FImages[nextImage].Delay do
    202     begin
    203       FTimeAccumulator -= FImages[nextImage].Delay;
     230    while FTimeAccumulator > FImages[nextImage].DelayMs do
     231    begin
     232      FTimeAccumulator -= FImages[nextImage].DelayMs;
    204233      Inc(nextImage);
    205234      if nextImage >= Count then
    … …  
    244273        FInternalVirtualScreen.PutImage(Position.X, Position.Y, Image,
    245274          dmSetExceptTransparent);
    246       FPreviousDisposeMode := disposeMode;
     275      FPreviousDisposeMode := DisposeMode;
    247276    end;
    248277
    … …  
    262291end;
    263292
     293procedure TBGRAAnimatedGif.SetAspectRatio(AValue: single);
     294begin
     295  if AValue < 0.25 then AValue := 0.25;
     296  if AValue > 4 then AValue := 4;
     297  if FAspectRatio=AValue then Exit;
     298  FAspectRatio:=AValue;
     299end;
     300
     301procedure TBGRAAnimatedGif.SetBackgroundColor(AValue: TColor);
     302begin
     303  if FBackgroundColor=AValue then Exit;
     304  FBackgroundColor:=AValue;
     305end;
     306
     307procedure TBGRAAnimatedGif.SetFrameDelayMs(AIndex: integer; AValue: integer);
     308begin
     309  CheckFrameIndex(AIndex);
     310  if AValue < 0 then AValue := 0;
     311  FTotalAnimationTime := FTotalAnimationTime + AValue - FImages[AIndex].DelayMs;
     312  FImages[AIndex].DelayMs := AValue;
     313end;
     314
     315procedure TBGRAAnimatedGif.SetFrameDisposeMode(AIndex: integer;
     316  AValue: TDisposeMode);
     317begin
     318  CheckFrameIndex(AIndex);
     319  FImages[AIndex].DisposeMode := AValue;
     320end;
     321
     322procedure TBGRAAnimatedGif.SetFrameHasLocalPalette(AIndex: integer;
     323  AValue: boolean);
     324begin
     325  CheckFrameIndex(AIndex);
     326  FImages[AIndex].HasLocalPalette := AValue;
     327
     328end;
     329
     330procedure TBGRAAnimatedGif.SetFrameImage(AIndex: integer; AValue: TBGRABitmap);
     331var ACopy: TBGRABitmap;
     332begin
     333  CheckFrameIndex(AIndex);
     334  ACopy := AValue.Duplicate as TBGRABitmap;
     335  FImages[AIndex].Image.FreeReference;
     336  FImages[AIndex].Image := ACopy;
     337end;
     338
     339procedure TBGRAAnimatedGif.SetFrameImagePos(AIndex: integer; AValue: TPoint);
     340begin
     341  CheckFrameIndex(AIndex);
     342  FImages[AIndex].Position := AValue;
     343end;
     344
    264345procedure TBGRAAnimatedGif.UpdateSimple(Canvas: TCanvas; ARect: TRect;
    265346  DrawOnlyIfChanged: boolean = True);
    … …  
    284365end;
    285366
     367procedure TBGRAAnimatedGif.CheckFrameIndex(AIndex: integer);
     368begin
     369  if (AIndex < 0) or (AIndex >= Count) then Raise ERangeError.Create('Index out of bounds');
     370end;
     371
    286372function TBGRAAnimatedGif.GetCount: integer;
    287373begin
    288374  Result := length(FImages);
     375end;
     376
     377function TBGRAAnimatedGif.GetFrameDelayMs(AIndex: integer): integer;
     378begin
     379  CheckFrameIndex(AIndex);
     380  result := FImages[AIndex].DelayMs;
     381end;
     382
     383function TBGRAAnimatedGif.GetFrameDisposeMode(AIndex: integer): TDisposeMode;
     384begin
     385  CheckFrameIndex(AIndex);
     386  result := FImages[AIndex].DisposeMode;
     387end;
     388
     389function TBGRAAnimatedGif.GetFrameHasLocalPalette(AIndex: integer): boolean;
     390begin
     391  CheckFrameIndex(AIndex);
     392  result := FImages[AIndex].HasLocalPalette;
     393end;
     394
     395function TBGRAAnimatedGif.GetFrameImage(AIndex: integer): TBGRABitmap;
     396begin
     397  CheckFrameIndex(AIndex);
     398  result := FImages[AIndex].Image;
     399end;
     400
     401function TBGRAAnimatedGif.GetFrameImagePos(AIndex: integer): TPoint;
     402begin
     403  CheckFrameIndex(AIndex);
     404  result := FImages[AIndex].Position;
    289405end;
    290406
    … …  
    300416    acc := FTimeAccumulator;
    301417    if not FPaused then acc += (Now- FPrevDate) * 24 * 60 * 60 * 1000;
    302     if acc >= FImages[FCurrentImage].Delay then
     418    if acc >= FImages[FCurrentImage].DelayMs then
    303419      result := 0
    304420    else
    305       result := round(FImages[FCurrentImage].Delay-FTimeAccumulator);
     421      result := round(FImages[FCurrentImage].DelayMs-FTimeAccumulator);
    306422  end;
    307423end;
    308424
    309425constructor TBGRAAnimatedGif.Create(filenameUTF8: string);
    310 var
    311   Stream: TFileStreamUTF8;
    312426begin
    313427  inherited Create;
    314428  Init;
    315   Stream := TFileStreamUTF8.Create(filenameUTF8, fmOpenRead or fmShareDenyWrite);
    316   LoadFromStream(Stream);
    317   Stream.Free;
     429  LoadFromFile(filenameUTF8);
    318430end;
    319431
    … …  
    348460end;
    349461
     462function TBGRAAnimatedGif.AddFrame(AImage: TFPCustomImage; X, Y: integer;
     463  ADelayMs: integer; ADisposeMode: TDisposeMode; AHasLocalPalette: boolean
     464  ): integer;
     465begin
     466  result := length(FImages);
     467  setlength(FImages, length(FImages)+1);
     468  if ADelayMs < 0 then ADelayMs:= 0;
     469  with FImages[result] do
     470  begin
     471    Image := TBGRABitmap.Create(AImage);
     472    Position := Point(x,y);
     473    DelayMs := ADelayMs;
     474    HasLocalPalette := AHasLocalPalette;
     475    DisposeMode := ADisposeMode;
     476  end;
     477  inc(FTotalAnimationTime, ADelayMs);
     478end;
     479
     480procedure TBGRAAnimatedGif.InsertFrame(AIndex: integer; AImage: TBGRABitmap; X,
     481  Y: integer; ADelayMs: integer; ADisposeMode: TDisposeMode;
     482  AHasLocalPalette: boolean);
     483var i: integer;
     484begin
     485  if (AIndex < 0) or (AIndex > Count) then
     486    raise ERangeError.Create('Index out of bounds');
     487  setlength(FImages, length(FImages)+1);
     488  if ADelayMs < 0 then ADelayMs:= 0;
     489  for i := high(FImages) downto AIndex+1 do
     490    FImages[i] := FImages[i-1];
     491  with FImages[AIndex] do
     492  begin
     493    Image := AImage.Duplicate as TBGRABitmap;
     494    Position := Point(x,y);
     495    DelayMs := ADelayMs;
     496    HasLocalPalette := AHasLocalPalette;
     497    DisposeMode := ADisposeMode;
     498  end;
     499  inc(FTotalAnimationTime, ADelayMs);
     500end;
     501
    350502procedure TBGRAAnimatedGif.LoadFromStream(Stream: TStream);
     503var data: TGIFData;
     504  i: integer;
     505begin
     506  data := GIFLoadFromStream(Stream);
     507
     508  ClearViewer;
     509  Clear;
     510  FWidth  := data.Width;
     511  FHeight := data.Height;
     512  FBackgroundColor := data.BackgroundColor;
     513  FAspectRatio:= data.AspectRatio;
     514
     515  SetLength(FImages, length(data.Images));
     516  FTotalAnimationTime:= 0;
     517  for i := 0 to high(FImages) do
     518  begin
     519    FImages[i] := data.Images[i];
     520    FTotalAnimationTime += FImages[i].DelayMs;
     521  end;
     522end;
     523
     524procedure TBGRAAnimatedGif.SaveToStream(Stream: TStream);
     525begin
     526  SaveToStream(Stream, BGRAColorQuantizerFactory, daFloydSteinberg);
     527end;
     528
     529procedure TBGRAAnimatedGif.LoadFromFile(const AFilenameUTF8: string);
     530var stream: TFileStreamUTF8;
     531begin
     532  stream := TFileStreamUTF8.Create(AFilenameUTF8,fmOpenRead or fmShareDenyWrite);
     533  try
     534    LoadFromStream(stream);
     535  finally
     536    Stream.Free;
     537  end;
     538end;
     539
     540procedure TBGRAAnimatedGif.SaveToFile(const AFilenameUTF8: string);
     541var
     542  Stream: TFileStreamUTF8;
     543begin
     544  Stream := TFileStreamUTF8.Create(AFilenameUTF8, fmCreate);
     545  try
     546    SaveToStream(Stream);
     547  finally
     548    Stream.Free;
     549  end;
     550end;
     551
     552procedure TBGRAAnimatedGif.Draw(ACanvas: TCanvas; const Rect: TRect);
     553begin
     554  if FBackgroundImage <> nil then
     555    FreeAndNil(FBackgroundImage);
     556  SaveBackgroundOnce(ACanvas, Rect);
     557
     558  if FPreviousVirtualScreen <> nil then
     559  begin
     560    FPreviousVirtualScreen.FreeReference;
     561    FPreviousVirtualScreen := nil;
     562  end;
     563
     564  Render(Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
     565  FStretchedVirtualScreen.Draw(ACanvas, Rect.Left, Rect.Top, false);
     566  FImageChanged := False;
     567
     568  FPreviousVirtualScreen := TBGRABitmap(FStretchedVirtualScreen.Duplicate);
     569end;
     570
     571function TBGRAAnimatedGif.GetEmpty: boolean;
     572begin
     573  Result := (length(FImages) = 0);
     574end;
     575
     576function TBGRAAnimatedGif.GetHeight: integer;
     577begin
     578  Result := FHeight;
     579end;
     580
     581function TBGRAAnimatedGif.GetTransparent: boolean;
     582begin
     583  Result := True;
     584end;
     585
     586function TBGRAAnimatedGif.GetWidth: integer;
     587begin
     588  Result := FWidth;
     589end;
     590
     591procedure TBGRAAnimatedGif.SetHeight(Value: integer);
     592begin
     593  //not implemented
     594end;
     595
     596procedure TBGRAAnimatedGif.SetTransparent(Value: boolean);
     597begin
     598  //not implemented
     599end;
     600
     601procedure TBGRAAnimatedGif.SetWidth(Value: integer);
     602begin
     603  //not implemented
     604end;
     605
     606procedure TBGRAAnimatedGif.ClearViewer;
    351607begin
    352608  FCurrentImage    := -1;
    … …  
    368624  FPreviousVirtualScreen := nil;
    369625
    370   EraseColor := clBlack;
    371626  FPreviousDisposeMode := dmNone;
    372 
    373   FWidth  := 0;
    374   FHeight := 0;
    375 
    376   if Stream <> nil then
    377     LoadImages(Stream);
    378 end;
    379 
    380 procedure TBGRAAnimatedGif.SaveToStream(Stream: TStream);
    381 begin
    382   //not implemented
    383 end;
    384 
    385 procedure TBGRAAnimatedGif.LoadFromFile(const AFilenameUTF8: string);
    386 var stream: TFileStreamUTF8;
    387 begin
    388   stream := TFileStreamUTF8.Create(AFilenameUTF8,fmOpenRead or fmShareDenyWrite);
    389   try
    390     LoadFromStream(Stream);
    391   finally
    392     Stream.Free;
    393   end;
    394 end;
    395 
    396 procedure TBGRAAnimatedGif.SaveToFile(const AFilenameUTF8: string);
    397 var
    398   Stream: TFileStreamUTF8;
    399 begin
    400   Stream := TFileStreamUTF8.Create(AFilenameUTF8, fmCreate);
    401   try
    402     SaveToStream(Stream);
    403   finally
    404     Stream.Free;
    405   end;
    406 end;
    407 
    408 {$HINTS OFF}
    409 procedure TBGRAAnimatedGif.LoadImages(stream: TStream);
    410 
    411   procedure DumpData;
    412   var
    413     Count: byte;
    414   begin
    415     repeat
    416       stream.Read(Count, 1);
    417       stream.position := stream.position + Count;
    418     until (Count = 0) or (stream.position >= stream.size);
    419   end;
    420 
    421 type
    422   TRGB = packed record
    423     r, g, b: byte;
    424   end;
    425 
    426   TPalette = array of TBGRAPixel;
    427 
    428   function rgbToColor(rgb: TRGB): TBGRAPixel;
    429   begin
    430     Result.red   := rgb.r;
    431     Result.green := rgb.g;
    432     Result.blue  := rgb.b;
    433     Result.alpha := 255;
    434   end;
    435 
    436 const
    437   GIFScreenDescriptor_GlobalColorTableFlag = $80;
    438   GIFImageDescriptor_LocalColorTableFlag = $80;
    439   GIFImageDescriptor_InterlacedFlag = $40;
    440   GIFGraphicControlExtension_TransparentFlag = $01;
    441 
    442 const
    443   ilstart: array[1..4] of longint = (0, 4, 2, 1);
    444   ilstep: array[1..4] of longint = (8, 8, 4, 2);
    445 
    446 var
    447   NewImages: array of TGifSubImage;
    448   NbImages:  integer;
    449 
    450   GIFSignature: TGIFSignature;
    451   GIFScreenDescriptor: TGIFScreenDescriptor;
    452   GIFBlockID:   char;
    453   GIFImageDescriptor: TGIFImageDescriptor;
    454 
    455   globalPalette: TPalette;
    456   localPalette:  TPalette;
    457 
    458   transcolorIndex: integer;
    459   delay: integer;
    460   disposeMode: TDisposeMode;
    461 
    462   procedure LoadGlobalPalette;
    463   var
    464     NbEntries, i: integer;
    465     rgb: TRGB;
    466   begin
    467     NbEntries := 1 shl (GIFScreenDescriptor.flags and $07 + 1);
    468     setlength(globalPalette, NbEntries);
    469     for i := 0 to NbEntries - 1 do
    470     begin
    471       stream.Read(rgb, 3);
    472       globalPalette[i] := rgbToColor(rgb);
    473     end;
    474   end;
    475 
    476   procedure LoadLocalPalette;
    477   var
    478     NbEntries, i: integer;
    479     rgb: TRGB;
    480   begin
    481     NbEntries := 1 shl (GIFImageDescriptor.flags and $07 + 1);
    482     setlength(localPalette, NbEntries);
    483     for i := 0 to NbEntries - 1 do
    484     begin
    485       stream.Read(rgb, 3);
    486       localPalette[i] := rgbToColor(rgb);
    487     end;
    488   end;
    489 
    490   procedure decodeGIFLZW(image: TBGRABitmap; const pal: TPalette; interlaced: boolean);
    491   var
    492     xd, yd: longint;
    493   const
    494     tablen = 4095;
    495   type
    496     Pstr = ^Tstr;
    497 
    498     Tstr = record
    499       prefix: Pstr;
    500       suffix: longint;
    501     end;
    502     Pstrtab = ^Tstrtab;
    503     Tstrtab = array[0..tablen] of Tstr;
    504 
    505   var
    506     strtab:   Pstrtab;
    507     oldcode, curcode, clearcode, endcode: longint;
    508     codesize, codelen, codemask: longint;
    509     stridx:   longint;
    510     bitbuf, bitsinbuf: longint;
    511     bytbuf:   packed array[0..255] of byte;
    512     bytinbuf, bytbufidx: byte;
    513     endofsrc: boolean;
    514     xcnt, ycnt, ystep, pass: longint;
    515 
    516     procedure InitStringTable;
    517     var
    518       i: longint;
    519     begin
    520       new(strtab);
    521       clearcode := 1 shl codesize;
    522       endcode   := clearcode + 1;
    523       stridx    := endcode + 1;
    524       codelen   := codesize + 1;
    525       codemask  := (1 shl codelen) - 1;
    526       for i := 0 to clearcode - 1 do
    527       begin
    528         strtab^[i].prefix := nil;
    529         strtab^[i].suffix := i;
    530       end;
    531       for i := clearcode to tablen do
    532       begin
    533         strtab^[i].prefix := nil;
    534         strtab^[i].suffix := 0;
    535       end;
    536     end;
    537 
    538     procedure ClearStringTable;
    539     var
    540       i: longint;
    541     begin
    542       clearcode := 1 shl codesize;
    543       endcode   := clearcode + 1;
    544       stridx    := endcode + 1;
    545       codelen   := codesize + 1;
    546       codemask  := (1 shl codelen) - 1;
    547       for i := clearcode to tablen do
    548       begin
    549         strtab^[i].prefix := nil;
    550         strtab^[i].suffix := 0;
    551       end;
    552     end;
    553 
    554     procedure DoneStringTable;
    555     begin
    556       dispose(strtab);
    557     end;
    558 
    559     function GetNextCode: longint;
    560     begin
    561       while (bitsinbuf < codelen) do
    562       begin
    563         if (bytinbuf = 0) then
    564         begin
    565           stream.Read(bytinbuf, 1);
    566           if (bytinbuf = 0) then
    567             endofsrc := True;
    568           stream.Read(bytbuf, bytinbuf);
    569           bytbufidx := 0;
    570         end;
    571         bitbuf := bitbuf or (longint(byte(bytbuf[bytbufidx])) shl bitsinbuf);
    572         Inc(bytbufidx);
    573         Dec(bytinbuf);
    574         Inc(bitsinbuf, 8);
    575       end;
    576       Result := bitbuf and codemask;
    577       {DBG(bitbuf AND codemask);}
    578       bitbuf := bitbuf shr codelen;
    579       Dec(bitsinbuf, codelen);
    580     end;
    581 
    582     procedure AddStr2Tab(prefix: Pstr; suffix: longint);
    583     begin
    584       strtab^[stridx].prefix := prefix;
    585       strtab^[stridx].suffix := suffix;
    586       Inc(stridx);
    587       case stridx of
    588         0..1: codelen      := 1;
    589         2..3: codelen      := 2;
    590         4..7: codelen      := 3;
    591         8..15: codelen     := 4;
    592         16..31: codelen    := 5;
    593         32..63: codelen    := 6;
    594         64..127: codelen   := 7;
    595         128..255: codelen  := 8;
    596         256..511: codelen  := 9;
    597         512..1023: codelen := 10;
    598         1024..2047: codelen := 11;
    599         2048..4096: codelen := 12;
    600       end;
    601       codemask := (1 shl codelen) - 1;
    602     end;
    603 
    604     function Code2Str(code: longint): Pstr;
    605     begin
    606       Result := addr(strtab^[code]);
    607     end;
    608 
    609     procedure WriteStr(s: Pstr);
    610     var
    611       colorIndex: integer;
    612     begin
    613       if (s^.prefix <> nil) then
    614         WriteStr(s^.prefix);
    615       if (ycnt >= yd) then
    616       begin
    617         if interlaced then
    618         begin
    619           while (ycnt >= yd) and (pass < 5) do
    620           begin
    621             Inc(pass);
    622             ycnt  := ilstart[pass];
    623             ystep := ilstep[pass];
    624           end;
    625         end;
    626       end;
    627 
    628       colorIndex := s^.suffix;
    629       if (colorIndex <> transcolorIndex) and (colorIndex >= 0) and
    630         (colorIndex < length(pal)) then
    631         image.setpixel(xcnt, ycnt, pal[colorIndex]);
    632 
    633       Inc(xcnt);
    634       if (xcnt >= xd) then
    635       begin
    636         xcnt := 0;
    637         Inc(ycnt, ystep);
    638 
    639         if not interlaced then
    640           if (ycnt >= yd) then
    641           begin
    642             Inc(pass);
    643           end;
    644 
    645       end;
    646     end;
    647 
    648     function firstchar(s: Pstr): byte;
    649     begin
    650       while (s^.prefix <> nil) do
    651         s    := s^.prefix;
    652       Result := s^.suffix;
    653     end;
    654 
    655   begin
    656     {DBG('lzw start');}
    657     endofsrc := False;
    658     xd   := image.Width;
    659     yd   := image.Height;
    660     xcnt := 0;
    661     if interlaced then
    662     begin
    663       pass  := 1;
    664       ycnt  := ilstart[pass];
    665       ystep := ilstep[pass];
    666     end
    667     else
    668     begin
    669       pass  := 4;
    670       ycnt  := 0;
    671       ystep := 1;
    672     end;
    673     oldcode   := 0;
    674     bitbuf    := 0;
    675     bitsinbuf := 0;
    676     bytinbuf  := 0;
    677     bytbufidx := 0;
    678     codesize  := 0;
    679     stream.Read(codesize, 1);
    680     {DBG(codesize);}
    681     InitStringTable;
    682     curcode := getnextcode;
    683     {DBG(curcode);}
    684     while (curcode <> endcode) and (pass < 5) and not endofsrc{ AND NOT finished} do
    685     begin
    686 {DBG('-----');
    687 DBG(curcode);
    688 DBGw(stridx);}
    689       if (curcode = clearcode) then
    690       begin
    691         ClearStringTable;
    692         repeat
    693           curcode := getnextcode;
    694           {DBG('lzw clear');}
    695         until (curcode <> clearcode);
    696         if (curcode = endcode) then
    697           break;
    698         WriteStr(code2str(curcode));
    699         oldcode := curcode;
    700       end
    701       else
    702       begin
    703         if (curcode < stridx) then
    704         begin
    705           WriteStr(Code2Str(curcode));
    706           AddStr2Tab(Code2Str(oldcode), firstchar(Code2Str(curcode)));
    707           oldcode := curcode;
    708         end
    709         else
    710         begin
    711           if (curcode > stridx) then
    712             break;
    713           AddStr2Tab(Code2Str(oldcode), firstchar(Code2Str(oldcode)));
    714           WriteStr(Code2Str(stridx - 1));
    715           oldcode := curcode;
    716         end;
    717       end;
    718       curcode := getnextcode;
    719     end;
    720     DoneStringTable;
    721     {putimage(0,0,image);}
    722 {DBG('lzw end');
    723 DBG(bytinbuf);}
    724     if not endofsrc then
    725       DumpData;
    726     {DBG('lzw finished');}
    727   end;
    728 
    729   procedure LoadImage;
    730   var
    731     imgWidth, imgHeight: integer;
    732     img:     TBGRABitmap;
    733     Interlaced: boolean;
    734     palette: TPalette;
    735   begin
    736     stream.Read(GIFImageDescriptor, sizeof(GIFImageDescriptor));
    737     GIFImageDescriptor.Width := LEtoN(GIFImageDescriptor.Width);
    738     GIFImageDescriptor.Height := LEtoN(GIFImageDescriptor.Height);
    739     GIFImageDescriptor.x := LEtoN(GIFImageDescriptor.x);
    740     GIFImageDescriptor.y := LEtoN(GIFImageDescriptor.y);
    741     if (GIFImageDescriptor.flags and GIFImageDescriptor_LocalColorTableFlag =
    742       GIFImageDescriptor_LocalColorTableFlag) then
    743       LoadLocalPalette
    744     else
    745       localPalette := nil;
    746 
    747     if localPalette <> nil then
    748       palette := localPalette
    749     else
    750       palette := globalPalette;
    751     imgWidth := GIFImageDescriptor.Width;
    752     imgHeight := GIFImageDescriptor.Height;
    753 
    754     if length(NewImages) <= NbImages then
    755       setlength(NewImages, length(NewImages) * 2 + 1);
    756     img := TBGRABitmap.Create(imgWidth, imgHeight);
    757     img.Fill(BGRAPixelTransparent);
    758     NewImages[NbImages].Image    := img;
    759     NewImages[NbImages].Position := point(GIFImageDescriptor.x, GIFImageDescriptor.y);
    760     NewImages[NbImages].Delay    := Delay;
    761     NewImages[NbImages].disposeMode := disposeMode;
    762 
    763     if (transcolorIndex >= 0) and (transcolorIndex < length(palette)) then
    764       NewImages[nbImages].TransparentColor := palette[transcolorIndex]
    765     else
    766       NewImages[nbImages].TransparentColor := BGRAPixelTransparent;
    767 
    768     Inc(NbImages);
    769 
    770     Interlaced := GIFImageDescriptor.flags and GIFImageDescriptor_InterlacedFlag =
    771       GIFImageDescriptor_InterlacedFlag;
    772     DecodeGIFLZW(img, palette, Interlaced);
    773   end;
    774 
    775   procedure ChangeImages;
    776   var
    777     i: integer;
    778   begin
    779     Clear;
    780     SetLength(FImages, NbImages);
    781     FFullAnimationTime:= 0;
    782     for i := 0 to Count - 1 do
    783     begin
    784       FImages[i] := NewImages[i];
    785       FFullAnimationTime += NewImages[i].Delay;
    786     end;
    787   end;
    788 
    789   procedure ReadExtension;
    790   var
    791     GIFExtensionBlock: TGIFExtensionBlock;
    792     GIFGraphicControlExtension: TGIFGraphicControlExtension;
    793     mincount, Count:   byte;
    794 
    795   begin
    796     stream.Read(GIFExtensionBlock, sizeof(GIFExtensionBlock));
    797     case GIFExtensionBlock.functioncode of
    798       $F9:
    799       begin
    800         stream.Read(Count, 1);
    801         if Count < sizeof(GIFGraphicControlExtension) then
    802           mincount := 0
    803         else
    804         begin
    805           mincount := sizeof(GIFGraphicControlExtension);
    806           stream.Read(GIFGraphicControlExtension, mincount);
    807           GIFGraphicControlExtension.delaytime := LEtoN(GIFGraphicControlExtension.delaytime);
    808 
    809           if GIFGraphicControlExtension.flags and
    810             GIFGraphicControlExtension_TransparentFlag =
    811             GIFGraphicControlExtension_TransparentFlag then
    812             transcolorIndex := GIFGraphicControlExtension.transcolor
    813           else
    814             transcolorIndex := -1;
    815           if GIFGraphicControlExtension.delaytime <> 0 then
    816             Delay     := GIFGraphicControlExtension.delaytime * 10;
    817           disposeMode := TDisposeMode((GIFGraphicControlExtension.flags shr 2) and 7);
    818         end;
    819         stream.Position := Stream.Position + Count - mincount;
    820         DumpData;
    821       end;
    822       else
    823       begin
    824         DumpData;
    825       end;
    826     end;
    827   end;
    828 
    829 begin
    830   NewImages := nil;
    831   NbImages  := 0;
    832   transcolorIndex := -1;
    833   Delay     := 100;
    834   FBackgroundColor := clBlack;
    835   FWidth    := 0;
    836   FHeight   := 0;
    837   disposeMode := dmErase;
    838 
    839   stream.Read(GIFSignature, sizeof(GIFSignature));
    840   if (GIFSignature[1] = 'G') and (GIFSignature[2] = 'I') and (GIFSignature[3] = 'F') then
    841   begin
    842     stream.Read(GIFScreenDescriptor, sizeof(GIFScreenDescriptor));
    843     GIFScreenDescriptor.Width := LEtoN(GIFScreenDescriptor.Width);
    844     GIFScreenDescriptor.Height := LEtoN(GIFScreenDescriptor.Height);
    845     FWidth  := GIFScreenDescriptor.Width;
    846     FHeight := GIFScreenDescriptor.Height;
    847     if (GIFScreenDescriptor.flags and GIFScreenDescriptor_GlobalColorTableFlag =
    848       GIFScreenDescriptor_GlobalColorTableFlag) then
    849     begin
    850       LoadGlobalPalette;
    851       if GIFScreenDescriptor.background < length(globalPalette) then
    852         FBackgroundColor :=
    853           BGRAToColor(globalPalette[GIFScreenDescriptor.background]);
    854     end;
    855     repeat
    856       stream.Read(GIFBlockID, sizeof(GIFBlockID));
    857       case GIFBlockID of
    858         ';': ;
    859         ',': LoadImage;
    860         '!': ReadExtension;
    861         else
    862         begin
    863           raise Exception.Create('TBGRAAnimatedGif: unexpected block type');
    864           break;
    865         end;
    866       end;
    867     until (GIFBlockID = ';') or (stream.Position >= stream.size);
    868   end
    869   else
    870     raise Exception.Create('TBGRAAnimatedGif: invalid header');
    871   ChangeImages;
    872 end;
    873 
    874 procedure TBGRAAnimatedGif.Draw(ACanvas: TCanvas; const Rect: TRect);
    875 begin
    876   if FBackgroundImage <> nil then
    877     FreeAndNil(FBackgroundImage);
    878   SaveBackgroundOnce(ACanvas, Rect);
    879 
    880   if FPreviousVirtualScreen <> nil then
    881   begin
    882     FPreviousVirtualScreen.FreeReference;
    883     FPreviousVirtualScreen := nil;
    884   end;
    885 
    886   Render(Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
    887   FStretchedVirtualScreen.Draw(ACanvas, Rect.Left, Rect.Top, false);
    888   FImageChanged := False;
    889 
    890   FPreviousVirtualScreen := TBGRABitmap(FStretchedVirtualScreen.Duplicate);
    891 end;
    892 
    893 function TBGRAAnimatedGif.GetEmpty: boolean;
    894 begin
    895   Result := (length(FImages) = 0);
    896 end;
    897 
    898 function TBGRAAnimatedGif.GetHeight: integer;
    899 begin
    900   Result := FHeight;
    901 end;
    902 
    903 function TBGRAAnimatedGif.GetTransparent: boolean;
    904 begin
    905   Result := True;
    906 end;
    907 
    908 function TBGRAAnimatedGif.GetWidth: integer;
    909 begin
    910   Result := FWidth;
    911 end;
    912 
    913 procedure TBGRAAnimatedGif.SetHeight(Value: integer);
    914 begin
    915   //not implemented
    916 end;
    917 
    918 procedure TBGRAAnimatedGif.SetTransparent(Value: boolean);
    919 begin
    920   //not implemented
    921 end;
    922 
    923 procedure TBGRAAnimatedGif.SetWidth(Value: integer);
    924 begin
    925   //not implemented
    926627end;
    927628
    … …  
    947648    FWantedImage := Index;
    948649end;
    949 
    950 {$HINTS ON}
    951650
    952651procedure TBGRAAnimatedGif.Clear;
    … …  
    1045744          end;
    1046745
    1047           PChangePix  := PLongWord(FPreviousVirtualScreen.ScanLine[0]);
    1048           PNewPix     := PLongWord(FStretchedVirtualScreen.ScanLine[0]);
    1049           PBackground := PLongWord(FBackgroundImage.ScanLine[0]);
    1050           PNewBackground := PLongWord(NewBackgroundImage.ScanLine[0]);
     746          PChangePix  := PLongWord(FPreviousVirtualScreen.Data);
     747          PNewPix     := PLongWord(FStretchedVirtualScreen.Data);
     748          PBackground := PLongWord(FBackgroundImage.Data);
     749          PNewBackground := PLongWord(NewBackgroundImage.Data);
    1051750          for n := FStretchedVirtualScreen.NbPixels - 1 downto 0 do
    1052751          begin
    … …  
    1095794          else
    1096795          begin
    1097             PChangePix  := PLongWord(FPreviousVirtualScreen.ScanLine[0]);
    1098             PNewPix     := PLongWord(FStretchedVirtualScreen.ScanLine[0]);
    1099             PBackground := PLongWord(FBackgroundImage.ScanLine[0]);
     796            PChangePix  := PLongWord(FPreviousVirtualScreen.Data);
     797            PNewPix     := PLongWord(FStretchedVirtualScreen.Data);
     798            PBackground := PLongWord(FBackgroundImage.Data);
    1100799            for n := FStretchedVirtualScreen.NbPixels - 1 downto 0 do
    1101800            begin
    … …  
    1154853      begin
    1155854        shape := TBGRABitmap(FPreviousVirtualScreen.Duplicate);
    1156         p     := shape.ScanLine[0];
     855        p     := shape.Data;
    1157856        for n := shape.NbPixels - 1 downto 0 do
    1158857        begin
    … …  
    1172871      begin
    1173872        shape := TBGRABitmap(FPreviousVirtualScreen.Duplicate);
    1174         p     := shape.ScanLine[0];
    1175         pback := FBackgroundImage.ScanLine[0];
     873        p     := shape.Data;
     874        pback := FBackgroundImage.Data;
    1176875        for n := shape.NbPixels - 1 downto 0 do
    1177876        begin
    … …  
    1227926    else
    1228927    begin
    1229       PChangePix := PLongWord(FPreviousVirtualScreen.ScanLine[0]);
    1230       PNewPix    := PLongWord(FStretchedVirtualScreen.ScanLine[0]);
     928      PChangePix := PLongWord(FPreviousVirtualScreen.Data);
     929      PNewPix    := PLongWord(FStretchedVirtualScreen.Data);
    1231930      for n := FStretchedVirtualScreen.NbPixels - 1 downto 0 do
    1232931      begin
    … …  
    1274973end;
    1275974
    1276 { TFPReaderGIF }
    1277 
    1278 procedure TFPReaderGIF.InternalRead(Str: TStream; Img: TFPCustomImage);
     975{ TBGRAReaderGIF }
     976
     977procedure TBGRAReaderGIF.InternalRead(Str: TStream; Img: TFPCustomImage);
    1279978var
    1280979  gif:  TBGRAAnimatedGif;
    … …  
    1300999end;
    13011000
    1302 {$HINTS OFF}
    1303 function TFPReaderGIF.InternalCheck(Str: TStream): boolean;
     1001function TBGRAReaderGIF.InternalCheck(Str: TStream): boolean;
    13041002var
    13051003  GIFSignature: TGIFSignature;
    … …  
    13081006  savepos := str.Position;
    13091007  try
     1008    fillchar({%H-}GIFSignature, sizeof(GIFSignature), 0);
    13101009    str.Read(GIFSignature, sizeof(GIFSignature));
    13111010    if (GIFSignature[1] = 'G') and (GIFSignature[2] = 'I') and
    … …  
    13231022end;
    13241023
    1325 {$HINTS ON}
     1024{ TBGRAWriterGIF }
     1025
     1026procedure TBGRAWriterGIF.InternalWrite(Str: TStream; Img: TFPCustomImage);
     1027var
     1028  gif: TBGRAAnimatedGif;
     1029begin
     1030  gif := TBGRAAnimatedGif.Create;
     1031  try
     1032    gif.SetSize(Img.Width,Img.Height);
     1033    gif.AddFrame(Img, 0,0,0);
     1034    gif.SaveToStream(Str, BGRAColorQuantizerFactory, daFloydSteinberg);
     1035  except
     1036    on ex: EColorQuantizerMissing do
     1037    begin
     1038      FreeAndNil(gif);
     1039      raise EColorQuantizerMissing.Create('Please define the color quantizer factory. You can do that with the following statements: Uses BGRAPalette, BGRAColorQuantization; BGRAColorQuantizerFactory:= TBGRAColorQuantizer;');
     1040    end;
     1041    on ex: Exception do
     1042    begin
     1043      FreeAndNil(gif);
     1044      raise ex;
     1045    end;
     1046  end;
     1047  FreeAndNil(gif);
     1048end;
    13261049
    13271050initialization
     1051
     1052  DefaultBGRAImageReader[ifGif] := TBGRAReaderGIF;
     1053  DefaultBGRAImageWriter[ifGif] := TBGRAWriterGIF;
    13281054
    13291055  //Free Pascal Image
    13301056  ImageHandlers.RegisterImageReader('Animated GIF', TBGRAAnimatedGif.GetFileExtensions,
    1331     TFPReaderGIF);
    1332 
     1057    TBGRAReaderGIF);
     1058  ImageHandlers.RegisterImageWriter('Animated GIF', TBGRAAnimatedGif.GetFileExtensions,
     1059    TBGRAWriterGIF);
     1060
     1061  {$IFDEF BGRABITMAP_USE_LCL}
    13331062  //Lazarus Picture
    13341063  TPicture.RegisterFileFormat(TBGRAAnimatedGif.GetFileExtensions, 'Animated GIF',
    13351064    TBGRAAnimatedGif);
    1336 
     1065  {$ENDIF}
    13371066end.
    13381067
Note: See TracChangeset for help on using the changeset viewer.