{Version 9.45}

{$i HtmlCons.inc}

unit HtmlGif1;

{***************************************************************}
{*                     htmlgif1.pas                            *}
{*                                                             *}
{*   Thanks to Ron Collins for the Gif code in this module.    *}
{*   His copyright notice is below.                            *}
{*                                                             *}
{*   This is only a portion of his code modified slightly      *}
{*   in a few places to accomodate my own needs.  Ron's        *}
{*   full package may be found at www.Torry.net/gif.htm.       *}
{*   The zip file is rctgif.zip.                               *}
{*                                                             *}
{***************************************************************}


{ ============================================================================

TGif.pas    copyright (C) 2000   R. Collins
rlcollins@ksaits.com

LEGAL STUFF:

This software is provided "as-is".  This software comes without warranty
or garantee, explicit or implied.  Use this software at your own risk.
The author will not be liable for any damage to equipment, data, or information
that may result while using this software.

By using this software, you agree to the conditions stated above.

This software may be used freely, provided the author's name and copyright
statement remain a part of the source code.

NOTE:  CompuServe, Inc. holds the patent to the compression algorithym
used in creating a GIF file.  Before you save a GIF file (using LZW
compression) that may be distributed for profit, make sure you understand
the full implications and legal ramifications of using the LZW compression.

============================================================================ }

interface

uses
  {$ifdef UseCLX}
    SysUtils, Types, Classes, QGraphics, QControls, QForms, QDialogs,
    QStdCtrls;
  {$else}
  {$IFNDEF LCL} Windows, Messages, WinTypes, WinProcs, {$ELSE} LclIntf, LMessages, Types, LclType, HtmlMisc, {$ENDIF} 
    SysUtils, Classes, Graphics,
    Controls, StdCtrls, ExtCtrls, Forms;  
  {$endif}


// LZW encode table sizes

const
    kGifCodeTableSize = 4096;


// the parts of a GIF file
// yes, yes, I know ... I don't have to put in "type"
// before each record definition.  I just think it makes it
// easier to read, especially when the definitions may be broken
// across the printed page.  if you don't like it, take them out.

type                         {LDB}
  TRGBQUAD = packed record
    rgbBlue: Byte;
    rgbGreen: Byte;
    rgbRed: Byte;
    rgbReserved: Byte;
    end;
type
    PGifDataBlock           = ^TGifDataBlock;
    TGifDataBlock           = record            // generic data clump
        rSize:              integer;            // NOTE: array starts at "1"
        rData:              packed array[1..255] of byte;
        end;

type
    PGifSignature           = ^TgifSignature;
    TGifSignature           = record            // GIF87A or GIF89A
        rSignature:         packed array[1..6] of char;
        end;

type
    PGifExtensionGraphic    = ^TgifExtensionGraphic;
    TGifExtensionGraphic    = record            // graphic control extension
        rBlockSize:         integer;            // must always be 4
        rDisposal:          integer;            // disposal method when drawing
        rUserInputValid:    boolean;            // wait for user input?
        rTransparentValid:  boolean;            // transparent color given?
        rDelayTime:         integer;            // delay between display images
        rTransparentIndex:  integer;            // into color table
        end;

type
    PGifExtensionComment    = ^TgifExtensionComment;
    TGifExtensionComment    = record            // comment extension
        rDataBlockList:     TList;               // data blocks
        end;

type
    PGifExtensionText       = ^TGifExtensionText;
    TGifExtensionText       = record            // plain text extension
        rBlockSize:         integer;            // must always be 12
        rGridLeft:          integer;            // text grid position
        rGridTop:           integer;
        rGridWidth:         integer;            // text grid size
        rGridHeight:        integer;
        rCellWidth:         integer;            // size of a character cell
        rCellHeight:        integer;
        rForegroundIndex:   integer;            // text foreground color
        rBackgroundIndex:   integer;            // text background color
        rDataBlockList:     TList;              // data blocks
        end;

type
    PGifExtensionApplication    = ^TgifExtensionApplication;
    TGifExtensionApplication    = record        // application extension
        rBlockSize:         integer;            // must always be 11
        rIdentifier:        packed array[1..8] of char;
        rAuthentication:    packed array[1..3] of char;
        rDataBlockList:     TList;              // data blocks
        end;

type
    PGifExtension           = ^TGifExtension;
    TGifExtension           = record            // for any extension type
        case rLabel: byte of                    // cannot use CONST names
            $f9:        (rGraphic:  TGifExtensionGraphic);
            $fe:        (rComment:  TGifExtensionComment);
            $01:        (rText:     TGifExtensionText);
            $ff:        (rApp:      TGifExtensionApplication);
            $00:        (rDummy:    longint);
        end;

type
    PGifScreenDescriptor    = ^TGifScreenDescriptor;
    TGifScreenDescriptor    = record
        rWidth:             integer;            // size of logical screen
        rHeight:            integer;            // size of logical screen
        rGlobalColorValid:  boolean;            // global color table found in file?
        rColorResolution:   integer;            // bits per color
        rSorted:            boolean;            // global colors are sorted?
        rGlobalColorSize:   integer;            // size of global color table
        rBackgroundIndex:   integer;            // background color index
        rAspectRatio:       integer;            // pixel aspect ratio
        rGlobalColorTable:  integer;            // default color table for all images
        end;

type
    PGifColorTable          = ^TGifColorTable;  // pointer to a color table
    TGifColorTable          = record
        rSize:              integer;            // number of valid entries
        rColors:            array[0..255] of TColor;    // the colors
        end;

type
    PGifImageDescriptor     = ^TGifImageDescriptor;
    TGifImageDescriptor     = record
        rIndex:             integer;            // which image is this?
        rLeft:              integer;            // position of image
        rTop:               integer;            // position of image
        rWidth:             integer;            // size of image
        rHeight:            integer;            // size of image
        rLocalColorValid:   boolean;            // color table used?
        rInterlaced:        boolean;            // interlaced lines?
        rSorted:            boolean;            // color table sorted?
        rLocalColorSize:    integer;            // number entries in local color table
        rLocalColorTable:   integer;            // index into master list
        rLZWSize:           integer;            // LZW minimum code size
        rExtensionList:     TList;              // extensions read before this image
        rPixelList:         PChar;              // decoded pixel indices
        rPixelCount:        longint;            // number of pixels
        rBitmap:            TBitmap;            // the actual image
        end;


type
    PGifZip                 = ^TGifZip;
    TGifZip                 = record
        rID:                PGifImageDescriptor;    // image parameters to decode
        rCT:                PGifColorTable;         // color table for this image
        rPrefix:            array[0..kGifCodeTableSize-1] of integer;   // string prefixes
        rSuffix:            array[0..kGifCodeTableSize-1] of integer;   // string suffixes
        rCodeStack:         array[0..kGifCodeTableSize-1] of byte;      // decode/encoded pixels
        rSP:                integer;                // pointer into CodeStack
        rClearCode:         integer;                // reset decode params
        rEndCode:           integer;                // last code in input stream
        rHighCode:          integer;                // highest LZW code possible
        rCurSize:           integer;                // current code size
        rBitString:         integer;                // steady stream of bits to be decoded
        rBits:              integer;                // number of valid bits in BitString
        rCurSlot:           integer;                // next stack index to store a code
        rTopSlot:           integer;                // highest slot used so far
        rMaxVal:            boolean;                // max code value found?
        rCurX:              integer;                // position of next pixel
        rCurY:              integer;                // position of next pixel
        rCurPass:           integer;                // pixel line pass 1..4
        rFirstSlot:         integer;                // for encoding an image
        rNextSlot:          integer;                // for encoding
        rCount:             integer;                // number of bytes read/written
        rLast:              integer;                // last byte read in
        rUnget:             boolean;                // read a new byte, or use zLast?
    end;

{ ---------------------------------------------------------------------------- }

// define a GIF

type
    TGif = class(TObject)
    private
        fIOStream:              TMemoryStream;      // read or write the image
        fDataStream:            TMemoryStream;      // temp storage for LZW
        fExtension:             TList;              // latest extensions read/written

        fSignature:             PGifSignature;      // version of GIF
        fScreenDescriptor:      PGifScreenDescriptor;   // logical screen descriptor
        fImageDescriptorList:   TList;              // list of all images
        fColorTableList:        TList;              // list of all color tables
        fPaletteList:           TList;              // list of palettes from color tables
        fZipData:               PGifZip;            // for encode/decode image
        FLoopCount:             integer;            // number of animated iterations


// functions that override TGraphic items

    protected
        function  GetHeight: integer;
        function  GetWidth: integer;
        function  GetTransparent: boolean;

// procedures to read a bitmap

   private
        procedure ReadSignature;
        procedure ReadScreenDescriptor;
        procedure ReadColorTable(Size: integer; var Table: integer);
        procedure ReadImageDescriptor;
        procedure ReadDataBlockList(List: TList);
        procedure ReadExtension(var Done: boolean);
        procedure ReadSourceInteger(size: integer; var value: integer);

// LZW encode and decode

        procedure LZWDecode(pID: PGifImageDescriptor);
        procedure LZWInit(pID: PGifImageDescriptor);
        procedure LZWFinit;
        procedure LZWReset;
        function  LZWGetCode: integer;
        procedure LZWSaveCode(Code: integer);
        procedure LZWDecodeCode(var Code: integer);
        procedure LZWSaveSlot(Prefix, Suffix: integer);
        procedure LZWIncrPosition;
        procedure LZWCheckSlot;
        procedure LZWWriteBitmap;
        function  LZWReadBitmap: integer;

// procedures used to implement the PROPERTIES

        function  GetSignature: string;
        function  GetScreenDescriptor: PGifScreenDescriptor;
        function  GetImageCount: integer;
        function  GetImageDescriptor(image: integer): PGifImageDescriptor;
        function  GetBitmap(image: integer): TBitmap;
        function  GetColorTableCount: integer;
        function  GetColorTable(table: integer): PGifColorTable;
        function  GetImageDelay(Image: integer): integer;  {LDB}
        function  GetImageDisposal(Image: integer): integer; {LDB}
        function  GetColorIndex(image, x, y: integer): integer;
        function  GetTransparentIndex(image: integer): integer;
        function  GetTransparentColor: TColor;
        function  GetImageLeft(image: integer): integer;
        function  GetImageTop(image: integer): integer;
        function  GetImageWidth(image: integer): integer;
        function  GetImageHeight(image: integer): integer;
        function  GetImageDepth(image: integer): integer;

// generally usefull routines

        procedure FreeDataBlockList(var list: TList);
        procedure FreeExtensionList(var list: TList);
        procedure MakeBitmaps;
        function  FindGraphicExtension(image: integer): PGifExtensionGraphic;
        function  FindColorIndex(c: TColor; ct: PGifColorTable): integer;
        procedure ExtractLoopCount(List: TList);

    public
        constructor Create;
        destructor Destroy; override;
        procedure FreeImage;

        procedure LoadFromStream(Source: TStream);
        function GetStripBitmap(var Mask: TBitmap): TBitmap;  {LDB}

        property Signature:                         string                  read GetSignature;
        property ScreenDescriptor:                  PGifScreenDescriptor    read GetScreenDescriptor;
        property ImageCount:                        integer                 read GetImageCount;
        property ImageDescriptor[Image: integer]:   PGifImageDescriptor     read GetImageDescriptor;
        property Bitmap[Image: integer]:            TBitmap                 read GetBitmap;
        property ColorTableCount:                   integer                 read GetColorTableCount;
        property ColorTable[Table: integer]:        PGifColorTable          read GetColorTable;
        property Height:                            integer                 read GetHeight;
        property Width:                             integer                 read GetWidth ;

        property ImageDelay[Image: integer]:        integer                 read GetImageDelay;
        property ImageDisposal[Image: integer]:     integer                 read GetImageDisposal;

        property Transparent:                       boolean                 read GetTransparent;
        property TransparentIndex[Image: integer]:  integer                 read GetTransparentIndex;
        property TransparentColor:                  TColor                  read GetTransparentColor;
        property ImageLeft[Image: integer]:         integer                 read GetImageLeft;
        property ImageTop[Image: integer]:          integer                 read GetImageTop;
        property ImageWidth[Image: integer]:        integer                 read GetImageWidth;
        property ImageHeight[Image: integer]:       integer                 read GetImageHeight;
        property ImageDepth[Image: integer]:        integer                 read GetImageDepth;
        property LoopCount:                         integer                 read FLoopCount;

    end;

implementation

uses
  HtmlUn2;    

const
  TransColor = $170725;

  // GIF record separators

const
    kGifImageSeparator:     byte = $2c;
    kGifExtensionSeparator: byte = $21;
    kGifTerminator:         byte = $3b;
    kGifLabelGraphic:       byte = $f9;
    kGifLabelComment:       byte = $fe;
    kGifLabelText:          byte = $01;
    kGifLabelApplication:   byte = $ff;

// define a set of error messages

const
    kGifErrorMessages:      array[0..27] of string = (      
        'no error',                                                 // 0
        'Invalid GIF Signature Code',                               // 1
        'No Local or Global Color Table for Image',                 // 2
        'Unknown Graphics Extension Type',                          // 3
        'Unknown Graphics Operation Code',                          // 4
        'Invalid Extension Block Size',                             // 5
        '[special message]',                                        // 6
        'Invalid Extension Block Terminator',                       // 7
        'Invalid Integer Size',                                     // 8
        'No GIF Terminator Found',                                  // 9
        'Extension Block Out-Of-Order With Image Data',             // 10
        'Invalid Image Descriptor Index',                           // 11
        'Invalid LZW Code Size',                                    // 12
        'Invalid LZW Data Format',                                  // 13
        'LZW Code Overflow',                                        // 14
        'Value Out Of Range',                                       // 15
        'NIL Pointer assigned',                                     // 16
        'Invalid Color Table Size',                                 // 17
        'No Image Description',                                     // 18
        'Invalid Bitmap Image',                                     // 19
        'Invalid Color Table Index',                                // 20
        'Invalid Interlace Pass',                                   // 21
        'Invalid Bitmap',                                           // 22
        'Too Many Colors In Bitmap',                                // 23
        'Unexpected end of file',                                   // 24   {LDB}
        'Animated GIF too large',                                   // 25   {LDB}
        'Zero width or height',                                     // 26   {LDB}  
        'next message'                                              //
    );

var
    GIF_ErrorCode:      integer;                    // last error
    GIF_ErrorString:    string;                     // last error

procedure GIF_Error(n: integer);  forward;
procedure GIF_ErrorMessage(m: string);  forward;


constructor TGif.Create;
begin
inherited Create;

// nothing defined yet

fIOStream            := nil;
fDataStream          := nil;
fExtension           := nil;
fSignature           := nil;
fScreenDescriptor    := nil;
fImageDescriptorList := nil;
fColorTableList      := nil;
fPaletteList         := nil;
fZipData             := nil;
FLoopCount := -1;    // -1 is no loop count entered

// some things, though, will always be needed

new(fSignature);
if (fSignature = nil) then OutOfMemoryError;
fSignature^.rSignature := '------';

new(fScreenDescriptor);
if (fScreenDescriptor = nil) then OutOfMemoryError;
fillchar(fScreenDescriptor^, sizeof(TGifScreenDescriptor), 0);

fImageDescriptorList := TList.Create;
fColorTableList      := TList.Create;
fPaletteList         := TList.Create;

end;


destructor TGif.Destroy;
begin

// clean up most of the data

FreeImage;

// and then the left-overs

dispose(fSignature);
dispose(fScreenDescriptor);

fImageDescriptorList.Free;
fColorTableList.Free;
fPaletteList.Free;

// and the ancestor

inherited;
end;

{ ---------------------------------------------------------------------------- }
{ release all memory used to store image data }

procedure TGif.FreeImage;
var
    i:    integer;
    id:     PGifImageDescriptor;
    ct:     PGifColorTable;
begin

// temp input/output stream

if (fIOStream <> nil) then fIOStream.Free;
fIOStream := nil;

// temp encoded data

if (fDataStream <> nil) then fDataStream.Free;
fDataStream:= nil;

// temp list of image extensions

if (fExtension <> nil) then FreeExtensionList(fExtension);
fExtension := nil;

// signature record stays, but is cleared

if (fSignature = nil) then new(fSignature);
fSignature^.rSignature := '------';

// ditto the screen descriptor

if (fScreenDescriptor = nil) then new(fScreenDescriptor);
fillchar(fScreenDescriptor^, sizeof(TGifScreenDescriptor), 0);

// delete all items from image list, but leave the list

if (fImageDescriptorList = nil) then fImageDescriptorList := TList.Create;
for i := 0 to (fImageDescriptorList.Count - 1) do
    begin
    id := fImageDescriptorList.Items[i];
    if (id <> nil) then
        begin
        if (id^.rExtensionList <> nil) then FreeExtensionList(id^.rExtensionList);
        if (id^.rPixelList     <> nil) then freemem(id^.rPixelList);
        if (id^.rBitmap        <> nil) then id^.rBitmap.Free;

        dispose(id);
        end;
    end;
fImageDescriptorList.Clear;

// release color tables, but keep the list

if (fColorTableList = nil) then fColorTableList := TList.Create;
for i := 0 to (fColorTableList.Count - 1) do
    begin
    ct := fColorTableList.Items[i];
    if (ct <> nil) then dispose(ct);
    end;
fColorTableList.Clear;

// once again, keep the palette list object, but not the data

if (fPaletteList = nil) then fPaletteList := TList.Create;
fPaletteList.Clear;

// don't need the zip/unzip data block

if (fZipData <> nil) then dispose(fZipData);
fZipData := nil;
end;


{ ---------------------------------------------------------------------------- }
{ READ and WRITE A GIF ------------------------------------------------------- }

{ ---------------------------------------------------------------------------- }
{ read a GIF definition from a stream }

procedure TGif.LoadFromStream(Source: TStream);
var
    done:   boolean;
    b:      byte;
begin

// release old image that may be here ...

FreeImage;

// no error yet

GIF_ErrorCode := 0;
GIF_ErrorString := '';

// make a local copy of the source data
// memory streams are faster and easier to manipulate than file streams

fIOStream := TMemoryStream.Create;
Source.Position := 0;
fIOStream.LoadFromStream(Source);

// local temp vars

fDataStream := TMemoryStream.Create;        // data to be un-zipped
fExtension  := nil;                         // extensions to an image


// read the signature GIF87A or GIF89A

ReadSignature;

// read the logical screen descriptor

ReadScreenDescriptor;

// read extensions and image data until end of file

done := false;
while (not done) do
  try  {LDB}
    if (fIOStream.Position >= fIOStream.Size) then
      //GIF_Error(9);    {LDB} 
      b := 0             {LDB}

    else fIOStream.Read(b, 1);    {LDB}         // image separator

    if (b = 0) then                             // just skip this?
        begin
        b := 0;
        Done := True;   {LDB}
        end
    else if (b = kGifTerminator) then           // got it all
        begin
        done := true;
        end
    else if (b = kGifImageSeparator) then       // next bitmap
        begin
        ReadImageDescriptor;
        end
    else if (b = kGifExtensionSeparator) then   // special operations
        begin
        ReadExtension(Done);
        end
    else                                        // unknown
        begin
        GIF_Error(4);
        end;
  except  {LDB}  
    if GetImageCount > 0 then
      Done := True     {use what images we have}
    else
      Raise;
    end;

// must have an image

if (fImageDescriptorList.Count = 0) then GIF_Error(18);  

// no longer need the source data in memory

fIOStream.Free;
fDataStream.Free;
FreeExtensionList(fExtension);

fIOStream   := nil;
fDataStream := nil;
fExtension  := nil;
end;


function TGif.GetHeight: integer;
begin
GetHeight := fScreenDescriptor^.rHeight;
end;

function TGif.GetWidth: integer;
begin
GetWidth := fScreenDescriptor^.rWidth;
end;

{ ---------------------------------------------------------------------------- }
{ TRANSPARENT is assument to be the same for all images; i.e., if the first }
{ image is transparent, they they are all transparent }
{ if SetTransparent(TRUE) then set default color index for transparent color }
{ this can be changed with TransparentColor after this call }

{LDB  changed so that if any images are transparent, Transparent returns True}
function TGif.GetTransparent: boolean;
var
    b:      boolean;
    gx:     PGifExtensionGraphic;
    i:      integer;
begin
b := false;
for I := 0 to (fImageDescriptorList.Count - 1) do
  begin
  gx := FindGraphicExtension(I);
  if (gx <> nil) then
    b := gx^.rTransparentValid or b;
  end;

GetTransparent := b;
end;

{ ---------------------------------------------------------------------------- }
{ PROCEDURES TO READ A GIF FILE ---------------------------------------------- }

{ ---------------------------------------------------------------------------- }
{ read the GIF signature from the source stream }
{ this assumes the memory stream position is correct }
{ the signature is always 6 bytes, and must be either GIF87A or GIF89A }

procedure TGif.ReadSignature;
var
    s:      string;
begin
with fSignature^ do
    begin
    fIOStream.Read(rSignature, 6);
    s := rSignature;
    s := UpperCase(s);
    if ((s <> 'GIF87A') and (s <> 'GIF89A')) then GIF_Error(1);
    end;
end;


{ ---------------------------------------------------------------------------- }
{ read the GIF logical screen descriptor from the source stream }
{ this assumes the memory stream position is correct }
{ this always follows the GIF signature }

procedure TGif.ReadScreenDescriptor;
var
    i,n:    integer;
begin
with fScreenDescriptor^ do
    begin
    ReadSourceInteger(2, rWidth);                   // logical screen width
    ReadSourceInteger(2, rHeight);                  // logical screen height

    ReadSourceInteger(1, n);                        // packed bit fields
    rGlobalColorValid := ((n and $80) <> 0);
    rColorResolution  := ((n shr 4) and $07) + 1;
    rSorted           := ((n and $08) <> 0);

    i := (n and $07);
    if      (i = 0) then rGlobalColorSize := 2
    else if (i = 1) then rGlobalColorSize := 4
    else if (i = 2) then rGlobalColorSize := 8
    else if (i = 3) then rGlobalColorSize := 16
    else if (i = 4) then rGlobalColorSize := 32
    else if (i = 5) then rGlobalColorSize := 64
    else if (i = 6) then rGlobalColorSize := 128
    else if (i = 7) then rGlobalColorSize := 256
    else                 rGlobalColorSize := 256;


    ReadSourceInteger(1, rBackgroundIndex);         // background color
    ReadSourceInteger(1, rAspectRatio);             // pixel aspect ratio

// read the global color table from the source stream
// this assumes the memory stream position is correct
// the global color table is only valid if a flag is set in the logical
// screen descriptor.  if the flag is set, the global color table will
// immediately follow the logical screen descriptor

    rGlobalColorTable := -1;
    if (rGlobalColorValid) then                     // a global color table?
        ReadColorTable(rGlobalColorSize, rGlobalColorTable)
    end;
end;

{ ---------------------------------------------------------------------------- }
{ read in any type of color table }
{ number of RGB entries is given by SIZE, and save the index into the }
{ master color table list in TABLE }
{ if SIZE is <= 0, then there is no table, and the TABLE becomes -1 }

procedure TGif.ReadColorTable(Size: integer; var Table: integer);
var
    i,n:        integer;
    r,g,b:      byte;
    ct:         PGifColorTable;
begin
Table := -1;                            // assume no table
if (Size > 0) then                      // OK, a table does exist
    begin
    new(ct);                            // make a anew color table
    if (ct = nil) then OutOfMemoryError;
    n := fColorTableList.Add(ct);       // save it in master list
    Table := n;                         // save index for a valid table

    ct^.rSize := Size;

    for i := 0 to (ct^.rSize-1) do      // read a triplet for each TColor
        begin
        fIOStream.Read(r, 1);             // red
        fIOStream.Read(g, 1);             // green
        fIOStream.Read(b, 1);             // blue

        ct^.rColors[i] := r or (g shl 8) or (b shl 16);  
        end;

// make sure we store palette handle in same index slot as the color table

    while (fPaletteList.Count < fColorTableList.Count) do fPaletteList.Add(nil);
    fPaletteList.Items[Table] := Nil;
    end;
end;

{ ---------------------------------------------------------------------------- }
{ read the next image descriptor }
{ the source stream position should be immediately following the }
{ special code image separator }
{ note: this routine only reads in the raw data; the LZW de-compression }
{ occurs later, after all the data has been read }
{ this probably makes for a bigger data chunk, but it doesn't much effect }
{ the speed, and it is certainly a more modular approach and is much easier }
{ to understand the mechanics later }

procedure TGif.ReadImageDescriptor;
var
    i,n:    integer;
    ix:     integer;
    id:     PGifImageDescriptor;
    db:     TGifDataBlock;
begin

// make a new image desctiptor record and add this record to main list

new(id);
if (id = nil) then OutOfMemoryError;
if (fImageDescriptorList = nil) then fImageDescriptorList := TList.Create;
ix := fImageDescriptorList.Add(id);
id^.rIndex := ix;

// initialize data

fillchar(id^, sizeof(TGifImageDescriptor), 0);

// init the sotrage for compressed data

fDataStream.Clear;

// if extensions were read in earlier, save that list
// for this image descriptor
// if no extensions were read in, then we don't need this list at all

if (fExtension <> nil) then
    begin
    id^.rExtensionList := fExtension;
    fExtension := nil;
    end;

// shortcut to the record fields

with id^ do
    begin

// read the basic descriptor record

    ReadSourceInteger(2, rLeft);            // left position
    ReadSourceInteger(2, rTop);             // top position
    ReadSourceInteger(2, rWidth);           // size of image
    ReadSourceInteger(2, rHeight);          // size of image

    if rHeight > Height then   {LDB make sure bad values don't overflow elsewhere}  
      rHeight := Height;

    ReadSourceInteger(1, n);                // packed bit field
    rLocalColorValid := ((n and $80) <> 0);
    rInterlaced      := ((n and $40) <> 0);
    rSorted          := ((n and $20) <> 0);

    i := (n and $07);
    if      (i = 0) then rLocalColorSize :=   2
    else if (i = 1) then rLocalColorSize :=   4
    else if (i = 2) then rLocalColorSize :=   8
    else if (i = 3) then rLocalColorSize :=  16
    else if (i = 4) then rLocalColorSize :=  32
    else if (i = 5) then rLocalColorSize :=  64
    else if (i = 6) then rLocalColorSize := 128
    else if (i = 7) then rLocalColorSize := 256
    else                 rLocalColorSize := 256;


// if a local color table is defined, read it
// otherwise, use the global color table

    if (rLocalColorValid) then ReadColorTable(rLocalColorSize, rLocalColorTable)
    else                       rLocalColorTable := fScreenDescriptor^.rGlobalColorTable;

// _something_ must have defined by now ...

    if (rLocalColorTable < 0) then GIF_Error(2);

// the LZW minimum code size

    ReadSourceInteger(1, rLZWSize);

// read data blocks until the end of the list

    ReadSourceInteger(1, db.rSize);
    while (db.rSize > 0) do
        begin
        if fIOStream.Read(db.rData, db.rSize) < db.rSize then
          Gif_Error(24);             {LDB}
        fDataStream.Write(db.rData, db.rSize);
        ReadSourceInteger(1, db.rSize);
        end;

// save the pixel list

    rPixelCount := rWidth * rHeight;
    if rPixelCount = 0 then    {LDB}  
      Gif_Error(26);
    rPixelList := allocmem(rPixelCount);
    if (rPixelList = nil) then
      OutOfMemoryError;

// uncompress the data and write the bitmap

    LZWDecode(id);
    end; // with id^
end;


{ ---------------------------------------------------------------------------- }
{ read in a group of data blocks until a zero-length block is found }
{ store the data on the give TList }

procedure TGif.ReadDataBlockList(List: TList);
var
    b:      byte;
    db:     PGifDataBlock;
    BytesRead: integer;
begin

// read data blocks until the end of the list

fIOStream.Read(b, 1);                       // size of next block
while (b > 0) do                            // more blocks to get?
    begin
    new(db);                                // new data block record
    db^.rSize := b;
    BytesRead := fIOStream.Read(db^.rData, db^.rSize);   // read the data
    List.Add(db);                           // save in given list

    if BytesRead < db^.rSize then
      Gif_Error(24);                       {LDB}
    fIOStream.Read(b, 1);                   // size of next block
    end;
end;



{ ---------------------------------------------------------------------------- }
{ read in any type of extension record }
{ assume that the source position is AFTER the extension separator, }
{ but BEFORE the specific extension label }
{ the extension record we read in is stored in the master extension }
{ list; however, the indexes for these exrtensions is stored in a }
{ temporary list which will be assigned to the next image descriptor }
{ record read in.  this is because all extension blocks preceed the }
{ image descriptor to which they belong }

procedure TGif.ReadExtension(var Done: boolean);
var
    n:    integer;
    b:      byte;
    eb:     PGifExtension;
begin

// make a list exists

if (fExtension = nil) then fExtension := TList.Create;

// make a new extension record and add it to temp holding list

new(eb);
if (eb = nil) then OutOfMemoryError;
fillchar(eb^, sizeof(TGifExtension), 0);
fExtension.Add(eb);

// get the type of extension

fIOStream.Read(b, 1);
eb^.rLabel := b;

// "with eb^" gives us access to rGraphic, rText, rComment, and rApp

with eb^ do
    begin

// a graphic extension

    if (rLabel = kGifLabelGraphic) then
        begin
        ReadSourceInteger(1, rGraphic.rBlockSize);      // block size
        if (rGraphic.rBlockSize <> 4) then GIF_Error(5);

        ReadSourceInteger(1, n);                        // packed bit field
        rGraphic.rDisposal         := ((n shr 2) and $07);
        rGraphic.rUserInputValid   := ((n and $02) <> 0);
        rGraphic.rTransparentValid := ((n and $01) <> 0);

        ReadSourceInteger(2, rGraphic.rDelayTime);      // delay time
        ReadSourceInteger(1, rGraphic.rTransparentIndex);   // transparent color
        ReadSourceInteger(1, n);                        // block terminator
        if (n <> 0) then GIF_Error(7);
        end

// a comment extension

    else if (rLabel = kGifLabelComment) then
        begin
        rComment.rDataBlockList := TList.Create;
          ReadDataBlockList(rComment.rDataBlockList);
        end

// a plain text extension

    else if (rLabel = kGifLabelText) then
        begin
        ReadSourceInteger(1, rText.rBlockSize);         // block size
        if (rText.rBlockSize <> 12) then GIF_Error(5);
        ReadSourceInteger(2, rText.rGridLeft);          // grid position
        ReadSourceInteger(2, rText.rGridTop);           // grid position
        ReadSourceInteger(2, rText.rGridWidth);         // grid size
        ReadSourceInteger(2, rText.rGridHeight);        // grid size
        ReadSourceInteger(1, rText.rCellWidth);         // character cell size    {LDB}{was 2 bytes}
        ReadSourceInteger(1, rText.rCellHeight);        // character cell size
        ReadSourceInteger(1, rText.rForegroundIndex);   // foreground color
        ReadSourceInteger(1, rText.rBackgroundIndex);   // background color
        rText.rDataBlockList := TList.Create;           // list of text data blocks
        ReadDataBlockList(rText.rDataBlockList);
        end

// an application extension

    else if (rLabel = kGifLabelApplication) then
        begin
        ReadSourceInteger(1, rApp.rBlockSize);          // block size
        if (rApp.rBlockSize <> 11) then //GIF_Error(5);       {LDB} allow other  blocksizes
          begin
          fIOStream.Position := fIOStream.Position+rApp.rBlockSize;
          rApp.rDataBlockList := TList.Create;
          ReadDataBlockList(rApp.rDataBlockList);
          end
        else
          begin
        fIOStream.Read(rApp.rIdentifier, 8);            // application identifier
        fIOStream.Read(rApp.rAuthentication, 3);        // authentication code
        rApp.rDataBlockList := TList.Create;
        ReadDataBlockList(rApp.rDataBlockList);
        if rApp.rIdentifier = 'NETSCAPE' then
          ExtractLoopCount(rApp.rDataBlockList);
          end;
        end

// unknown type

    else
        begin
        GIF_ErrorMessage('unknown extension: ' + IntToHex(rLabel, 4)); 
        end;
    end; // with eb^
end;


{ ---------------------------------------------------------------------------- }
{ read a 1 or 2-byte integer from the source stream }

procedure TGif.ReadSourceInteger(size: integer; var value: integer);
var
    b:  byte;
    w:  word;
begin
if (size = 1) then
    begin
    fIOStream.Read(b, 1);
    value := b;
    end
else if (size = 2) then
    begin
    fIOStream.Read(w, 2);
    value := w;
    end
else
    begin
    GIF_Error(8);
    end;
end;

{ ---------------------------------------------------------------------------- }
{ decode the compressed data blocks into a bitmap }

procedure TGif.LZWDecode(pID: PGifImageDescriptor);
var
    pc:         integer;            // next compressed code parsed from input
    cc:         integer;            // current code to translate
    oc:         integer;            // old code translated
    tt:         integer;            // temp storage for OldCode
    Done:       boolean;
begin

// init local data

LZWInit(pID);
LZWReset;

// do everything within the ZIP record

with fZipData^ do
    begin

// parse next code from BitString

    pc := LZWGetCode;
    oc := pc;
    Done := False;
    while (pc <> rEndCode) and not Done do      
        begin

// reset decode parameters and save first code

        if (pc = rClearCode) then
            begin
            rCurSize := rID^.rLZWSize + 1;
            rCurSlot := rEndCode + 1;
            rTopSlot := (1 shl rCurSize);
            while (pc = rClearCode) do pc := LZWGetCode;
            if (pc = rEndCode) then
              GIF_Error(13);   
            if (pc >= rCurSlot) then pc := 0;
            oc := pc;
            LZWSaveCode(pc);
            end

// find a code in the table and write out translation

        else
            begin
            cc := pc;
            if (cc < rCurSlot) then
                begin
                LZWDecodeCode(cc);
                if (rCurSlot <= rTopSlot) then
                    begin
                    LZWSaveSlot(oc, cc);
                    oc := pc;
                    end;
                LZWCheckSlot;
                end

// add a new code to the decode table

            else
                begin
                if (cc <> rCurSlot) then GIF_Error(13);
                tt := oc;
                while (oc > rHighCode) do oc := rPrefix[oc];
                if (rCurSlot <= rTopSlot) then LZWSaveSlot(tt, oc);
                LZWCheckSlot;
                LZWDecodeCode(cc);
                oc := pc;
                end;
            end;

// write out translated bytes to the image storage

            LZWWriteBitmap;
            if fDataStream.Position < fDataStream.Size then
              pc := LZWGetCode
            else Done := True;    
            rMaxVal := false;

        end; // while not EOI

    end;    // with

// done with stack space

LZWFinit;
end;

{ ---------------------------------------------------------------------------- }

procedure TGif.LZWInit(pID: PGifImageDescriptor);
begin

// get a valid record?

if (pID = nil) then GIF_Error(11);

// make sure we can actually decode this turkey

// if ((pID^.rLZWSize < 2) or (pID^.rLZWSize > 9)) then GIF_Error(12);

// allocate stack space

new(fZipData);
if (fZipData = nil) then OutOfMemoryError;

// init data block

fillchar(fZipData^, sizeof(TGifZip), 0);
fZipData^.rID := pID;
fZipData^.rCT := fColorTableList.Items[pID^.rLocalColorTable];

// reset data stream

fDataStream.Position := 0;
end;

{ ---------------------------------------------------------------------------- }

procedure TGif.LZWFinit;
begin
if (fZipData <> nil) then dispose(fZipData);
fZipData := nil;
end;

{ ---------------------------------------------------------------------------- }

procedure TGif.LZWReset;
var
    i:    integer;
begin
with fZipData^ do
    begin
    for i := 0 to (kGifCodeTableSize - 1) do
        begin
        rPrefix[i] := 0;
        rSuffix[i] := 0;
        end;

    rCurSize   := rID^.rLZWSize + 1;
    rClearCode := (1 shl rID^.rLZWSize);
    rEndCode   := rClearCode + 1;
    rHighCode  := rClearCode - 1;
    rFirstSlot := (1 shl (rCurSize - 1)) + 2;
    rNextSlot  := rFirstSlot;
    rMaxVal    := false;
    end;    // with
end;


{ ---------------------------------------------------------------------------- }
{ get the next code from the BitString }
{ CurrentSize specifies the number of bits to get }

function TGif.LZWGetCode: integer;
var
    n:    integer;
    cc:     integer;
    mask:   integer;
    b:      byte;
begin
with fZipData^ do
    begin

// make sure we have enough bits

    while (rCurSize > rBits) do
        begin
        if (fDataStream.Position >= fDataStream.Size) then
          b := 0
        else
          fDataStream.Read(b, 1);
        n := b;
        n := (n shl rBits);                 // scoot bits over to avoid previous data
        rBitString := (rBitString or n);    // put bits in the BitString
        rBits := rBits + 8;                 // number of bits in a byte
        end;


// get the code, then dump the bits we used from the BitString

    case rCurSize of
         0:     mask := 0;
         1:     mask := $0001;
         2:     mask := $0003;
         3:     mask := $0007;
         4:     mask := $000f;
         5:     mask := $001f;
         6:     mask := $003f;
         7:     mask := $007f;
         8:     mask := $00ff;
         9:     mask := $01ff;
        10:     mask := $03ff;
        11:     mask := $07ff;
        12:     mask := $0fff;
        else
          begin
          GIF_Error(12);
          Mask := 0;    //stop warning
          end;
        end;

    cc := (rBitString and mask);                // mask off bits wanted
    rBitString := (rBitString shr rCurSize);    // delete bits we just took
    rBits  := rBits - rCurSize;                 // number of bits left in BitString
    end;    // with

// done

LZWGetCode := cc;
end;

{ ---------------------------------------------------------------------------- }
{ save a code value on the code stack }

procedure TGif.LZWSaveCode(Code: integer);
begin
with fZipData^ do
    begin
    rCodeStack[rSP] := Code;
    rSP := rSP + 1;
    end;
end;


{ ---------------------------------------------------------------------------- }
{ decode the CurrentCode into the clear-text pixel value }
{ mainly, just save the CurrentCode on the output stack, along with }
{ whatever prefixes go with it }

procedure TGif.LZWDecodeCode(var Code: integer);
begin
with fZipData^ do
    begin
    while (Code > rHighCode) do
        begin
        LZWSaveCode(rSuffix[Code]);
        Code := rPrefix[Code];
        end;
    LZWSaveCode(Code);
    end;
end;   


{ ---------------------------------------------------------------------------- }
{ save a new prefix/suffix pair }

procedure TGif.LZWSaveSlot(Prefix, Suffix: integer);
begin
with fZipData^ do
    begin
    rPrefix[rCurSlot] := Prefix;
    rSuffix[rCurSlot] := Suffix;
    rCurSlot := rCurSlot + 1;
    end;
end;



{ ---------------------------------------------------------------------------- }
{ given current line number, compute the next line to be filled }
{ this gets a little tricky if an interlaced image }
{ what is the purpose of this interlace, anyway?  it doesn't save space, }
{ and I can't imagine it makes for any faster image disply or loading }

procedure TGif.LZWIncrPosition;
var
    n:    integer;
begin
with fZipData^ do
    begin

// if first pass, make sure CurPass was initialized

    if (rCurPass = 0) then rCurPass := 1;

// incr X position

    rCurX := rCurX + 1;

// bumping Y ?

    if (rCurX >= rID^.rWidth) then
        begin
        rCurX := 0;

// if not interlaced image, then just move down the page

        if (not  rID^.rInterlaced) then
            begin
            rCurY := rCurY + 1;
            end

// interlaced images select the next line by some archane black-magical sheme

        else
            begin
            case rCurPass of                // delta to next row on this pass
                1:      n := 8;
                2:      n := 8;
                3:      n := 4;
                4:      n := 2;
                else
                  begin
                  GIF_Error(21);
                  n := 0;  //prevent warning
                  end;
                end;

            rCurY := rCurY + n;

// if past the end of the bitmap, start next pass

            if (rCurY >= rID^.rHeight) then
                begin
                rCurPass := rCurPass + 1;
                if (rCurPass = 5) then rCurPass := 1;
                case rCurPass of            // first line for given pass
                    1:      n := 0;
                    2:      n := 4;
                    3:      n := 2;
                    4:      n := 1;
                    else    GIF_Error(21);
                    end;

                rCurY := n;
                end;
            end;
        end;
    end;    // with
end;

{ ---------------------------------------------------------------------------- }
{ see if it is time to add a new slot to the decoder tables }

procedure TGif.LZWCheckSlot;
begin
with fZipData^ do
    begin
    if (rCurSlot >= rTopSlot) then
        begin
        if (rCurSize < 12) then
            begin
            rTopSlot := (rTopSlot shl 1);
            rCurSize := rCurSize + 1;
            end
        else
            begin
            rMaxVal := true;
            end;
        end;
    end;
end;

{ ---------------------------------------------------------------------------- }
{ empty the Codes stack and write to the Bitmap }

procedure TGif.LZWWriteBitmap;
var
    i,n:    integer;
    j:      longint;
    p:      PChar;
begin
with fZipData^ do
    begin
    for n := (rSP - 1) downto 0 do
        begin
        rCount := rCount + 1;

// get next code from the stack, and index into PixelList

        i := rCodeStack[n];
        j := (rCurY * rID^.rWidth) + rCurX;
        if ((0 <= j) and (j < rID^.rPixelCount)) then
            begin

// store the pixel index into PixelList

            p := rID^.rPixelList + j;
            p^ := chr(i);
            end;

        LZWIncrPosition;
        end;

    rSP := 0;
    end;    // with
end;

{ ---------------------------------------------------------------------------- }
{ get the next pixel from the bitmap, and return it as an index into }
{ the colormap }

function TGif.LZWReadBitmap: integer;
var
    n:    integer;
    j:      longint;
    p:      PChar;
begin
with fZipData^ do
    begin
    if (rUnget) then
        begin
        n := rLast;
        rUnget := false;
        end
    else
        begin
        rCount := rCount + 1;
        j := (rCurY * rID^.rWidth) + rCurX;
        if ((0 <= j) and (j < rID^.rPixelCount)) then
            begin
            p := rID^.rPixelList + j;
            n := ord(p^);
            end
        else
            begin
            n := 0;
            end;

        LZWIncrPosition;
        end;

    rLast := n;
    end;    // with

LZWReadBitmap := n;
end;

{ ---------------------------------------------------------------------------- }
{ PROCEDURES TO IMPLEMENT PROPERTIES ----------------------------------------- }

{ ---------------------------------------------------------------------------- }

function TGif.GetSignature: string;
var
    s:      string;
begin
s := fSignature^.rSignature;
GetSignature := s;
end;


{ ---------------------------------------------------------------------------- }
{ return screen descriptor data pointer, or set a new record block }

function TGif.GetScreenDescriptor: PGifScreenDescriptor;
begin
GetScreenDescriptor := fScreenDescriptor;
end;


{ ---------------------------------------------------------------------------- }

function TGif.GetImageCount: integer;
begin
GetImageCount := fImageDescriptorList.Count;
end;


function TGif.GetImageDescriptor(image: integer): PGifImageDescriptor;
begin
if ((image < 0) or (image >= fImageDescriptorList.Count)) then GIF_Error(15);
GetImageDescriptor := fImageDescriptorList.Items[image];
end;


{ ---------------------------------------------------------------------------- }

function TGif.GetBitmap(image: integer): TBitmap;
var
    p:      PGifImageDescriptor;
    b:      TBitmap;
begin
p := GetImageDescriptor(image);
if (p^.rBitmap = nil) then MakeBitmaps;
b := p^.rBitmap;

GetBitmap := b;
end;

{ ---------------------------------------------------------------------------- }

function TGif.GetColorTableCount: integer;
begin
GetColorTableCount := fColorTableList.Count;
end;


function TGif.GetColorTable(table: integer): PGifColorTable;
begin
if ((table < 0) or (table >= fColorTableList.Count)) then GIF_Error(15);
GetColorTable := fColorTableList.Items[table];
end;

function TGif.GetImageDelay(Image: integer): integer;
var
    gx:     PGifExtensionGraphic;
begin
gx := FindGraphicExtension(Image);
if (gx <> nil) then
  begin
  Result := gx^.rDelayTime;
  if Result < 1 then
    Result := 1;
  end
else Result := 1;
end;

function TGif.GetImageDisposal(Image: integer): integer;
var
    gx:     PGifExtensionGraphic;
begin
gx := FindGraphicExtension(Image);
if (gx <> nil) then
  Result := gx^.rDisposal and 3
else Result := 0;
end;

{ ---------------------------------------------------------------------------- }

function TGif.GetColorIndex(image, x, y: integer): integer;
var
    i,n:    integer;
    id:     PGifImageDescriptor;
    p:      PChar;
begin
if ((image < 0) or (image >= fImageDescriptorList.Count)) then GIF_Error(15);
id := fImageDescriptorList.Items[image];
if ((x < 0) or (x >= id^.rWidth))  then GIF_Error(15);
if ((y < 0) or (y >= id^.rHeight)) then GIF_Error(15);

n := (y * id^.rWidth) + x;
p := id^.rPixelList + n;
i := ord(p^);

GetColorIndex := i;
end;

{ ---------------------------------------------------------------------------- }
{ transparent color for each individual image.
  returns -1 if none. }

function TGif.GetTransparentIndex(image: integer): integer;
var
    i:    integer;
    gx:     PGifExtensionGraphic;
begin
i := -1;
gx := FindGraphicExtension(image);
if (gx <> nil) and (gx^.rTransparentValid) then   {LDB}
  i := gx^.rTransparentIndex;

GetTransparentIndex := i;
end;

{ ---------------------------------------------------------------------------- }
{ transparent color for all images }
{LDB Changed to always return the standard used for the transparent color}

function TGif.GetTransparentColor: TColor;
begin
GetTransparentColor := TransColor;
end; 

procedure TGif.ExtractLoopCount(List: TList);
begin
if List.Count > 0 then
  with PGifDataBlock(List[0])^ do
    if rSize = 3 then
      FLoopCount := rData[2] + rData[3]*256;
end;

{ ---------------------------------------------------------------------------- }

function TGif.GetImageLeft(image: integer): integer;
var
    id:     PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageLeft := id^.rLeft;
end;

function TGif.GetImageTop(image: integer): integer;
var
    id:     PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageTop := id^.rTop;
end;

function TGif.GetImageWidth(image: integer): integer;
var
    id:     PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageWidth := id^.rWidth;
end;

function TGif.GetImageHeight(image: integer): integer;
var
    id:     PGifImageDescriptor;
begin
id := GetImageDescriptor(image);
GetImageHeight := id^.rHeight;
end;

function TGif.GetImageDepth(image: integer): integer;
var
    id:     PGifImageDescriptor;
    ct:     PGifColorTable;
begin
id := GetImageDescriptor(image);
ct := fColorTableList.Items[id^.rLocalColorTable];
GetImageDepth := ct^.rSize;
end;


{ ---------------------------------------------------------------------------- }
{ GENERAL INTERNAL ROUTINES -------------------------------------------------- }

{ ---------------------------------------------------------------------------- }

procedure TGif.FreeDataBlockList(var list: TList);
var
    i:    integer;
    db:     PGifDataBlock;
begin
if (list <> nil) then
    begin
    for i := 0 to (list.Count - 1) do
        begin
        db := list.Items[i];
        if (db <> nil) then dispose(db);
        end;

    list.Free;
    end;

list := nil;
end;

{ ---------------------------------------------------------------------------- }

procedure TGif.FreeExtensionList(var list: TList);
var
    i:    integer;
    ex:     PGifExtension;
begin
if (list <> nil) then
    begin
    for i := 0 to (list.Count - 1) do
        begin
        ex := list.Items[i];
        if (ex <> nil) then
            begin
            if      (ex^.rLabel = kGifLabelComment)     then FreeDataBlockList(ex^.rComment.rDataBlockList)
            else if (ex^.rLabel = kGifLabelText)        then FreeDataBlockList(ex^.rText.rDataBlockList)
            else if (ex^.rLabel = kGifLabelApplication) then FreeDataBlockList(ex^.rApp.rDataBlockList);

            dispose(ex);
            end;
        end;

    list.Free;
    end;

list := nil;
end;


{ ---------------------------------------------------------------------------- }
{ after an image has been LZW decoded, write a bitmap from the string of pixels }

{----------------TGif.MakeBitmaps}
procedure TGif.MakeBitmaps;
type
  LayoutType = Packed Record
    BFH: TBitmapFileHeader;
    BIH: TBitmapInfoHeader;
    end;
  PLayoutType = ^LayoutType;
var
  id:     PGifImageDescriptor;
  ct:     PGifColorTable;
  FullWidth, PixelSize, FileSize: integer;
  Stream: TMemoryStream;
  PL: PLayoutType;
  Color: TColor;
  Index: integer;
  Pix, P: PChar;
  I, X, Y, N: integer;
  TrIndex: integer;
begin
for i := 0 to (fImageDescriptorList.Count - 1) do
    begin
    id := fImageDescriptorList.Items[i];
    if ((id <> nil) and (id^.rBitmap = nil)) then      // don't do it again
      with id^ do
        begin
        FullWidth := rWidth * 3;
        if FullWidth and $3 <> 0 then
          FullWidth := (FullWidth and $FFFFFFFC) + $4;
        PixelSize := FullWidth * rHeight;
        FileSize := Sizeof(LayoutType)+PixelSize;
        Stream := TMemoryStream.Create;
        try
          Stream.Size := FileSize;
          PL := Stream.Memory;
          FillChar(PL^, FileSize, 0);

          with PL^.BFH do
            begin
            bfType := 19778;
            bfSize := FileSize;
            bfReserved1 := 0;
            bfReserved2 := 0;
            bfOffBits := Sizeof(LayoutType);
            end;
          with PL^.BIH do
            begin
            biSize := Sizeof(TBitmapInfoHeader);
            biWidth := rWidth;
            biHeight := rHeight;
            biPlanes := 1;
            biBitCount := 24;
            biCompression := 0;
            biSizeImage := 0;
            biXPelsPerMeter := 0;
            biYPelsPerMeter := 0;
            biClrUsed := 0;
            biClrImportant := 0;
            end;

          ct := fColorTableList.Items[rLocalColorTable];
          TrIndex := GetTransparentIndex(i);
          if (TrIndex >= 0) and (TrIndex < ct^.rSize) then
            {change transparent color to something that won't likely match any other color}
            ct^.rColors[TrIndex] := TransColor;

          N := 0;
          Pix := PChar(PL) + Sizeof(LayoutType);
          for Y := rHeight-1 downto 0 do
            begin
            P := Pix + (Y * FullWidth);
            for X := 0 to rWidth-1 do
              begin
              Index := Integer((rPixelList + N)^);
              Color := ct^.rColors[Index];
              P^ := Char((Color shr 16) and $FF);
              Inc(P);
              P^ := Char((Color shr 8) and $FF);
              Inc(P);
              P^ := Char(Color and $FF);
              Inc(P);
              Inc(N);
              end;
            end;
          rBitmap := TBitmap.Create;
          {$ifndef UseCLX}
          rBitmap.HandleType  := bmDIB;
          {$endif}
          rBitmap.LoadFromStream(Stream);
        finally
          Stream.Free;               
          end;

// is bitmap transparent?

        if ((0 <= TrIndex) and (TrIndex < ct^.rSize)) then
            begin
            rBitmap.Transparent      := true;
            rBitmap.TransparentMode  := tmFixed;
            rBitmap.TransparentColor := ct^.rColors[TrIndex];
            end;
        end;
    end;
end;

{----------------TGif.GetStripBitmap}
function TGif.GetStripBitmap(var Mask: TBitmap): TBitmap;   {LDB}
{This is a single bitmap containing all the frames.  A mask is also provided
 if the GIF is transparent.  Each Frame is set up so that it can be transparently
 blted to a background.}
type
  LayoutType = Packed Record
    BFH: TBitmapFileHeader;
    BIH: TBitmapInfoHeader;
    end;
  PLayoutType = ^LayoutType;
var
  id:     PGifImageDescriptor;
  ct:     PGifColorTable;
  FullWidth, PixelSize, FileSize: integer;
  Stream, MStream: TMemoryStream;
  PL, MPL: PLayoutType;
  Color: TColor;
  Index: integer;
  Pix, P, MPix, MP, PRight: PChar;
  I, X, Y, N: integer;
  TrIndex: integer;
  C: char;
  IsTransparent: boolean;
begin
MStream := Nil;
Result := Nil;
Mask := Nil;
MP := Nil;
MPix := Nil;
{find size needed for strip bitmap}
FullWidth := Width * 3 * ImageCount;  {3 bytes per pixel}
if FullWidth and $3 <> 0 then         {make sure it is DWord boundary}
  FullWidth := (FullWidth and $FFFFFFFC) + $4;
PixelSize := FullWidth * Height;
FileSize := Sizeof(LayoutType)+PixelSize;
if (FileSize > 200000000) or Transparent and (FileSize > 100000000) then
  GIF_Error(25);
Stream := TMemoryStream.Create;
try
  Stream.Size := FileSize;
  PL := Stream.Memory;
  FillChar(PL^, FileSize, 0);

  with PL^.BFH do
    begin          {set up the bitmap file header}
    bfType := 19778;
    bfSize := FileSize;
    bfReserved1 := 0;
    bfReserved2 := 0;
    bfOffBits := Sizeof(LayoutType);
    end;
  with PL^.BIH do
    begin           {and the bitmap info header}
    biSize := Sizeof(TBitmapInfoHeader);
    biWidth := Width * ImageCount;
    biHeight := Height;
    biPlanes := 1;
    biBitCount := 24;   {will use 24 bit pixel}
    biCompression := 0;
    biSizeImage := 0;
    biXPelsPerMeter := 0;
    biYPelsPerMeter := 0;
    biClrUsed := 0;
    biClrImportant := 0;
    end;

  Pix := PChar(PL) + Sizeof(LayoutType);  {where pixels start}

  IsTransparent := Transparent;
  if IsTransparent then
    begin           {set up a mask similarly}
    MStream := TMemoryStream.Create;
    MStream.Size := FileSize;
    MPL := MStream.Memory;
    Move(PL^, MPL^, FileSize);   {for now, this is a direct copy}
    MPix := PChar(MPL) + Sizeof(LayoutType);   {where mask pixels start}
    FillChar(MPix^, PixelSize, $FF);   {Need to make first frame totally transparent}
    end;

  for i := 0 to (fImageDescriptorList.Count - 1) do  {for all the frames}
    begin
    id := fImageDescriptorList.Items[i];
    if (id <> nil) then
      with id^ do
        begin
        ct := fColorTableList.Items[rLocalColorTable];
        TrIndex := GetTransparentIndex(i);

        N := 0;   {pixel index in rPixelList, the frame source pixels}
        for Y := Height-1 downto IntMax(Height-rHeight, ImageTop[I]) do    
          begin
          {find the start of each frame row in destination.  Note that the source
           frame may be smaller than the destination and positioned according to
           imagetop and imageleft}
          P := Pix + ((Y-ImageTop[i]) * FullWidth) + i*Width*3 +ImageLeft[i]*3;
          PRight := P + Width*3;   
          if IsTransparent then  {same for mask}
            MP := MPix + ((Y-ImageTop[i]) * FullWidth) + i*Width*3 +ImageLeft[i]*3;
          for X := 0 to rWidth-1 do
            begin
            if P < PRight then   {prevent write beyond proper right side in case rwidth to wide}
              begin
              Index := Integer((rPixelList + N)^);  {Source pixel index in colortable}
              Color := ct^.rColors[Index];          {its color}
              {for frames after the 0th, only the non transparent pixels are written
               as writing transparent ones might cover results copied from the previous frame}
              if (Index <> trIndex) then
                begin
                P^ := Char((Color shr 16) and $FF);
                Inc(P);
                P^ := Char((Color shr 8) and $FF);
                Inc(P);
                P^ := Char(Color and $FF);
                Inc(P);
                end
              else if i = 0 then
                begin     {transparent pixel, first frame, write black}
                P^ := #0;
                Inc(P);
                P^ := #0;
                Inc(P);
                P^ := #0;
                Inc(P);
                end
              else Inc(P, 3);   {ignore transparent pixel}
              if IsTransparent then   {also do the mask}
                begin
                if Index = trIndex then
                  C := #$FF  {transparent part is white}
                else C := #0;  {non transparent is black}
                {again for frames after the 0th, only non-transparent pixels are written}
                if (i = 0) or (C = #0) then
                  begin
                  MP^ := C;
                  Inc(MP);
                  MP^ := C;
                  Inc(MP);
                  MP^ := C;
                  Inc(MP);
                  end
                else Inc(MP, 3);
                end;
              end;
            Inc(N);    {bump source pixel index}
            end;
          end;
        end;
    {Now copy this frame to the next (unless it the last one).  This serves as a
     background for the next image.  This is all that's needed for the dtDoNothing
     disposal method but will be fixed up for dtBackground below}
    if (i < fImageDescriptorList.Count-1) then
      begin
      for Y := Height-1 downto 0 do
        begin  {copy line by line}
        P := Pix + (Y * FullWidth) + i*Width*3;
        if IsTransparent then
          MP := MPix + (Y * FullWidth) + i*Width*3;
        Move(P^, (P+Width*3)^, Width*3);
        if IsTransparent then
          Move(MP^, (MP+Width*3)^, Width*3);
        end;
      {for dtBackground, fill the mask area occupied by the current copied image with
       white. This makes it transparent so the original background will appear here
       (although the next image will no doubt write on part of this area.}
      if IsTransparent and (ImageDisposal[i] in [2,3]) then   {dtToPrevious run as dtBackground as it seems other browsers do this}
        with id^ do
          for Y := Height-1 downto IntMax(Height-rHeight, ImageTop[I]) do
            begin
            MP := MPix + ((Y-ImageTop[i]) * FullWidth) + (i+1)*Width*3 +ImageLeft[i]*3;
            FillChar(MP^, rWidth*3, $FF);
            end;
      end;
    end;

  Result := TBitmap.Create;
  {$ifndef UseCLX}
  Result.HandleType  := bmDIB;
  {$endif}
  Result.LoadFromStream(Stream); {turn the stream just formed into a TBitmap}
  if IsTransparent then
    begin
    Mask := TBitmap.Create;
    Mask.HandleType := bmDIB;
    Mask.LoadFromStream(MStream);
    Mask.Monochrome := True;      {crunch mask into a monochrome TBitmap}
    end;
  Stream.Free;
  MStream.Free;
except
  Stream.Free;
  MStream.Free;
  Mask.Free;
  Result.Free;
  Raise;
  end;
end;

{ ---------------------------------------------------------------------------- }
{ find the graphic extension for an image }

function TGif.FindGraphicExtension(image: integer): PGifExtensionGraphic;
var
    n:  integer;
    id:     PGifImageDescriptor;
    ex:     PGifExtension;
    gx:     PGifExtensionGraphic;
begin
gx := nil;
id := fImageDescriptorList.Items[image];
if (id^.rExtensionList <> nil) then
    begin
    for n := 0 to (id^.rExtensionList.Count - 1) do
        begin
        ex := id^.rExtensionList.Items[n];
        if ((ex^.rLabel = kGifLabelGraphic) and (gx = nil)) then
            begin
            gx := @(ex^.rGraphic);
            end;
        end;
    end;

FindGraphicExtension := gx;
end;

{ ---------------------------------------------------------------------------- }
{ find the color within the color table; returns 0..255 }
{ return -1 if color not found }

function TGif.FindColorIndex(c: TColor; ct: PGifColorTable): integer;
var
    i,n:    integer;
begin
n := -1;
for i := 0 to (ct^.rSize - 1) do
    begin
    if ((n < 0) and (ct^.rColors[i] = c)) then n := i;
    end;

FindColorIndex := n;
end;

{ ---------------------------------------------------------------------------- }
{ RAISE AN ERROR ------------------------------------------------------------- }

procedure GIF_Error(n: integer);
begin
GIF_ErrorCode   := n;
GIF_ErrorString := kGifErrorMessages[n];
raise EInvalidGraphicOperation.CreateFmt('TGif: %s', [GIF_ErrorString]);
end;


procedure GIF_ErrorMessage(m: string);
begin
GIF_ErrorCode := 6;
GIF_ErrorString := m;
raise EInvalidGraphicOperation.CreateFmt('TGif: %s', [GIF_ErrorString]);
end;

end.
