galfar.imaginglib/Source/ImagingGif.pas

{
  Vampyre Imaging Library
  by Marek Mauder 
  http://imaginglib.sourceforge.net

  The contents of this file are used with permission, subject to the Mozilla
  Public License Version 1.1 (the "License"); you may not use this file except
  in compliance with the License. You may obtain a copy of the License at
  http://www.mozilla.org/MPL/MPL-1.1.html

  Software distributed under the License is distributed on an "AS IS" basis,
  WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
  the specific language governing rights and limitations under the License.

  Alternatively, the contents of this file may be used under the terms of the
  GNU Lesser General Public License (the  "LGPL License"), in which case the
  provisions of the LGPL License are applicable instead of those above.
  If you wish to allow use of your version of this file only under the terms
  of the LGPL License and not to allow others to use your version of this file
  under the MPL, indicate your decision by deleting  the provisions above and
  replace  them with the notice and other provisions required by the LGPL
  License.  If you do not delete the provisions above, a recipient may use
  your version of this file under either the MPL or the LGPL License.

  For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}

{ This unit contains image format loader/saver for GIF images.}
unit ImagingGif;

{$I ImagingOptions.inc}

interface

uses
  SysUtils, Classes, Imaging, ImagingTypes, ImagingIO, ImagingUtility;

type
  { GIF (Graphics Interchange Format) loader/saver class. GIF was
    (and is still used) popular format for storing images supporting
    multiple images per file and single color transparency.
    Pixel format is 8 bit indexed where each image frame can have
    its own color palette. GIF uses lossless LZW compression
    (patent expired few years ago).
    Imaging can load and save all GIFs with all frames and supports
    transparency. Imaging can load just raw ifIndex8 frames or
    also animate them in ifA8R8G8B8 format. See ImagingGIFLoadAnimated option.}
  TGIFFileFormat = class(TImageFileFormat)
  private
    FLoadAnimated: LongBool;
    function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
    procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle;
      Width, Height: Integer; Interlaced: Boolean; Data: Pointer);
    procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle;
      Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer);
  protected
    procedure Define; override;
    function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
      OnlyFirstLevel: Boolean): Boolean; override;
    function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
      Index: LongInt): Boolean; override;
    procedure ConvertToSupported(var Image: TImageData;
      const Info: TImageFormatInfo); override;
  public
    function TestFormat(Handle: TImagingHandle): Boolean; override;
  published
    property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
  end;

implementation

const
  SGIFFormatName = 'Graphics Interchange Format';
  SGIFMasks      = '*.gif';
  GIFSupportedFormats: TImageFormats = [ifIndex8];
  GIFDefaultLoadAnimated = True;

type
  TGIFVersion = (gv87, gv89);
  TDisposalMethod = (dmNoRemoval, dmLeave, dmRestoreBackground,
    dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);

const
  GIFSignature: TChar3 = 'GIF';
  GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a');
  GIFDefaultDelay = 65;

  // Masks for accessing fields in PackedFields of TGIFHeader
  GIFGlobalColorTable = $80;
  GIFColorResolution  = $70;
  GIFColorTableSorted = $08;
  GIFColorTableSize   = $07;

  // Masks for accessing fields in PackedFields of TImageDescriptor
  GIFLocalColorTable  = $80;
  GIFInterlaced       = $40;
  GIFLocalTableSorted = $20;

  // Block identifiers
  GIFPlainText: Byte               = $01;
  GIFGraphicControlExtension: Byte = $F9;
  GIFCommentExtension: Byte        = $FE;
  GIFApplicationExtension: Byte    = $FF;
  GIFImageDescriptor: Byte         = Ord(',');
  GIFExtensionIntroducer: Byte     = Ord('!');
  GIFTrailer: Byte                 = Ord(';');
  GIFBlockTerminator: Byte         = $00;

  // Masks for accessing fields in PackedFields of TGraphicControlExtension
  GIFTransparent    = $01;
  GIFUserInput      = $02;
  GIFDisposalMethod = $1C;

const
  // Netscape sub block types
  GIFAppLoopExtension   = 1;
  GIFAppBufferExtension = 2;

type
  TGIFHeader = packed record
    // File header part
    Signature: TChar3;  // Header Signature (always "GIF")
    Version: TChar3;    // GIF format version("87a" or "89a")
    // Logical Screen Descriptor part
    ScreenWidth: Word;  // Width of Display Screen in Pixels
    ScreenHeight: Word; // Height of Display Screen in Pixels
    PackedFields: Byte; // Screen and color map information
    BackgroundColorIndex: Byte; // Background color index (in global color table)
    AspectRatio: Byte;  // Pixel aspect ratio, ratio = (AspectRatio + 15) / 64
  end;

  TImageDescriptor = packed record
    //Separator: Byte; // leave that out since we always read one bye ahead
    Left: Word;        // X position of image with respect to logical screen
    Top: Word;         // Y position
    Width: Word;
    Height: Word;
    PackedFields: Byte;
  end;

const
  // GIF extension labels
  GIFExtTypeGraphic     = $F9;
  GIFExtTypePlainText   = $01;
  GIFExtTypeApplication = $FF;
  GIFExtTypeComment     = $FE;

type
  TGraphicControlExtension = packed record
    BlockSize: Byte;
    PackedFields: Byte;
    DelayTime: Word;
    TransparentColorIndex: Byte;
    Terminator: Byte;
  end;

type
  TGIFIdentifierCode = array[0..7] of AnsiChar;
  TGIFAuthenticationCode = array[0..2] of AnsiChar;
  TGIFApplicationRec = packed record
    Identifier: TGIFIdentifierCode;
    Authentication: TGIFAuthenticationCode;
  end;

const
  CodeTableSize = 4096;
  HashTableSize = 17777;

type
  TReadContext = record
    Inx: Integer;
    Size: Integer;
    Buf: array [0..255 + 4] of Byte;
    CodeSize: Integer;
    ReadMask: Integer;
  end;
  PReadContext = ^TReadContext;

  TWriteContext = record
    Inx: Integer;
    CodeSize: Integer;
    Buf: array [0..255 + 4] of Byte;
  end;
  PWriteContext = ^TWriteContext;

  TOutputContext = record
    W: Integer;
    H: Integer;
    X: Integer;
    Y: Integer;
    BitsPerPixel: Integer;
    Pass: Integer;
    Interlace: Boolean;
    LineIdent: Integer;
    Data: Pointer;
    CurrLineData: Pointer;
  end;

  TImageDict = record
    Tail: Word;
    Index: Word;
    Col: Byte;
  end;
  PImageDict = ^TImageDict;

  PIntCodeTable = ^TIntCodeTable;
  TIntCodeTable = array [0..CodeTableSize - 1] of Word;

  TDictTable = array [0..CodeTableSize - 1] of TImageDict;
  PDictTable = ^TDictTable;

resourcestring
  SGIFDecodingError = 'Error when decoding GIF LZW data';

{
  TGIFFileFormat implementation
}

procedure TGIFFileFormat.Define;
begin
  inherited;
  FName := SGIFFormatName;
  FFeatures := [ffLoad, ffSave, ffMultiImage];
  FSupportedFormats := GIFSupportedFormats;
  FLoadAnimated := GIFDefaultLoadAnimated;

  AddMasks(SGIFMasks);
  RegisterOption(ImagingGIFLoadAnimated, @FLoadAnimated);
end;

function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
begin
  Result := Y;
  case Pass of
    0, 1:
      Inc(Result, 8);
    2:
      Inc(Result, 4);
    3:
      Inc(Result, 2);
  end;
  if Result >= Height then
  begin
    if Pass = 0 then
    begin
      Pass := 1;
      Result := 4;
      if Result < Height then
        Exit;
    end;
    if Pass = 1 then
    begin
      Pass := 2;
      Result := 2;
      if Result < Height then
        Exit;
    end;
    if Pass = 2 then
    begin
      Pass := 3;
      Result := 1;
    end;
  end;
end;

{ GIF LZW decompresion code is from JVCL JvGIF.pas unit.}
procedure TGIFFileFormat.LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer;
  Interlaced: Boolean; Data: Pointer);
var
  MinCodeSize: Byte;
  MaxCode, BitMask, InitCodeSize: Integer;
  ClearCode, EndingCode, FirstFreeCode, FreeCode: Word;
  I, OutCount, Code: Integer;
  CurCode, OldCode, InCode, FinalChar: Word;
  Prefix, Suffix, OutCode: PIntCodeTable;
  ReadCtxt: TReadContext;
  OutCtxt: TOutputContext;
  TableFull: Boolean;

  function ReadCode(var Context: TReadContext): Integer;
  var
    RawCode: Integer;
    ByteIndex: Integer;
    Bytes: Byte;
    BytesToLose: Integer;
  begin
    while (Context.Inx + Context.CodeSize > Context.Size) and
      (Stream.Position < Stream.Size) do
    begin
      // Not enough bits in buffer - refill it - Not very efficient, but infrequently called
      BytesToLose := Context.Inx shr 3;
      // Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes
      Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3);
      Context.Inx := Context.Inx and 7;
      Context.Size := Context.Size - (BytesToLose shl 3);
      Stream.Read(Bytes, 1);
      if Bytes > 0 then
        Stream.Read(Context.Buf[Word(Context.Size shr 3)], Bytes);
      Context.Size := Context.Size + (Bytes shl 3);
    end;
    ByteIndex := Context.Inx shr 3;
    RawCode := Context.Buf[Word(ByteIndex)] +
      (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
    if Context.CodeSize > 8 then
      RawCode := RawCode + (Integer(Context.Buf[ByteIndex + 2]) shl 16);
    RawCode := RawCode shr (Context.Inx and 7);
    Context.Inx := Context.Inx + Byte(Context.CodeSize);
    Result := RawCode and Context.ReadMask;
  end;

  procedure Output(Value: Byte; var Context: TOutputContext);
  var
    P: PByte;
  begin
    if Context.Y >= Context.H then
      Exit;

    // Only ifIndex8 supported
    P := @PByteArray(Context.CurrLineData)[Context.X];
    P^ := Value;

    {case Context.BitsPerPixel of
      1:
        begin
          P := @PByteArray(Context.CurrLineData)[Context.X shr 3];
          if (Context.X and $07) <> 0 then
            P^ := P^ or Word(Value shl (7 - (Word(Context.X and 7))))
          else
            P^ := Byte(Value shl 7);
        end;
      4:
        begin
          P := @PByteArray(Context.CurrLineData)[Context.X shr 1];
          if (Context.X and 1) <> 0 then
            P^ := P^ or Value
          else
            P^ := Byte(Value shl 4);
        end;
      8:
        begin
          P := @PByteArray(Context.CurrLineData)[Context.X];
          P^ := Value;
        end;
    end;}
    Inc(Context.X);

    if Context.X < Context.W then
      Exit;
    Context.X := 0;
    if Context.Interlace then
      Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass)
    else
      Inc(Context.Y);

    Context.CurrLineData := @PByteArray(Context.Data)[Context.Y * Context.LineIdent];
  end;

begin
  OutCount := 0;
  OldCode := 0;
  FinalChar := 0;
  TableFull := False;
  GetMem(Prefix, SizeOf(TIntCodeTable));
  GetMem(Suffix, SizeOf(TIntCodeTable));
  GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));
  try
    Stream.Read(MinCodeSize, 1);
    if (MinCodeSize < 2) or (MinCodeSize > 9) then
      RaiseImaging(SGIFDecodingError, []);
    // Initial read context
    ReadCtxt.Inx := 0;
    ReadCtxt.Size := 0;
    ReadCtxt.CodeSize := MinCodeSize + 1;
    ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
    // Initialise pixel-output context
    OutCtxt.X := 0;
    OutCtxt.Y := 0;
    OutCtxt.Pass := 0;
    OutCtxt.W := Width;
    OutCtxt.H := Height;
    OutCtxt.BitsPerPixel := MinCodeSize;
    OutCtxt.Interlace := Interlaced;
    OutCtxt.LineIdent := Width;
    OutCtxt.Data := Data;
    OutCtxt.CurrLineData := Data;
    BitMask := (1 shl OutCtxt.BitsPerPixel) - 1;
    // 2 ^ MinCodeSize accounts for all colours in file
    ClearCode := 1 shl MinCodeSize;
    EndingCode := ClearCode + 1;
    FreeCode := ClearCode + 2;
    FirstFreeCode := FreeCode;
    // 2^ (MinCodeSize + 1) includes clear and eoi Code and space too
    InitCodeSize := ReadCtxt.CodeSize;
    MaxCode := 1 shl ReadCtxt.CodeSize;
    Code := ReadCode(ReadCtxt);
    while (Code <> EndingCode) and (Code <> $FFFF) and
      (OutCtxt.Y < OutCtxt.H) do
    begin
      if Code = ClearCode then
      begin
        ReadCtxt.CodeSize := InitCodeSize;
        MaxCode := 1 shl ReadCtxt.CodeSize;
        ReadCtxt.ReadMask := MaxCode - 1;
        FreeCode := FirstFreeCode;
        Code := ReadCode(ReadCtxt);
        CurCode := Code;
        OldCode := Code;
        if Code = $FFFF then
          Break;
        FinalChar := (CurCode and BitMask);
        Output(Byte(FinalChar), OutCtxt);
        TableFull := False;
      end
      else
      begin
        CurCode := Code;
        InCode := Code;
        if CurCode >= FreeCode then
        begin
          CurCode := OldCode;
          OutCode^[OutCount] := FinalChar;
          Inc(OutCount);
        end;
        while CurCode > BitMask do
        begin
          if OutCount > CodeTableSize then
            RaiseImaging(SGIFDecodingError, []);
          OutCode^[OutCount] := Suffix^[CurCode];
          Inc(OutCount);
          CurCode := Prefix^[CurCode];
        end;

        FinalChar := CurCode and BitMask;
        OutCode^[OutCount] := FinalChar;
        Inc(OutCount);
        for I := OutCount - 1 downto 0 do
          Output(Byte(OutCode^[I]), OutCtxt);
        OutCount := 0;
        // Update dictionary
        if not TableFull then
        begin
          Prefix^[FreeCode] := OldCode;
          Suffix^[FreeCode] := FinalChar;
          // Advance to next free slot
          Inc(FreeCode);
          if FreeCode >= MaxCode then
          begin
            if ReadCtxt.CodeSize < 12 then
            begin
              Inc(ReadCtxt.CodeSize);
              MaxCode := MaxCode shl 1;
              ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
            end
            else
              TableFull := True;
          end;
        end;
        OldCode := InCode;
      end;
      Code := ReadCode(ReadCtxt);
    end;
    if Code = $FFFF then
      RaiseImaging(SGIFDecodingError, []);
  finally
    FreeMem(Prefix);
    FreeMem(OutCode);
    FreeMem(Suffix);
  end;
end;

{ GIF LZW compresion code is from JVCL JvGIF.pas unit.}
procedure TGIFFileFormat.LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height, BitCount: Integer;
    Interlaced: Boolean; Data: Pointer);
var
  LineIdent: Integer;
  MinCodeSize, Col: Byte;
  InitCodeSize, X, Y: Integer;
  Pass: Integer;
  MaxCode: Integer; { 1 shl CodeSize }
  ClearCode, EndingCode, LastCode, Tail: Integer;
  I, HashValue: Integer;
  LenString: Word;
  Dict: PDictTable;
  HashTable: TList;
  PData: PByte;
  WriteCtxt: TWriteContext;

  function InitHash(P: Integer): Integer;
  begin
    Result := (P + 3) * 301;
  end;

  procedure WriteCode(Code: Integer; var Context: TWriteContext);
  var
    BufIndex: Integer;
    Bytes: Byte;
  begin
    BufIndex := Context.Inx shr 3;
    Code := Code shl (Context.Inx and 7);
    Context.Buf[BufIndex] := Context.Buf[BufIndex] or Byte(Code);
    Context.Buf[BufIndex + 1] := Byte(Code shr 8);
    Context.Buf[BufIndex + 2] := Byte(Code shr 16);
    Context.Inx := Context.Inx + Context.CodeSize;
    if Context.Inx >= 255 * 8 then
    begin
      // Flush out full buffer
      Bytes := 255;
      IO.Write(Handle, @Bytes, 1);
      IO.Write(Handle, @Context.Buf, Bytes);
      Move(Context.Buf[255], Context.Buf[0], 2);
      FillChar(Context.Buf[2], 255, 0);
      Context.Inx := Context.Inx - (255 * 8);
    end;
  end;

  procedure FlushCode(var Context: TWriteContext);
  var
    Bytes: Byte;
  begin
    Bytes := (Context.Inx + 7) shr 3;
    if Bytes > 0 then
    begin
      IO.Write(Handle, @Bytes, 1);
      IO.Write(Handle, @Context.Buf, Bytes);
    end;
    // Data block terminator - a block of zero Size
    Bytes := 0;
    IO.Write(Handle, @Bytes, 1);
  end;

begin
  LineIdent := Width;
  Tail := 0;
  HashValue := 0;
  Col := 0;
  HashTable := TList.Create;
  GetMem(Dict, SizeOf(TDictTable));
  try
    for I := 0 to HashTableSize - 1 do
      HashTable.Add(nil);

    // Initialise encoder variables
    InitCodeSize := BitCount + 1;
    if InitCodeSize = 2 then
      Inc(InitCodeSize);
    MinCodeSize := InitCodeSize - 1;
    IO.Write(Handle, @MinCodeSize, 1);
    ClearCode := 1 shl MinCodeSize;
    EndingCode := ClearCode + 1;
    LastCode := EndingCode;
    MaxCode := 1 shl InitCodeSize;
    LenString := 0;
    // Setup write context
    WriteCtxt.Inx := 0;
    WriteCtxt.CodeSize := InitCodeSize;
    FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0);
    WriteCode(ClearCode, WriteCtxt);
    Y := 0;
    Pass := 0;

    while Y < Height do
    begin
      PData := @PByteArray(Data)[Y * LineIdent];
      for X := 0 to Width - 1 do
      begin
        // Only ifIndex8 support
        case BitCount of
          8:
            begin
              Col := PData^;
              PData := @PByteArray(PData)[1];
            end;
          {4:
            begin
              if X and 1 <> 0 then
              begin
                Col := PData^ and $0F;
                PData := @PByteArray(PData)[1];
              end
              else
                Col := PData^ shr 4;
            end;
          1:
            begin
              if X and 7 = 7 then
              begin
                Col := PData^ and 1;
                PData := @PByteArray(PData)[1];
              end
              else
                Col := (PData^ shr (7 - (X and $07))) and $01;
            end;}
        end;
        Inc(LenString);
        if LenString = 1 then
        begin
          Tail := Col;
          HashValue := InitHash(Col);
        end
        else
        begin
          HashValue := HashValue * (Col + LenString + 4);
          I := HashValue mod HashTableSize;
          HashValue := HashValue mod HashTableSize;
          while (HashTable[I] <> nil) and
            ((PImageDict(HashTable[I])^.Tail <> Tail) or
            (PImageDict(HashTable[I])^.Col <> Col)) do
          begin
            Inc(I);
            if I >= HashTableSize then
              I := 0;
          end;
          if HashTable[I] <> nil then // Found in the strings table
            Tail := PImageDict(HashTable[I])^.Index
          else
          begin
            // Not found
            WriteCode(Tail, WriteCtxt);
            Inc(LastCode);
            HashTable[I] := @Dict^[LastCode];
            PImageDict(HashTable[I])^.Index := LastCode;
            PImageDict(HashTable[I])^.Tail := Tail;
            PImageDict(HashTable[I])^.Col := Col;
            Tail := Col;
            HashValue := InitHash(Col);
            LenString := 1;
            if LastCode >= MaxCode then
            begin
              // Next Code will be written longer
              MaxCode := MaxCode shl 1;
              Inc(WriteCtxt.CodeSize);
            end
            else
            if LastCode >= CodeTableSize - 2 then
            begin
              // Reset tables
              WriteCode(Tail, WriteCtxt);
              WriteCode(ClearCode, WriteCtxt);
              LenString := 0;
              LastCode := EndingCode;
              WriteCtxt.CodeSize := InitCodeSize;
              MaxCode := 1 shl InitCodeSize;
              for I := 0 to HashTableSize - 1 do
                HashTable[I] := nil;
            end;
          end;
        end;
      end;
      if Interlaced then
        Y := InterlaceStep(Y, Height, Pass)
      else
        Inc(Y);
    end;
    WriteCode(Tail, WriteCtxt);
    WriteCode(EndingCode, WriteCtxt);
    FlushCode(WriteCtxt);
  finally
    HashTable.Free;
    FreeMem(Dict);
  end;
end;

function TGIFFileFormat.LoadData(Handle: TImagingHandle;
  var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
type
  TFrameInfo = record
    Left, Top: Integer;
    Width, Height: Integer;
    Disposal: TDisposalMethod;
    HasTransparency: Boolean;
    HasLocalPal: Boolean;
    TransIndex: Integer;
    BackIndex: Integer;
  end;
var
  Header: TGIFHeader;
  HasGlobalPal: Boolean;
  GlobalPalLength: Integer;
  GlobalPal: TPalette32Size256;
  ScreenWidth, ScreenHeight, I, CachedIndex: Integer;
  BlockID: Byte;
  HasGraphicExt: Boolean;
  GraphicExt: TGraphicControlExtension;
  FrameInfos: array of TFrameInfo;
  AppRead: Boolean;
  CachedFrame: TImageData;
  AnimFrames: TDynImageDataArray;

  function ReadBlockID: Byte;
  begin
    Result := GIFTrailer;
    if GetIO.Read(Handle, @Result, SizeOf(Result)) < SizeOf(Result) then
      Result := GIFTrailer;
  end;

  procedure ReadExtensions;
  var
    BlockSize, BlockType, ExtType: Byte;
    AppRec: TGIFApplicationRec;
    LoopCount: SmallInt;

    procedure SkipBytes;
    begin
      with GetIO do
      repeat
        // Read block sizes and skip them
        Read(Handle, @BlockSize, SizeOf(BlockSize));
        Seek(Handle, BlockSize, smFromCurrent);
      until BlockSize = 0;
    end;

  begin
    HasGraphicExt := False;
    AppRead := False;

    // Read extensions until image descriptor is found. Only graphic extension
    // is stored now (for transparency), others are skipped.
    while BlockID = GIFExtensionIntroducer do
    with GetIO do
    begin
      Read(Handle, @ExtType, SizeOf(ExtType));

      while ExtType in [GIFGraphicControlExtension, GIFCommentExtension, GIFApplicationExtension, GIFPlainText] do
      begin
        if ExtType = GIFGraphicControlExtension then
        begin
          HasGraphicExt := True;
          Read(Handle, @GraphicExt, SizeOf(GraphicExt));
        end
        else if (ExtType = GIFApplicationExtension) and not AppRead then
        begin
          Read(Handle, @BlockSize, SizeOf(BlockSize));
          if BlockSize >= SizeOf(AppRec) then
          begin
            Read(Handle, @AppRec, SizeOf(AppRec));
            if ((AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0')) or
              ((AppRec.Identifier = 'ANIMEXTS') and (AppRec.Authentication = '1.0')) then
            begin
              Read(Handle, @BlockSize, SizeOf(BlockSize));
              while BlockSize <> 0 do
              begin
                BlockType := ReadBlockID;
                Dec(BlockSize);

                case BlockType of
                  GIFAppLoopExtension:
                    if (BlockSize >= SizeOf(LoopCount)) then
                    begin
                      // Read loop count
                      Read(Handle, @LoopCount, SizeOf(LoopCount));
                      Dec(BlockSize, SizeOf(LoopCount));
                      if LoopCount > 0 then
                        Inc(LoopCount); // Netscape extension is really "repeats" not "loops"
                      FMetadata.SetMetaItem(SMetaAnimationLoops, LoopCount);
                    end;
                  GIFAppBufferExtension:
                    begin
                      Dec(BlockSize, SizeOf(Word));
                      Seek(Handle, SizeOf(Word), smFromCurrent);
                    end;
                end;
              end;
              SkipBytes;
              AppRead := True;
            end
            else
              begin
                // Revert all bytes reading
                Seek(Handle, - SizeOf(AppRec) - SizeOf(BlockSize), smFromCurrent);
                SkipBytes;
              end;
          end
          else
            begin
              Seek(Handle, - BlockSize - SizeOf(BlockSize), smFromCurrent);
              SkipBytes;
            end;
        end
        else if ExtType in [GIFCommentExtension, GIFApplicationExtension, GIFPlainText] then
        repeat
          // Read block sizes and skip them
          Read(Handle, @BlockSize, SizeOf(BlockSize));
          Seek(Handle, BlockSize, smFromCurrent);
        until BlockSize = 0;

        // Read ID of following block
        BlockID := ReadBlockID;
        ExtType := BlockID;
      end
    end;
  end;

  procedure CopyLZWData(Dest: TStream);
  var
    CodeSize, BlockSize: Byte;
    InputSize: Integer;
    Buff: array[Byte] of Byte;
  begin
    InputSize := ImagingIO.GetInputSize(GetIO, Handle);
    // Copy codesize to stream
    GetIO.Read(Handle, @CodeSize, 1);
    Dest.Write(CodeSize, 1);
    repeat
      // Read and write data blocks, last is block term value of 0
      GetIO.Read(Handle, @BlockSize, 1);
      Dest.Write(BlockSize, 1);
      if BlockSize > 0 then
      begin
        GetIO.Read(Handle, @Buff[0], BlockSize);
        Dest.Write(Buff[0], BlockSize);
      end;
    until (BlockSize = 0) or (GetIO.Tell(Handle) >= InputSize);
  end;

  procedure ReadFrame;
  var
    ImageDesc: TImageDescriptor;
    Interlaced: Boolean;
    I, Idx, LocalPalLength: Integer;
    LocalPal: TPalette32Size256;
    LZWStream: TMemoryStream;

    procedure RemoveBadFrame;
    begin
      FreeImage(Images[Idx]);
      SetLength(Images, Length(Images) - 1);
    end;

  begin
    Idx := Length(Images);
    SetLength(Images, Idx + 1);
    SetLength(FrameInfos, Idx + 1);
    FillChar(LocalPal, SizeOf(LocalPal), 0);

    with GetIO do
    begin
      // Read and parse image descriptor
      Read(Handle, @ImageDesc, SizeOf(ImageDesc));
      FrameInfos[Idx].HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable;
      Interlaced := (ImageDesc.PackedFields and GIFInterlaced) = GIFInterlaced;
      LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize;
      LocalPalLength := 1 shl (LocalPalLength + 1);   // Total pal length is 2^(n+1)

      // From Mozilla source
      if (ImageDesc.Width = 0) or (ImageDesc.Width > Header.ScreenWidth) then
        ImageDesc.Width := Header.ScreenWidth;
      if (ImageDesc.Height = 0) or (ImageDesc.Height > Header.ScreenHeight)  then
        ImageDesc.Height := Header.ScreenHeight;

      FrameInfos[Idx].Left := ImageDesc.Left;
      FrameInfos[Idx].Top := ImageDesc.Top;
      FrameInfos[Idx].Width := ImageDesc.Width;
      FrameInfos[Idx].Height := ImageDesc.Height;
      FrameInfos[Idx].BackIndex := Header.BackgroundColorIndex;

      // Create new image for this frame which would be later pasted onto logical screen
      NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Images[Idx]);

      // Load local palette if there is any
      if FrameInfos[Idx].HasLocalPal then
        for I := 0 to LocalPalLength - 1 do
        begin
          LocalPal[I].A := 255;
          Read(Handle, @LocalPal[I].R, SizeOf(LocalPal[I].R));
          Read(Handle, @LocalPal[I].G, SizeOf(LocalPal[I].G));
          Read(Handle, @LocalPal[I].B, SizeOf(LocalPal[I].B));
        end;

      // Use local pal if present or global pal if present or create
      // default pal if neither of them is present
      if FrameInfos[Idx].HasLocalPal then
        Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal))
      else if HasGlobalPal then
        Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal))
      else
        FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2);

      if (ImageDesc.Left <= Header.ScreenWidth + 1) and (ImageDesc.Top <= Header.ScreenHeight + 1) then
      begin
        // Resize the screen if needed to fit the frame
        ScreenWidth := Max(ScreenWidth, ImageDesc.Width + ImageDesc.Left);
        ScreenHeight := Max(ScreenHeight, ImageDesc.Height + ImageDesc.Top);
      end
      else
      begin
        // Remove frame outside logical screen
        RemoveBadFrame;
        Exit;
      end;

      // If Grahic Control Extension is present make use of it
      if HasGraphicExt then
      begin
        FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
        FrameInfos[Idx].Disposal := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
        if FrameInfos[Idx].HasTransparency then
        begin
          FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
          Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
        end;
        FMetadata.SetMetaItem(SMetaFrameDelay, Integer(GraphicExt.DelayTime * 10), Idx);
      end
      else
        FrameInfos[Idx].HasTransparency := False;

      LZWStream := TMemoryStream.Create;
      try
        try
          // Copy LZW data to temp stream, needed for correct decompression
          CopyLZWData(LZWStream);
          LZWStream.Position := 0;
          // Data decompression finally
          LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Images[Idx].Bits);
        except
          RemoveBadFrame;
          Exit;
        end;
      finally
        LZWStream.Free;
      end;
    end;
  end;

  procedure CopyFrameTransparent32(const Image, Frame: TImageData; Left, Top: Integer);
  var
    X, Y: Integer;
    Src: PByte;
    Dst: PColor32;
  begin
    Src := Frame.Bits;

    // Copy all pixels from frame to log screen but ignore the transparent ones
    for Y := 0 to Frame.Height - 1 do
    begin
      Dst := @PColor32RecArray(Image.Bits)[(Top + Y) * Image.Width + Left];
      for X := 0 to Frame.Width - 1 do
      begin
        if (Frame.Palette[Src^].A <> 0) then
          Dst^ := Frame.Palette[Src^].Color;
        Inc(Src);
        Inc(Dst);
      end;
    end;
  end;

  procedure AnimateFrame(Index: Integer; var AnimFrame: TImageData);
  var
    I, First, Last: Integer;
    UseCache: Boolean;
    BGColor: TColor32;
  begin
    // We may need to use raw frame 0 to n to correctly animate n-th frame
    Last := Index;
    First := Max(0, Last);
    // See if we can use last animate frame as a basis for this one
    // (so we don't have to use previous raw frames).
    UseCache := TestImage(CachedFrame) and (CachedIndex = Index - 1) and (CachedIndex >= 0) and
      (FrameInfos[CachedIndex].Disposal <> dmRestorePrevious);

    // Reuse or release cache
    if UseCache then
      CloneImage(CachedFrame, AnimFrame)
    else
      FreeImage(CachedFrame);

    // Default color for clearing of the screen
    BGColor := Images[Index].Palette[FrameInfos[Index].BackIndex].Color;

    // Now prepare logical screen for drawing of raw frame at Index.
    // We may need to use all previous raw frames to get the screen
    // to proper state (according to their disposal methods).

    if not UseCache then
    begin
      if FrameInfos[Index].HasTransparency then
        BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color;
      // Clear whole screen
      FillMemoryUInt32(AnimFrame.Bits, AnimFrame.Size, BGColor);

      // Try to maximize First so we don't have to use all 0 to n raw frames
      while First > 0 do
      begin
        if (ScreenWidth = Images[First].Width) and (ScreenHeight = Images[First].Height) then
        begin
          if (FrameInfos[First].Disposal = dmRestoreBackground) and (First < Last) then
            Break;
        end;
        Dec(First);
      end;

      for I := First to Last - 1 do
      begin
        case FrameInfos[I].Disposal of
          dmNoRemoval, dmLeave:
            begin
              // Copy previous raw frame  onto screen
              CopyFrameTransparent32(AnimFrame, Images[I], FrameInfos[I].Left, FrameInfos[I].Top);
            end;
          dmRestoreBackground:
            if (I > First) then
            begin
              // Restore background color
              FillRect(AnimFrame, FrameInfos[I].Left, FrameInfos[I].Top,
                FrameInfos[I].Width, FrameInfos[I].Height, @BGColor);
            end;
          dmRestorePrevious: ; // Do nothing - previous state is already on screen
        end;
      end;
    end
    else if FrameInfos[CachedIndex].Disposal = dmRestoreBackground then
    begin
      // We have our cached result but also need to restore
      // background in a place of cached frame
      if FrameInfos[CachedIndex].HasTransparency then
        BGColor := Images[CachedIndex].Palette[FrameInfos[CachedIndex].TransIndex].Color;
      FillRect(AnimFrame, FrameInfos[CachedIndex].Left, FrameInfos[CachedIndex].Top,
        FrameInfos[CachedIndex].Width, FrameInfos[CachedIndex].Height, @BGColor);
    end;

    // Copy current raw frame to prepared screen
    CopyFrameTransparent32(AnimFrame, Images[Index], FrameInfos[Index].Left, FrameInfos[Index].Top);

    // Cache animated result
    CloneImage(AnimFrame, CachedFrame);
    CachedIndex := Index;
  end;

begin
  AppRead := False;

  SetLength(Images, 0);
  FillChar(GlobalPal, SizeOf(GlobalPal), 0);

  with GetIO do
  begin
    // Read GIF header
    Read(Handle, @Header, SizeOf(Header));
    ScreenWidth := Header.ScreenWidth;
    ScreenHeight := Header.ScreenHeight;
    HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7
    GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2
    GlobalPalLength := 1 shl (GlobalPalLength + 1);   // Total pal length is 2^(n+1)

    // Read global palette from file if present
    if HasGlobalPal then
    begin
      for I := 0 to GlobalPalLength - 1 do
      begin
        GlobalPal[I].A := 255;
        Read(Handle, @GlobalPal[I].R, SizeOf(GlobalPal[I].R));
        Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G));
        Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B));
      end;
    end;

    // Read ID of the first block
    BlockID := ReadBlockID;

    // Now read all data blocks in the file until file trailer is reached
    while BlockID <> GIFTrailer do
    begin
      // Read blocks until we find the one of known type
      while not (BlockID in [GIFTrailer, GIFExtensionIntroducer, GIFImageDescriptor]) do
        BlockID := ReadBlockID;
      // Read supported and skip unsupported extensions
      ReadExtensions;
      // If image frame is found read it
      if BlockID = GIFImageDescriptor then
        ReadFrame;
      // Read next block's ID
      BlockID := ReadBlockID;
      // If block ID is unknown set it to end-of-GIF marker
      if not (BlockID in [GIFExtensionIntroducer, GIFTrailer, GIFImageDescriptor]) then
        BlockID := GIFTrailer;
    end;

    if FLoadAnimated then
    begin
      // Aniated frames will be stored in AnimFrames
      SetLength(AnimFrames, Length(Images));
      InitImage(CachedFrame);
      CachedIndex := -1;

      for I := 0 to High(Images) do
      begin
        // Create new logical screen
        NewImage(ScreenWidth, ScreenHeight, ifA8R8G8B8, AnimFrames[I]);
        // Animate frames to current log screen
        AnimateFrame(I, AnimFrames[I]);
      end;

      // Now release raw 8bit frames and put animated 32bit ones
      // to output array
      FreeImage(CachedFrame);
      for I := 0 to High(AnimFrames) do
      begin
        FreeImage(Images[I]);
        Images[I] := AnimFrames[I];
      end;
    end;

    Result := True;
  end;
end;

function TGIFFileFormat.SaveData(Handle: TImagingHandle;
  const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
  Header: TGIFHeader;
  ImageDesc: TImageDescriptor;
  ImageToSave: TImageData;
  MustBeFreed: Boolean;
  I, J: Integer;
  GraphicExt: TGraphicControlExtension;

  procedure FindMaxDimensions(var MaxWidth, MaxHeight: Word);
  var
    I: Integer;
  begin
    MaxWidth := Images[FFirstIdx].Width;
    MaxHeight := Images[FFirstIdx].Height;

    for I := FFirstIdx + 1 to FLastIdx do
    begin
      MaxWidth := Iff(Images[I].Width > MaxWidth, Images[I].Width, MaxWidth);
      MaxHeight := Iff(Images[I].Height > MaxWidth, Images[I].Height, MaxHeight);
    end;
  end;

  procedure SetFrameDelay(Idx: Integer; var Ext: TGraphicControlExtension);
  begin
    if FMetadata.HasMetaItemForSaving(SMetaFrameDelay, Idx) then
      Ext.DelayTime := FMetadata.MetaItemsForSavingMulti[SMetaFrameDelay, Idx] div 10
    else
      Ext.DelayTime := GIFDefaultDelay;
  end;

  procedure SaveGlobalMetadata;
  var
    AppExt: TGIFApplicationRec;
    BlockSize, LoopExtId: Byte;
    Repeats: Word;
  begin
    if FMetadata.HasMetaItemForSaving(SMetaAnimationLoops) then
    with GetIO do
    begin
      FillChar(AppExt, SizeOf(AppExt), 0);
      AppExt.Identifier := 'NETSCAPE';
      AppExt.Authentication := '2.0';
      Repeats := FMetadata.MetaItemsForSaving[SMetaAnimationLoops];
      if Repeats > 0 then
        Dec(Repeats);
      LoopExtId := GIFAppLoopExtension;

      Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
      Write(Handle, @GIFApplicationExtension, SizeOf(GIFApplicationExtension));
      BlockSize := 11;
      Write(Handle, @BlockSize, SizeOf(BlockSize));
      Write(Handle, @AppExt, SizeOf(AppExt));
      BlockSize := 3;
      Write(Handle, @BlockSize, SizeOf(BlockSize));
      Write(Handle, @LoopExtId, SizeOf(LoopExtId));
      Write(Handle, @Repeats, SizeOf(Repeats));
      Write(Handle, @GIFBlockTerminator, SizeOf(GIFBlockTerminator));
    end;
  end;

begin
  // Fill header with data, select size of largest image in array as
  // logical screen size
  FillChar(Header, Sizeof(Header), 0);
  Header.Signature := GIFSignature;
  Header.Version := GIFVersions[gv89];
  FindMaxDimensions(Header.ScreenWidth, Header.ScreenHeight);
  Header.PackedFields := GIFColorResolution; // Color resolution is 256
  GetIO.Write(Handle, @Header, SizeOf(Header));

  // Prepare default GC extension with delay
  FillChar(GraphicExt, Sizeof(GraphicExt), 0);
  GraphicExt.DelayTime := GIFDefaultDelay;
  GraphicExt.BlockSize := 4;

  SaveGlobalMetadata;

  for I := FFirstIdx to FLastIdx do
  begin
    if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
    with GetIO, ImageToSave do
    try
      // Write Graphic Control Extension with default delay
      Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
      Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension));
      SetFrameDelay(I, GraphicExt);
      Write(Handle, @GraphicExt, SizeOf(GraphicExt));
      // Write frame marker and fill and write image descriptor for this frame
      Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor));
      FillChar(ImageDesc, Sizeof(ImageDesc), 0);
      ImageDesc.Width := Width;
      ImageDesc.Height := Height;
      ImageDesc.PackedFields := GIFLocalColorTable or GIFColorTableSize; // Use lccal color table with 256 entries
      Write(Handle, @ImageDesc, SizeOf(ImageDesc));

      // Write local color table for each frame
      for J := 0 to 255 do
      begin
        Write(Handle, @Palette[J].R, SizeOf(Palette[J].R));
        Write(Handle, @Palette[J].G, SizeOf(Palette[J].G));
        Write(Handle, @Palette[J].B, SizeOf(Palette[J].B));
      end;

      // Finally compress image data
      LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits);

    finally
      if MustBeFreed then
        FreeImage(ImageToSave);
    end;
  end;

  GetIO.Write(Handle, @GIFTrailer, SizeOf(GIFTrailer));
  Result := True;
end;

procedure TGIFFileFormat.ConvertToSupported(var Image: TImageData;
  const Info: TImageFormatInfo);
begin
  ConvertImage(Image, ifIndex8);
end;

function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
  Header: TGIFHeader;
  ReadCount: Integer;
begin
  Result := False;
  if Handle <> nil then
  begin
    ReadCount := GetIO.Read(Handle, @Header, SizeOf(Header));
    GetIO.Seek(Handle, -ReadCount, smFromCurrent);
    Result := (ReadCount >= SizeOf(Header)) and
      (Header.Signature = GIFSignature) and
      ((Header.Version = GIFVersions[gv87]) or (Header.Version = GIFVersions[gv89]));
  end;
end;

initialization
  RegisterImageFileFormat(TGIFFileFormat);

{
  File Notes:

 -- TODOS ----------------------------------------------------
    - nothing now

  -- 0.77 Changes/Bug Fixes -----------------------------------
    - Fixed crash when resaving GIF with animation metadata.
    - Writes frame delays of GIF animations from metadata.
    - Reads and writes looping of GIF animations stored into/from metadata.

  -- 0.26.5 Changes/Bug Fixes ---------------------------------
    - Reads frame delays from GIF animations into metadata.

  -- 0.26.3 Changes/Bug Fixes ---------------------------------
    - Fixed bug - loading of GIF with NETSCAPE app extensions
      failed with Delphi 2009.

  -- 0.26.1 Changes/Bug Fixes ---------------------------------
    - GIF loading and animation mostly rewritten, based on
      modification by Sergey Galezdinov (ExtraGIF in Extras/Contrib).

  -- 0.25.0 Changes/Bug Fixes ---------------------------------
    - Fixed loading of some rare GIFs, problems with LZW
      decompression.

  -- 0.24.3 Changes/Bug Fixes ---------------------------------
    - Better solution to transparency for some GIFs. Background not
      transparent by default.

  -- 0.24.1 Changes/Bug Fixes ---------------------------------
    - Made backround color transparent by default (alpha = 0).

  -- 0.23 Changes/Bug Fixes -----------------------------------
    - Fixed other loading bugs (local pal size, transparency).
    - Added GIF saving.
    - Fixed bug when loading multiframe GIFs and implemented few animation
      features (disposal methods, ...). 
    - Loading of GIFs working.
    - Unit created with initial stuff!
}

end.