CentrED

{

  $Id: ImagingGif.pas 111 2007-12-02 23:25:44Z galfar $

  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, 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.}

  TGIFFileFormat = class(TImageFileFormat)

  private

    function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;

    procedure LZWDecompress(const IO: TIOFunctions; 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

    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

    constructor Create; override;

    function TestFormat(Handle: TImagingHandle): Boolean; override;

  end;

implementation

const

  SGIFFormatName = 'Graphics Interchange Format';

  SGIFMasks      = '*.gif';

  GIFSupportedFormats: TImageFormats = [ifIndex8];

type

  TGIFVersion = (gv87, gv89);

  TDisposalMethod = (dmUndefined, dmLeave, dmRestoreBackground,

    dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);

const

  GIFSignature: TChar3 = 'GIF';

  GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a');

  // 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;

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;

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

}

constructor TGIFFileFormat.Create;

begin

  inherited Create;

  FName := SGIFFormatName;

  FCanLoad := True;

  FCanSave := True;

  FIsMultiImageFormat := True;

  FSupportedFormats := GIFSupportedFormats;

  AddMasks(SGIFMasks);

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(const IO: TIOFunctions; 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 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);

      IO.Read(Handle, @Bytes, 1);

      if Bytes > 0 then

        IO.Read(Handle, @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 + (Longint(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

    IO.Read(Handle, @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;

var

  Header: TGIFHeader;

  HasGlobalPal: Boolean;

  GlobalPalLength: Integer;

  GlobalPal: TPalette32Size256;

  I: Integer;

  BlockID: Byte;

  HasGraphicExt: Boolean;

  GraphicExt: TGraphicControlExtension;

  Disposals: array of TDisposalMethod;

  function ReadBlockID: Byte;

  begin

    Result := GIFTrailer;

    GetIO.Read(Handle, @Result, SizeOf(Result));

  end;

  procedure ReadExtensions;

  var

    BlockSize, ExtType: Byte;

  begin

    HasGraphicExt := 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));

      if ExtType = GIFGraphicControlExtension then

      begin

        HasGraphicExt := True;

        Read(Handle, @GraphicExt, SizeOf(GraphicExt));

      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;

    end;

  end;

  procedure CopyFrameTransparent(const Image, Frame: TImageData; Left, Top, TransIndex: Integer);

  var

    X, Y: Integer;

    Src, Dst: PByte;

  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 := @PByteArray(Image.Bits)[(Top + Y) * Image.Width + Left];

      for X := 0 to Frame.Width - 1 do

      begin

        if Src^ <> TransIndex then

          Dst^ := Src^;

        Inc(Src);

        Inc(Dst);

      end;

    end;

  end;

  procedure ReadFrame;

  var

    ImageDesc: TImageDescriptor;

    HasLocalPal, Interlaced, HasTransparency: Boolean;

    I, Idx, LocalPalLength, TransIndex: Integer;

    LocalPal: TPalette32Size256;

    BlockTerm: Byte;

    Frame: TImageData;

  begin

    Idx := Length(Images);

    SetLength(Images, Idx + 1);

    FillChar(LocalPal, SizeOf(LocalPal), 0);

    with GetIO do

    begin

      // Read and parse image descriptor

      Read(Handle, @ImageDesc, SizeOf(ImageDesc));

      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)

      // Create new logical screen

      NewImage(Header.ScreenWidth, Header.ScreenHeight, ifIndex8, Images[Idx]);

      // Create new image for this frame which would be later pasted onto logical screen

      InitImage(Frame);

      NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Frame);

      // Load local palette if there is any

      if 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 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);

      // Add default disposal method for this frame

      SetLength(Disposals, Length(Disposals) + 1);

      Disposals[High(Disposals)] := dmUndefined;

      // If Grahic Control Extension is present make use of it

      if HasGraphicExt then

      begin

        HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;

        Disposals[High(Disposals)] := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);

        if HasTransparency then

          Images[Idx].Palette[GraphicExt.TransparentColorIndex].A := 0;

      end

      else

        HasTransparency := False;

      if Idx >= 1 then

      begin

        // If previous frame had some special disposal method we take it into

        // account now

        case Disposals[Idx - 1] of

          dmUndefined: ; // Do nothing

          dmLeave:

            begin

              // Leave previous frame on log screen

              CopyRect(Images[Idx - 1], 0, 0, Images[Idx].Width,

                Images[Idx].Height, Images[Idx], 0, 0);

            end;

          dmRestoreBackground:

            begin

              // Clear log screen with background color

              FillRect(Images[Idx], 0, 0, Images[Idx].Width, Images[Idx].Height,

                @Header.BackgroundColorIndex);

            end;

          dmRestorePrevious:

            if Idx >= 2 then

            begin

              // Set log screen to "previous of previous" frame

              CopyRect(Images[Idx - 2], 0, 0, Images[Idx].Width,

                Images[Idx].Height, Images[Idx], 0, 0);

            end;

        end;

      end

      else

      begin

        // First frame - just fill with background color

        FillRect(Images[Idx], 0, 0, Images[Idx].Width, Images[Idx].Height,

          @Header.BackgroundColorIndex);

      end;

      try

        // Data decompression finally

        LZWDecompress(GetIO, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Frame.Bits);

        Read(Handle, @BlockTerm, SizeOf(BlockTerm));

        // Now copy frame to logical screen with skipping of transparent pixels (if enabled)

        TransIndex := Iff(HasTransparency, GraphicExt.TransparentColorIndex, MaxInt);

        CopyFrameTransparent(Images[Idx], Frame, ImageDesc.Left, ImageDesc.Top, TransIndex);

      finally

        FreeImage(Frame);

      end;

    end;

  end;

begin

  SetLength(Images, 0);

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

  with GetIO do

  begin

    // Read GIF header

    Read(Handle, @Header, SizeOf(Header));

    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;

      GlobalPal[Header.BackgroundColorIndex].A := 0;

    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 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;

    Result := True;

  end;

end;

function TGIFFileFormat.SaveData(Handle: TImagingHandle;

  const Images: TDynImageDataArray; Index: Integer): 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;

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 := 65;

  GraphicExt.BlockSize := 4;

  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));

      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;

      // Fonally 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: LongInt;

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.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.