bgragifformat.pas

{ ***************************************************************************
 *                                                                          *
 *  This file is part of BGRABitmap library which is distributed under the  *
 *  modified LGPL.                                                          *
 *                                                                          *
 *  See the file COPYING.modifiedLGPL.txt, included in this distribution,   *
 *  for details about the copyright.                                        *
 *                                                                          *
 *  This program is distributed in the hope that it will be useful,         *
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of          *
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.                    *
 *                                                                          *
 ************************* BGRABitmap library  ******************************

 - Drawing routines with transparency and antialiasing with Lazarus.
   Offers also various transforms.
 - These routines allow to manipulate 32bit images in BGRA format or RGBA
   format (depending on the platform).
 - This code is under modified LGPL (see COPYING.modifiedLGPL.txt).
   This means that you can link this library inside your programs for any purpose.
   Only the included part of the code must remain LGPL.

 - If you make some improvements to this library, please notify here:
   http://www.lazarus.freepascal.org/index.php/topic,12037.0.html

   ********************* Contact : Circular at operamail.com *******************


   ******************************* CONTRIBUTOR(S) ******************************
   - Edivando S. Santos Brasil | mailedivando@gmail.com
     (Compatibility with FPC ($Mode objfpc/delphi) and delphi VCL 11/2018)

   ***************************** END CONTRIBUTOR(S) *****************************}


Unit BGRAGifFormat;

{$i bgrabitmap.inc}{$H+}
{.$POINTERMATH ON}

interface

uses
  Classes, SysUtils, BGRATypes,{$IFNDEF FPC}Types, GraphType,{$ENDIF} BGRAGraphics, BGRABitmap, BGRABitmapTypes,
  BGRAPalette;

type
  //what to do when finishing a frame and starting the next one
  TDisposeMode = (dmNone,        //undefined value
                  dmKeep,        //keep the changes done by the frame
                  dmErase,       //clear everything after the frame
                  dmRestore);    //restore to how it was before the frame

  //one image in the array
  TGifSubImage = record
    Image:    TBGRABitmap;       //image to draw at the beggining of the frame
    Position: TPoint;            //relative position of the image in the frame
    DelayMs:    integer;         //time in milliseconds to wait before going to next frame
    DisposeMode: TDisposeMode;   //what do do when going to next frame
    HasLocalPalette: boolean;    //the image has its own palette
  end;
  TGifSubImageArray = array of TGifSubImage;

  TGIFSignature = packed array[1..6] of AnsiChar; //'GIF87a' or 'GIF89a'

  TGIFScreenDescriptor = packed record
    Width, Height: BGRAWord;
    flags,                    //screen bit depth  = ((flags shr 4) and 7) + 1
                              //palette bit depth = (flags and 7) + 1
    BackgroundColorIndex,     //index of background color in global palette
    AspectRatio64 : byte;     //0 if not specified, otherwise aspect ratio is (AspectRatio64 + 15) / 64
  end;

  TGIFImageDescriptor = packed record
    x, y, Width, Height: BGRAWord;
    flags: byte;
  end;

  TGIFImageDescriptorWithHeader = packed record
    ImageIntroducer: byte;
    Image: TGIFImageDescriptor;
  end;

  TGIFExtensionBlock = packed record
    FunctionCode: byte;
  end;

  TGIFGraphicControlExtension = packed record
    flags: byte;
    DelayHundredthSec: BGRAWord;
    TransparentColorIndex: byte;
  end;

  TGIFGraphicControlExtensionWithHeader = packed record
    ExtensionIntroducer: byte;
    FunctionCode: byte;
    BlockSize: byte;
    GraphicControl: TGIFGraphicControlExtension;
    BlockTerminator: byte;
  end;

  TPackedRGBTriple = packed record
    r, g, b: byte;
  end;

  TGIFData = record
    Width, Height: integer;
    AspectRatio: single;
    BackgroundColor: TColor;
    LoopCount: BGRAWord;
    Images: {$IFDEF BDS}TGifSubImageArray{$ELSE}array of TGifSubImage{$ENDIF};
  end;

  { EColorQuantizerMissing }

  EColorQuantizerMissing = class(Exception)
    constructor Create; overload;
    constructor Create(AMessage: string); overload;
  end;

const
  GIFScreenDescriptor_GlobalColorTableFlag = $80;    //global palette is present
  GIFScreenDescriptor_GlobalColorSortFlag  = $08;    //global palette colors are sorted by importance

  GIFImageIntroducer     = $2c;
  GIFExtensionIntroducer = $21;
  GIFBlockTerminator     = $00;
  GIFFileTerminator      = $3B;

  GIFGraphicControlExtension_TransparentFlag = $01;  //transparent color index is provided
  GIFGraphicControlExtension_UserInputFlag = $02;    //wait for user input at this frame (ignored)
  GIFGraphicControlExtension_FunctionCode = $f9;
  GIFGraphicControlExtension_DisposeModeShift = 2;

  GIFImageDescriptor_LocalColorTableFlag = $80;      //local palette is present
  GIFImageDescriptor_InterlacedFlag = $40;           //image data is interlaced
  GIFImageDescriptor_LocalColorSortFlag = $20;       //local palette colors are sorted by importance

  GIFInterlacedStart: array[1..4] of BGRALongInt = (0, 4, 2, 1);
  GIFInterlacedStep: array[1..4] of BGRALongInt = (8, 8, 4, 2);

  GIFCodeTableSize = 4096;

  NetscapeApplicationIdentifier = 'NETSCAPE2.0';
  NetscapeSubBlockIdLoopCount = 1;
  NetscapeSubBlockIdBuffering = 2;

function CeilLn2(AValue: Integer): integer;
function BGRAToPackedRgbTriple(color: TBGRAPixel): TPackedRGBTriple;
function PackedRgbTribleToBGRA(rgb: TPackedRGBTriple): TBGRAPixel;
function GIFLoadFromStream(stream: TStream; MaxImageCount: integer = maxLongint): TGIFData;
procedure GIFSaveToStream(AData: TGifData; Stream: TStream; AQuantizerFactory: TBGRAColorQuantizerAny;
          ADitheringAlgorithm: TDitheringAlgorithm);
procedure GIFDecodeLZW(AStream: TStream; AImage: TBGRACustomBitmap;
          const APalette: ArrayOfTBGRAPixel; transcolorIndex: integer;
          interlaced: boolean);

//Encode an image supplied as an sequence of bytes, from left to right and top to bottom.
//Adapted from the work of Udo Schmal, http://www.gocher.me/FPWriteGIF
procedure GIFEncodeLZW(AStream: TStream; AImageData: PByte;
          AImageWidth, AImageHeight: integer; ABitDepth: byte);

implementation

function PackedRgbTribleToBGRA(rgb: TPackedRGBTriple): TBGRAPixel;
begin
  Result.red   := rgb.r;
  Result.green := rgb.g;
  Result.blue  := rgb.b;
  Result.alpha := 255;
end;

function BGRAToPackedRgbTriple(color: TBGRAPixel): TPackedRGBTriple;
begin
  result.r := color.red;
  result.g := color.green;
  result.b := color.blue;
end;

function CeilLn2(AValue: Integer): integer;
var comp: integer;
begin
  result := 0;
  comp := 1;
  while (comp < AValue) and (result < 30) do
  begin
    inc(result);
    comp := comp shl 1;
  end;
end;

procedure GIFDecodeLZW(AStream: TStream; AImage: TBGRACustomBitmap;
          const APalette: ArrayOfTBGRAPixel; transcolorIndex: integer;
          interlaced: boolean);
var
  xd, yd: BGRALongInt;
type
  Pstr = ^Tstr;

  Tstr = record
    prefix: Pstr;
    suffix: BGRALongInt;
  end;
  Pstrtab = ^Tstrtab;
  Tstrtab = array[0..GIFCodeTableSize-1] of Tstr;

var
  strtab:   Pstrtab;
  oldcode, curcode, clearcode, endcode: BGRALongInt;
  codesize, codelen, codemask: BGRALongInt;
  stridx:   BGRALongInt;
  bitbuf, bitsinbuf: BGRALongInt;
  bytbuf:   packed array[0..255] of byte;
  bytinbuf, bytbufidx: byte;
  endofsrc: boolean;
  xcnt, ycnt, ystep, pass: BGRALongInt;
  pdest: PBGRAPixel;

  procedure InitStringTable;
  var
    i: BGRALongInt;
  begin
    new(strtab);
    clearcode := 1 shl codesize;
    endcode   := clearcode + 1;
    stridx    := endcode + 1;
    codelen   := codesize + 1;
    codemask  := (1 shl codelen) - 1;
    for i := 0 to clearcode - 1 do
    begin
      strtab^[i].prefix := nil;
      strtab^[i].suffix := i;
    end;
    for i := clearcode to GIFCodeTableSize-1 do
    begin
      strtab^[i].prefix := nil;
      strtab^[i].suffix := 0;
    end;
  end;

  procedure ClearStringTable;
  var
    i: BGRALongInt;
  begin
    clearcode := 1 shl codesize;
    endcode   := clearcode + 1;
    stridx    := endcode + 1;
    codelen   := codesize + 1;
    codemask  := (1 shl codelen) - 1;
    for i := clearcode to GIFCodeTableSize-1 do
    begin
      strtab^[i].prefix := nil;
      strtab^[i].suffix := 0;
    end;
  end;

  procedure DoneStringTable;
  begin
    dispose(strtab);
  end;

  function GetNextCode: BGRALongInt;
  begin
    while (bitsinbuf < codelen) do
    begin
      if (bytinbuf = 0) then
      begin
        if AStream.Read(bytinbuf, 1) <> 1 then
          raise exception.Create('Unexpected end of stream');

        if (bytinbuf = 0) then
        begin
          endofsrc := True;
          result := endcode;
          exit;
        end;
        AStream.Read(bytbuf, bytinbuf);
        bytbufidx := 0;
      end;
      bitbuf := bitbuf or (BGRALongInt(byte(bytbuf[bytbufidx])) shl bitsinbuf);
      Inc(bytbufidx);
      Dec(bytinbuf);
      Inc(bitsinbuf, 8);
    end;
    Result := bitbuf and codemask;
    bitbuf := bitbuf shr codelen;
    Dec(bitsinbuf, codelen);
    //write(inttostr(result)+'@'+inttostr(codelen)+' ');
  end;

  procedure AddStr2Tab(prefix: Pstr; suffix: BGRALongInt);
  begin
    if stridx >= GIFCodeTableSize then exit;
    strtab^[stridx].prefix := prefix;
    strtab^[stridx].suffix := suffix;
    Inc(stridx);
    case stridx of
      0..1: codelen      := 1;
      2..3: codelen      := 2;
      4..7: codelen      := 3;
      8..15: codelen     := 4;
      16..31: codelen    := 5;
      32..63: codelen    := 6;
      64..127: codelen   := 7;
      128..255: codelen  := 8;
      256..511: codelen  := 9;
      512..1023: codelen := 10;
      1024..2047: codelen := 11;
      2048..4096: codelen := 12;
    end;
    codemask := (1 shl codelen) - 1;
  end;

  function Code2Str(code: BGRALongInt): Pstr;
  begin
    Result := addr(strtab^[code]);
  end;

  procedure WriteStr(s: Pstr);
  var
    colorIndex: integer;
  begin
    if (s^.prefix <> nil) then
      WriteStr(s^.prefix);
    if (ycnt >= yd) then
    begin
      if interlaced then
      begin
        while ycnt >= yd do
        begin
          if pass >= 5 then exit;

          Inc(pass);
          ycnt  := GIFInterlacedStart[pass];
          ystep := GIFInterlacedStep[pass];
        end;
      end else exit;
    end;

    colorIndex := s^.suffix;
    if xcnt = 0 then pdest := AImage.ScanLine[ycnt];

    if (colorIndex <> transcolorIndex) and (colorIndex >= 0) and
      (colorIndex < length(APalette)) then
      pdest^ := APalette[colorIndex];

    Inc(xcnt);
    inc(pdest);

    if (xcnt >= xd) then
    begin
      pdest := nil;
      xcnt := 0;
      Inc(ycnt, ystep);

      if not interlaced then
        if (ycnt >= yd) then
        begin
          Inc(pass);
        end;

    end;
  end;

  function firstchar(s: Pstr): byte;
  begin
    while (s^.prefix <> nil) do
      s    := s^.prefix;
    Result := s^.suffix;
  end;

begin
  endofsrc := False;
  xd   := AImage.Width;
  yd   := AImage.Height;
  xcnt := 0;
  pdest := nil;
  if interlaced then
  begin
    pass  := 1;
    ycnt  := GIFInterlacedStart[pass];
    ystep := GIFInterlacedStep[pass];
  end
  else
  begin
    pass  := 4;
    ycnt  := 0;
    ystep := 1;
  end;
  oldcode   := 0;
  bitbuf    := 0;
  bitsinbuf := 0;
  bytinbuf  := 0;
  bytbufidx := 0;
  codesize  := 0;
  AStream.Read(codesize, 1);
  InitStringTable;
  curcode := getnextcode;
  //Write('Reading ');
  while (curcode <> endcode) and (pass < 5) and not endofsrc do
  begin
    if (curcode = clearcode) then
    begin
      ClearStringTable;
      repeat
        curcode := getnextcode;
      until (curcode <> clearcode);
      if (curcode = endcode) then
        break;
      WriteStr(code2str(curcode));
      oldcode := curcode;
    end
    else
    begin
      if (curcode < stridx) then
      begin
        WriteStr(Code2Str(curcode));
        AddStr2Tab(Code2Str(oldcode), firstchar(Code2Str(curcode)));
        oldcode := curcode;
      end
      else
      begin
        if (curcode > stridx) then
        begin
          //write('!Invalid! ');
          break;
        end;
        AddStr2Tab(Code2Str(oldcode), firstchar(Code2Str(oldcode)));
        WriteStr(Code2Str(stridx - 1));
        oldcode := curcode;
      end;
    end;
    curcode := getnextcode;
  end;
  DoneStringTable;
  //Writeln;
  if not endofsrc then
  begin
    bytinbuf:= 0;
    AStream.ReadBuffer(bytinbuf, 1);
    if bytinbuf <> 0 then
      raise exception.Create('Invalid GIF format: expecting block terminator');
  end;
end;

//Encode an image supplied as an sequence of bytes, from left to right and top to bottom.
//Adapted from the work of Udo Schmal, http://www.gocher.me/FPWriteGIF
procedure GIFEncodeLZW(AStream: TStream; AImageData: PByte;
          AImageWidth, AImageHeight: integer; ABitDepth: byte);

var  //input position
  PInput, PInputEnd: PByte;

  // get the next pixel from the bitmap
  function ReadValue: byte;
  begin
    result := PInput^;
    Inc(PInput);
  end;

var // GIF buffer can be up to 255 bytes long
  OutputBufferSize: BGRANativeInt;
  OutputBuffer: packed array[0..255] of byte;

  procedure FlushByteOutput;
  begin
    if OutputBufferSize > 0 then
    begin
      OutputBuffer[0] := OutputBufferSize;
      AStream.WriteBuffer(OutputBuffer, OutputBufferSize+1);
      OutputBufferSize := 0;
    end;
  end;

  procedure OutputByte(AValue: byte);
  begin
    if OutputBufferSize = 255 then FlushByteOutput;
    inc(OutputBufferSize);
    OutputBuffer[OutputBufferSize] := AValue;
  end;

type TCode = BGRAWord;

var
  BitBuffer       : BGRADWord; // steady stream of bit output
  BitBufferLen    : Byte;  // number of bits in buffer
  CurCodeSize     : byte;  // current code size

  // save the code in the output data stream
  procedure WriteCode(Code: TCode);
  begin
    //Write(IntToStr(Code)+'@'+IntToStr(CurCodeSize)+' ');

    // append code to bit buffer
    BitBuffer := BitBuffer or (Code shl BitBufferLen);
    BitBufferLen := BitBufferLen + CurCodeSize;
    // output whole bytes
    while BitBufferLen >= 8 do
    begin
      OutputByte(BitBuffer and $ff);
      BitBuffer := BitBuffer shr 8;
      BitBufferLen := BitBufferLen -8;
    end;
  end;

  procedure CloseBitOutput;
  begin
    // write out the rest of the bit string
    // and add padding bits if necessary
    while BitBufferLen > 0 do
    begin
      OutputByte(BitBuffer and $ff);
      BitBuffer := BitBuffer shr 8;
      if BitBufferLen >= 8 then
        BitBufferLen := BitBufferLen -8
      else
        BitBufferLen := 0;
    end;
  end;

type
  PCodeTableEntry = ^TCodeTableEntry;
  TCodeTableEntry = packed record
               Prefix: TCode;
               LongerFirst, LongerLast: TCode;
               Suffix, Padding: Byte;
               NextWithPrefix: TCode;
             end;

var
  ClearCode     : TCode;   // reset decode params
  EndStreamCode : TCode;   // last code in input stream
  FirstCodeSlot : TCode;   // first slot when table is empty
  NextCodeSlot  : TCode;   // next slot to be used

  PEntry: PCodeTableEntry;
  CodeTable: array of TCodeTableEntry;
  CurrentCode   : TCode; // code representing current string

  procedure DoClearCode;
  var
    i: BGRAWord;
  begin
    for i := 0 to (1 shl ABitDepth)-1 do
    with CodeTable[i] do
    begin
      LongerFirst:= 0;
      LongerLast:= 0;
    end;

    WriteCode(ClearCode);
    CurCodeSize := ABitDepth + 1;
    NextCodeSlot := FirstCodeSlot;
  end;

var
  CurValue: Byte;
  i: TCode;
  found: boolean; // decoded string in prefix table?
begin
   if ABitDepth > 8 then
     raise exception.Create('Maximum bit depth is 8');

   //output
   AStream.WriteByte(ABitDepth);
   ClearCode := 1 shl ABitDepth;
   EndStreamCode := ClearCode + 1;
   FirstCodeSlot := ClearCode + 2;
   CurCodeSize := ABitDepth + 1;

   OutputBufferSize := 0;
   BitBuffer := 0;
   BitBufferLen := 0;

   //input
   PInput := AImageData;
   PInputEnd := AImageData + BGRAPtrInt(AImageWidth)*AImageHeight;

   setlength(CodeTable, GIFCodeTableSize);
   DoClearCode;
   //write('Writing ');

   while PInput < PInputEnd do
   begin
     CurrentCode := ReadValue;
     if CurrentCode >= ClearCode then
       raise exception.Create('Internal error');

     //try to match the longest string
     while PInput < PInputEnd do
     begin
       CurValue := ReadValue;

       found := false;

       i := CodeTable[CurrentCode].LongerFirst;
       while i <> 0 do
       begin
         PEntry := @CodeTable[i];
         if PEntry^.Suffix = CurValue then
         begin
           found := true;
           CurrentCode := i;
           break;
         end;
         i := PEntry^.NextWithPrefix;
       end;

       if not found then
       begin
         PEntry := @CodeTable[CurrentCode];
         if PEntry^.LongerFirst = 0 then
         begin
           //store the first and last code being longer
           PEntry^.LongerFirst := NextCodeSlot;
           PEntry^.LongerLast := NextCodeSlot;
         end else
         begin
           //link next entry having the same prefix
           CodeTable[PEntry^.LongerLast].NextWithPrefix:= NextCodeSlot;
           PEntry^.LongerLast := NextCodeSlot;
         end;

         // add new encode table entry
         PEntry := @CodeTable[NextCodeSlot];
         PEntry^.Prefix := CurrentCode;
         PEntry^.Suffix := CurValue;
         PEntry^.LongerFirst := 0;
         PEntry^.LongerLast := 0;
         PEntry^.NextWithPrefix := 0;
         inc(NextCodeSlot);

         Dec(PInput);
         break;
       end;
     end;

     // write the code of the longest entry found
     WriteCode(CurrentCode);

     if NextCodeSlot >= GIFCodeTableSize then
       DoClearCode
     else if NextCodeSlot > 1 shl CurCodeSize then
       inc(CurCodeSize);
   end;

   WriteCode(EndStreamCode);
   CloseBitOutput;
   FlushByteOutput;

   AStream.WriteByte(0); //GIF block terminator
   //Writeln;
end;

function GIFLoadFromStream(stream: TStream; MaxImageCount: integer = maxLongint): TGIFData;

  procedure DumpData;
  var
    Count: byte;
  begin
    repeat
      Count := 0;
      stream.Read(Count, 1);
      stream.position := stream.position + Count;
    until (Count = 0) or (stream.position >= stream.size);
  end;

  function ReadString: Ansistring;
  var Count: byte;
  begin
    Count := 0;
    stream.Read(Count, 1);
    setlength(result, Count);
    if Count > 0 then
      stream.ReadBuffer(result[1], length(result));
  end;

var
  NbImages:  integer;

  GIFSignature: TGIFSignature;
  GIFScreenDescriptor: TGIFScreenDescriptor;
  GIFBlockID:   {$IFDEF FPC}Char{$ELSE}AnsiChar{$ENDIF};
  GIFImageDescriptor: TGIFImageDescriptor;

  globalPalette: ArrayOfTBGRAPixel;
  localPalette:  ArrayOfTBGRAPixel;

  transcolorIndex: integer;
  DelayMs: integer;
  disposeMode: TDisposeMode;

  procedure LoadGlobalPalette;
  var
    NbEntries, i: integer;
    rgb: TPackedRGBTriple;
  begin
    NbEntries := 1 shl (GIFScreenDescriptor.flags and $07 + 1);
    setlength(globalPalette, NbEntries);
    for i := 0 to NbEntries - 1 do
    begin
      stream.ReadBuffer({%H-}rgb, 3);
      globalPalette[i] := PackedRgbTribleToBGRA(rgb);
    end;
  end;

  procedure LoadLocalPalette;
  var
    NbEntries, i: integer;
    rgb: TPackedRGBTriple;
  begin
    NbEntries := 1 shl (GIFImageDescriptor.flags and $07 + 1);
    setlength(localPalette, NbEntries);
    for i := 0 to NbEntries - 1 do
    begin
      stream.ReadBuffer({%H-}rgb, 3);
      localPalette[i] := PackedRgbTribleToBGRA(rgb);
    end;
  end;

  procedure LoadImage;
  var
    imgWidth, imgHeight: integer;
    img:     TBGRABitmap;
    Interlaced: boolean;
    palette: ArrayOfTBGRAPixel;
  begin
    stream.Read(GIFImageDescriptor, sizeof(GIFImageDescriptor));
    {$IFNDEF BDS}GIFImageDescriptor.Width := LEtoN(GIFImageDescriptor.Width);{$ENDIF}
    {$IFNDEF BDS}GIFImageDescriptor.Height := LEtoN(GIFImageDescriptor.Height);{$ENDIF}
    {$IFNDEF BDS}GIFImageDescriptor.x := LEtoN(GIFImageDescriptor.x);{$ENDIF}
    {$IFNDEF BDS}GIFImageDescriptor.y := LEtoN(GIFImageDescriptor.y);{$ENDIF}
    if (GIFImageDescriptor.flags and GIFImageDescriptor_LocalColorTableFlag =
      GIFImageDescriptor_LocalColorTableFlag) then
      LoadLocalPalette
    else
      localPalette := nil;

    if localPalette <> nil then
      palette := localPalette
    else
      palette := globalPalette;
    imgWidth := GIFImageDescriptor.Width;
    imgHeight := GIFImageDescriptor.Height;

    if length(result.Images) <= NbImages then
      setlength(result.Images, length(result.Images) * 2 + 1);
    img := TBGRABitmap.Create(imgWidth, imgHeight);
    img.Fill(BGRAPixelTransparent);
    result.Images[NbImages].Image    := img;
    result.Images[NbImages].Position := point(GIFImageDescriptor.x, GIFImageDescriptor.y);
    result.Images[NbImages].DelayMs    := DelayMs;
    result.Images[NbImages].DisposeMode := disposeMode;
    result.Images[NbImages].HasLocalPalette := localPalette <> nil;
    Inc(NbImages);

    Interlaced := GIFImageDescriptor.flags and GIFImageDescriptor_InterlacedFlag =
      GIFImageDescriptor_InterlacedFlag;
    GIFDecodeLZW(stream, img, palette, transcolorIndex, Interlaced);
  end;

  procedure ReadExtension;
  var
    GIFExtensionBlock: TGIFExtensionBlock;
    GIFGraphicControlExtension: TGIFGraphicControlExtension;
    mincount, Count, SubBlockId:   byte;
    app: String;

  begin
    stream.ReadBuffer({%H-}GIFExtensionBlock, sizeof(GIFExtensionBlock));
    case GIFExtensionBlock.FunctionCode of
      $F9: //graphic control extension
      begin
        Count := 0;
        stream.Read(Count, 1);
        if Count < sizeof(GIFGraphicControlExtension) then
          mincount := 0
        else
        begin
          mincount := sizeof(GIFGraphicControlExtension);
          stream.ReadBuffer({%H-}GIFGraphicControlExtension, mincount);
          {$IFNDEF BDS}GIFGraphicControlExtension.DelayHundredthSec := LEtoN(GIFGraphicControlExtension.DelayHundredthSec);{$ENDIF}

          if GIFGraphicControlExtension.flags and
            GIFGraphicControlExtension_TransparentFlag =
            GIFGraphicControlExtension_TransparentFlag then
            transcolorIndex := GIFGraphicControlExtension.TransparentColorIndex
          else
            transcolorIndex := -1;
          if GIFGraphicControlExtension.DelayHundredthSec <> 0 then
            DelayMs     := GIFGraphicControlExtension.DelayHundredthSec * 10;
          DisposeMode := TDisposeMode((GIFGraphicControlExtension.flags shr GIFGraphicControlExtension_DisposeModeShift) and 7);
        end;
        stream.Position := Stream.Position + Count - mincount;
        DumpData;
      end;
      $ff: //application extension
      begin
        app := ReadString;
        if app <> '' then
        begin
          if app = NetscapeApplicationIdentifier then
          begin
            repeat
              Count := 0;
              stream.Read(Count,1);
              if Count = 0 then break;
              stream.ReadBuffer({%H-}SubBlockId,1);
              Dec(Count);
              if (SubBlockId = NetscapeSubBlockIdLoopCount) and (Count >= 2) then
              begin
                stream.ReadBuffer(result.LoopCount, 2);
                dec(Count,2);
                {$IFNDEF BDS}result.LoopCount := LEtoN(result.LoopCount);{$ENDIF}
                if result.LoopCount > 0 then inc(result.LoopCount);
              end;
              stream.Position:= stream.Position+Count;
            until false;
          end else
            DumpData;
        end;
      end
      else
      begin
        DumpData;
      end;
    end;
  end;

begin
  result.Width := 0;
  result.Height := 0;
  result.BackgroundColor := clNone;
  result.Images := nil;
  result.AspectRatio := 1;
  result.LoopCount := 1;
  if stream = nil then exit;

  NbImages  := 0;
  transcolorIndex := -1;
  DelayMs     := 100;
  disposeMode := dmErase;

  FillChar({%H-}GIFSignature,sizeof(GIFSignature),0);
  stream.Read(GIFSignature, sizeof(GIFSignature));
  if (GIFSignature[1] = 'G') and (GIFSignature[2] = 'I') and (GIFSignature[3] = 'F') then
  begin
    stream.ReadBuffer({%H-}GIFScreenDescriptor, sizeof(GIFScreenDescriptor));
    {$IFNDEF BDS}GIFScreenDescriptor.Width := LEtoN(GIFScreenDescriptor.Width);{$ENDIF}
    {$IFNDEF BDS}GIFScreenDescriptor.Height := LEtoN(GIFScreenDescriptor.Height);{$ENDIF}
    result.Width  := GIFScreenDescriptor.Width;
    result.Height := GIFScreenDescriptor.Height;
    if GIFScreenDescriptor.AspectRatio64 = 0 then
      result.AspectRatio:= 1
    else
      result.AspectRatio:= (GIFScreenDescriptor.AspectRatio64+15)/64;
    if (GIFScreenDescriptor.flags and GIFScreenDescriptor_GlobalColorTableFlag =
      GIFScreenDescriptor_GlobalColorTableFlag) then
    begin
      LoadGlobalPalette;
      if GIFScreenDescriptor.BackgroundColorIndex < length(globalPalette) then
        result.BackgroundColor :=
          BGRAToColor(globalPalette[GIFScreenDescriptor.BackgroundColorIndex]);
    end;
    repeat
      stream.ReadBuffer({%H-}GIFBlockID, sizeof(GIFBlockID));
      case GIFBlockID of
        ';': ;
        ',': begin
               if NbImages >= MaxImageCount then break;
               LoadImage;
             end;
        '!': ReadExtension;
        else
        begin
          raise Exception.Create('TBGRAAnimatedGif: unexpected block type');
          break;
        end;
      end;
    until (GIFBlockID = ';') or (stream.Position >= stream.size);
  end
  else
    raise Exception.Create('TBGRAAnimatedGif: invalid header');
  setlength(result.Images, NbImages);
end;

procedure GIFSaveToStream(AData: TGifData; Stream: TStream; AQuantizerFactory: TBGRAColorQuantizerAny;
          ADitheringAlgorithm: TDitheringAlgorithm);
var
  signature: TGIFSignature;
  screenDescriptor: TGIFScreenDescriptor;
  globalPalette: TBGRAPalette;
  globalQuantizer: TBGRACustomColorQuantizer;
  globalTranspIndex: integer;

  procedure AddColorsToPalette(AImage: TBGRACustomBitmap; APalette: TBGRAPalette);
  var n: integer;
    p: PBGRAPixel;
    c: TBGRAPixel;
  begin
    p := AImage.Data;
    for n := AImage.NbPixels-1 downto 0 do
    begin
      if p^.alpha < 255 then //transparent color will be needed to dither properly
        APalette.AddColor(BGRAPixelTransparent);
      if p^.alpha > 0 then //color may be needed to dither properly
      begin
        c := p^;
        c.alpha := 255;
        APalette.AddColor(c);
      end;
      inc(p);
    end;
  end;

  function ImageCount: integer;
  begin
    result := length(AData.Images);
  end;

  function NeedGlobalPalette: boolean;
  var i: integer;
  begin
    for i := 0 to ImageCount-1 do
      if not AData.Images[i].HasLocalPalette then
      begin
        result := true;
        exit;
      end;
  end;

  function IndexOfGlobalColor(AColor: TBGRAPixel): integer;
  begin
    if Assigned(globalQuantizer) then
      result := globalQuantizer.ReducedPalette.FindNearestColorIndex(AColor)
    else
      result := globalPalette.IndexOfColor(AColor);
  end;

  procedure MakeGlobalPalette;
  var i: integer;
    indexed: TBGRAIndexedPalette;
    bitDepth: integer;
  begin
    globalPalette := TBGRAPalette.Create;
    for i := 0 to ImageCount-1 do
      if not AData.Images[i].HasLocalPalette then
        AddColorsToPalette(AData.Images[i].Image, globalPalette);
    if AData.BackgroundColor <> clNone then
      globalPalette.AddColor(ColorToBGRA(ColorToRGB(AData.BackgroundColor)));

    if globalPalette.Count > 256 then
    begin
      if Assigned(AQuantizerFactory) then
      begin
        globalQuantizer:= AQuantizerFactory.Create(globalPalette, False, 256);
        globalPalette.Free;
        globalPalette := TBGRAIndexedPalette.Create(globalQuantizer.ReducedPalette);
      end
      else
      begin
        globalPalette.Free;
        raise EColorQuantizerMissing.Create;
      end;
    end else
    begin
      indexed := TBGRAIndexedPalette.Create(globalPalette);
      globalPalette.Free;
      globalPalette := indexed;
    end;

    globalTranspIndex:= globalPalette.IndexOfColor(BGRAPixelTransparent);
    if AData.BackgroundColor <> clNone then
      screenDescriptor.BackgroundColorIndex:= IndexOfGlobalColor(ColorToBGRA(ColorToRGB(AData.BackgroundColor))) and 255;

    bitDepth := CeilLn2(globalPalette.Count);
    if bitDepth > 8 then bitDepth:= 8;
    if bitDepth < 1 then bitDepth:= 1;
    screenDescriptor.flags := screenDescriptor.flags or GIFScreenDescriptor_GlobalColorTableFlag;
    screenDescriptor.flags := screenDescriptor.flags or (bitDepth-1);
  end;

  procedure WritePalette(pal: TBGRAPalette; bitDepth: integer);
  var i: integer;
    numberToWrite,numberFromPal: Integer;
    rgbs: ^TPackedRGBTriple;
    black: TPackedRGBTriple;
  begin
    if not Assigned(pal) then exit;
    numberToWrite:= 1 shl bitDepth;
    numberFromPal := pal.Count;
    if numberFromPal > numberToWrite then numberFromPal:= numberToWrite;
    getmem(rgbs, numberToWrite*sizeof(TPackedRGBTriple));
    try
      for i := 0 to numberFromPal-1 do
        rgbs[i] := BGRAToPackedRgbTriple(pal.Color[i]);
      black := BGRAToPackedRgbTriple(ColorToBGRA(clBlack));
      for i := numberFromPal to numberToWrite-1 do
        rgbs[i] := black;
      Stream.WriteBuffer(rgbs^,sizeof(TPackedRGBTriple)*numberToWrite);
    finally
      freemem(rgbs);
    end;
  end;

  procedure WriteGlobalPalette;
  begin
    WritePalette(globalPalette, (screenDescriptor.flags and 7)+1);
  end;

  procedure FreeGlobalPalette;
  begin
    FreeAndNil(globalPalette);
    FreeAndNil(globalQuantizer);
  end;

  procedure WriteImages;
  var
    localPalette: TBGRAPalette;
    localQuantizer: TBGRACustomColorQuantizer;
    localTranspIndex: integer;
    imageDescriptor: TGIFImageDescriptorWithHeader;

    procedure MakeLocalPalette(AFrameIndex: integer);
    var
      indexed: TBGRAIndexedPalette;
      bitDepth: integer;
    begin
      localPalette := TBGRAPalette.Create;
      AddColorsToPalette(AData.Images[AFrameIndex].Image, localPalette);
      if localPalette.Count > 256 then
      begin
        if Assigned(AQuantizerFactory) then
        begin
          localQuantizer:= AQuantizerFactory.Create(localPalette, False, 256);
          localPalette.Free;
          localPalette := TBGRAIndexedPalette.Create(localQuantizer.ReducedPalette);
        end
        else
        begin
          localPalette.Free;
          raise EColorQuantizerMissing.Create;
        end;
      end else
      begin
        indexed := TBGRAIndexedPalette.Create(localPalette);
        localPalette.Free;
        localPalette := indexed;
      end;

      localTranspIndex:= localPalette.IndexOfColor(BGRAPixelTransparent);

      bitDepth := CeilLn2(localPalette.Count);
      if bitDepth > 8 then bitDepth:= 8;
      if bitDepth < 1 then bitDepth:= 1;
      imageDescriptor.Image.flags := imageDescriptor.Image.flags or GIFImageDescriptor_LocalColorTableFlag;
      imageDescriptor.Image.flags := imageDescriptor.Image.flags or (bitDepth-1);
    end;

    procedure WriteLocalPalette;
    begin
      WritePalette(localPalette, (imageDescriptor.Image.flags and 7)+1);
    end;

    procedure FreeLocalPalette;
    begin
      FreeAndNil(localPalette);
      FreeAndNil(localQuantizer);
      localTranspIndex:= -1;
    end;

    procedure DitherAndCompressImage(AFrame: integer; APalette: TBGRAPalette; AQuantizer: TBGRACustomColorQuantizer);
    var ImageData: Pointer;
      Image: TBGRABitmap;
      y,x: BGRANativeInt;
      psource: PBGRAPixel;
      pdest: PByte;
    begin
      Image := AData.Images[AFrame].Image;
      if Assigned(AQuantizer) then
        ImageData := AQuantizer.GetDitheredBitmapIndexedData(8, ADitheringAlgorithm, Image)
      else
      begin
        GetMem(ImageData, Image.Width*Image.Height);
        pdest := ImageData;
        for y := 0 to Image.Height -1 do
        begin
          psource := Image.ScanLine[y];
          for x := 0 to Image.Width -1 do
          begin
            if psource^.alpha < 128 then
              pdest^ := APalette.IndexOfColor(BGRAPixelTransparent)
            else
              pdest^ := APalette.IndexOfColor(BGRA(psource^.red,psource^.green,psource^.blue,255));
            inc(psource);
            inc(pdest);
          end;
        end;
      end;
      try
        GIFEncodeLZW(Stream, ImageData, Image.Width, Image.Height, CeilLn2(APalette.Count));
      finally
        FreeMem(ImageData);
      end;
    end;

    procedure WriteImage(AFrame: integer);
    var
      ext: TGIFGraphicControlExtensionWithHeader;
      transpIndex: integer;
    begin
      fillchar({%H-}ext, sizeof(ext), 0);
      try
        ext.ExtensionIntroducer := GIFExtensionIntroducer;
        ext.FunctionCode := GIFGraphicControlExtension_FunctionCode;
        ext.BlockSize := sizeof(ext.GraphicControl);
        ext.GraphicControl.DelayHundredthSec := (AData.Images[AFrame].DelayMs+5) div 10;
        ext.GraphicControl.TransparentColorIndex := 0;
        ext.GraphicControl.flags := integer(AData.Images[AFrame].DisposeMode) shl GIFGraphicControlExtension_DisposeModeShift;
        ext.BlockTerminator := GIFBlockTerminator;
        with AData.Images[AFrame].Position do
        begin
          imageDescriptor.Image.x := x;
          imageDescriptor.Image.y := y;
        end;
        with AData.Images[AFrame].Image do
        begin
          imageDescriptor.Image.Width := Width;
          imageDescriptor.Image.Height := Height;
        end;
        imageDescriptor.Image.flags := 0;

        if AData.Images[AFrame].HasLocalPalette then MakeLocalPalette(AFrame);

        if AData.Images[AFrame].Image.HasTransparentPixels then
        begin
          if AData.Images[AFrame].HasLocalPalette then
            transpIndex := localTranspIndex
          else
            transpIndex := globalTranspIndex;
        end else
          transpIndex := -1;
        if (transpIndex >= 0) and (transpIndex <= 255) then
        begin
          ext.GraphicControl.flags := ext.GraphicControl.flags or GIFGraphicControlExtension_TransparentFlag;
          ext.GraphicControl.TransparentColorIndex := transpIndex;
        end;

        Stream.WriteBuffer(ext, sizeof(ext));
        Stream.WriteBuffer(imageDescriptor, sizeof(imageDescriptor));
        WriteLocalPalette;

        if AData.Images[AFrame].HasLocalPalette then
          DitherAndCompressImage(AFrame, localPalette, localQuantizer)
        else
          DitherAndCompressImage(AFrame, globalPalette, globalQuantizer);
      finally
        FreeLocalPalette;
      end;
    end;

  var
    i: integer;
  begin
    localPalette := nil;
    localQuantizer := nil;
    localTranspIndex:= -1;
    fillchar({%H-}imageDescriptor, sizeof(imageDescriptor), 0);
    imageDescriptor.ImageIntroducer := GIFImageIntroducer;
    for i := 0 to ImageCount-1 do
      WriteImage(i);
  end;

  procedure WriteLoopExtension;
  var
    app: shortstring;
    w: BGRAWord;
  begin
    if AData.LoopCount = 1 then exit;

    Stream.WriteByte(GIFExtensionIntroducer);
    Stream.WriteByte($ff);
    app := NetscapeApplicationIdentifier;
    Stream.WriteBuffer(app[0], length(app)+1);

    Stream.WriteByte(3);
    Stream.WriteByte(NetscapeSubBlockIdLoopCount);
    if AData.LoopCount = 0 then
      w := 0
    else
      w := AData.LoopCount-1;
    {$IFNDEF BDS}w := NtoLE(w);{$ENDIF}
    Stream.WriteWord(w);

    Stream.WriteByte(0);
  end;

begin
  globalPalette := nil;
  globalQuantizer := nil;
  globalTranspIndex:= -1;
  try
    signature := 'GIF89a';
    screenDescriptor.Width := {$IFNDEF BDS}NtoLE{$ENDIF}(AData.Width);
    screenDescriptor.Height := {$IFNDEF BDS}NtoLE{$ENDIF}(AData.Height);
    screenDescriptor.flags := $70;               //suppose 8-bit screen
    screenDescriptor.BackgroundColorIndex := 0;  //not specified for now
    screenDescriptor.AspectRatio64 := round(AData.AspectRatio*64)-15;
    if NeedGlobalPalette then MakeGlobalPalette;

    Stream.WriteBuffer(signature, sizeof(signature));
    Stream.WriteBuffer(screenDescriptor, sizeof(screenDescriptor));
    WriteGlobalPalette;

    WriteLoopExtension;

    WriteImages;
    Stream.WriteByte(GIFFileTerminator); //end of file

  finally
    FreeGlobalPalette;
  end;
end;

{ EColorQuantizerMissing }

constructor EColorQuantizerMissing.Create;
begin
  inherited Create('Please provide a color quantizer class (one is provided in BGRAColorQuantization)')
end;

constructor EColorQuantizerMissing.Create(AMessage: string);
begin
  inherited Create(AMessage);
end;

end.