如何在deiphi中显示gif图 ( 积分: 100 )

;
        Inc(Source);
        if (code = table0[code]) then
          Error(sDecodeCircular);
        code := table0[code];
        ASSERT(Code < TableSize, 'Code too large');
      end;

      firstcode := table1[code];
      Source^ := firstcode;
      Inc(Source);

      code := MaxCode;
      if (code <= GIFCodeMax) then
      begin
        table0[code] := oldcode;
        table1[code] := firstcode;
        Inc(MaxCode);
        if ((MaxCode >= MaxCodeSize) and (MaxCodeSize <= GIFCodeMax)) then
        begin
          MaxCodeSize := MaxCodeSize * 2;
          Inc(BitsPerCode);
        end;
      end;

      oldcode := incode;

      if (longInt(Source) > longInt(@stack)) then
      begin
        Dec(Source);
        Result := Source^;
        exit;
      end
    end;
    Result := code;
  end;

  function readLZW: integer;
  begin
    if (longInt(Source) > longInt(@stack)) then
    begin
      Dec(Source);
      Result := Source^;
    end else
      Result := NextLZW;
  end;

begin
  NewImage;

  // Clear image data in case decompress doesn't complete
  if (Transparent) then
    // Clear to transparent color
    ClearValue := GraphicControlExtension.GetTransparentColorIndex
  else
    // Clear to first color
    ClearValue := 0;

  FillChar(FData^, FDataSize, ClearValue);

{$ifdef DEBUG_DECOMPRESSPERFORMANCE}
  TimeStartDecompress := timeGetTime;
{$endif}

  (*
  ** Read initial code size in bits from stream
  *)
  if (Stream.Read(InitialBitsPerCode, 1) <> 1) then
    exit;

  (*
  **  Initialize the Compression routines
  *)
  BitsPerCode := InitialBitsPerCode + 1;
  ClearCode := 1 SHL InitialBitsPerCode;
  EOFCode := ClearCode + 1;
  MaxCodeSize := 2 * ClearCode;
  MaxCode := ClearCode + 2;

  StartBit := 0;
  LastBit := 0;
  LastByte := 2;

  ZeroBlock := False;
  get_done := False;
  return_clear := TRUE;

  Source := @stack;

  try
    if (Interlaced) then
    begin
      ypos := 0;
      pass := 0;
      step := 8;

      for i := 0 to Height-1 do
      begin
        Dest := FData + Width * ypos;
        for xpos := 0 to width-1 do
        begin
          v := readLZW;
          if (v < 0) then
            exit;
          Dest^ := char(v);
          Inc(Dest);
        end;
        Inc(ypos, step);
        if (ypos >= height) then
          repeat
            if (pass > 0) then
              step := step DIV 2;
            Inc(pass);
            ypos := step DIV 2;
          until (ypos < height);
      end;
    end else
    begin
      Dest := FData;
      for ypos := 0 to (height * width)-1 do
      begin
        v := readLZW;
        if (v < 0) then
          exit;
        Dest^ := char(v);
        Inc(Dest);
      end;
    end;
  finally
    if (readLZW >= 0) then
      ;
//      raise GIFException.Create('Too much input data, ignoring extra...');
  end;
{$ifdef DEBUG_DECOMPRESSPERFORMANCE}
  TimeStopDecompress := timeGetTime;
  ShowMessage(format('Decompressed %d pixels in %d mS, Rate %d pixels/mS',
    [Height*Width, TimeStopDecompress-TimeStartDecompress,
    (Height*Width) DIV (TimeStopDecompress-TimeStartDecompress+1)]));
{$endif}
end;

////////////////////////////////////////////////////////////////////////////////
//
//			LZW Encoder stuff
//
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
//			LZW Encoder THashTable
////////////////////////////////////////////////////////////////////////////////
const
  HashKeyBits		= 13;			// Max number of bits per Hash Key

  HashSize		= 8009;			// Size of hash table
  						// Must be prime
                                                // Must be > than HashMaxCode
                                                // Must be < than HashMaxKey

  HashKeyMax		= (1 SHL HashKeyBits)-1;// Max hash key value
  						// 13 bits = 8191

  HashKeyMask		= HashKeyMax;		// $1FFF
  GIFCodeMask		= GIFCodeMax;		// $0FFF

  HashEmpty		= $000FFFFF;		// 20 bits

type
  // A Hash Key is 20 bits wide.
  // - The lower 8 bits are the postfix character (the new pixel).
  // - The upper 12 bits are the prefix code (the GIF token).
  // A KeyInt must be able to represent the integer values -1..(2^20)-1
  KeyInt = longInt;	// 32 bits
  CodeInt = SmallInt;	// 16 bits

  THashArray = array[0..HashSize-1] of KeyInt;
  PHashArray = ^THashArray;

  THashTable = class
{$ifdef DEBUG_HASHPERFORMANCE}
    CountLookupFound	: longInt;
    CountMissFound	: longInt;
    CountLookupNotFound	: longInt;
    CountMissNotFound	: longInt;
{$endif}
    HashTable: PHashArray;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Clear;
    procedure Insert(Key: KeyInt; Code: CodeInt);
    function Lookup(Key: KeyInt): CodeInt;
  end;

function HashKey(Key: KeyInt): CodeInt;
begin
  Result := ((Key SHR (GIFCodeBits-8)) XOR Key) MOD HashSize;
end;

function NextHashKey(HKey: CodeInt): CodeInt;
var
  disp		: CodeInt;
begin
  (*
  ** secondary hash (after G. Knott)
  *)
  disp := HashSize - HKey;
  if (HKey = 0) then
    disp := 1;
//  disp := 13;		// disp should be prime relative to HashSize, but
			// it doesn't seem to matter here...
  dec(HKey, disp);
  if (HKey < 0) then
    inc(HKey, HashSize);
  Result := HKey;
end;


constructor THashTable.Create;
begin
  ASSERT(longInt($FFFFFFFF) = -1, 'TGIFImage implementation assumes $FFFFFFFF = -1');

  inherited Create;
  GetMem(HashTable, sizeof(THashArray));
  Clear;
{$ifdef DEBUG_HASHPERFORMANCE}
  CountLookupFound := 0;
  CountMissFound := 0;
  CountLookupNotFound := 0;
  CountMissNotFound := 0;
{$endif}
end;

destructor THashTable.Destroy;
begin
{$ifdef DEBUG_HASHPERFORMANCE}
  ShowMessage(
    Format('Found: %d  HitRate: %.2f',
      [CountLookupFound, (CountLookupFound+1)/(CountMissFound+1)])+#13+
    Format('Not found: %d  HitRate: %.2f',
      [CountLookupNotFound, (CountLookupNotFound+1)/(CountMissNotFound+1)]));
{$endif}
  FreeMem(HashTable);
  inherited Destroy;
end;

// Clear hash table and fill with empty slots (doh!)
procedure THashTable.Clear;
{$ifdef DEBUG_HASHFILLFACTOR}
var
  i			,
  Count			: longInt;
{$endif}
begin
{$ifdef DEBUG_HASHFILLFACTOR}
  Count := 0;
  for i := 0 to HashSize-1 do
    if (HashTable[i] SHR GIFCodeBits <> HashEmpty) then
      inc(Count);
  ShowMessage(format('Size: %d, Filled: %d, Rate %.4f',
    [HashSize, Count, Count/HashSize]));
{$endif}

  FillChar(HashTable^, sizeof(THashArray), $FF);
end;

// Insert new key/value pair into hash table
procedure THashTable.Insert(Key: KeyInt; Code: CodeInt);
var
  HKey			: CodeInt;
begin
  // Create hash key from prefix string
  HKey := HashKey(Key);

  // Scan for empty slot
  // while (HashTable[HKey] SHR GIFCodeBits <> HashEmpty) do { Unoptimized }
  while (HashTable[HKey] AND (HashEmpty SHL GIFCodeBits) <> (HashEmpty SHL GIFCodeBits)) do { Optimized }
    HKey := NextHashKey(HKey);
  // Fill slot with key/value pair
  HashTable[HKey] := (Key SHL GIFCodeBits) OR (Code AND GIFCodeMask);
end;

// Search for key in hash table.
// Returns value if found or -1 if not
function THashTable.Lookup(Key: KeyInt): CodeInt;
var
  HKey			: CodeInt;
  HTKey			: KeyInt;
{$ifdef DEBUG_HASHPERFORMANCE}
  n			: LongInt;
{$endif}
begin
  // Create hash key from prefix string
  HKey := HashKey(Key);

{$ifdef DEBUG_HASHPERFORMANCE}
  n := 0;
{$endif}
  // Scan table for key
  // HTKey := HashTable[HKey] SHR GIFCodeBits; { Unoptimized }
  Key := Key SHL GIFCodeBits; { Optimized }
  HTKey := HashTable[HKey] AND (HashEmpty SHL GIFCodeBits); { Optimized }
  // while (HTKey <> HashEmpty) do { Unoptimized }
  while (HTKey <> HashEmpty SHL GIFCodeBits) do { Optimized }
  begin
    if (Key = HTKey) then
    begin
      // Extract and return value
      Result := HashTable[HKey] AND GIFCodeMask;
{$ifdef DEBUG_HASHPERFORMANCE}
      inc(CountLookupFound);
      inc(CountMissFound, n);
{$endif}
      exit;
    end;
{$ifdef DEBUG_HASHPERFORMANCE}
    inc(n);
{$endif}
    // Try next slot
    HKey := NextHashKey(HKey);
    // HTKey := HashTable[HKey] SHR GIFCodeBits; { Unoptimized }
    HTKey := HashTable[HKey] AND (HashEmpty SHL GIFCodeBits); { Optimized }
  end;
  // Found empty slot - key doesn't exist
  Result := -1;
{$ifdef DEBUG_HASHPERFORMANCE}
  inc(CountLookupNotFound);
  inc(CountMissNotFound, n);
{$endif}
end;

////////////////////////////////////////////////////////////////////////////////
//		TGIFStream - Abstract GIF block stream
//
// Descendants from TGIFStream either reads or writes data in blocks
// of up to 255 bytes. These blocks are organized as a leading byte
// containing the number of bytes in the block (exclusing the count
// byte itself), followed by the data (up to 254 bytes of data).
////////////////////////////////////////////////////////////////////////////////
type
  TGIFStream = class(TStream)
  private
    FOnWarning		: TGIFWarning;
    FStream		: TStream;
    FOnProgress		: TNotifyEvent;
    FBuffer		: array [BYTE] of Char;
    FBufferCount	: integer;

  protected
    constructor Create(Stream: TStream);

    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;

    procedure Progress(Sender: TObject); dynamic;
    property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
  public
    property Warning: TGIFWarning read FOnWarning write FOnWarning;
  end;

constructor TGIFStream.Create(Stream: TStream);
begin
  inherited Create;
  FStream := Stream;
  FBufferCount := 1; // Reserve first byte of buffer for length
end;

procedure TGIFStream.Progress(Sender: TObject);
begin
  if Assigned(FOnProgress) then
    FOnProgress(Sender);
end;

function TGIFStream.Write(const Buffer; Count: Longint): Longint;
begin
  raise Exception.Create(sInvalidStream);
end;

function TGIFStream.Read(var Buffer; Count: Longint): Longint;
begin
  raise Exception.Create(sInvalidStream);
end;

function TGIFStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
  raise Exception.Create(sInvalidStream);
end;

////////////////////////////////////////////////////////////////////////////////
//		TGIFReader - GIF block reader
////////////////////////////////////////////////////////////////////////////////
type
  TGIFReader = class(TGIFStream)
  public
    constructor Create(Stream: TStream);

    function Read(var Buffer; Count: Longint): Longint; override;
  end;

constructor TGIFReader.Create(Stream: TStream);
begin
  inherited Create(Stream);
  FBufferCount := 0;
end;

function TGIFReader.Read(var Buffer; Count: Longint): Longint;
var
  n			: integer;
  Dst			: PChar;
  size			: BYTE;
begin
  Dst := @Buffer;
  Result := 0;

  while (Count > 0) do
  begin
    // Get data from buffer
    while (FBufferCount > 0) and (Count > 0) do
    begin
      if (FBufferCount > Count) then
        n := Count
      else
        n := FBufferCount;
      Move(FBuffer, Dst^, n);
      dec(FBufferCount, n);
      dec(Count, n);
      inc(Result, n);
      inc(Dst, n);
    end;

    // Refill buffer when it becomes empty
    if (FBufferCount <= 0) then
    begin
      FStream.Read(size, 1);
      { TODO -oanme -cImprovement : Should be handled as a warning instead of an error. }
      if (size >= 255) then
        Error('GIF block too large');
      FBufferCount := size;
      if (FBufferCount > 0) then
      begin
        n := FStream.Read(FBuffer, size);
        if (n = FBufferCount) then
        begin
          Warning(self, gsWarning, sOutOfData);
          break;
        end;
      end else
        break;
    end;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//		TGIFWriter - GIF block writer
////////////////////////////////////////////////////////////////////////////////
type
  TGIFWriter = class(TGIFStream)
  private
    FOutputDirty	: boolean;

  protected
    procedure FlushBuffer;

  public
    constructor Create(Stream: TStream);
    destructor Destroy; override;

    function Write(const Buffer; Count: Longint): Longint; override;
    function WriteByte(Value: BYTE): Longint;
  end;

constructor TGIFWriter.Create(Stream: TStream);
begin
  inherited Create(Stream);
  FBufferCount := 1; // Reserve first byte of buffer for length
  FOutputDirty := False;
end;

destructor TGIFWriter.Destroy;
begin
  inherited Destroy;
  if (FOutputDirty) then
    FlushBuffer;
end;

procedure TGIFWriter.FlushBuffer;
begin
  if (FBufferCount <= 0) then
    exit;

  FBuffer[0] := char(FBufferCount-1); // Block size excluding the count
  FStream.WriteBuffer(FBuffer, FBufferCount);
  FBufferCount := 1; // Reserve first byte of buffer for length
  FOutputDirty := False;
end;

function TGIFWriter.Write(const Buffer; Count: Longint): Longint;
var
  n			: integer;
  Src			: PChar;
begin
  Result := Count;
  FOutputDirty := True;
  Src := @Buffer;
  while (Count > 0) do
  begin
    // Move data to the internal buffer in 255 byte chunks
    while (FBufferCount < sizeof(FBuffer)) and (Count > 0) do
    begin
      n := sizeof(FBuffer) - FBufferCount;
      if (n > Count) then
        n := Count;
      Move(Src^, FBuffer[FBufferCount], n);
      inc(Src, n);
      inc(FBufferCount, n);
      dec(Count, n);
    end;

    // Flush the buffer when it is full
    if (FBufferCount >= sizeof(FBuffer)) then
      FlushBuffer;
  end;
end;

function TGIFWriter.WriteByte(Value: BYTE): Longint;
begin
  Result := Write(Value, 1);
end;

////////////////////////////////////////////////////////////////////////////////
//		TGIFEncoder - Abstract encoder
////////////////////////////////////////////////////////////////////////////////
type
  TGIFEncoder = class(TObject)
  protected
    FOnWarning		: TGIFWarning;
    MaxColor		: integer;
    BitsPerPixel	: BYTE;		// Bits per pixel of image
    Stream		: TStream;	// Output stream
    Width		,		// Width of image in pixels
    Height		: integer;	// height of image in pixels
    Interlace		: boolean;	// Interlace flag (True = interlaced image)
    Data		: PChar;	// Pointer to pixel data
    GIFStream		: TGIFWriter;	// Output buffer

    OutputBucket	: longInt;	// Output bit bucket
    OutputBits		: integer;	// Current # of bits in bucket

    ClearFlag		: Boolean;	// True if dictionary has just been cleared
    BitsPerCode		,		// Current # of bits per code
    InitialBitsPerCode	: integer;	// Initial # of bits per code after
  					// dictionary has been cleared
    MaxCode		: CodeInt;	// maximum code, given BitsPerCode
    ClearCode		: CodeInt;	// Special output code to signal &quot;Clear table&quot;
    EOFCode		: CodeInt;	// Special output code to signal EOF
    BaseCode		: CodeInt;	// ...

    Pixel		: PChar;	// Pointer to current pixel

    cX			,		// Current X counter (Width - X)
    Y			: integer;	// Current Y
    Pass		: integer;	// Interlace pass

    function MaxCodesFromBits(Bits: integer): CodeInt;
    procedure Output(Value: integer); virtual;
    procedure Clear; virtual;
    function BumpPixel: boolean;
    procedure DoCompress; virtual; abstract;
  public
    procedure Compress(AStream: TStream; ABitsPerPixel: integer;
      AWidth, AHeight: integer; AInterlace: boolean; AData: PChar; AMaxColor: integer);
    property Warning: TGIFWarning read FOnWarning write FOnWarning;
  end;

// Calculate the maximum number of codes that a given number of bits can represent
// MaxCodes := (1^bits)-1
function TGIFEncoder.MaxCodesFromBits(Bits: integer): CodeInt;
begin
  Result := (CodeInt(1) SHL Bits) - 1;
end;

// Stuff bits (variable sized codes) into a buffer and output them
// a byte at a time
procedure TGIFEncoder.Output(Value: integer);
const
  BitBucketMask: array[0..16] of longInt =
    ($0000,
     $0001, $0003, $0007, $000F,
     $001F, $003F, $007F, $00FF,
     $01FF, $03FF, $07FF, $0FFF,
     $1FFF, $3FFF, $7FFF, $FFFF);
begin
  if (OutputBits > 0) then
    OutputBucket :=
      (OutputBucket AND BitBucketMask[OutputBits]) OR (longInt(Value) SHL OutputBits)
  else
    OutputBucket := Value;

  inc(OutputBits, BitsPerCode);

  while (OutputBits >= 8) do
  begin
    GIFStream.WriteByte(OutputBucket AND $FF);
    OutputBucket := OutputBucket SHR 8;
    dec(OutputBits, 8);
  end;

  if (Value = EOFCode) then
  begin
    // At EOF, write the rest of the buffer.
    while (OutputBits > 0) do
    begin
      GIFStream.WriteByte(OutputBucket AND $FF);
      OutputBucket := OutputBucket SHR 8;
      dec(OutputBits, 8);
    end;
  end;
end;

procedure TGIFEncoder.Clear;
begin
  // just_cleared = 1;
  ClearFlag := TRUE;
  Output(ClearCode);
end;

// Bump (X,Y) and data pointer to point to the next pixel
function TGIFEncoder.BumpPixel: boolean;
begin
  // Bump the current X position
  dec(cX);

  // If we are at the end of a scan line, set cX back to the beginning
  // If we are interlaced, bump Y to the appropriate spot, otherwise,
  // just increment it.
  if (cX <= 0) then
  begin

    if not(Interlace) then
    begin
      // Done - no more data
      Result := False;
      exit;
    end;

    cX := Width;
    case (Pass) of
      0:
        begin
          inc(Y, 8);
          if (Y >= Height) then
          begin
            inc(Pass);
            Y := 4;
          end;
        end;
      1:
        begin
          inc(Y, 8);
          if (Y >= Height) then
          begin
            inc(Pass);
            Y := 2;
          end;
        end;
      2:
        begin
          inc(Y, 4);
          if (Y >= Height) then
          begin
            inc(Pass);
            Y := 1;
          end;
        end;
      3:
        inc(Y, 2);
    end;

    if (Y >= height) then
    begin
      // Done - No more data
      Result := False;
      exit;
    end;
    Pixel := Data + (Y * Width);
  end;
  Result := True;
end;


procedure TGIFEncoder.Compress(AStream: TStream; ABitsPerPixel: integer;
  AWidth, AHeight: integer; AInterlace: boolean; AData: PChar; AMaxColor: integer);
const
  EndBlockByte		= $00;			// End of block marker
{$ifdef DEBUG_COMPRESSPERFORMANCE}
var
  TimeStartCompress	,
  TimeStopCompress	: DWORD;
{$endif}
begin
  MaxColor := AMaxColor;
  Stream := AStream;
  BitsPerPixel := ABitsPerPixel;
  Width := AWidth;
  Height := AHeight;
  Interlace := AInterlace;
  Data := AData;

  if (BitsPerPixel <= 1) then
    BitsPerPixel := 2;

  InitialBitsPerCode := BitsPerPixel + 1;
  Stream.Write(BitsPerPixel, 1);

  // out_bits_init = init_bits;
  BitsPerCode := InitialBitsPerCode;
  MaxCode := MaxCodesFromBits(BitsPerCode);

  ClearCode := (1 SHL (InitialBitsPerCode - 1));
  EOFCode := ClearCode + 1;
  BaseCode := EOFCode + 1;

  // Clear bit bucket
  OutputBucket := 0;
  OutputBits  := 0;

  // Reset pixel counter
  if (Interlace) then
    cX := Width
  else
    cX := Width*Height;
  // Reset row counter
  Y := 0;
  Pass := 0;

  GIFStream := TGIFWriter.Create(AStream);
  try
    GIFStream.Warning := Warning;
    if (Data <> nil) and (Height > 0) and (Width > 0) then
    begin
{$ifdef DEBUG_COMPRESSPERFORMANCE}
      TimeStartCompress := timeGetTime;
{$endif}

      // Call compress implementation
      DoCompress;

{$ifdef DEBUG_COMPRESSPERFORMANCE}
      TimeStopCompress := timeGetTime;
      ShowMessage(format('Compressed %d pixels in %d mS, Rate %d pixels/mS',
        [Height*Width, TimeStopCompress-TimeStartCompress,
        DWORD(Height*Width) DIV (TimeStopCompress-TimeStartCompress+1)]));
{$endif}
      // Output the final code.
      Output(EOFCode);
    end else
      // Output the final code (and nothing else).
      TGIFEncoder(self).Output(EOFCode);
  finally
    GIFStream.Free;
  end;

  WriteByte(Stream, EndBlockByte);
end;

////////////////////////////////////////////////////////////////////////////////
//		TRLEEncoder - RLE encoder
////////////////////////////////////////////////////////////////////////////////
type
  TRLEEncoder = class(TGIFEncoder)
  private
    MaxCodes		: integer;
    OutBumpInit		,
    OutClearInit	: integer;
    Prefix		: integer;	// Current run color
    RunLengthTableMax	,
    RunLengthTablePixel	,
    OutCount		,
    OutClear		,
    OutBump		: integer;
  protected
    function ComputeTriangleCount(count: integer; nrepcodes: integer): integer;
    procedure MaxOutClear;
    procedure ResetOutClear;
    procedure FlushFromClear(Count: integer);
    procedure FlushClearOrRepeat(Count: integer);
    procedure FlushWithTable(Count: integer);
    procedure Flush(RunLengthCount: integer);
    procedure OutputPlain(Value: integer);
    procedure Clear; override;
    procedure DoCompress; override;
  end;


procedure TRLEEncoder.Clear;
begin
  OutBump := OutBumpInit;
  OutClear := OutClearInit;
  OutCount := 0;
  RunLengthTableMax := 0;

  inherited Clear;

  BitsPerCode := InitialBitsPerCode;
end;

procedure TRLEEncoder.OutputPlain(Value: integer);
begin
  ClearFlag := False;
  Output(Value);
  inc(OutCount);

  if (OutCount >= OutBump) then
  begin
    inc(BitsPerCode);
    inc(OutBump, 1 SHL (BitsPerCode - 1));
  end;

  if (OutCount >= OutClear) then
    Clear;
end;

function TRLEEncoder.ComputeTriangleCount(count: integer; nrepcodes: integer): integer;
var
  PerRepeat		: integer;
  n			: integer;

  function iSqrt(x: integer): integer;
  var
    r, v		: integer;
  begin
    if (x < 2) then
    begin
      Result := x;
      exit;
    end else
    begin
      v := x;
      r := 1;
      while (v > 0) do
      begin
        v := v DIV 4;
        r := r * 2;
      end;
    end;

    while (True) do
    begin
      v := ((x DIV r) + r) DIV 2;
      if ((v = r) or (v = r+1)) then
      begin
        Result := r;
        exit;
      end;
      r := v;
    end;
  end;

begin
  Result := 0;
  PerRepeat := (nrepcodes * (nrepcodes+1)) DIV 2;

  while (Count >= PerRepeat) do
  begin
    inc(Result, nrepcodes);
    dec(Count, PerRepeat);
  end;

  if (Count > 0) then
  begin
    n := iSqrt(Count);
    while ((n * (n+1)) >= 2*Count) do
      dec(n);
    while ((n * (n+1)) < 2*Count) do
      inc(n);
    inc(Result, n);
  end;
end;

procedure TRLEEncoder.MaxOutClear;
begin
  OutClear := MaxCodes;
end;

procedure TRLEEncoder.ResetOutClear;
begin
  OutClear := OutClearInit;
  if (OutCount >= OutClear) then
    Clear;
end;

procedure TRLEEncoder.FlushFromClear(Count: integer);
var
  n			: integer;
begin
  MaxOutClear;
  RunLengthTablePixel := Prefix;
  n := 1;
  while (Count > 0) do
  begin
    if (n = 1) then
    begin
      RunLengthTableMax := 1;
      OutputPlain(Prefix);
      dec(Count);
    end else
    if (Count >= n) then
    begin
      RunLengthTableMax := n;
      OutputPlain(BaseCode + n - 2);
      dec(Count, n);
    end else
    if (Count = 1) then
    begin
      inc(RunLengthTableMax);
      OutputPlain(Prefix);
      break;
    end else
    begin
      inc(RunLengthTableMax);
      OutputPlain(BaseCode + Count - 2);
      break;
    end;

    if (OutCount = 0) then
      n := 1
    else
      inc(n);
  end;
  ResetOutClear;
end;

procedure TRLEEncoder.FlushClearOrRepeat(Count: integer);
var
  WithClear		: integer;
begin
  WithClear := 1 + ComputeTriangleCount(Count, MaxCodes);

  if (WithClear < Count) then
  begin
    Clear;
    FlushFromClear(Count);
  end else
    while (Count > 0) do
    begin
      OutputPlain(Prefix);
      dec(Count);
    end;
end;

procedure TRLEEncoder.FlushWithTable(Count: integer);
var
  RepeatMax		,
  RepeatLeft		,
  LeftOver		: integer;
begin
  RepeatMax := Count DIV RunLengthTableMax;
  LeftOver := Count MOD RunLengthTableMax;
  if (LeftOver <> 0) then
    RepeatLeft := 1
  else
    RepeatLeft := 0;

  if (OutCount + RepeatMax + RepeatLeft > MaxCodes) then
  begin
    RepeatMax := MaxCodes - OutCount;
    LeftOver := Count - (RepeatMax * RunLengthTableMax);
    RepeatLeft := 1 + ComputeTriangleCount(LeftOver, MaxCodes);
  end;

  if (1 + ComputeTriangleCount(Count, MaxCodes) < RepeatMax + RepeatLeft) then
  begin
    Clear;
    FlushFromClear(Count);
    exit;
  end;
  MaxOutClear;

  while (RepeatMax > 0) do
  begin
    OutputPlain(BaseCode + RunLengthTableMax-2);
    dec(RepeatMax);
  end;

  if (LeftOver > 0) then
  begin
    if (ClearFlag) then
      FlushFromClear(LeftOver)
    else if (LeftOver = 1) then
      OutputPlain(Prefix)
    else
      OutputPlain(BaseCode +  LeftOver - 2);
  end;
  ResetOutClear;
end;

procedure TRLEEncoder.Flush(RunLengthCount: integer);
begin
  if (RunLengthCount = 1) then
  begin
    OutputPlain(Prefix);
    exit;
  end;

  if (ClearFlag) then
    FlushFromClear(RunLengthCount)
  else if ((RunLengthTableMax < 2) or (RunLengthTablePixel <> Prefix)) then
    FlushClearOrRepeat(RunLengthCount)
  else
    FlushWithTable(RunLengthCount);
end;

procedure TRLEEncoder.DoCompress;
var
  Color			: CodeInt;
  RunLengthCount	: integer;

begin
  OutBumpInit := ClearCode - 1;

  // For images with a lot of runs, making OutClearInit larger will
  // give better compression.
  if (BitsPerPixel <= 3) then
    OutClearInit := 9
  else
    OutClearInit := OutBumpInit - 1;

  // max_ocodes = (1 << GIFBITS) - ((1 << (out_bits_init - 1)) + 3);
  // <=> MaxCodes := (1 SHL GIFCodeBits) - ((1 SHL (BitsPerCode - 1)) + 3);
  // <=> MaxCodes := (1 SHL GIFCodeBits) - ((1 SHL (InitialBitsPerCode - 1)) + 3);
  // <=> MaxCodes := (1 SHL GIFCodeBits) - (ClearCode + 3);
  // <=> MaxCodes := (1 SHL GIFCodeBits) - (EOFCode + 2);
  // <=> MaxCodes := (1 SHL GIFCodeBits) - (BaseCode + 1);
  // <=> MaxCodes := MaxCodesFromBits(GIFCodeBits) - BaseCode;
  MaxCodes := MaxCodesFromBits(GIFCodeBits) - BaseCode;

  Clear;
  RunLengthCount := 0;

  Pixel := Data;
  Prefix := -1; // Dummy value to make Color <> Prefix
  repeat
    // Fetch the next pixel
    Color := CodeInt(Pixel^);
    inc(Pixel);

    if (Color >= MaxColor) then
      Error(sInvalidColor);

    if (RunLengthCount > 0) and (Color <> Prefix) then
    begin
      // End of current run
      Flush(RunLengthCount);
      RunLengthCount := 0;
    end;

    if (Color = Prefix) then
      // Increment run length
      inc(RunLengthCount)
    else
    begin
      // Start new run
      Prefix := Color;
      RunLengthCount := 1;
    end;
  until not(BumpPixel);
  Flush(RunLengthCount);
end;

////////////////////////////////////////////////////////////////////////////////
//		TLZWEncoder - LZW encoder
////////////////////////////////////////////////////////////////////////////////
const
  TableMaxMaxCode	= (1 SHL GIFCodeBits);	//
  TableMaxFill		= TableMaxMaxCode-1;	// Clear table when it fills to
  						// this point.
  						// Note: Must be <= GIFCodeMax
type
  TLZWEncoder = class(TGIFEncoder)
  private
    Prefix		: CodeInt;	// Current run color
    FreeEntry		: CodeInt;	// next unused code in table
    HashTable		: THashTable;
  protected
    procedure Output(Value: integer); override;
    procedure Clear; override;
    procedure DoCompress; override;
  end;


procedure TLZWEncoder.Output(Value: integer);
begin
  inherited Output(Value);

  // If the next entry is going to be too big for the code size,
  // then increase it, if possible.
  if (FreeEntry > MaxCode) or (ClearFlag) then
  begin
    if (ClearFlag) then
    begin
      BitsPerCode := InitialBitsPerCode;
      MaxCode := MaxCodesFromBits(BitsPerCode);
      ClearFlag := False;
    end else
    begin
      inc(BitsPerCode);
      if (BitsPerCode = GIFCodeBits) then
        MaxCode := TableMaxMaxCode
      else
        MaxCode := MaxCodesFromBits(BitsPerCode);
    end;
  end;
end;

procedure TLZWEncoder.Clear;
begin
  inherited Clear;
  HashTable.Clear;
  FreeEntry := ClearCode + 2;
end;


procedure TLZWEncoder.DoCompress;
var
  Color			: char;
  NewKey		: KeyInt;
  NewCode		: CodeInt;

begin
  HashTable := THashTable.Create;
  try
    // clear hash table and sync decoder
    Clear;

    Pixel := Data;
    Prefix := CodeInt(Pixel^);
    inc(Pixel);
    if (Prefix >= MaxColor) then
      Error(sInvalidColor);
    while (BumpPixel) do
    begin
      // Fetch the next pixel
      Color := Pixel^;
      inc(Pixel);
      if (ord(Color) >= MaxColor) then
        Error(sInvalidColor);

      // Append Postfix to Prefix and lookup in table...
      NewKey := (KeyInt(Prefix) SHL 8) OR ord(Color);
      NewCode := HashTable.Lookup(NewKey);
      if (NewCode >= 0) then
      begin
        // ...if found, get next pixel
        Prefix := NewCode;
        continue;
      end;

      // ...if not found, output and start over
      Output(Prefix);
      Prefix := CodeInt(Color);

      if (FreeEntry < TableMaxFill) then
      begin
        HashTable.Insert(NewKey, FreeEntry);
        inc(FreeEntry);
      end else
        Clear;
    end;
    Output(Prefix);
  finally
    HashTable.Free;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFSubImage
//
////////////////////////////////////////////////////////////////////////////////

/////////////////////////////////////////////////////////////////////////
//		TGIFSubImage.Compress
/////////////////////////////////////////////////////////////////////////
procedure TGIFSubImage.Compress(Stream: TStream);
var
  Encoder		: TGIFEncoder;
  BitsPerPixel		: BYTE;
  MaxColors		: integer;
begin
  if (ColorMap.Count > 0) then
  begin
    MaxColors := ColorMap.Count;
    BitsPerPixel := ColorMap.BitsPerPixel
  end else
  begin
    BitsPerPixel := Image.BitsPerPixel;
    MaxColors := 1 SHL BitsPerPixel;
  end;

  // Create a RLE or LZW GIF encoder
  if (Image.Compression = gcRLE) then
    Encoder := TRLEEncoder.Create
  else
    Encoder := TLZWEncoder.Create;
  try
    Encoder.Warning := Image.Warning;
    Encoder.Compress(Stream, BitsPerPixel, Width, Height, Interlaced, FData, MaxColors);
  finally
    Encoder.Free;
  end;
end;

function TGIFExtensionList.GetExtension(Index: Integer): TGIFExtension;
begin
  Result := TGIFExtension(Items[Index]);
end;

procedure TGIFExtensionList.SetExtension(Index: Integer; Extension: TGIFExtension);
begin
  Items[Index] := Extension;
end;

procedure TGIFExtensionList.LoadFromStream(Stream: TStream; Parent: TObject);
var
  b			: BYTE;
  Extension		: TGIFExtension;
  ExtensionClass	: TGIFExtensionClass;
begin
  // Peek ahead to determine block type
  if (Stream.Read(b, 1) <> 1) then
    exit;
  while not(b in [bsTrailer, bsImageDescriptor]) do
  begin
    if (b = bsExtensionIntroducer) then
    begin
      ExtensionClass := TGIFExtension.FindExtension(Stream);
      if (ExtensionClass = nil) then
        Error(sUnknownExtension);
      Stream.Seek(-1, soFromCurrent);
      Extension := ExtensionClass.Create(Parent as TGIFSubImage);
      try
        Extension.LoadFromStream(Stream);
        Add(Extension);
      except
        Extension.Free;
        raise;
      end;
    end else
    begin
      Warning(gsWarning, sBadExtensionLabel);
      break;
    end;
    if (Stream.Read(b, 1) <> 1) then
      exit;
  end;
  Stream.Seek(-1, soFromCurrent);
end;

const
  { image descriptor bit masks }
  idLocalColorTable	= $80;    { set if a local color table follows }
  idInterlaced		= $40;    { set if image is interlaced }
  idSort		= $20;    { set if color table is sorted }
  idReserved		= $0C;    { reserved - must be set to $00 }
  idColorTableSize	= $07;    { size of color table as above }

constructor TGIFSubImage.Create(GIFImage: TGIFImage);
begin
  inherited Create(GIFImage);
  FExtensions := TGIFExtensionList.Create(GIFImage);
  FColorMap := TGIFLocalColorMap.Create(self);
  FImageDescriptor.Separator := bsImageDescriptor;
  FImageDescriptor.Left := 0;
  FImageDescriptor.Top := 0;
  FImageDescriptor.Width := 0;
  FImageDescriptor.Height := 0;
  FImageDescriptor.PackedFields := 0;
  FBitmap := nil;
  FMask := 0;
  FNeedMask := True;
  FData := nil;
  FDataSize := 0;
  FTransparent := False;
  FGCE := nil;
  // Remember to synchronize with TGIFSubImage.Clear
end;

destructor TGIFSubImage.Destroy;
begin
  if (FGIFImage <> nil) then
    FGIFImage.Images.Remove(self);
  Clear;
  FExtensions.Free;
  FColorMap.Free;
  if (FLocalPalette <> 0) then
    DeleteObject(FLocalPalette);
  inherited Destroy;
end;

procedure TGIFSubImage.Clear;
begin
  FExtensions.Clear;
  FColorMap.Clear;
  FreeImage;
  Height := 0;
  Width := 0;
  FTransparent := False;
  FGCE := nil;
  FreeBitmap;
  FreeMask;
  // Remember to synchronize with TGIFSubImage.Create
end;

function TGIFSubImage.GetEmpty: Boolean;
begin
  Result := ((FData = nil) or (FDataSize = 0) or (Height = 0) or (Width = 0));
end;

function TGIFSubImage.GetPalette: HPALETTE;
begin
  if (FBitmap <> nil) and (FBitmap.Palette <> 0) then
    // Use bitmaps own palette if possible
    Result := FBitmap.Palette
  else if (FLocalPalette <> 0) then
    // Or a previously exported local palette
    Result := FLocalPalette
  else if (Image.DoDither) then
  begin
    // or create a new dither palette
    FLocalPalette := WebPalette;
    Result := FLocalPalette;
  end
  else if (ColorMap.Count > 0) then
  begin
    // or create a new if first time
    FLocalPalette := ColorMap.ExportPalette;
    Result := FLocalPalette;
  end else
    // Use global palette if everything else fails
    Result := Image.Palette;
end;

procedure TGIFSubImage.SetPalette(Value: HPalette);
var
  NeedNewBitmap		: boolean;
begin
  if (Value <> FLocalPalette) then
  begin
    // Zap old palette
    if (FLocalPalette <> 0) then
      DeleteObject(FLocalPalette);
    // Zap bitmap unless new palette is same as bitmaps own
    NeedNewBitmap := (FBitmap <> nil) and (Value <> FBitmap.Palette);

    // Use new palette
    FLocalPalette := Value;
    if (NeedNewBitmap) then
    begin
      // Need to create new bitmap and repaint
      FreeBitmap;
      Image.PaletteModified := True;
      Image.Changed(Self);
    end;
  end;
end;

procedure TGIFSubImage.NeedImage;
begin
  if (FData = nil) then
    NewImage;
  if (FDataSize = 0) then
    Error(sEmptyImage);
end;

procedure TGIFSubImage.NewImage;
var
  NewSize		: longInt;
begin
  FreeImage;
  NewSize := Height * Width;
  if (NewSize <> 0) then
  begin
    GetMem(FData, NewSize);
    FillChar(FData^, NewSize, 0);
  end else
    FData := nil;
  FDataSize := NewSize;
end;

procedure TGIFSubImage.FreeImage;
begin
  if (FData <> nil) then
    FreeMem(FData);
  FDataSize := 0;
  FData := nil;
end;

function TGIFSubImage.GetHasBitmap: boolean;
begin
  Result := (FBitmap <> nil);
end;

procedure TGIFSubImage.SetHasBitmap(Value: boolean);
begin
  if (Value <> (FBitmap <> nil)) then
  begin
    if (Value) then
      Bitmap // Referencing Bitmap will automatically create it
    else
      FreeBitmap;
  end;
end;

procedure TGIFSubImage.NewBitmap;
begin
  FreeBitmap;
  FBitmap := TBitmap.Create;
end;

procedure TGIFSubImage.FreeBitmap;
begin
  if (FBitmap <> nil) then
  begin
    FBitmap.Free;
    FBitmap := nil;
  end;
end;

procedure TGIFSubImage.FreeMask;
begin
  if (FMask <> 0) then
  begin
    DeleteObject(FMask);
    FMask := 0;
  end;
  FNeedMask := True;
end;

function TGIFSubImage.HasMask: boolean;
begin
  if (FNeedMask) and (Transparent) then
  begin
    // Zap old bitmap
    FreeBitmap;
    // Create new bitmap and mask
    GetBitmap;
  end;
  Result := (FMask <> 0);
end;

function TGIFSubImage.GetBounds(Index: integer): WORD;
begin
  case (Index) of
    1: Result := FImageDescriptor.Left;
    2: Result := FImageDescriptor.Top;
    3: Result := FImageDescriptor.Width;
    4: Result := FImageDescriptor.Height;
  else
    Result := 0; // To avoid compiler warnings
  end;
end;

procedure TGIFSubImage.SetBounds(Index: integer; Value: WORD);
begin
  case (Index) of
    1: DoSetBounds(Value, FImageDescriptor.Top, FImageDescriptor.Width, FImageDescriptor.Height);
    2: DoSetBounds(FImageDescriptor.Left, Value, FImageDescriptor.Width, FImageDescriptor.Height);
    3: DoSetBounds(FImageDescriptor.Left, FImageDescriptor.Top, Value, FImageDescriptor.Height);
    4: DoSetBounds(FImageDescriptor.Left, FImageDescriptor.Top, FImageDescriptor.Width, Value);
  end;
end;

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
function TGIFSubImage.DoGetDitherBitmap: TBitmap;
var
  ColorLookup		: TColorLookup;
  Ditherer		: TDitherEngine;
  DIBResult		: TDIB;
  Src			: PChar;
  Dst			: PChar;

  Row			: integer;
  Color			: TGIFColor;
  ColMap		: PColorMap;
  Index			: byte;
  TransparentIndex	: byte;
  IsTransparent		: boolean;
  WasTransparent	: boolean;
  MappedTransparentIndex: char;

  MaskBits		: PChar;
  MaskDest		: PChar;
  MaskRow		: PChar;
  MaskRowWidth		,
  MaskRowBitWidth	: integer;
  Bit			,
  RightBit		: BYTE;

begin
  Result := TBitmap.Create;
  try

{$IFNDEF VER9x}
    if (Width*Height > BitmapAllocationThreshold) then
      SetPixelFormat(Result, pf1bit); // To reduce resource consumption of resize
{$ENDIF}

    if (Empty) then
    begin
      // Set bitmap width and height
      Result.Width := Width;
      Result.Height := Height;

      // Build and copy palette to bitmap
      Result.Palette := CopyPalette(Palette);

      exit;
    end;

    ColorLookup := nil;
    Ditherer := nil;
    DIBResult := nil;
    try // Protect above resources
      ColorLookup := TNetscapeColorLookup.Create(Palette);
      Ditherer := TFloydSteinbergDitherer.Create(Width, ColorLookup);
      // Get DIB buffer for scanline operations
      // It is assumed that the source palette is the 216 color Netscape palette
      DIBResult := TDIBWriter.Create(Result, pf8bit, Width, Height, Palette);

      // Determine if this image is transparent
      ColMap := ActiveColorMap.Data;
      IsTransparent := FNeedMask and Transparent;
      WasTransparent := False;
      FNeedMask := False;
      TransparentIndex := 0;
      MappedTransparentIndex := #0;
      if (FMask = 0) and (IsTransparent) then
      begin
        IsTransparent := True;
        TransparentIndex := GraphicControlExtension.TransparentColorIndex;
        Color := ColMap[ord(TransparentIndex)];
        MappedTransparentIndex := char(Color.Blue DIV 51 +
          MulDiv(6, Color.Green, 51) + MulDiv(36, Color.Red, 51)+1);
      end;

      // Allocate bit buffer for transparency mask
      MaskDest := nil;
      Bit := $00;
      if (IsTransparent) then
      begin
        MaskRowWidth := ((Width+15) DIV 16) * 2;
        MaskRowBitWidth := (Width+7) DIV 8;
        RightBit := $01 SHL ((8 - (Width AND $0007)) AND $0007);
        GetMem(MaskBits, MaskRowWidth * Height);
        FillChar(MaskBits^, MaskRowWidth * Height, 0);
      end else
      begin
        MaskBits := nil;
        MaskRowWidth := 0;
        MaskRowBitWidth := 0;
        RightBit := $00;
      end;

      try
        // Process the image
        Row := 0;
        MaskRow := MaskBits;
        Src := FData;
        while (Row < Height) do
        begin
          if ((Row AND $1F) = 0) then
            Image.Progress(Self, psRunning, MulDiv(Row, 100, Height),
              False, Rect(0,0,0,0), sProgressRendering);

          Dst := DIBResult.ScanLine[Row];
          if (IsTransparent) then
          begin
            // Preset all pixels to transparent
            FillChar(Dst^, Width, ord(MappedTransparentIndex));
            if (Ditherer.Direction = 1) then
            begin
              MaskDest := MaskRow;
              Bit := $80;
            end else
            begin
              MaskDest := MaskRow + MaskRowBitWidth-1;
              Bit := RightBit;
            end;
          end;
          inc(Dst, Ditherer.Column);

          while (Ditherer.Column < Ditherer.Width) and (Ditherer.Column >= 0) do
          begin
            Index := ord(Src^);
            Color := ColMap[ord(Index)];

            if (IsTransparent) and (Index = TransparentIndex) then
            begin
              MaskDest^ := char(byte(MaskDest^) OR Bit);
              WasTransparent := True;
              Ditherer.NextColumn;
            end else
            begin
              // Dither and map a single pixel
              Dst^ := Ditherer.Dither(Color.Red, Color.Green, Color.Blue,
                Color.Red, Color.Green, Color.Blue);
            end;

            if (IsTransparent) then
            begin
              if (Ditherer.Direction = 1) then
              begin
                Bit := Bit SHR 1;
                if (Bit = $00) then
                begin
                  Bit := $80;
                  inc(MaskDest, 1);
                end;
              end else
              begin
                Bit := Bit SHL 1;
                if (Bit = $00) then
                begin
                  Bit := $01;
                  dec(MaskDest, 1);
                end;
              end;
            end;

            inc(Src, Ditherer.Direction);
            inc(Dst, Ditherer.Direction);
          end;

          if (IsTransparent) then
            Inc(MaskRow, MaskRowWidth);
          Inc(Row);
          inc(Src, Width-Ditherer.Direction);
          Ditherer.NextLine;
        end;

        // Transparent paint needs a mask bitmap
        if (IsTransparent) and (WasTransparent) then
          FMask := CreateBitmap(Width, Height, 1, 1, MaskBits);
      finally
        if (MaskBits <> nil) then
          FreeMem(MaskBits);
      end;
    finally
      if (ColorLookup <> nil) then
        ColorLookup.Free;
      if (Ditherer <> nil) then
        Ditherer.Free;
      if (DIBResult <> nil) then
        DIBResult.Free;
    end;
  except
    Result.Free;
    raise;
  end;
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

function TGIFSubImage.DoGetBitmap: TBitmap;
var
  ScanLineRow		: Integer;
  DIBResult		: TDIB;
  DestScanLine		,
  Src			: PChar;
  TransparentIndex	: byte;
  IsTransparent		: boolean;
  WasTransparent	: boolean;

  MaskBits		: PChar;
  MaskDest		: PChar;
  MaskRow		: PChar;
  MaskRowWidth		: integer;
  Col			: integer;
  MaskByte		: byte;
  Bit			: byte;
begin
  Result := TBitmap.Create;
  try

{$IFNDEF VER9x}
    if (Width*Height > BitmapAllocationThreshold) then
      SetPixelFormat(Result, pf1bit); // To reduce resource consumption of resize
{$ENDIF}

    if (Empty) then
    begin
      // Set bitmap width and height
      Result.Width := Width;
      Result.Height := Height;

      // Build and copy palette to bitmap
      Result.Palette := CopyPalette(Palette);

      exit;
    end;

    // Get DIB buffer for scanline operations
    DIBResult := TDIBWriter.Create(Result, pf8bit, Width, Height, Palette);
    try

      // Determine if this image is transparent
      IsTransparent := FNeedMask and Transparent;
      WasTransparent := False;
      FNeedMask := False;
      TransparentIndex := 0;
      if (FMask = 0) and (IsTransparent) then
      begin
        IsTransparent := True;
        TransparentIndex := GraphicControlExtension.TransparentColorIndex;
      end;
      // Allocate bit buffer for transparency mask
      if (IsTransparent) then
      begin
        MaskRowWidth := ((Width+15) DIV 16) * 2;
        GetMem(MaskBits, MaskRowWidth * Height);
        FillChar(MaskBits^, MaskRowWidth * Height, 0);
        IsTransparent := (MaskBits <> nil);
      end else
      begin
        MaskBits := nil;
        MaskRowWidth := 0;
      end;

      try
        ScanLineRow := 0;
        Src := FData;
        MaskRow := MaskBits;
        while (ScanLineRow < Height) do
        begin
          DestScanline := DIBResult.ScanLine[ScanLineRow];

          if ((ScanLineRow AND $1F) = 0) then
            Image.Progress(Self, psRunning, MulDiv(ScanLineRow, 100, Height),
              False, Rect(0,0,0,0), sProgressRendering);

          Move(Src^, DestScanline^, Width);
          Inc(ScanLineRow);

          if (IsTransparent) then
          begin
            Bit := $80;
            MaskDest := MaskRow;
            MaskByte := 0;
            for Col := 0 to Width-1 do
            begin
              // Set a bit in the mask if the pixel is transparent
              if (Src^ = char(TransparentIndex)) then
                MaskByte := MaskByte OR Bit;

              Bit := Bit SHR 1;
              if (Bit = $00) then
              begin
                // Store a mask byte for each 8 pixels
                Bit := $80;
                WasTransparent := WasTransparent or (MaskByte <> 0);
                MaskDest^ := char(MaskByte);
                inc(MaskDest);
                MaskByte := 0;
              end;
              Inc(Src);
            end;
            // Save the last mask byte in case the width isn't divisable by 8
            if (MaskByte <> 0) then
            begin
              WasTransparent := True;
              MaskDest^ := char(MaskByte);
            end;
            Inc(MaskRow, MaskRowWidth);
          end else
            Inc(Src, Width);
        end;

        // Transparent paint needs a mask bitmap
        if (IsTransparent) and (WasTransparent) then
          FMask := CreateBitmap(Width, Height, 1, 1, MaskBits);
      finally
        if (MaskBits <> nil) then
          FreeMem(MaskBits);
      end;
    finally
      // Free DIB buffer used for scanline operations
      DIBResult.Free;
    end;
  except
    Result.Free;
    raise;
  end;
end;

{$ifdef DEBUG_RENDERPERFORMANCE}
var
  ImageCount		: DWORD = 0;
  RenderTime		: DWORD = 0;
{$endif}
function TGIFSubImage.GetBitmap: TBitmap;
var
  n			: integer;
{$ifdef DEBUG_RENDERPERFORMANCE}
  RenderStartTime	: DWORD;
{$endif}
begin
{$ifdef DEBUG_RENDERPERFORMANCE}
  if (GetAsyncKeyState(VK_CONTROL) <> 0) then
  begin
    ShowMessage(format('Render %d images in %d mS, Rate %d mS/image (%d images/S)',
      [ImageCount, RenderTime,
       RenderTime DIV (ImageCount+1),
       MulDiv(ImageCount, 1000, RenderTime+1)]));
  end;
{$endif}
  Result := FBitmap;
  if (Result <> nil) or (Empty) then
    Exit;

{$ifdef DEBUG_RENDERPERFORMANCE}
  inc(ImageCount);
  RenderStartTime := timeGetTime;
{$endif}
  try
    Image.Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressRendering);
    try

      if (Image.DoDither) then
        // Create dithered bitmap
        FBitmap := DoGetDitherBitmap
      else
        // Create &quot;regular&quot; bitmap
        FBitmap := DoGetBitmap;

      Result := FBitmap;

    finally
      if ExceptObject = nil then
        n := 100
      else
        n := 0;
      Image.Progress(Self, psEnding, n, Image.PaletteModified, Rect(0,0,0,0),
        sProgressRendering);
      // Make sure new palette gets realized, in case OnProgress event didn't.
      if Image.PaletteModified then
        Image.Changed(Self);
    end;
  except
    on EAbort do ;   // OnProgress can raise EAbort to cancel image load
  end;
{$ifdef DEBUG_RENDERPERFORMANCE}
  inc(RenderTime, timeGetTime-RenderStartTime);
{$endif}
end;

procedure TGIFSubImage.SetBitmap(Value: TBitmap);
begin
  FreeBitmap;
  if (Value <> nil) then
    Assign(Value);
end;

function TGIFSubImage.GetActiveColorMap: TGIFColorMap;
begin
  if (ColorMap.Count > 0) or (Image.GlobalColorMap.Count = 0) then
    Result := ColorMap
  else
    Result := Image.GlobalColorMap;
end;

function TGIFSubImage.GetInterlaced: boolean;
begin
  Result := (FImageDescriptor.PackedFields AND idInterlaced) <> 0;
end;

procedure TGIFSubImage.SetInterlaced(Value: boolean);
begin
  if (Value) then
    FImageDescriptor.PackedFields := FImageDescriptor.PackedFields OR idInterlaced
  else
    FImageDescriptor.PackedFields := FImageDescriptor.PackedFields AND NOT(idInterlaced);
end;

function TGIFSubImage.GetVersion: TGIFVersion;
var
  v			: TGIFVersion;
  i			: integer;
begin
  if (ColorMap.Optimized) then
    Result := gv89a
  else
    Result := inherited GetVersion;
  i := 0;
  while (Result < high(TGIFVersion)) and (i < FExtensions.Count) do
  begin
    v := FExtensions[i].Version;
    if (v > Result) then
      Result := v;
  end;
end;

function TGIFSubImage.GetColorResolution: integer;
begin
  Result := ColorMap.BitsPerPixel-1;
end;

function TGIFSubImage.GetBitsPerPixel: integer;
begin
  Result := ColorMap.BitsPerPixel;
end;

function TGIFSubImage.GetBoundsRect: TRect;
begin
  Result := Rect(FImageDescriptor.Left,
    FImageDescriptor.Top,
    FImageDescriptor.Left+FImageDescriptor.Width,
    FImageDescriptor.Top+FImageDescriptor.Height);
end;

procedure TGIFSubImage.DoSetBounds(ALeft, ATop, AWidth, AHeight: integer);
var
  TooLarge		: boolean;
  Zap			: boolean;
begin
  Zap := (FImageDescriptor.Width <> Width) or (FImageDescriptor.Height <> AHeight);
  FImageDescriptor.Left := ALeft;
  FImageDescriptor.Top := ATop;
  FImageDescriptor.Width := AWidth;
  FImageDescriptor.Height := AHeight;

  // Delete existing image and bitmaps if size has changed
  if (Zap) then
  begin
    FreeBitmap;
    FreeMask;
    FreeImage;
    // ...and allocate a new image
    NewImage;
  end;

  TooLarge := False;
  // Set width &amp; height if added image is larger than existing images
{$IFDEF STRICT_MOZILLA}
  // From Mozilla source:
  // Work around broken GIF files where the logical screen
  // size has weird width or height. [...]
  if (Image.Width < AWidth) or (Image.Height < AHeight) then
  begin
    TooLarge := True;
    Image.Width := AWidth;
    Image.Height := AHeight;
    Left := 0;
    Top := 0;
  end;
{$ELSE}
  if (Image.Width < ALeft+AWidth) then
  begin
    if (Image.Width > 0) then
    begin
      TooLarge := True;
      Warning(gsWarning, sBadWidth)
    end;
    Image.Width := ALeft+AWidth;
  end;
  if (Image.Height < ATop+AHeight) then
  begin
    if (Image.Height > 0) then
    begin
      TooLarge := True;
      Warning(gsWarning, sBadHeight)
    end;
    Image.Height := ATop+AHeight;
  end;
{$ENDIF}

  if (TooLarge) then
    Warning(gsWarning, sScreenSizeExceeded);
end;

procedure TGIFSubImage.SetBoundsRect(const Value: TRect);
begin
  DoSetBounds(Value.Left, Value.Top, Value.Right-Value.Left+1, Value.Bottom-Value.Top+1);
end;

function TGIFSubImage.GetClientRect: TRect;
begin
  Result := Rect(0, 0, FImageDescriptor.Width, FImageDescriptor.Height);
end;

function TGIFSubImage.GetPixel(x, y: integer): BYTE;
begin
  if (x < 0) or (x > Width-1) then
    Error(sBadPixelCoordinates);
  Result := BYTE(PChar(longInt(Scanline[y]) + x)^);
end;

function TGIFSubImage.GetScanline(y: integer): pointer;
begin
  if (y < 0) or (y > Height-1) then
    Error(sBadPixelCoordinates);
  NeedImage;
  Result := pointer(longInt(FData) + y * Width);
end;

procedure TGIFSubImage.Prepare;
var
  Pack			: BYTE;
begin
  Pack := FImageDescriptor.PackedFields;
  if (ColorMap.Count > 0) then
  begin
    Pack := idLocalColorTable;
    if (ColorMap.Optimized) then
      Pack := Pack OR idSort;
    Pack := (Pack AND NOT(idColorTableSize)) OR (ColorResolution AND idColorTableSize);
  end else
    Pack := Pack AND NOT(idLocalColorTable OR idSort OR idColorTableSize);
  FImageDescriptor.PackedFields := Pack;
end;

procedure TGIFSubImage.SaveToStream(Stream: TStream);
begin
  FExtensions.SaveToStream(Stream);
  if (Empty) then
    exit;
  Prepare;
  Stream.Write(FImageDescriptor, sizeof(TImageDescriptor));
  ColorMap.SaveToStream(Stream);
  Compress(Stream);
end;

procedure TGIFSubImage.LoadFromStream(Stream: TStream);
var
  ColorCount		: integer;
  b			: BYTE;
begin
  Clear;
  FExtensions.LoadFromStream(Stream, self);
  // Check for extension without image
  if (Stream.Read(b, 1) <> 1) then
    exit;
  Stream.Seek(-1, soFromCurrent);
  if (b = bsTrailer) or (b = 0) then
    exit;

  ReadCheck(Stream, FImageDescriptor, sizeof(TImageDescriptor));

  // From Mozilla source:
  // Work around more broken GIF files that have zero image
  // width or height
  if (FImageDescriptor.Height = 0) or (FImageDescriptor.Width = 0) then
  begin
    FImageDescriptor.Height := Image.Height;
    FImageDescriptor.Width := Image.Width;
    Warning(gsWarning, sScreenSizeExceeded);
  end;

  if (FImageDescriptor.PackedFields AND idLocalColorTable = idLocalColorTable) then
  begin
    ColorCount := 2 SHL (FImageDescriptor.PackedFields AND idColorTableSize);
    if (ColorCount < 2) or (ColorCount > 256) then
      Error(sImageBadColorSize);
    ColorMap.LoadFromStream(Stream, ColorCount);
  end;

  Decompress(Stream);

  // On-load rendering
  if (GIFImageRenderOnLoad) then
    // Touch bitmap to force frame to be rendered
    Bitmap;
end;

procedure TGIFSubImage.AssignTo(Dest: TPersistent);
begin
  if (Dest is TBitmap) then
    Dest.Assign(Bitmap)
  else
    inherited AssignTo(Dest);
end;

procedure TGIFSubImage.Assign(Source: TPersistent);
var
  MemoryStream		: TMemoryStream;
  i			: integer;
  PixelFormat		: TPixelFormat;
  DIBSource		: TDIB;
  ABitmap		: TBitmap;

  procedure Import8Bit(Dest: PChar);
  var
    y			: integer;
  begin
    // Copy colormap
{$ifdef VER10_PLUS}
    if (FBitmap.HandleType = bmDIB) then
      FColorMap.ImportDIBColors(FBitmap.Canvas.Handle)
    else
{$ENDIF}
      FColorMap.ImportPalette(FBitmap.Palette);
    // Copy pixels
    for y := 0 to Height-1 do
    begin
      if ((y AND $1F) = 0) then
        Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
      Move(DIBSource.Scanline[y]^, Dest^, Width);
      inc(Dest, Width);
    end;
  end;

  procedure Import4Bit(Dest: PChar);
  var
    x, y		: integer;
    Scanline		: PChar;
  begin
    // Copy colormap
    FColorMap.ImportPalette(FBitmap.Palette);
    // Copy pixels
    for y := 0 to Height-1 do
    begin
      if ((y AND $1F) = 0) then
        Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
      ScanLine := DIBSource.Scanline[y];
      for x := 0 to Width-1 do
      begin
        if (x AND $01 = 0) then
          Dest^ := chr(ord(ScanLine^) SHR 4)
        else
        begin
          Dest^ := chr(ord(ScanLine^) AND $0F);
          inc(ScanLine);
        end;
        inc(Dest);
      end;
    end;
  end;

  procedure Import1Bit(Dest: PChar);
  var
    x, y		: integer;
    Scanline		: PChar;
    Bit			: integer;
    Byte		: integer;
  begin
    // Copy colormap
    FColorMap.ImportPalette(FBitmap.Palette);
    // Copy pixels
    for y := 0 to Height-1 do
    begin
      if ((y AND $1F) = 0) then
        Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
      ScanLine := DIBSource.Scanline[y];
      x := Width;
      Bit := 0;
      Byte := 0; // To avoid compiler warning
      while (x > 0) do
      begin
        if (Bit = 0) then
        begin
          Bit := 8;
          Byte := ord(ScanLine^);
          inc(Scanline);
        end;
        Dest^ := chr((Byte AND $80) SHR 7);
        Byte := Byte SHL 1;
        inc(Dest);
        dec(Bit);
        dec(x);
      end;
    end;
  end;

  procedure Import24Bit(Dest: PChar);
  type
    TCacheEntry = record
      Color		: TColor;
      Index		: integer;
    end;
  const
    // Size of palette cache. Must be 2^n.
    // The cache holds the palette index of the last &quot;CacheSize&quot; colors
    // processed. Hopefully the cache can speed things up a bit... Initial
    // testing shows that this is indeed the case at least for non-dithered
    // bitmaps.
    // All the same, a small hash table would probably be much better.
    CacheSize		= 8;
  var
    i			: integer;
    Cache		: array[0..CacheSize-1] of TCacheEntry;
    LastEntry		: integer;
    Scanline		: PRGBTriple;
    Pixel		: TColor;
    RGBTriple		: TRGBTriple absolute Pixel;
    x, y		: integer;
    ColorMap		: PColorMap;
    t			: byte;
  label
    NextPixel;
  begin
    for i := 0 to CacheSize-1 do
      Cache[i].Index := -1;
    LastEntry := 0;

    // Copy all pixels and build colormap
    for y := 0 to Height-1 do
    begin
      if ((y AND $1F) = 0) then
        Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
      ScanLine := DIBSource.Scanline[y];
      for x := 0 to Width-1 do
      begin
        Pixel := 0;
        RGBTriple := Scanline^;
        // Scan cache for color from most recently processed color to last
        // recently processed. This is done because TColorMap.AddUnique is very slow.
        i := LastEntry;
        repeat
          if (Cache[i].Index = -1) then
            break;
          if (Cache[i].Color = Pixel) then
          begin
            Dest^ := chr(Cache[i].Index);
            LastEntry := i;
            goto NextPixel;
          end;
          if (i = 0) then
            i := CacheSize-1
          else
            dec(i);
        until (i = LastEntry);
        // Color not found in cache, do it the slow way instead
        Dest^ := chr(FColorMap.AddUnique(Pixel));
        // Add color and index to cache
        LastEntry := (LastEntry + 1) AND (CacheSize-1);
        Cache[LastEntry].Color := Pixel;
        Cache[LastEntry].Index := ord(Dest^);

        NextPixel:
        Inc(Dest);
        Inc(Scanline);
      end;
    end;
    // Convert colors in colormap from BGR to RGB
    ColorMap := FColorMap.Data;
    i := FColorMap.Count;
    while (i > 0) do
    begin
      t := ColorMap^[0].Red;
      ColorMap^[0].Red := ColorMap^[0].Blue;
      ColorMap^[0].Blue := t;
      inc(integer(ColorMap), sizeof(TGIFColor));
      dec(i);
    end;
  end;

  procedure ImportViaDraw(ABitmap: TBitmap; Graphic: TGraphic);
  begin
    ABitmap.Height := Graphic.Height;
    ABitmap.Width := Graphic.Width;

    // Note: Disable the call to SafeSetPixelFormat below to import
    // in max number of colors with the risk of having to use
    // TCanvas.Pixels to do it (very slow).

    // Make things a little easier for TGIFSubImage.Assign by converting
    // pfDevice to a more import friendly format
{$ifdef SLOW_BUT_SAFE}
    SafeSetPixelFormat(ABitmap, pf8bit);
{$else}
{$ifndef VER9x}
    SetPixelFormat(ABitmap, pf24bit);
{$endif}
{$endif}
    ABitmap.Canvas.Draw(0, 0, Graphic);
  end;

  procedure AddMask(Mask: TBitmap);
  var
    DIBReader		: TDIBReader;
    TransparentIndex	: integer;
    i			,
    j			: integer;
    GIFPixel		,
    MaskPixel		: PChar;
    WasTransparent	: boolean;
    GCE			: TGIFGraphicControlExtension;
  begin
    // Optimize colormap to make room for transparent color
    ColorMap.Optimize;
    // Can't make transparent if no color or colormap full
    if (ColorMap.Count = 0) or (ColorMap.Count = 256) then
      exit;

    // Add the transparent color to the color map
    TransparentIndex := ColorMap.Add(TColor(0));
    WasTransparent := False;

    DIBReader := TDIBReader.Create(Mask, pf8bit);
    try
      for i := 0 to Height-1 do
      begin
        MaskPixel := DIBReader.Scanline[i];
        GIFPixel := Scanline[i];
        for j := 0 to Width-1 do
        begin
          // Change all unmasked pixels to transparent
          if (MaskPixel^ <> #0) then
          begin
            GIFPixel^ := chr(TransparentIndex);
            WasTransparent := True;
          end;
          inc(MaskPixel);
          inc(GIFPixel);
        end;
      end;
    finally
      DIBReader.Free;
    end;

    // Add a Graphic Control Extension if any part of the mask was transparent
    if (WasTransparent) then
    begin
      GCE := TGIFGraphicControlExtension.Create(self);
      GCE.Transparent := True;
      GCE.TransparentColorIndex := TransparentIndex;
      Extensions.Add(GCE);
    end else
      // Otherwise removed the transparency color since it wasn't used
      ColorMap.Delete(TransparentIndex);
  end;

  procedure AddMaskOnly(hMask: hBitmap);
  var
    Mask		: TBitmap;
  begin
    if (hMask = 0) then
      exit;

    // Encapsulate the mask
    Mask := TBitmap.Create;
    try
      Mask.Handle := hMask;
      AddMask(Mask);
    finally
      Mask.ReleaseHandle;
      Mask.Free;
    end;
  end;

  procedure AddIconMask(Icon: TIcon);
  var
    IconInfo		: TIconInfo;
  begin
    if (not GetIconInfo(Icon.Handle, IconInfo)) then
      exit;

    // Extract the icon mask
    AddMaskOnly(IconInfo.hbmMask);
  end;

  procedure AddMetafileMask(Metafile: TMetaFile);
  var
    Mask1		,
    Mask2		: TBitmap;

    procedure DrawMetafile(ABitmap: TBitmap; Background: TColor);
    begin
      ABitmap.Width := Metafile.Width;
      ABitmap.Height := Metafile.Height;
{$ifndef VER9x}
      SetPixelFormat(ABitmap, pf24bit);
{$endif}
      ABitmap.Canvas.Brush.Color := Background;
      ABitmap.Canvas.Brush.Style := bsSolid;
      ABitmap.Canvas.FillRect(ABitmap.Canvas.ClipRect);
      ABitmap.Canvas.Draw(0,0, Metafile);
    end;

  begin
    // Create the metafile mask
    Mask1 := TBitmap.Create;
    try
      Mask2 := TBitmap.Create;
      try
        DrawMetafile(Mask1, clWhite);
        DrawMetafile(Mask2, clBlack);
        Mask1.Canvas.CopyMode := cmSrcInvert;
        Mask1.Canvas.Draw(0,0, Mask2);
        AddMask(Mask1);
      finally
        Mask2.Free;
      end;
    finally
      Mask1.Free;
    end;
  end;

begin
  if (Source = self) then
    exit;
  if (Source = nil) then
  begin
    Clear;
  end else
  //
  // TGIFSubImage import
  //
  if (Source is TGIFSubImage) then
  begin
    // Zap existing colormap, extensions and bitmap
    Clear;
    if (TGIFSubImage(Source).Empty) then
      exit;
    // Copy source data
    FImageDescriptor := TGIFSubImage(Source).FImageDescriptor;
    FTransparent := TGIFSubImage(Source).Transparent;
    // Copy image data
    NewImage;
    if (FData <> nil) and (TGIFSubImage(Source).Data <> nil) then
      Move(TGIFSubImage(Source).Data^, FData^, FDataSize);
    // Copy palette
    FColorMap.Assign(TGIFSubImage(Source).ColorMap);
    // Copy extensions
    if (TGIFSubImage(Source).Extensions.Count > 0) then
    begin
      MemoryStream := TMemoryStream.Create;
      try
        TGIFSubImage(Source).Extensions.SaveToStream(MemoryStream);
        MemoryStream.Seek(0, soFromBeginning);
        Extensions.LoadFromStream(MemoryStream, Self);
      finally
        MemoryStream.Free;
      end;
    end;

    // Copy bitmap representation
    // (Not really nescessary but improves performance if the bitmap is needed
    // later on)
    if (TGIFSubImage(Source).HasBitmap) then
    begin
      NewBitmap;
      FBitmap.Assign(TGIFSubImage(Source).Bitmap);
    end;
  end else
  //
  // Bitmap import
  //
  if (Source is TBitmap) then
  begin
    // Zap existing colormap, extensions and bitmap
    Clear;
    if (TBitmap(Source).Empty) then
      exit;

    Width := TBitmap(Source).Width;
    Height := TBitmap(Source).Height;

    PixelFormat := GetPixelFormat(TBitmap(Source));
{$ifdef VER9x}
    // Delphi 2 TBitmaps are always DDBs. This means that if a 24 bit
    // bitmap is loaded in 8 bit device mode, TBitmap.PixelFormat will
    // be pf8bit, but TBitmap.Palette will be 0!
    if (TBitmap(Source).Palette = 0) then
      PixelFormat := pfDevice;
{$endif}
    if (PixelFormat > pf8bit) or (PixelFormat = pfDevice) then
    begin
      // Convert image to 8 bits/pixel or less
      FBitmap := ReduceColors(TBitmap(Source), Image.ColorReduction,
        Image.DitherMode, Image.ReductionBits, 0);
      PixelFormat := GetPixelFormat(FBitmap);
    end else
    begin
      // Create new bitmap and copy
      NewBitmap;
      FBitmap.Assign(TBitmap(Source));
    end;

    // Allocate new buffer
    NewImage;

    Image.Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressConverting);
    try
{$ifdef VER9x}
      // This shouldn't happen, but better safe...
      if (FBitmap.Palette = 0) then
        PixelFormat := pf24bit;
{$endif}
      if (not(PixelFormat in [pf1bit, pf4bit, pf8bit, pf24bit])) then
        PixelFormat := pf24bit;
      DIBSource := TDIBReader.Create(FBitmap, PixelFormat);
      try
        // Copy pixels
        case (PixelFormat) of
          pf8bit: Import8Bit(Fdata);
          pf4bit: Import4Bit(Fdata);
          pf1bit: Import1Bit(Fdata);
        else
//        Error(sUnsupportedBitmap);
          Import24Bit(Fdata);
        end;

      finally
        DIBSource.Free;
      end;

{$ifdef VER10_PLUS}
      // Add mask for transparent bitmaps
      if (TBitmap(Source).Transparent) then
        AddMaskOnly(TBitmap(Source).MaskHandle);
{$endif}

    finally
      if ExceptObject = nil then
        i := 100
      else
        i := 0;
      Image.Progress(Self, psEnding, i, Image.PaletteModified, Rect(0,0,0,0), sProgressConverting);
    end;
  end else
  //
  // TGraphic import
  //
  if (Source is TGraphic) then
  begin
    // Zap existing colormap, extensions and bitmap
    Clear;
    if (TGraphic(Source).Empty) then
      exit;

    ABitmap := TBitmap.Create;
    try
      // Import TIcon and TMetafile by drawing them onto a bitmap...
      // ...and then importing the bitmap recursively
      if (Source is TIcon) or (Source is TMetafile) then
      begin
        try
          ImportViaDraw(ABitmap, TGraphic(Source))
        except
          // If import via TCanvas.Draw fails (which it shouldn't), we try the
          // Assign mechanism instead
          ABitmap.Assign(Source);
        end;
      end else
        try
          ABitmap.Assign(Source);
        except
          // If automatic conversion to bitmap fails, we try and draw the
          // graphic on the bitmap instead
          ImportViaDraw(ABitmap, TGraphic(Source));
        end;
      // Convert the bitmap to a GIF frame recursively
      Assign(ABitmap);
    finally
      ABitmap.Free;
    end;

    // Import transparency mask
    if (Source is TIcon) then
      AddIconMask(TIcon(Source));
    if (Source is TMetaFile) then
      AddMetafileMask(TMetaFile(Source));

  end else
  //
  // TPicture import
  //
  if (Source is TPicture) then
  begin
    // Recursively import TGraphic
    Assign(TPicture(Source).Graphic);
  end else
    // Unsupported format - fall back to Source.AssignTo
    inherited Assign(Source);
end;

// Copied from D3 graphics.pas
// Fixed by Brian Lowe of Acro Technology Inc. 30Jan98
function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
  MaskY: Integer): Boolean;
const
  ROP_DstCopy		= $00AA0029;
var
  MemDC			,
  OrMaskDC		: HDC;
  MemBmp		,
  OrMaskBmp		: HBITMAP;
  Save			,
  OrMaskSave		: THandle;
  crText, crBack	: TColorRef;
  SavePal		: HPALETTE;

begin
  Result := True;
  if (Win32Platform = VER_PLATFORM_WIN32_NT) and (SrcW = DstW) and (SrcH = DstH) then
  begin
    MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, 1, 1));
    MemBmp := SelectObject(MaskDC, MemBmp);
    try
      MaskBlt(DstDC, DstX, DstY, DstW, DstH, SrcDC, SrcX, SrcY, MemBmp, MaskX,
        MaskY, MakeRop4(ROP_DstCopy, SrcCopy));
    finally
      MemBmp := SelectObject(MaskDC, MemBmp);
      DeleteObject(MemBmp);
    end;
    Exit;
  end;

  SavePal := 0;
  MemDC := GDICheck(CreateCompatibleDC(DstDC));
  try
    { Color bitmap for combining OR mask with source bitmap }
    MemBmp := GDICheck(CreateCompatibleBitmap(DstDC, SrcW, SrcH));
    try
      Save := SelectObject(MemDC, MemBmp);
      try
        { This bitmap needs the size of the source but DC of the dest }
        OrMaskDC := GDICheck(CreateCompatibleDC(DstDC));
        try
          { Need a monochrome bitmap for OR mask!! }
          OrMaskBmp := GDICheck(CreateBitmap(SrcW, SrcH, 1, 1, nil));
          try
            OrMaskSave := SelectObject(OrMaskDC, OrMaskBmp);
            try

              // OrMask := 1
              // Original: BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, OrMaskDC, SrcX, SrcY, WHITENESS);
              // Replacement, but not needed: PatBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, WHITENESS);
              // OrMask := OrMask XOR Mask
              // Not needed: BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, MaskDC, SrcX, SrcY, SrcInvert);
              // OrMask := NOT Mask
              BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, MaskDC, SrcX, SrcY, NotSrcCopy);

              // Retrieve source palette (with dummy select)
              SavePal := SelectPalette(SrcDC, SystemPalette16, False);
              // Restore source palette
              SelectPalette(SrcDC, SavePal, False);
              // Select source palette into memory buffer
              if SavePal <> 0 then
                SavePal := SelectPalette(MemDC, SavePal, True)
              else
                SavePal := SelectPalette(MemDC, SystemPalette16, True);
              RealizePalette(MemDC);

              // Mem := OrMask
              BitBlt(MemDC, SrcX, SrcY, SrcW, SrcH, OrMaskDC, SrcX, SrcY, SrcCopy);
              // Mem := Mem AND Src
{$IFNDEF GIF_TESTMASK} // Define GIF_TESTMASK if you want to know what it does...
              BitBlt(MemDC, SrcX, SrcY, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcAnd);
{$ELSE}
              StretchBlt(DstDC, DstX, DstY, DstW DIV 2, DstH, MemDC, SrcX, SrcY, SrcW, SrcH, SrcCopy);
              StretchBlt(DstDC, DstX+DstW DIV 2, DstY, DstW DIV 2, DstH, SrcDC, SrcX, SrcY, SrcW, SrcH, SrcCopy);
              exit;
{$ENDIF}
            finally
              if (OrMaskSave <> 0) then
                SelectObject(OrMaskDC, OrMaskSave);
            end;
          finally
            DeleteObject(OrMaskBmp);
          end;
        finally
          DeleteDC(OrMaskDC);
        end;

        crText := SetTextColor(DstDC, $00000000);
        crBack := SetBkColor(DstDC, $00FFFFFF);

        { All color rendering is done at 1X (no stretching),
          then final 2 masks are stretched to dest DC }
        // Neat trick!
        // Dst := Dst AND Mask
        StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, SrcX, SrcY, SrcW, SrcH, SrcAnd);
        // Dst := Dst OR Mem
        StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, SrcX, SrcY, SrcW, SrcH, SrcPaint);

        SetTextColor(DstDC, crText);
        SetTextColor(DstDC, crBack);

      finally
        if (Save <> 0) then
          SelectObject(MemDC, Save);
      end;
    finally
      DeleteObject(MemBmp);
    end;
  finally
    if (SavePal <> 0) then
      SelectPalette(MemDC, SavePal, False);
    DeleteDC(MemDC);
  end;
end;

procedure TGIFSubImage.Draw(ACanvas: TCanvas; const Rect: TRect;
  DoTransparent, DoTile: boolean);
begin
  if (DoTile) then
    StretchDraw(ACanvas, Rect, DoTransparent, DoTile)
  else
    StretchDraw(ACanvas, ScaleRect(Rect), DoTransparent, DoTile);
end;

type
  // Dummy class used to gain access to protected method TCanvas.Changed
  TChangableCanvas = class(TCanvas)
  end;

procedure TGIFSubImage.StretchDraw(ACanvas: TCanvas; const Rect: TRect;
  DoTransparent, DoTile: boolean);
var
  MaskDC		: HDC;
  Save			: THandle;
  Tile			: TRect;
{$ifdef DEBUG_DRAWPERFORMANCE}
  ImageCount		,
  TimeStart		,
  TimeStop		: DWORD;
{$endif}

begin
{$ifdef DEBUG_DRAWPERFORMANCE}
  TimeStart := timeGetTime;
  ImageCount := 0;
{$endif}
  if (DoTransparent) and (Transparent) and (HasMask) then
  begin
    // Draw transparent using mask
    Save := 0;
    MaskDC := 0;
    try
      MaskDC := GDICheck(CreateCompatibleDC(0));
      Save := SelectObject(MaskDC, FMask);

      if (DoTile) then
      begin
        Tile.Left := Rect.Left+Left;
        Tile.Right := Tile.Left + Width;
        while (Tile.Left < Rect.Right) do
        begin
          Tile.Top := Rect.Top+Top;
          Tile.Bottom := Tile.Top + Height;
          while (Tile.Top < Rect.Bottom) do
          begin
            TransparentStretchBlt(ACanvas.Handle, Tile.Left, Tile.Top, Width, Height,
              Bitmap.Canvas.Handle, 0, 0, Width, Height, MaskDC, 0, 0);
            Tile.Top := Tile.Top + Image.Height;
            Tile.Bottom := Tile.Bottom + Image.Height;
{$ifdef DEBUG_DRAWPERFORMANCE}
            inc(ImageCount);
{$endif}
          end;
          Tile.Left := Tile.Left + Image.Width;
          Tile.Right := Tile.Right + Image.Width;
        end;
      end else
        TransparentStretchBlt(ACanvas.Handle, Rect.Left, Rect.Top,
          Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
          Bitmap.Canvas.Handle, 0, 0, Width, Height, MaskDC, 0, 0);

      // Since we are not using any of the TCanvas functions (only handle)
      // we need to fire the TCanvas.Changed method &quot;manually&quot;.
      TChangableCanvas(ACanvas).Changed;

    finally
      if (Save <> 0) then
        SelectObject(MaskDC, Save);
      if (MaskDC <> 0) then
        DeleteDC(MaskDC);
    end;
  end else
  begin
    if (DoTile) then
    begin
      Tile.Left := Rect.Left+Left;
      Tile.Right := Tile.Left + Width;
      while (Tile.Left < Rect.Right) do
      begin
        Tile.Top := Rect.Top+Top;
        Tile.Bottom := Tile.Top + Height;
        while (Tile.Top < Rect.Bottom) do
        begin
          ACanvas.StretchDraw(Tile, Bitmap);
          Tile.Top := Tile.Top + Image.Height;
          Tile.Bottom := Tile.Bottom + Image.Height;
{$ifdef DEBUG_DRAWPERFORMANCE}
          inc(ImageCount);
{$endif}
        end;
        Tile.Left := Tile.Left + Image.Width;
        Tile.Right := Tile.Right + Image.Width;
      end;
    end else
      ACanvas.StretchDraw(Rect, Bitmap);
  end;
{$ifdef DEBUG_DRAWPERFORMANCE}
  if (GetAsyncKeyState(VK_CONTROL) <> 0) then
  begin
    TimeStop := timeGetTime;
    ShowMessage(format('Draw %d images in %d mS, Rate %d images/mS (%d images/S)',
      [ImageCount, TimeStop-TimeStart,
      ImageCount DIV (TimeStop-TimeStart+1),
      MulDiv(ImageCount, 1000, TimeStop-TimeStart+1)]));
  end;
{$endif}
end;

// Given a destination rect (DestRect) calculates the
// area covered by this sub image
function TGIFSubImage.ScaleRect(DestRect: TRect): TRect;
var
  HeightMul		,
  HeightDiv		: integer;
  WidthMul		,
  WidthDiv		: integer;
begin
  HeightDiv := Image.Height;
  HeightMul := DestRect.Bottom-DestRect.Top;
  WidthDiv := Image.Width;
  WidthMul := DestRect.Right-DestRect.Left;

  Result.Left := DestRect.Left + muldiv(Left, WidthMul, WidthDiv);
  Result.Top := DestRect.Top + muldiv(Top, HeightMul, HeightDiv);
  Result.Right := DestRect.Left + muldiv(Left+Width, WidthMul, WidthDiv);
  Result.Bottom := DestRect.Top + muldiv(Top+Height, HeightMul, HeightDiv);
end;

procedure TGIFSubImage.Crop;
var
  TransparentColorIndex	: byte;
  CropLeft		,
  CropTop		,
  CropRight		,
  CropBottom		: integer;
  WasTransparent	: boolean;
  i			: integer;
  NewSize		: integer;
  NewData		: PChar;
  NewWidth		,
  NewHeight		: integer;
  pSource		,
  pDest			: PChar;
begin
  if (Empty) or (not Transparent) then
    exit;
  TransparentColorIndex := GraphicControlExtension.TransparentColorIndex;
  CropLeft := 0;
  CropRight := Width - 1;
  CropTop := 0;
  CropBottom := Height - 1;
  // Find left edge
  WasTransparent := True;
  while (CropLeft <= CropRight) and (WasTransparent) do
  begin
    for i := CropTop to CropBottom do
      if (Pixels[CropLeft, i] <> TransparentColorIndex) then
      begin
        WasTransparent := False;
        break;
      end;
    if (WasTransparent) then
      inc(CropLeft);
  end;
  // Find right edge
  WasTransparent := True;
  while (CropLeft <= CropRight) and (WasTransparent) do
  begin
    for i := CropTop to CropBottom do
      if (pixels[CropRight, i] <> TransparentColorIndex) then
      begin
        WasTransparent := False;
        break;
      end;
    if (WasTransparent) then
      dec(CropRight);
  end;
  if (CropLeft <= CropRight) then
  begin
    // Find top edge
    WasTransparent := True;
    while (CropTop <= CropBottom) and (WasTransparent) do
    begin
      for i := CropLeft to CropRight do
        if (pixels[i, CropTop] <> TransparentColorIndex) then
        begin
          WasTransparent := False;
          break;
        end;
      if (WasTransparent) then
        inc(CropTop);
    end;
    // Find bottom edge
    WasTransparent := True;
    while (CropTop <= CropBottom) and (WasTransparent) do
    begin
      for i := CropLeft to CropRight do
        if (pixels[i, CropBottom] <> TransparentColorIndex) then
        begin
          WasTransparent := False;
          break;
        end;
      if (WasTransparent) then
        dec(CropBottom);
    end;
  end;

  if (CropLeft > CropRight) or (CropTop > CropBottom) then
  begin
    // Cropped to nothing - frame is invisible
    Clear;
  end else
  begin
    // Crop frame - move data
    NewWidth := CropRight - CropLeft + 1;
    Newheight := CropBottom - CropTop + 1;
    NewSize := NewWidth * NewHeight;
    GetMem(NewData, NewSize);
    pSource := PChar(integer(FData) + CropTop * Width + CropLeft);
    pDest := NewData;
    for i := 0 to NewHeight-1 do
    begin
      Move(pSource^, pDest^, NewWidth);
      inc(pSource, Width);
      inc(pDest, NewWidth);
    end;
    FreeImage;
    FData := NewData;
    FDataSize := NewSize;
    inc(FImageDescriptor.Left, CropLeft);
    inc(FImageDescriptor.Top, CropTop);
    FImageDescriptor.Width := NewWidth;
    FImageDescriptor.Height := NewHeight;
    FreeBitmap;
    FreeMask
  end;
end;

procedure TGIFSubImage.Merge(Previous: TGIFSubImage);
var
  SourceIndex		,
  DestIndex		: byte;
  SourceTransparent	: boolean;
  NeedTransparentColorIndex: boolean;
  PreviousRect		,
  ThisRect		,
  MergeRect		: TRect;
  PreviousY		,
  X			,
  Y			: integer;
  pSource		,
  pDest			: PChar;
  pSourceMap		,
  pDestMap		: PColorMap;
  GCE			: TGIFGraphicControlExtension;

  function CanMakeTransparent: boolean;
  begin
    // Is there a local color map...
    if (ColorMap.Count > 0) then
      // ...and is there room in it?
      Result := (ColorMap.Count < 256)
    // Is there a global color map...
    else if (Image.GlobalColorMap.Count > 0) then
      // ...and is there room in it?
      Result := (Image.GlobalColorMap.Count < 256)
    else
      Result := False;
  end;

  function GetTransparentColorIndex: byte;
  var
    i			: integer;
  begin
    if (ColorMap.Count > 0) then
    begin
      // Get the transparent color from the local color map
      Result := ColorMap.Add(TColor(0));
    end else
    begin
      // Are any other frames using the global color map for transparency
      for i := 0 to Image.Images.Count-1 do
        if (Image.Images[i] <> self) and (Image.Images[i].Transparent) and
          (Image.Images[i].ColorMap.Count = 0) then
        begin
          // Use the same transparency color as the other frame
          Result := Image.Images[i].GraphicControlExtension.TransparentColorIndex;
          exit;
        end;
      // Get the transparent color from the global color map
      Result := Image.GlobalColorMap.Add(TColor(0));
    end;
  end;

begin
  // Determine if it is possible to merge this frame
  if (Empty) or (Previous = nil) or (Previous.Empty) or
    ((Previous.GraphicControlExtension <> nil) and
     (Previous.GraphicControlExtension.Disposal in [dmBackground, dmPrevious])) then
    exit;

  PreviousRect := Previous.BoundsRect;
  ThisRect := BoundsRect;

  // Cannot merge unless the frames intersect
  if (not IntersectRect(MergeRect, PreviousRect, ThisRect)) then
    exit;

  // If the frame isn't already transparent, determine
  // if it is possible to make it so
  if (Transparent) then
  begin
    DestIndex := GraphicControlExtension.TransparentColorIndex;
    NeedTransparentColorIndex := False;
  end else
  begin
    if (not CanMakeTransparent) then
      exit;
    DestIndex := 0; // To avoid compiler warning
    NeedTransparentColorIndex := True;
  end;

  SourceTransparent := Previous.Transparent;
  if (SourceTransparent) then
    SourceIndex := Previous.GraphicControlExtension.TransparentColorIndex
  else
    SourceIndex := 0; // To avoid compiler warning

  PreviousY := MergeRect.Top - Previous.Top;

  pSourceMap := Previous.ActiveColorMap.Data;
  pDestMap := ActiveColorMap.Data;

  for Y := MergeRect.Top - Top to MergeRect.Bottom - Top-1 do
  begin
    pSource := PChar(integer(Previous.Scanline[PreviousY]) + MergeRect.Left - Previous.Left);
    pDest := PChar(integer(Scanline[Y]) + MergeRect.Left - Left);

    for X := MergeRect.Left to MergeRect.Right-1 do
    begin
      // Ignore pixels if either this frame's or the previous frame's pixel is transparent
      if (
            not(
              ((not NeedTransparentColorIndex) and (pDest^ = char(DestIndex))) or
              ((SourceTransparent) and (pSource^ = char(SourceIndex)))
            )
          ) and (
            // Replace same colored pixels with transparency
            ((pDestMap = pSourceMap) and (pDest^ = pSource^)) or
            (CompareMem(@(pDestMap^[ord(pDest^)]), @(pSourceMap^[ord(pSource^)]), sizeof(TGIFColor)))
          ) then
      begin
        if (NeedTransparentColorIndex) then
        begin
          NeedTransparentColorIndex := False;
          DestIndex := GetTransparentColorIndex;
        end;
        pDest^ := char(DestIndex);
      end;
      inc(pDest);
      inc(pSource);
    end;
    inc(PreviousY);
  end;

  (*
  ** Create a GCE if the frame wasn't already transparent and any
  ** pixels were made transparent
  *)
  if (not Transparent) and (not NeedTransparentColorIndex) then
  begin
    if (GraphicControlExtension = nil) then
    begin
      GCE := TGIFGraphicControlExtension.Create(self);
      Extensions.Add(GCE);
    end else
      GCE := GraphicControlExtension;
    GCE.Transparent := True;
    GCE.TransparentColorIndex := DestIndex;
  end;

  FreeBitmap;
  FreeMask
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFTrailer
//
////////////////////////////////////////////////////////////////////////////////
procedure TGIFTrailer.SaveToStream(Stream: TStream);
begin
  WriteByte(Stream, bsTrailer);
end;

procedure TGIFTrailer.LoadFromStream(Stream: TStream);
var
  b			: BYTE;
begin
  if (Stream.Read(b, 1) <> 1) then
    exit;
  if (b <> bsTrailer) then
    Warning(gsWarning, sBadTrailer);
end;

////////////////////////////////////////////////////////////////////////////////
//
//		TGIFExtension registration database
//
////////////////////////////////////////////////////////////////////////////////
type
  TExtensionLeadIn = packed record
    Introducer: byte;      { always $21 }
    ExtensionLabel: byte;
  end;

  PExtRec = ^TExtRec;
  TExtRec = record
    ExtClass: TGIFExtensionClass;
    ExtLabel: BYTE;
  end;

  TExtensionList = class(TList)
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(eLabel: BYTE; eClass: TGIFExtensionClass);
    function FindExt(eLabel: BYTE): TGIFExtensionClass;
    procedure Remove(eClass: TGIFExtensionClass);
  end;

constructor TExtensionList.Create;
begin
  inherited Create;
  Add(bsPlainTextExtension, TGIFTextExtension);
  Add(bsGraphicControlExtension, TGIFGraphicControlExtension);
  Add(bsCommentExtension, TGIFCommentExtension);
  Add(bsApplicationExtension, TGIFApplicationExtension);
end;

destructor TExtensionList.Destroy;
var
  I: Integer;
begin
  for I := 0 to Count-1 do
    Dispose(PExtRec(Items[I]));
  inherited Destroy;
end;

procedure TExtensionList.Add(eLabel: BYTE; eClass: TGIFExtensionClass);
var
  NewRec: PExtRec;
begin
  New(NewRec);
  with NewRec^ do
  begin
    ExtLabel := eLabel;
    ExtClass := eClass;
  end;
  inherited Add(NewRec);
end;

function TExtensionList.FindExt(eLabel: BYTE): TGIFExtensionClass;
var
  I: Integer;
begin
  for I := Count-1 downto 0 do
    with PExtRec(Items[I])^ do
      if ExtLabel = eLabel then
      begin
        Result := ExtClass;
        Exit;
      end;
  Result := nil;
end;

procedure TExtensionList.Remove(eClass: TGIFExtensionClass);
var
  I: Integer;
  P: PExtRec;
begin
  for I := Count-1 downto 0 do
  begin
    P := PExtRec(Items[I]);
    if P^.ExtClass.InheritsFrom(eClass) then
    begin
      Dispose(P);
      Delete(I);
    end;
  end;
end;

var
  ExtensionList: TExtensionList = nil;

function GetExtensionList: TExtensionList;
begin
  if (ExtensionList = nil) then
    ExtensionList := TExtensionList.Create;
  Result := ExtensionList;
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFExtension
//
////////////////////////////////////////////////////////////////////////////////
function TGIFExtension.GetVersion: TGIFVersion;
begin
  Result := gv89a;
end;

class procedure TGIFExtension.RegisterExtension(eLabel: BYTE; eClass: TGIFExtensionClass);
begin
  GetExtensionList.Add(eLabel, eClass);
end;

class function TGIFExtension.FindExtension(Stream: TStream): TGIFExtensionClass;
var
  eLabel		: BYTE;
  SubClass		: TGIFExtensionClass;
  Pos			: LongInt;
begin
  Pos := Stream.Position;
  if (Stream.Read(eLabel, 1) <> 1) then
  begin
    Result := nil;
    exit;
  end;
  Result := GetExtensionList.FindExt(eLabel);
  while (Result <> nil) do
  begin
    SubClass := Result.FindSubExtension(Stream);
    if (SubClass = Result) then
      break;
    Result := SubClass;
  end;
  Stream.Position := Pos;
end;

class function TGIFExtension.FindSubExtension(Stream: TStream): TGIFExtensionClass;
begin
  Result := self;
end;

constructor TGIFExtension.Create(ASubImage: TGIFSubImage);
begin
  inherited Create(ASubImage.Image);
  FSubImage := ASubImage;
end;

destructor TGIFExtension.Destroy;
begin
  if (FSubImage <> nil) then
    FSubImage.Extensions.Remove(self);
  inherited Destroy;
end;

procedure TGIFExtension.SaveToStream(Stream: TStream);
var
  ExtensionLeadIn	: TExtensionLeadIn;
begin
  ExtensionLeadIn.Introducer := bsExtensionIntroducer;
  ExtensionLeadIn.ExtensionLabel := ExtensionType;
  Stream.Write(ExtensionLeadIn, sizeof(ExtensionLeadIn));
end;

function TGIFExtension.DoReadFromStream(Stream: TStream): TGIFExtensionType;
var
  ExtensionLeadIn	: TExtensionLeadIn;
begin
  ReadCheck(Stream, ExtensionLeadIn, sizeof(ExtensionLeadIn));
  if (ExtensionLeadIn.Introducer <> bsExtensionIntroducer) then
    Error(sBadExtensionLabel);
  Result := ExtensionLeadIn.ExtensionLabel;
end;

procedure TGIFExtension.LoadFromStream(Stream: TStream);
begin
  // Seek past lead-in
  // Stream.Seek(sizeof(TExtensionLeadIn), soFromCurrent);
  if (DoReadFromStream(Stream) <> ExtensionType) then
    Error(sBadExtensionInstance);
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFGraphicControlExtension
//
////////////////////////////////////////////////////////////////////////////////
const
  { Extension flag bit masks }
  efInputFlag		= $02;		{ 00000010 }
  efDisposal		= $1C;		{ 00011100 }
  efTransparent		= $01;		{ 00000001 }
  efReserved		= $E0;		{ 11100000 }

constructor TGIFGraphicControlExtension.Create(ASubImage: TGIFSubImage);
begin
  inherited Create(ASubImage);

  FGCExtension.BlockSize := 4;
  FGCExtension.PackedFields := $00;
  FGCExtension.DelayTime := 0;
  FGCExtension.TransparentColorIndex := 0;
  FGCExtension.Terminator := 0;
  if (ASubImage.FGCE = nil) then
    ASubImage.FGCE := self;
end;

destructor TGIFGraphicControlExtension.Destroy;
begin
  // Clear transparent flag in sub image
  if (Transparent) then
    SubImage.FTransparent := False;

  if (SubImage.FGCE = self) then
    SubImage.FGCE := nil;

  inherited Destroy;
end;

function TGIFGraphicControlExtension.GetExtensionType: TGIFExtensionType;
begin
  Result := bsGraphicControlExtension;
end;

function TGIFGraphicControlExtension.GetTransparent: boolean;
begin
  Result := (FGCExtension.PackedFields AND efTransparent) <> 0;
end;

procedure TGIFGraphicControlExtension.SetTransparent(Value: boolean);
begin
  // Set transparent flag in sub image
  SubImage.FTransparent := Value;
  if (Value) then
    FGCExtension.PackedFields := FGCExtension.PackedFields OR efTransparent
  else
    FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efTransparent);
end;

function TGIFGraphicControlExtension.GetTransparentColor: TColor;
begin
  Result := SubImage.ActiveColorMap[TransparentColorIndex];
end;

procedure TGIFGraphicControlExtension.SetTransparentColor(Color: TColor);
begin
  FGCExtension.TransparentColorIndex := Subimage.ActiveColorMap.AddUnique(Color);
end;

function TGIFGraphicControlExtension.GetTransparentColorIndex: BYTE;
begin
  Result := FGCExtension.TransparentColorIndex;
end;

procedure TGIFGraphicControlExtension.SetTransparentColorIndex(Value: BYTE);
begin
  if ((Value >= SubImage.ActiveColorMap.Count) and (SubImage.ActiveColorMap.Count > 0)) then
  begin
    Warning(gsWarning, sBadColorIndex);
    Value := 0;
  end;
  FGCExtension.TransparentColorIndex := Value;
end;

function TGIFGraphicControlExtension.GetDelay: WORD;
begin
  Result := FGCExtension.DelayTime;
end;
procedure TGIFGraphicControlExtension.SetDelay(Value: WORD);
begin
  FGCExtension.DelayTime := Value;
end;

function TGIFGraphicControlExtension.GetUserInput: boolean;
begin
  Result := (FGCExtension.PackedFields AND efInputFlag) <> 0;
end;

procedure TGIFGraphicControlExtension.SetUserInput(Value: boolean);
begin
  if (Value) then
    FGCExtension.PackedFields := FGCExtension.PackedFields OR efInputFlag
  else
    FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efInputFlag);
end;

function TGIFGraphicControlExtension.GetDisposal: TDisposalMethod;
begin
  Result := TDisposalMethod((FGCExtension.PackedFields AND efDisposal) SHR 2);
end;

procedure TGIFGraphicControlExtension.SetDisposal(Value: TDisposalMethod);
begin
  FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efDisposal)
    OR ((ord(Value) SHL 2) AND efDisposal);
end;

procedure TGIFGraphicControlExtension.SaveToStream(Stream: TStream);
begin
  inherited SaveToStream(Stream);
  Stream.Write(FGCExtension, sizeof(FGCExtension));
end;

procedure TGIFGraphicControlExtension.LoadFromStream(Stream: TStream);
begin
  inherited LoadFromStream(Stream);
  if (Stream.Read(FGCExtension, sizeof(FGCExtension)) <> sizeof(FGCExtension)) then
  begin
    Warning(gsWarning, sOutOfData);
    exit;
  end;
  // Set transparent flag in sub image
  if (Transparent) then
    SubImage.FTransparent := True;
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFTextExtension
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFTextExtension.Create(ASubImage: TGIFSubImage);
begin
  inherited Create(ASubImage);
  FText := TStringList.Create;
  FPlainTextExtension.BlockSize := 12;
  FPlainTextExtension.Left := 0;
  FPlainTextExtension.Top := 0;
  FPlainTextExtension.Width := 0;
  FPlainTextExtension.Height := 0;
  FPlainTextExtension.CellWidth := 0;
  FPlainTextExtension.CellHeight := 0;
  FPlainTextExtension.TextFGColorIndex := 0;
  FPlainTextExtension.TextBGColorIndex := 0;
end;

destructor TGIFTextExtension.Destroy;
begin
  FText.Free;
  inherited Destroy;
end;

function TGIFTextExtension.GetExtensionType: TGIFExtensionType;
begin
  Result := bsPlainTextExtension;
end;

function TGIFTextExtension.GetForegroundColor: TColor;
begin
  Result := SubImage.ColorMap[ForegroundColorIndex];
end;

procedure TGIFTextExtension.SetForegroundColor(Color: TColor);
begin
  ForegroundColorIndex := SubImage.ActiveColorMap.AddUnique(Color);
end;

function TGIFTextExtension.GetBackgroundColor: TColor;
begin
  Result := SubImage.ActiveColorMap[BackgroundColorIndex];
end;

procedure TGIFTextExtension.SetBackgroundColor(Color: TColor);
begin
  BackgroundColorIndex := SubImage.ColorMap.AddUnique(Color);
end;

function TGIFTextExtension.GetBounds(Index: integer): WORD;
begin
  case (Index) of
    1: Result := FPlainTextExtension.Left;
    2: Result := FPlainTextExtension.Top;
    3: Result := FPlainTextExtension.Width;
    4: Result := FPlainTextExtension.Height;
  else
    Result := 0; // To avoid compiler warnings
  end;
end;

procedure TGIFTextExtension.SetBounds(Index: integer; Value: WORD);
begin
  case (Index) of
    1: FPlainTextExtension.Left := Value;
    2: FPlainTextExtension.Top := Value;
    3: FPlainTextExtension.Width := Value;
    4: FPlainTextExtension.Height := Value;
  end;
end;

function TGIFTextExtension.GetCharWidthHeight(Index: integer): BYTE;
begin
  case (Index) of
    1: Result := FPlainTextExtension.CellWidth;
    2: Result := FPlainTextExtension.CellHeight;
  else
    Result := 0; // To avoid compiler warnings
  end;
end;

procedure TGIFTextExtension.SetCharWidthHeight(Index: integer; Value: BYTE);
begin
  case (Index) of
    1: FPlainTextExtension.CellWidth := Value;
    2: FPlainTextExtension.CellHeight := Value;
  end;
end;

function TGIFTextExtension.GetColorIndex(Index: integer): BYTE;
begin
  case (Index) of
    1: Result := FPlainTextExtension.TextFGColorIndex;
    2: Result := FPlainTextExtension.TextBGColorIndex;
  else
    Result := 0; // To avoid compiler warnings
  end;
end;

procedure TGIFTextExtension.SetColorIndex(Index: integer; Value: BYTE);
begin
  case (Index) of
    1: FPlainTextExtension.TextFGColorIndex := Value;
    2: FPlainTextExtension.TextBGColorIndex := Value;
  end;
end;

procedure TGIFTextExtension.SaveToStream(Stream: TStream);
begin
  inherited SaveToStream(Stream);
  Stream.Write(FPlainTextExtension, sizeof(FPlainTextExtension));
  WriteStrings(Stream, FText);
end;

procedure TGIFTextExtension.LoadFromStream(Stream: TStream);
begin
  inherited LoadFromStream(Stream);
  ReadCheck(Stream, FPlainTextExtension, sizeof(FPlainTextExtension));
  ReadStrings(Stream, FText);
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFCommentExtension
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFCommentExtension.Create(ASubImage: TGIFSubImage);
begin
  inherited Create(ASubImage);
  FText := TStringList.Create;
end;

destructor TGIFCommentExtension.Destroy;
begin
  FText.Free;
  inherited Destroy;
end;

function TGIFCommentExtension.GetExtensionType: TGIFExtensionType;
begin
  Result := bsCommentExtension;
end;

procedure TGIFCommentExtension.SaveToStream(Stream: TStream);
begin
  inherited SaveToStream(Stream);
  WriteStrings(Stream, FText);
end;

procedure TGIFCommentExtension.LoadFromStream(Stream: TStream);
begin
  inherited LoadFromStream(Stream);
  ReadStrings(Stream, FText);
end;

////////////////////////////////////////////////////////////////////////////////
//
//		TGIFApplicationExtension registration database
//
////////////////////////////////////////////////////////////////////////////////
type
  PAppExtRec = ^TAppExtRec;
  TAppExtRec = record
    AppClass: TGIFAppExtensionClass;
    Ident: TGIFApplicationRec;
  end;

  TAppExtensionList = class(TList)
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
    function FindExt(eIdent: TGIFApplicationRec): TGIFAppExtensionClass;
    procedure Remove(eClass: TGIFAppExtensionClass);
  end;

constructor TAppExtensionList.Create;
const
  NSLoopIdent: array[0..1] of TGIFApplicationRec =
    ((Identifier: 'NETSCAPE'; Authentication: '2.0'),
     (Identifier: 'ANIMEXTS'; Authentication: '1.0'));
begin
  inherited Create;
  Add(NSLoopIdent[0], TGIFAppExtNSLoop);
  Add(NSLoopIdent[1], TGIFAppExtNSLoop);
end;

destructor TAppExtensionList.Destroy;
var
  I: Integer;
begin
  for I := 0 to Count-1 do
    Dispose(PAppExtRec(Items[I]));
  inherited Destroy;
end;

procedure TAppExtensionList.Add(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
var
  NewRec: PAppExtRec;
begin
  New(NewRec);
  NewRec^.Ident := eIdent;
  NewRec^.AppClass := eClass;
  inherited Add(NewRec);
end;

function TAppExtensionList.FindExt(eIdent: TGIFApplicationRec): TGIFAppExtensionClass;
var
  I: Integer;
begin
  for I := Count-1 downto 0 do
    with PAppExtRec(Items[I])^ do
      if CompareMem(@Ident, @eIdent, sizeof(TGIFApplicationRec)) then
      begin
        Result := AppClass;
        Exit;
      end;
  Result := nil;
end;

procedure TAppExtensionList.Remove(eClass: TGIFAppExtensionClass);
var
  I: Integer;
  P: PAppExtRec;
begin
  for I := Count-1 downto 0 do
  begin
    P := PAppExtRec(Items[I]);
    if P^.AppClass.InheritsFrom(eClass) then
    begin
      Dispose(P);
      Delete(I);
    end;
  end;
end;

var
  AppExtensionList: TAppExtensionList = nil;

function GetAppExtensionList: TAppExtensionList;
begin
  if (AppExtensionList = nil) then
    AppExtensionList := TAppExtensionList.Create;
  Result := AppExtensionList;
end;

class procedure TGIFApplicationExtension.RegisterExtension(eIdent: TGIFApplicationRec;
  eClass: TGIFAppExtensionClass);
begin
  GetAppExtensionList.Add(eIdent, eClass);
end;

class function TGIFApplicationExtension.FindSubExtension(Stream: TStream): TGIFExtensionClass;
var
  eIdent		: TGIFApplicationRec;
  OldPos		: longInt;
  Size			: BYTE;
begin
  OldPos := Stream.Position;
  Result := nil;
  if (Stream.Read(Size, 1) <> 1) then
    exit;

  // Some old Adobe export filters mistakenly uses a value of 10
  if (Size = 10) then
  begin
    { TODO -oanme -cImprovement : replace with seek or read and check contents = 'Adobe' }
    if (Stream.Read(eIdent, 10) <> 10) then
      exit;
    Result := TGIFUnknownAppExtension;
    exit;
  end else
  if (Size <> sizeof(TGIFApplicationRec)) or
    (Stream.Read(eIdent, sizeof(eIdent)) <> sizeof(eIdent)) then
  begin
    Stream.Position := OldPos;
    Result := inherited FindSubExtension(Stream);
  end else
  begin
    Result := GetAppExtensionList.FindExt(eIdent);
    if (Result = nil) then
      Result := TGIFUnknownAppExtension;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFApplicationExtension
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFApplicationExtension.Create(ASubImage: TGIFSubImage);
begin
  inherited Create(ASubImage);
  FillChar(FIdent, sizeof(FIdent), 0);
end;

destructor TGIFApplicationExtension.Destroy;
begin
  inherited Destroy;
end;

function TGIFApplicationExtension.GetExtensionType: TGIFExtensionType;
begin
  Result := bsApplicationExtension;
end;

function TGIFApplicationExtension.GetAuthentication: string;
begin
  Result := FIdent.Authentication;
end;

procedure TGIFApplicationExtension.SetAuthentication(const Value: string);
begin
  if (Length(Value) < sizeof(TGIFAuthenticationCode)) then
    FillChar(FIdent.Authentication, sizeof(TGIFAuthenticationCode), 32);
  StrLCopy(@(FIdent.Authentication[0]), PChar(Value), sizeof(TGIFAuthenticationCode));
end;

function TGIFApplicationExtension.GetIdentifier: string;
begin
  Result := FIdent.Identifier;
end;

procedure TGIFApplicationExtension.SetIdentifier(const Value: string);
begin
  if (Length(Value) < sizeof(TGIFIdentifierCode)) then
    FillChar(FIdent.Identifier, sizeof(TGIFIdentifierCode), 32);
  StrLCopy(@(FIdent.Identifier[0]), PChar(Value), sizeof(TGIFIdentifierCode));
end;

procedure TGIFApplicationExtension.SaveToStream(Stream: TStream);
begin
  inherited SaveToStream(Stream);
  WriteByte(Stream, sizeof(FIdent)); // Block size
  Stream.Write(FIdent, sizeof(FIdent));
  SaveData(Stream);
end;

procedure TGIFApplicationExtension.LoadFromStream(Stream: TStream);
var
  i			: integer;
begin
  inherited LoadFromStream(Stream);
  i := ReadByte(Stream);
  // Some old Adobe export filters mistakenly uses a value of 10
  if (i = 10) then
    FillChar(FIdent, sizeOf(FIdent), 0)
  else
    if (i < 11) then
      Error(sBadBlockSize);

  ReadCheck(Stream, FIdent, sizeof(FIdent));

  Dec(i, sizeof(FIdent));
  // Ignore extra data
  Stream.Seek(i, soFromCurrent);

  // ***FIXME***
  // If self class is TGIFApplicationExtension, this will cause an &quot;abstract
  // error&quot;.
  // TGIFApplicationExtension.LoadData should read and ignore rest of block.
  LoadData(Stream);
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFUnknownAppExtension
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFBlock.Create(ASize: integer);
begin
  inherited Create;
  FSize := ASize;
  GetMem(FData, FSize);
  FillChar(FData^, FSize, 0);
end;

destructor TGIFBlock.Destroy;
begin
  FreeMem(FData);
  inherited Destroy;
end;

procedure TGIFBlock.SaveToStream(Stream: TStream);
begin
  Stream.Write(FSize, 1);
  Stream.Write(FData^, FSize);
end;

procedure TGIFBlock.LoadFromStream(Stream: TStream);
begin
  ReadCheck(Stream, FData^, FSize);
end;

constructor TGIFUnknownAppExtension.Create(ASubImage: TGIFSubImage);
begin
  inherited Create(ASubImage);
  FBlocks := TList.Create;
end;

destructor TGIFUnknownAppExtension.Destroy;
var
  i			: integer;
begin
  for i := 0 to FBlocks.Count-1 do
    TGIFBlock(FBlocks[i]).Free;
  FBlocks.Free;
  inherited Destroy;
end;


procedure TGIFUnknownAppExtension.SaveData(Stream: TStream);
var
  i			: integer;
begin
  for i := 0 to FBlocks.Count-1 do
    TGIFBlock(FBlocks[i]).SaveToStream(Stream);
  // Terminating zero
  WriteByte(Stream, 0);
end;

procedure TGIFUnknownAppExtension.LoadData(Stream: TStream);
var
  b			: BYTE;
  Block			: TGIFBlock;
  i			: integer;
begin
  // Zap old blocks
  for i := 0 to FBlocks.Count-1 do
    TGIFBlock(FBlocks[i]).Free;
  FBlocks.Clear;

  // Read blocks
  if (Stream.Read(b, 1) <> 1) then
    exit;
  while (b <> 0) do
  begin
    Block := TGIFBlock.Create(b);
    try
      Block.LoadFromStream(Stream);
    except
      Block.Free;
      raise;
    end;
    FBlocks.Add(Block);
    if (Stream.Read(b, 1) <> 1) then
      exit;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//                      TGIFAppExtNSLoop
//
////////////////////////////////////////////////////////////////////////////////
const
  // Netscape sub block types
  nbLoopExtension	= 1;
  nbBufferExtension	= 2;

constructor TGIFAppExtNSLoop.Create(ASubImage: TGIFSubImage);
const
  NSLoopIdent: TGIFApplicationRec = (Identifier: 'NETSCAPE'; Authentication: '2.0');
begin
  inherited Create(ASubImage);
  FIdent := NSLoopIdent;
end;

procedure TGIFAppExtNSLoop.SaveData(Stream: TStream);
begin
  // Write loop count
  WriteByte(Stream, 1 + sizeof(FLoops)); // Size of block
  WriteByte(Stream, nbLoopExtension); // Identify sub block as looping extension data
  Stream.Write(FLoops, sizeof(FLoops)); // Loop count

  // Write buffer size if specified
  if (FBufferSize > 0) then
  begin
    WriteByte(Stream, 1 + sizeof(FBufferSize)); // Size of block
    WriteByte(Stream, nbBufferExtension); // Identify sub block as buffer size data
    Stream.Write(FBufferSize, sizeof(FBufferSize)); // Buffer size
  end;

  WriteByte(Stream, 0); // Terminating zero
end;

procedure TGIFAppExtNSLoop.LoadData(Stream: TStream);
var
  BlockSize		: integer;
  BlockType		: integer;
begin
  // Read size of first block or terminating zero
  BlockSize := ReadByte(Stream);
  while (BlockSize <> 0) do
  begin
    BlockType := ReadByte(Stream);
    dec(BlockSize);

    case (BlockType AND $07) of
      nbLoopExtension:
        begin
          if (BlockSize < sizeof(FLoops)) then
            Error(sInvalidData);
          // Read loop count
          ReadCheck(Stream, FLoops, sizeof(FLoops));
          dec(BlockSize, sizeof(FLoops));
        end;
      nbBufferExtension:
        begin
          if (BlockSize < sizeof(FBufferSize)) then
            Error(sInvalidData);
          // Read buffer size
          ReadCheck(Stream, FBufferSize, sizeof(FBufferSize));
          dec(BlockSize, sizeof(FBufferSize));
        end;
    end;

    // Skip/ignore unread data
    if (BlockSize > 0) then
      Stream.Seek(BlockSize, soFromCurrent);

    // Read size of next block or terminating zero
    BlockSize := ReadByte(Stream);
  end;
end;


////////////////////////////////////////////////////////////////////////////////
//
//			TGIFImageList
//
////////////////////////////////////////////////////////////////////////////////
function TGIFImageList.GetImage(Index: Integer): TGIFSubImage;
begin
  Result := TGIFSubImage(Items[Index]);
end;

procedure TGIFImageList.SetImage(Index: Integer; SubImage: TGIFSubImage);
begin
  Items[Index] := SubImage;
end;

procedure TGIFImageList.LoadFromStream(Stream: TStream; Parent: TObject);
var
  b			: BYTE;
  SubImage		: TGIFSubImage;
begin
  // Peek ahead to determine block type
  repeat
    if (Stream.Read(b, 1) <> 1) then
      exit;
  until (b <> 0); // Ignore 0 padding (non-compliant)

  while (b <> bsTrailer) do
  begin
    Stream.Seek(-1, soFromCurrent);
    if (b in [bsExtensionIntroducer, bsImageDescriptor]) then
    begin
      SubImage := TGIFSubImage.Create(Parent as TGIFImage);
      try
        SubImage.LoadFromStream(Stream);
        Add(SubImage);
        Image.Progress(Self, psRunning, MulDiv(Stream.Position, 100, Stream.Size),
          GIFImageRenderOnLoad, Rect(0,0,0,0), sProgressLoading);
      except
        SubImage.Free;
        raise;
      end;
    end else
    begin
      Warning(gsWarning, sBadBlock);
      break;
    end;
    repeat
      if (Stream.Read(b, 1) <> 1) then
        exit;
    until (b <> 0); // Ignore 0 padding (non-compliant)
  end;
  Stream.Seek(-1, soFromCurrent);
end;

procedure TGIFImageList.SaveToStream(Stream: TStream);
var
  i			: integer;
begin
  for i := 0 to Count-1 do
  begin
    TGIFItem(Items[i]).SaveToStream(Stream);
    Image.Progress(Self, psRunning, MulDiv((i+1), 100, Count), False, Rect(0,0,0,0), sProgressSaving);
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFPainter
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFPainter.CreateRef(Painter: PGIFPainter; AImage: TGIFImage;
  ACanvas: TCanvas; ARect: TRect; Options: TGIFDrawOptions);
begin
  Create(AImage, ACanvas, ARect, Options);
  PainterRef := Painter;
  if (PainterRef <> nil) then
    PainterRef^ := self;
end;

constructor TGIFPainter.Create(AImage: TGIFImage; ACanvas: TCanvas; ARect: TRect;
  Options: TGIFDrawOptions);
var
  i			: integer;
  BackgroundColor	: TColor;
  Disposals		: set of TDisposalMethod;
begin
  inherited Create(True);
  FreeOnTerminate := True;
  Onterminate := DoOnTerminate;
  FImage := AImage;
  FCanvas := ACanvas;
  FRect := ARect;
  FActiveImage := -1;
  FDrawOptions := Options;
  FStarted := False;
  BackupBuffer := nil;
  FrameBuffer := nil;
  Background := nil;
  FEventHandle := 0;
  // This should be a parameter, but I think I've got enough of them already...
  FAnimationSpeed := FImage.AnimationSpeed;

  // An event handle is used for animation delays
  if (FDrawOptions >= [goAnimate, goAsync]) and (FImage.Images.Count > 1) and
    (FAnimationSpeed >= 0) then
    FEventHandle := CreateEvent(nil, False, False, nil);

  // Preprocessing of extensions to determine if we need frame buffers
  Disposals := [];
  if (FImage.DrawBackgroundColor = clNone) then
  begin
    if (FImage.GlobalColorMap.Count > 0) then
      BackgroundColor := FImage.BackgroundColor
    else
      BackgroundColor := ColorToRGB(clWindow);
  end else
    BackgroundColor := ColorToRGB(FImage.DrawBackgroundColor);

  // Need background buffer to clear on loop
  if (goClearOnLoop in FDrawOptions) then
    Include(Disposals, dmBackground);

  for i := 0 to FImage.Images.Count-1 do
    if (FImage.Images[i].GraphicControlExtension <> nil) then
      with (FImage.Images[i].GraphicControlExtension) do
        Include(Disposals, Disposal);

  // Need background buffer to draw transparent on background
  if (dmBackground in Disposals) and (goTransparent in FDrawOptions) then
  begin
    Background := TBitmap.Create;
    Background.Height := FRect.Bottom-FRect.Top;
    Background.Width := FRect.Right-FRect.Left;
    // Copy background immediately
    Background.Canvas.CopyMode := cmSrcCopy;
    Background.Canvas.CopyRect(Background.Canvas.ClipRect, FCanvas, FRect);
  end;
  // Need frame- and backup buffer to restore to previous and background
  if ((Disposals * [dmPrevious, dmBackground]) <> []) then
  begin
    BackupBuffer := TBitmap.Create;
    BackupBuffer.Height := FRect.Bottom-FRect.Top;
    BackupBuffer.Width := FRect.Right-FRect.Left;
    BackupBuffer.Canvas.CopyMode := cmSrcCopy;
    BackupBuffer.Canvas.Brush.Color := BackgroundColor;
    BackupBuffer.Canvas.Brush.Style := bsSolid;
{$IFDEF DEBUG}
    BackupBuffer.Canvas.Brush.Color := clBlack;
    BackupBuffer.Canvas.Brush.Style := bsDiagCross;
{$ENDIF}
    // Step 1: Copy destination to backup buffer
    //         Always executed before first frame and only once.
    BackupBuffer.Canvas.CopyRect(BackupBuffer.Canvas.ClipRect, FCanvas, FRect);
    FrameBuffer := TBitmap.Create;
    FrameBuffer.Height := FRect.Bottom-FRect.Top;
    FrameBuffer.Width := FRect.Right-FRect.Left;
    FrameBuffer.Canvas.CopyMode := cmSrcCopy;
    FrameBuffer.Canvas.Brush.Color := BackgroundColor;
    FrameBuffer.Canvas.Brush.Style := bsSolid;
{$IFDEF DEBUG}
    FrameBuffer.Canvas.Brush.Color := clBlack;
    FrameBuffer.Canvas.Brush.Style := bsDiagCross;
{$ENDIF}
  end;
end;

destructor TGIFPainter.Destroy;
begin
  // OnTerminate isn't called if we are running in main thread, so we must call
  // it manually
  if not(goAsync in DrawOptions) then
    DoOnTerminate(self);
  // Reraise any exptions that were eaten in the Execute method
  if (ExceptObject <> nil) then
    raise ExceptObject at ExceptAddress;
  inherited Destroy;
end;

procedure TGIFPainter.SetAnimationSpeed(Value: integer);
begin
  if (Value < 0) then
    Value := 0
  else if (Value > 1000) then
    Value := 1000;
  if (Value <> FAnimationSpeed) then
  begin
    FAnimationSpeed := Value;
    // Signal WaitForSingleObject delay to abort
    if (FEventHandle <> 0) then
      SetEvent(FEventHandle)
    else
      DoRestart := True;
  end;
end;

procedure TGIFPainter.SetActiveImage(const Value: integer);
begin
  if (Value >= 0) and (Value < FImage.Images.Count) then
    FActiveImage := Value;
end;

// Conditional Synchronize
procedure TGIFPainter.DoSynchronize(Method: TThreadMethod);
begin
  if (Terminated) then
    exit;
  if (goAsync in FDrawOptions) then
    // Execute Synchronized if requested...
    Synchronize(Method)
  else
    // ...Otherwise just execute in current thread (probably main thread)
    Method;
end;

// Delete frame buffers - Executed in main thread
procedure TGIFPainter.DoOnTerminate(Sender: TObject);
begin
  // It shouldn't really be nescessary to protect PainterRef in this manner
  // since we are running in the main thread at this point, but I'm a little
  // paranoid about the way PainterRef is being used...
  if Image <> nil then  // 2001.02.23
  begin  // 2001.02.23
    with Image.Painters.LockList do
      try
        // Zap pointer to self and remove from painter list
        if (PainterRef <> nil) and (PainterRef^ = self) then
          PainterRef^ := nil;
      finally
        Image.Painters.UnLockList;
      end;
    Image.Painters.Remove(self);
    FImage := nil;
  end;  // 2001.02.23

  // Free buffers
  if (BackupBuffer <> nil) then
    BackupBuffer.Free;
  if (FrameBuffer <> nil) then
    FrameBuffer.Free;
  if (Background <> nil) then
    Background.Free;

  // Delete event handle
  if (FEventHandle <> 0) then
    CloseHandle(FEventHandle);
end;

// Event &quot;dispatcher&quot; - Executed in main thread
procedure TGIFPainter.DoEvent;
begin
  if (Assigned(FEvent)) then
    FEvent(self);
end;

// Non-buffered paint - Executed in main thread
procedure TGIFPainter.DoPaint;
begin
  FImage.Images[ActiveImage].Draw(FCanvas, FRect, (goTransparent in FDrawOptions),
    (goTile in FDrawOptions));
  FStarted := True;
end;

// Buffered paint - Executed in main thread
procedure TGIFPainter.DoPaintFrame;
var
  DrawDestination	: TCanvas;
  DrawRect		: TRect;
  DoStep2		,
  DoStep3		,
  DoStep5		,
  DoStep6		: boolean;
  SavePal		,
  SourcePal		: HPALETTE;

  procedure ClearBackup;
  var
    r			,
    Tile		: TRect;
    FrameTop		,
    FrameHeight		: integer;
    ImageWidth		,
    ImageHeight		: integer;
  begin

    if (goTransparent in FDrawOptions) then
    begin
      // If the frame is transparent, we must remove it by copying the
      // background buffer over it
      if (goTile in FDrawOptions) then
      begin
        FrameTop := FImage.Images[ActiveImage].Top;
        FrameHeight := FImage.Images[ActiveImage].Height;
        ImageWidth := FImage.Width;
        ImageHeight := FImage.Height;

        Tile.Left := FRect.Left + FImage.Images[ActiveImage].Left;
        Tile.Right := Tile.Left + FImage.Images[ActiveImage].Width;
        while (Tile.Left < FRect.Right) do
        begin
          Tile.Top := FRect.Top + FrameTop;
          Tile.Bottom := Tile.Top + FrameHeight;
          while (Tile.Top < FRect.Bottom) do
          begin
            BackupBuffer.Canvas.CopyRect(Tile, Background.Canvas, Tile);
            Tile.Top := Tile.Top + ImageHeight;
            Tile.Bottom := Tile.Bottom + ImageHeight;
          end;
          Tile.Left := Tile.Left + ImageWidth;
          Tile.Right := Tile.Right + ImageWidth;
        end;
      end else
      begin
        r := FImage.Images[ActiveImage].ScaleRect(BackupBuffer.Canvas.ClipRect);
        BackupBuffer.Canvas.CopyRect(r, Background.Canvas, r)
      end;
    end else
    begin
      // If the frame isn't transparent, we just clear the area covered by
      // it to the background color.
      // Tile the background unless the frame covers all of the image
      if (goTile in FDrawOptions) and
        ((FImage.Width <> FImage.Images[ActiveImage].Width) and
         (FImage.height <> FImage.Images[ActiveImage].Height)) then
      begin
        FrameTop := FImage.Images[ActiveImage].Top;
        FrameHeight := FImage.Images[ActiveImage].Height;
        ImageWidth := FImage.Width;
        ImageHeight := FImage.Height;
        // ***FIXME*** I don't think this does any difference
        BackupBuffer.Canvas.Brush.Color := FImage.DrawBackgroundColor;

        Tile.Left := FRect.Left + FImage.Images[ActiveImage].Left;
        Tile.Right := Tile.Left + FImage.Images[ActiveImage].Width;
        while (Tile.Left < FRect.Right) do
        begin
          Tile.Top := FRect.Top + FrameTop;
          Tile.Bottom := Tile.Top + FrameHeight;
          while (Tile.Top < FRect.Bottom) do
          begin
            BackupBuffer.Canvas.FillRect(Tile);

            Tile.Top := Tile.Top + ImageHeight;
            Tile.Bottom := Tile.Bottom + ImageHeight;
          end;
          Tile.Left := Tile.Left + ImageWidth;
          Tile.Right := Tile.Right + ImageWidth;
        end;
      end else
        BackupBuffer.Canvas.FillRect(FImage.Images[ActiveImage].ScaleRect(FRect));
    end;
  end;

begin
  if (goValidateCanvas in FDrawOptions) then
    if (GetObjectType(ValidateDC) <> OBJ_DC) then
    begin
      Terminate;
      exit;
    end;

  DrawDestination := nil;
  DoStep2 := (goClearOnLoop in FDrawOptions) and (FActiveImage = 0);
  DoStep3 := False;
  DoStep5 := False;
  DoStep6 := False;
{
Disposal mode algorithm:

Step 1: Copy destination to backup buffer
        Always executed before first frame and only once.
        Done in constructor.
Step 2: Clear previous frame (implementation is same as step 6)
        Done implicitly by implementation.
        Only done explicitly on first frame if goClearOnLoop option is set.
Step 3: Copy backup buffer to frame buffer
Step 4: Draw frame
Step 5: Copy buffer to destination
Step 6: Clear frame from backup buffer
+------------+------------------+---------------------+------------------------+
|New  /  Old |  dmNone          |  dmBackground       |  dmPrevious            |
+------------+------------------+---------------------+------------------------+
|dmNone      |                  |                     |                        |
|            |4. Paint on backup|4. Paint on backup   |4. Paint on backup      |
|            |5. Restore        |5. Restore           |5. Restore              |
+------------+------------------+---------------------+------------------------+
|dmBackground|                  |                     |                        |
|            |4. Paint on backup|4. Paint on backup   |4. Paint on backup      |
|            |5. Restore        |5. Restore           |5. Restore              |
|            |6. Clear backup   |6. Clear backup      |6. Clear backup         |
+------------+------------------+---------------------+------------------------+
|dmPrevious  |                  |                     |                        |
|            |                  |3. Copy backup to buf|3. Copy backup to buf   |
|            |4. Paint on dest  |4. Paint on buf      |4. Paint on buf         |
|            |                  |5. Copy buf to dest  |5. Copy buf to dest     |
+------------+------------------+---------------------+------------------------+
}
  case (Disposal) of
    dmNone, dmNoDisposal:
      begin
        DrawDestination := BackupBuffer.Canvas;
        DrawRect := BackupBuffer.Canvas.ClipRect;
        DoStep5 := True;
      end;
    dmBackground:
      begin
        DrawDestination := BackupBuffer.Canvas;
        DrawRect := BackupBuffer.Canvas.ClipRect;
        DoStep5 := True;
        DoStep6 := True;
      end;
    dmPrevious:
      case (OldDisposal) of
        dmNone, dmNoDisposal:
        begin
          DrawDestination := FCanvas;
          DrawRect := FRect;
        end;
        dmBackground, dmPrevious:
        begin
          DrawDestination := FrameBuffer.Canvas;
          DrawRect := FrameBuffer.Canvas.ClipRect;
          DoStep3 := True;
          DoStep5 := True;
        end;
      end;
  end;

  // Find source palette
  SourcePal := FImage.Images[ActiveImage].Palette;
  if (SourcePal = 0) then
    SourcePal := SystemPalette16; // This should never happen

  SavePal := SelectPalette(DrawDestination.Handle, SourcePal, False);
  RealizePalette(DrawDestination.Handle);

  // Step 2: Clear previous frame
  if (DoStep2) then
   ClearBackup;

  // Step 3: Copy backup buffer to frame buffer
  if (DoStep3) then
    FrameBuffer.Canvas.CopyRect(FrameBuffer.Canvas.ClipRect,
      BackupBuffer.Canvas, BackupBuffer.Canvas.ClipRect);

  // Step 4: Draw frame
  if (DrawDestination <> nil) then
    FImage.Images[ActiveImage].Draw(DrawDestination, DrawRect,
      (goTransparent in FDrawOptions), (goTile in FDrawOptions));

  // Step 5: Copy buffer to destination
  if (DoStep5) then
  begin
    FCanvas.CopyMode := cmSrcCopy;
    FCanvas.CopyRect(FRect, DrawDestination, DrawRect);
  end;

  if (SavePal <> 0) then
    SelectPalette(DrawDestination.Handle, SavePal, False);

  // Step 6: Clear frame from backup buffer
  if (DoStep6) then
   ClearBackup;

  FStarted := True;
end;

// Prefetch bitmap
// Used to force the GIF image to be rendered as a bitmap
{$ifdef SERIALIZE_RENDER}
procedure TGIFPainter.PrefetchBitmap;
begin
  // Touch current bitmap to force bitmap to be rendered
  if not((FImage.Images[ActiveImage].Empty) or (FImage.Images[ActiveImage].HasBitmap)) then
    FImage.Images[ActiveImage].Bitmap;
end;
{$endif}

// Main thread execution loop - This is where it all happens...
procedure TGIFPainter.Execute;
var
  i			: integer;
  LoopCount		,
  LoopPoint		: integer;
  Looping		: boolean;
  Ext			: TGIFExtension;
  Msg			: TMsg;
  Delay			,
  OldDelay		,
  DelayUsed		: longInt;
  DelayStart		,
  NewDelayStart		: DWORD;

  procedure FireEvent(Event: TNotifyEvent);
  begin
    if not(Assigned(Event)) then
      exit;
    FEvent := Event;
    try
      DoSynchronize(DoEvent);
    finally
      FEvent := nil;
    end;
  end;

begin
{
  Disposal:
    dmNone: Same as dmNodisposal
    dmNoDisposal: Do not dispose
    dmBackground: Clear with background color *)
    dmPrevious: Previous image
    *) Note: Background color should either be a BROWSER SPECIFIED Background
       color (DrawBackgroundColor) or the background image if any frames are
       transparent.
}
  try
    try
      if (goValidateCanvas in FDrawOptions) then
        ValidateDC := FCanvas.Handle;
      DoRestart := True;

      // Loop to restart paint
      while (DoRestart) and not(Terminated) do
      begin
        FActiveImage := 0;
        // Fire OnStartPaint event
        // Note: ActiveImage may be altered by the event handler
        FireEvent(FOnStartPaint);

        FStarted := False;
        DoRestart := False;
        LoopCount := 1;
        LoopPoint := FActiveImage;
        Looping := False;
        if (goAsync in DrawOptions) then
          Delay := 0
        else
          Delay := 1; // Dummy to process messages
        OldDisposal := dmNoDisposal;
        // Fetch delay start time
        DelayStart := timeGetTime;
        OldDelay := 0;

        // Loop to loop - duh!
        while ((LoopCount <> 0) or (goLoopContinously in DrawOptions)) and
          not(Terminated or DoRestart) do
        begin
          FActiveImage := LoopPoint;

          // Fire OnLoopPaint event
          // Note: ActiveImage may be altered by the event handler
          if (FStarted) then
            FireEvent(FOnLoop);

          // Loop to animate
          while (ActiveImage < FImage.Images.Count) and not(Terminated or DoRestart) do
          begin
            // Ignore empty images
            if (FImage.Images[ActiveImage].Empty) then
              break;
            // Delay from previous image
            if (Delay > 0) then
            begin
              // Prefetch frame bitmap
{$ifdef SERIALIZE_RENDER}
              DoSynchronize(PrefetchBitmap);
{$else}
              FImage.Images[ActiveImage].Bitmap;
{$endif}

              // Calculate inter frame delay
              NewDelayStart := timeGetTime;
              if (FAnimationSpeed > 0) then
              begin
                // Calculate number of mS used in prefetch and display
                try
                  DelayUsed := integer(NewDelayStart-DelayStart)-OldDelay;
                  // Prevent feedback oscillations caused by over/undercompensation.
                  DelayUsed := DelayUsed DIV 2;
                  // Convert delay value to mS and...
                  // ...Adjust for time already spent converting GIF to bitmap and...
                  // ...Adjust for Animation Speed factor.
                  Delay := MulDiv(Delay * GIFDelayExp - DelayUsed, 100, FAnimationSpeed);
                  OldDelay := Delay;
                except
                  Delay := GIFMaximumDelay * GIFDelayExp;
                  OldDelay := 0;
                end;
              end else
              begin
                if (goAsync in DrawOptions) then
                  Delay := longInt(INFINITE)
                else
                  Delay := GIFMaximumDelay * GIFDelayExp;
              end;
              // Fetch delay start time
              DelayStart := NewDelayStart;

              // Sleep in one chunk if we are running in a thread
              if (goAsync in DrawOptions) then
              begin
                // Use of WaitForSingleObject allows TGIFPainter.Stop to wake us up
                if (Delay > 0) or (FAnimationSpeed = 0) then
                begin
                  if (WaitForSingleObject(FEventHandle, DWORD(Delay)) <> WAIT_TIMEOUT) then
                  begin
                    // Don't use interframe delay feedback adjustment if delay
                    // were prematurely aborted (e.g. because the animation
                    // speed were changed)
                    OldDelay := 0;
                    DelayStart := longInt(timeGetTime);
                  end;
                end;
              end else
              begin
                if (Delay <= 0) then
                  Delay := 1;
                // Fetch start time
                NewDelayStart := timeGetTime;
                // If we are not running in a thread we Sleep in small chunks
                // and give the user a chance to abort
                while (Delay > 0) and not(Terminated or DoRestart) do
                begin
                  if (Delay < 100) then
                    Sleep(Delay)
                  else
                    Sleep(100);
                  // Calculate number of mS delayed in this chunk
                  DelayUsed := integer(timeGetTime - NewDelayStart);
                  dec(Delay, DelayUsed);
                  // Reset start time for chunk
                  NewDelaySTart := timeGetTime;
                  // Application.ProcessMessages wannabe
                  while (not(Terminated or DoRestart)) and
                    (PeekMessage(Msg, 0, 0, 0, PM_REMOVE)) do
                  begin
                    if (Msg.Message <> WM_QUIT) then
                    begin
                      TranslateMessage(Msg);
                      DispatchMessage(Msg);
                    end else
                    begin
                      // Put WM_QUIT back in queue and get out of here fast
                      PostQuitMessage(Msg.WParam);
                      Terminate;
                    end;
                  end;
                end;
              end;
            end else
              Sleep(0); // Yield
            if (Terminated) then
              break;

            // Fire OnPaint event
            // Note: ActiveImage may be altered by the event handler
            FireEvent(FOnPaint);
            if (Terminated) then
              break;

            // Pre-draw processing of extensions
            Disposal := dmNoDisposal;
            for i := 0 to FImage.Images[ActiveImage].Extensions.Count-1 do
            begin
              Ext := FImage.Images[ActiveImage].Extensions[i];
              if (Ext is TGIFAppExtNSLoop) then
              begin
                // Recursive loops not supported (or defined)
                if (Looping) then
                  continue;
                Looping := True;
                LoopCount := TGIFAppExtNSLoop(Ext).Loops;
                if ((LoopCount = 0) or (goLoopContinously in DrawOptions)) and
                  (goAsync in DrawOptions) then
                  LoopCount := -1; // Infinite if running in separate thread
{$IFNDEF STRICT_MOZILLA}
                // Loop from this image and on
                // Note: This is not standard behavior
                LoopPoint := ActiveImage;
{$ENDIF}
              end else
              if (Ext is TGIFGraphicControlExtension) then
                Disposal := TGIFGraphicControlExtension(Ext).Disposal;
            end;

            // Paint the image
            if (BackupBuffer <> nil) then
              DoSynchronize(DoPaintFrame)
            else
              DoSynchronize(DoPaint);
            OldDisposal := Disposal;

            if (Terminated) then
              break;

            Delay := GIFDefaultDelay; // Default delay
            // Post-draw processing of extensions
            if (FImage.Images[ActiveImage].GraphicControlExtension <> nil) then
              if (FImage.Images[ActiveImage].GraphicControlExtension.Delay > 0) then
              begin
                Delay := FImage.Images[ActiveImage].GraphicControlExtension.Delay;

                // Enforce minimum animation delay in compliance with Mozilla
                if (Delay < GIFMinimumDelay) then
                  Delay := GIFMinimumDelay;

                // Do not delay more than 10 seconds if running in main thread
                if (Delay > GIFMaximumDelay) and not(goAsync in DrawOptions) then
                  Delay := GIFMaximumDelay; // Max 10 seconds
              end;
            // Fire OnAfterPaint event
            // Note: ActiveImage may be altered by the event handler
            i := FActiveImage;
            FireEvent(FOnAfterPaint);
            if (Terminated) then
              break;
            // Don't increment frame counter if event handler modified
            // current frame
            if (FActiveImage = i) then
              Inc(FActiveImage);
            // Nothing more to do unless we are animating
            if not(goAnimate in DrawOptions) then
              break;
          end;

          if (LoopCount > 0) then
            Dec(LoopCount);
          if ([goAnimate, goLoop] * DrawOptions <> [goAnimate, goLoop]) then
            break;
        end;
        if (Terminated) then  // 2001.07.23
          break;  // 2001.07.23
      end;
      FActiveImage := -1;
      // Fire OnEndPaint event
      FireEvent(FOnEndPaint);
    finally
      // If we are running in the main thread we will have to zap our self
      if not(goAsync in DrawOptions) then
        Free;
    end;
  except
    on E: Exception do
    begin
      // Eat exception and terminate thread...
      // If we allow the exception to abort the thread at this point, the
      // application will hang since the thread destructor will never be called
      // and the application will wait forever for the thread to die!
      Terminate;
      // Clone exception
      ExceptObject := E.Create(E.Message);
      ExceptAddress := ExceptAddr;
    end;
  end;
end;

procedure TGIFPainter.Start;
begin
  if (goAsync in FDrawOptions) then
    Resume;
end;

procedure TGIFPainter.Stop;
begin
  Terminate;
  if (goAsync in FDrawOptions) then
  begin
    // Signal WaitForSingleObject delay to abort
    if (FEventHandle <> 0) then
      SetEvent(FEventHandle);
    Priority := tpNormal;
    if (Suspended) then
      Resume; // Must be running before we can terminate
  end;
end;

procedure TGIFPainter.Restart;
begin
  DoRestart := True;
  if (Suspended) and (goAsync in FDrawOptions) then
    Resume; // Must be running before we can terminate
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TColorMapOptimizer
//
////////////////////////////////////////////////////////////////////////////////
// Used by TGIFImage to optimize local color maps to a single global color map.
// The following algorithm is used:
// 1) Build a histogram for each image
// 2) Merge histograms
// 3) Sum equal colors and adjust max # of colors
// 4) Map entries > max to entries <= 256
// 5) Build new color map
// 6) Map images to new color map
////////////////////////////////////////////////////////////////////////////////

type

  POptimizeEntry	= ^TOptimizeEntry;
  TColorRec = record
  case byte of
    0: (Value: integer);
    1: (Color: TGIFColor);
    2: (SameAs: POptimizeEntry); // Used if TOptimizeEntry.Count = 0
  end;

  TOptimizeEntry = record
    Count		: integer;	// Usage count
    OldIndex		: integer;	// Color OldIndex
    NewIndex		: integer;	// NewIndex color OldIndex
    Color		: TColorRec;	// Color value
  end;

  TOptimizeEntries	= array[0..255] of TOptimizeEntry;
  POptimizeEntries	= ^TOptimizeEntries;

  THistogram = class(TObject)
  private
    PHistogram		: POptimizeEntries;
    FCount		: integer;
    FColorMap		: TGIFColorMap;
    FList		: TList;
    FImages		: TList;
  public
    constructor Create(AColorMap: TGIFColorMap);
    destructor Destroy; override;
    function ProcessSubImage(Image: TGIFSubImage): boolean;
    function Prune: integer;
    procedure MapImages(UseTransparency: boolean; NewTransparentColorIndex: byte);
    property Count: integer read FCount;
    property ColorMap: TGIFColorMap read FColorMap;
    property List: TList read FList;
  end;

  TColorMapOptimizer = class(TObject)
  private
    FImage		: TGIFImage;
    FHistogramList	: TList;
    FHistogram		: TList;
    FColorMap		: TColorMap;
    FFinalCount		: integer;
    FUseTransparency	: boolean;
    FNewTransparentColorIndex: byte;
  protected
    procedure ProcessImage;
    procedure MergeColors;
    procedure MapColors;
    procedure ReplaceColorMaps;
  public
    constructor Create(AImage: TGIFImage);
    destructor Destroy; override;
    procedure Optimize;
  end;

function CompareColor(Item1, Item2: Pointer): integer;
begin
  Result := POptimizeEntry(Item2)^.Color.Value - POptimizeEntry(Item1)^.Color.Value;
end;

function CompareCount(Item1, Item2: Pointer): integer;
begin
  Result := POptimizeEntry(Item2)^.Count - POptimizeEntry(Item1)^.Count;
end;

constructor THistogram.Create(AColorMap: TGIFColorMap);
var
  i			: integer;
begin
  inherited Create;

  FCount := AColorMap.Count;
  FColorMap := AColorMap;

  FImages := TList.Create;

  // Allocate memory for histogram
  GetMem(PHistogram, FCount * sizeof(TOptimizeEntry));
  FList := TList.Create;

  FList.Capacity := FCount;

  // Move data to histogram and initialize
  for i := 0 to FCount-1 do
    with PHistogram^[i] do
    begin
      FList.Add(@PHistogram^[i]);
      OldIndex := i;
      Count := 0;
      Color.Value := 0;
      Color.Color := AColorMap.Data^[i];
      NewIndex := 256; // Used to signal unmapped
    end;
end;

destructor THistogram.Destroy;
begin
  FImages.Free;
  FList.Free;
  FreeMem(PHistogram);
  inherited Destroy;
end;

//: Build a color histogram
function THistogram.ProcessSubImage(Image: TGIFSubImage): boolean;
var
  Size			: integer;
  Pixel			: PChar;
  IsTransparent		,
  WasTransparent	: boolean;
  OldTransparentColorIndex: byte;
begin
  Result := False;
  if (Image.Empty) then
    exit;

  FImages.Add(Image);

  Pixel := Image.data;
  Size := Image.Width * Image.Height;

  IsTransparent := Image.Transparent;
  if (IsTransparent) then
    OldTransparentColorIndex := Image.GraphicControlExtension.TransparentColorIndex
  else
    OldTransparentColorIndex := 0; // To avoid compiler warning
  WasTransparent := False;

  (*
  ** Sum up usage count for each color
  *)
  while (Size > 0) do
  begin
    // Ignore transparent pixels
    if (not IsTransparent) or (ord(Pixel^) <> OldTransparentColorIndex) then
    begin
      // Check for invalid color index
      if (ord(Pixel^) >= FCount) then
      begin
        Pixel^ := #0; // ***FIXME*** Isn't this an error condition?
        Image.Warning(gsWarning, sInvalidColor);
      end;

      with PHistogram^[ord(Pixel^)] do
      begin
        // Stop if any color reaches the max count
        if (Count = high(integer)) then
          break;
        inc(Count);
      end;
    end else
      WasTransparent := WasTransparent or IsTransparent;
    inc(Pixel);
    dec(Size);
  end;

  (*
  ** Clear frames transparency flag if the frame claimed to
  ** be transparent, but wasn't
  *)
  if (IsTransparent and not WasTransparent) then
  begin
    Image.GraphicControlExtension.TransparentColorIndex := 0;
    Image.GraphicControlExtension.Transparent := False;
  end;

  Result := WasTransparent;
end;

//: Removed unused color entries from the histogram
function THistogram.Prune: integer;
var
  i, j			: integer;
begin
  (*
  **  Sort by usage count
  *)
  FList.Sort(CompareCount);

  (*
  **  Determine number of used colors
  *)
  for i := 0 to FCount-1 do
    // Find first unused color entry
    if (POptimizeEntry(FList[i])^.Count = 0) then
    begin
      // Zap unused colors
      for j := i to FCount-1 do
        POptimizeEntry(FList[j])^.Count := -1; // Use -1 to signal unused entry
      // Remove unused entries
      FCount := i;
      FList.Count := FCount;
      break;
    end;

  Result := FCount;
end;

//: Convert images from old color map to new color map
procedure THistogram.MapImages(UseTransparency: boolean; NewTransparentColorIndex: byte);
var
  i			: integer;
  Size			: integer;
  Pixel			: PChar;
  ReverseMap		: array[byte] of byte;
  IsTransparent		: boolean;
  OldTransparentColorIndex: byte;
begin
  (*
  ** Build NewIndex map
  *)
  for i := 0 to List.Count-1 do
    ReverseMap[POptimizeEntry(List[i])^.OldIndex] := POptimizeEntry(List[i])^.NewIndex;

  (*
  **  Reorder all images using this color map
  *)
  for i := 0 to FImages.Count-1 do
    with TGIFSubImage(FImages[i]) do
    begin
      Pixel := Data;
      Size := Width * Height;

      // Determine frame transparency
      IsTransparent := (Transparent) and (UseTransparency);
      if (IsTransparent) then
      begin
        OldTransparentColorIndex := GraphicControlExtension.TransparentColorIndex;
        // Map transparent color
        GraphicControlExtension.TransparentColorIndex := NewTransparentColorIndex;
      end else
        OldTransparentColorIndex := 0; // To avoid compiler warning

      // Map all pixels to new color map
      while (Size > 0) do
      begin
        // Map transparent pixels to the new transparent color index and...
        if (IsTransparent) and (ord(Pixel^) = OldTransparentColorIndex) then
          Pixel^ := char(NewTransparentColorIndex)
        else
          // ... all other pixels to their new color index
          Pixel^ := char(ReverseMap[ord(Pixel^)]);
        dec(size);
        inc(Pixel);
      end;
    end;
end;

constructor TColorMapOptimizer.Create(AImage: TGIFImage);
begin
  inherited Create;
  FImage := AImage;
  FHistogramList := TList.Create;
  FHistogram := TList.Create;
end;

destructor TColorMapOptimizer.Destroy;
var
  i			: integer;
begin
  FHistogram.Free;

  for i := FHistogramList.Count-1 downto 0 do
    THistogram(FHistogramList[i]).Free;
  FHistogramList.Free;

  inherited Destroy;
end;

procedure TColorMapOptimizer.ProcessImage;
var
  Hist			: THistogram;
  i			: integer;
  ProcessedImage	: boolean;
begin
  FUseTransparency := False;
  (*
  ** First process images using global color map
  *)
  if (FImage.GlobalColorMap.Count > 0) then
  begin
    Hist := THistogram.Create(FImage.GlobalColorMap);
    ProcessedImage := False;
    // Process all images that are using the global color map
    for i := 0 to FImage.Images.Count-1 do
      if (FImage.Images[i].ColorMap.Count = 0) and (not FImage.Images[i].Empty) then
      begin
        ProcessedImage := True;
      // Note: Do not change order of statements. Shortcircuit evaluation not desired!
        FUseTransparency := Hist.ProcessSubImage(FImage.Images[i]) or FUseTransparency;
      end;
    // Keep the histogram if any images used the global color map...
    if (ProcessedImage) then
      FHistogramList.Add(Hist)
    else // ... otherwise delete it
      Hist.Free;
  end;

  (*
  ** Next process images that have a local color map
  *)
  for i := 0 to FImage.Images.Count-1 do
    if (FImage.Images[i].ColorMap.Count > 0) and (not FImage.Images[i].Empty) then
    begin
      Hist := THistogram.Create(FImage.Images[i].ColorMap);
      FHistogramList.Add(Hist);
      // Note: Do not change order of statements. Shortcircuit evaluation not desired!
      FUseTransparency := Hist.ProcessSubImage(FImage.Images[i]) or FUseTransparency;
    end;
end;

procedure TColorMapOptimizer.MergeColors;
var
  Entry, SameEntry	: POptimizeEntry;
  i			: integer;
begin
  (*
  **  Sort by color value
  *)
  FHistogram.Sort(CompareColor);

  (*
  **  Merge same colors
  *)
  SameEntry := POptimizeEntry(FHistogram[0]);
  for i := 1 to FHistogram.Count-1 do
  begin
    Entry := POptimizeEntry(FHistogram[i]);
    ASSERT(Entry^.Count > 0, 'Unused entry exported from THistogram');
    if (Entry^.Color.Value = SameEntry^.Color.Value) then
    begin
      // Transfer usage count to first entry
      inc(SameEntry^.Count, Entry^.Count);
      Entry^.Count := 0; // Use 0 to signal merged entry
      Entry^.Color.SameAs := SameEntry; // Point to master
    end else
      SameEntry := Entry;
  end;
end;

procedure TColorMapOptimizer.MapColors;
var
  i, j			: integer;
  Delta, BestDelta	: integer;
  BestIndex		: integer;
  MaxColors		: integer;
begin
  (*
  **  Sort by usage count
  *)
  FHistogram.Sort(CompareCount);

  (*
  ** Handle transparency
  *)
  if (FUseTransparency) then
    MaxColors := 255
  else
    MaxColors := 256;

  (*
  **  Determine number of colors used (max 256)
  *)
  FFinalCount := FHistogram.Count;
  for i := 0 to FFinalCount-1 do
    if (i >= MaxColors) or (POptimizeEntry(FHistogram[i])^.Count = 0) then
    begin
      FFinalCount := i;
      break;
    end;

  (*
  **  Build color map and reverse map for final entries
  *)
  for i := 0 to FFinalCount-1 do
  begin
    POptimizeEntry(FHistogram[i])^.NewIndex := i;
    FColorMap[i] := POptimizeEntry(FHistogram[i])^.Color.Color;
  end;

  (*
  **  Map colors > 256 to colors <= 256 and build NewIndex color map
  *)
  for i := FFinalCount to FHistogram.Count-1 do
    with POptimizeEntry(FHistogram[i])^ do
    begin
      // Entries with a usage count of -1 is unused
      ASSERT(Count <> -1, 'Internal error: Unused entry exported');
      // Entries with a usage count of 0 has been merged with another entry
      if (Count = 0) then
      begin
        // Use mapping of master entry
        ASSERT(Color.SameAs.NewIndex < 256, 'Internal error: Mapping to unmapped color');
        NewIndex := Color.SameAs.NewIndex;
      end else
      begin
        // Search for entry with nearest color value
        BestIndex := 0;
        BestDelta := 255*3;
        for j := 0 to FFinalCount-1 do
        begin
          Delta := ABS((POptimizeEntry(FHistogram[j])^.Color.Color.Red - Color.Color.Red) +
            (POptimizeEntry(FHistogram[j])^.Color.Color.Green - Color.Color.Green) +
            (POptimizeEntry(FHistogram[j])^.Color.Color.Blue - Color.Color.Blue));
          if (Delta < BestDelta) then
          begin
            BestDelta := Delta;
            BestIndex := j;
          end;
        end;
        NewIndex := POptimizeEntry(FHistogram[BestIndex])^.NewIndex;;
      end;
    end;

  (*
  ** Add transparency color to new color map
  *)
  if (FUseTransparency) then
  begin
    FNewTransparentColorIndex := FFinalCount;
    FColorMap[FFinalCount].Red := 0;
    FColorMap[FFinalCount].Green := 0;
    FColorMap[FFinalCount].Blue := 0;
    inc(FFinalCount);
  end;
end;

procedure TColorMapOptimizer.ReplaceColorMaps;
var
  i			: integer;
begin
  // Zap all local color maps
  for i := 0 to FImage.Images.Count-1 do
    if (FImage.Images[i].ColorMap <> nil) then
      FImage.Images[i].ColorMap.Clear;
  // Store optimized global color map
  FImage.GlobalColorMap.ImportColorMap(FColorMap, FFinalCount);
  FImage.GlobalColorMap.Optimized := True;
end;

procedure TColorMapOptimizer.Optimize;
var
  Total			: integer;
  i, j			: integer;
begin
  // Stop all painters during optimize...
  FImage.PaintStop;
  // ...and prevent any new from starting while we are doing our thing
  FImage.Painters.LockList;
  try

    (*
    **  Process all sub images
    *)
    ProcessImage;

    // Prune histograms and calculate total number of colors
    Total := 0;
    for i := 0 to FHistogramList.Count-1 do
      inc(Total, THistogram(FHistogramList[i]).Prune);

    // Allocate global histogram
    FHistogram.Clear;
    FHistogram.Capacity := Total;

    // Move data pointers from local histograms to global histogram
    for i := 0 to FHistogramList.Count-1 do
      with THistogram(FHistogramList[i]) do
        for j := 0 to Count-1 do
        begin
          ASSERT(POptimizeEntry(List[j])^.Count > 0, 'Unused entry exported from THistogram');
          FHistogram.Add(List[j]);
        end;

    (*
    **  Merge same colors
    *)
    MergeColors;

    (*
    **  Build color map and NewIndex map for final entries
    *)
    MapColors;

    (*
    **  Replace local colormaps with global color map
    *)
    ReplaceColorMaps;

    (*
    **  Process images for each color map
    *)
    for i := 0 to FHistogramList.Count-1 do
      THistogram(FHistogramList[i]).MapImages(FUseTransparency, FNewTransparentColorIndex);

    (*
    **  Delete the frame's old bitmaps and palettes
    *)
    for i := 0 to FImage.Images.Count-1 do
    begin
      FImage.Images[i].HasBitmap := False;
      FImage.Images[i].Palette := 0;
    end;

  finally
    FImage.Painters.UnlockList;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFImage
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFImage.Create;
begin
  inherited Create;
  FImages := TGIFImageList.Create(self);
  FHeader := TGIFHeader.Create(self);
  FPainters := TThreadList.Create;
  FGlobalPalette := 0;
  // Load defaults
  FDrawOptions := GIFImageDefaultDrawOptions;
  ColorReduction := GIFImageDefaultColorReduction;
  FReductionBits := GIFImageDefaultColorReductionBits;
  FDitherMode := GIFImageDefaultDitherMode;
  FCompression := GIFImageDefaultCompression;
  FThreadPriority := GIFImageDefaultThreadPriority;
  FAnimationSpeed := GIFImageDefaultAnimationSpeed;

  FDrawBackgroundColor := clNone;
  IsDrawing := False;
  IsInsideGetPalette := False;
  NewImage;
end;

destructor TGIFImage.Destroy;
var
  i			: integer;
begin
  PaintStop;
  with FPainters.LockList do
    try
      for i := Count-1 downto 0 do
        TGIFPainter(Items[i]).FImage := nil;
    finally
      FPainters.UnLockList;
    end;

  Clear;
  FPainters.Free;
  FImages.Free;
  FHeader.Free;
  inherited Destroy;
end;

procedure TGIFImage.Clear;
begin
  PaintStop;
  FreeBitmap;
  FImages.Clear;
  FHeader.ColorMap.Clear;
  FHeader.Height := 0;
  FHeader.Width := 0;
  FHeader.Prepare;
  Palette := 0;
end;

procedure TGIFImage.NewImage;
begin
  Clear;
end;

function TGIFImage.GetVersion: TGIFVersion;
var
  v			: TGIFVersion;
  i			: integer;
begin
  Result := gvUnknown;
  for i := 0 to FImages.Count-1 do
  begin
    v := FImages[i].Version;
    if (v > Result) then
      Result := v;
    if (v >= high(TGIFVersion)) then
      break;
  end;
end;

function TGIFImage.GetColorResolution: integer;
var
  i			: integer;
begin
  Result := FHeader.ColorResolution;
  for i := 0 to FImages.Count-1 do
    if (FImages[i].ColorResolution > Result) then
      Result := FImages[i].ColorResolution;
end;

function TGIFImage.GetBitsPerPixel: integer;
var
  i			: integer;
begin
  Result := FHeader.BitsPerPixel;
  for i := 0 to FImages.Count-1 do
    if (FImages[i].BitsPerPixel > Result) then
      Result := FImages[i].BitsPerPixel;
end;

function TGIFImage.GetBackgroundColorIndex: BYTE;
begin
  Result := FHeader.BackgroundColorIndex;
end;

procedure TGIFImage.SetBackgroundColorIndex(const Value: BYTE);
begin
  FHeader.BackgroundColorIndex := Value;
end;

function TGIFImage.GetBackgroundColor: TColor;
begin
  Result := FHeader.BackgroundColor;
end;

procedure TGIFImage.SetBackgroundColor(const Value: TColor);
begin
  FHeader.BackgroundColor := Value;
end;

function TGIFImage.GetAspectRatio: BYTE;
begin
  Result := FHeader.AspectRatio;
end;

procedure TGIFImage.SetAspectRatio(const Value: BYTE);
begin
  FHeader.AspectRatio := Value;
end;

procedure TGIFImage.SetDrawOptions(Value: TGIFDrawOptions);
begin
  if (FDrawOptions = Value) then
    exit;

  if (DrawPainter <> nil) then
    DrawPainter.Stop;

  FDrawOptions := Value;
  // Zap all bitmaps
  Pack;
  Changed(self);
end;

function TGIFImage.GetAnimate: Boolean;
begin  // 2002.07.07
  Result:= goAnimate in DrawOptions;
end;

procedure TGIFImage.SetAnimate(const Value: Boolean);
begin  // 2002.07.07
  if Value then
    DrawOptions:= DrawOptions + [goAnimate]
  else
    DrawOptions:= DrawOptions - [goAnimate];
end;

procedure TGIFImage.SetAnimationSpeed(Value: integer);
begin
  if (Value < 0) then
    Value := 0
  else if (Value > 1000) then
    Value := 1000;
  if (Value <> FAnimationSpeed) then
  begin
    FAnimationSpeed := Value;
    // Use the FPainters threadlist to protect FDrawPainter from being modified
    // by the thread while we mess with it
    with FPainters.LockList do
      try
        if (FDrawPainter <> nil) then
          FDrawPainter.AnimationSpeed := FAnimationSpeed;
      finally
        // Release the lock on FPainters to let paint thread kill itself
        FPainters.UnLockList;
      end;
  end;
end;

procedure TGIFImage.SetReductionBits(Value: integer);
begin
  if (Value < 3) or (Value > 8) then
    Error(sInvalidBitSize);
  FReductionBits := Value;
end;

procedure TGIFImage.OptimizeColorMap;
var
  ColorMapOptimizer	: TColorMapOptimizer;
begin
  ColorMapOptimizer := TColorMapOptimizer.Create(self);
  try
    ColorMapOptimizer.Optimize;
  finally
    ColorMapOptimizer.Free;
  end;
end;

procedure TGIFImage.Optimize(Options: TGIFOptimizeOptions;
  ColorReduction: TColorReduction; DitherMode: TDitherMode;
  ReductionBits: integer);
var
  i			,
  j			: integer;
  Delay			: integer;
  GCE			: TGIFGraphicControlExtension;
  ThisRect		,
  NextRect		,
  MergeRect		: TRect;
  Prog			,
  MaxProg		: integer;

  function Scan(Buf: PChar; Value: Byte; Count: integer): boolean; assembler;
  asm
    PUSH	EDI
    MOV		EDI, Buf
    MOV		ECX, Count
    MOV		AL, Value
    REPNE	SCASB
    MOV		EAX, False
    JNE		@@1
    MOV		EAX, True
@@1:POP		EDI
  end;

begin
  if (Empty) then
    exit;
  // Stop all painters during optimize...
  PaintStop;
  // ...and prevent any new from starting while we are doing our thing
  FPainters.LockList;
  try
    Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressOptimizing);
    try

      Prog := 0;
      MaxProg := Images.Count*6;

      // Sort color map by usage and remove unused entries
      if (ooColorMap in Options) then
      begin
        // Optimize global color map
        if (GlobalColorMap.Count > 0) then
          GlobalColorMap.Optimize;
        // Optimize local color maps
        for i := 0 to Images.Count-1 do
        begin
          inc(Prog);
          if (Images[i].ColorMap.Count > 0) then
          begin
            Images[i].ColorMap.Optimize;
            Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
              Rect(0,0,0,0), sProgressOptimizing);
          end;
        end;
      end;

      // Remove passive elements, pass 1
      if (ooCleanup in Options) then
      begin
        // Check for transparency flag without any transparent pixels
        for i := 0 to Images.Count-1 do
        begin
          inc(Prog);
          if (Images[i].Transparent) then
          begin
            if not(Scan(Images[i].Data,
                        Images[i].GraphicControlExtension.TransparentColorIndex,
                        Images[i].DataSize)) then
            begin
              Images[i].GraphicControlExtension.Transparent := False;
              Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
                Rect(0,0,0,0), sProgressOptimizing);
            end;
          end;
        end;

        // Change redundant disposal modes
        for i := 0 to Images.Count-2 do
        begin
          inc(Prog);
          if (Images[i].GraphicControlExtension <> nil) and
            (Images[i].GraphicControlExtension.Disposal in [dmPrevious, dmBackground]) and
            (not Images[i+1].Transparent) then
          begin
            ThisRect := Images[i].BoundsRect;
            NextRect := Images[i+1].BoundsRect;
            if (not IntersectRect(MergeRect, ThisRect, NextRect)) then
              continue;
            // If the next frame completely covers the current frame,
            // change the disposal mode to dmNone
            if (EqualRect(MergeRect, NextRect)) then
              Images[i].GraphicControlExtension.Disposal := dmNone;
            Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
              Rect(0,0,0,0), sProgressOptimizing);
          end;
        end;
      end else
        inc(Prog, 2*Images.Count);

      // Merge layers of equal pixels (remove redundant pixels)
      if (ooMerge in Options) then
      begin
        // Merge from last to first to avoid intefering with merge
        for i := Images.Count-1 downto 1 do
        begin
          inc(Prog);
          j := i-1;
          // If the &quot;previous&quot; frames uses dmPrevious disposal mode, we must
          // instead merge with the frame before the previous
          while (j > 0) and
            ((Images[j].GraphicControlExtension <> nil) and
             (Images[j].GraphicControlExtension.Disposal = dmPrevious)) do
            dec(j);
          // Merge
          Images[i].Merge(Images[j]);
          Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
            Rect(0,0,0,0), sProgressOptimizing);
        end;
      end else
        inc(Prog, Images.Count);

      // Crop transparent areas
      if (ooCrop in Options) then
      begin
        for i := Images.Count-1 downto 0 do
        begin
          inc(Prog);
          if (not Images[i].Empty) and (Images[i].Transparent) then
          begin
            // Remember frames delay in case frame is deleted
            Delay := Images[i].GraphicControlExtension.Delay;
            // Crop
            Images[i].Crop;
            // If the frame was completely transparent we remove it
            if (Images[i].Empty) then
            begin
              // Transfer delay to previous frame in case frame was deleted
              if (i > 0) and (Images[i-1].Transparent) then
                Images[i-1].GraphicControlExtension.Delay :=
                  Images[i-1].GraphicControlExtension.Delay + Delay;
              Images.Delete(i);
            end;
            Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
              Rect(0,0,0,0), sProgressOptimizing);
          end;
        end;
      end else
        inc(Prog, Images.Count);

      // Remove passive elements, pass 2
      inc(Prog, Images.Count);
      if (ooCleanup in Options) then
      begin
        for i := Images.Count-1 downto 0 do
        begin
          // Remove comments and application extensions
          for j := Images[i].Extensions.Count-1 downto 0 do
            if (Images[i].Extensions[j] is TGIFCommentExtension) or
              (Images[i].Extensions[j] is TGIFTextExtension) or
              (Images[i].Extensions[j] is TGIFUnknownAppExtension) or
              ((Images[i].Extensions[j] is TGIFAppExtNSLoop) and
               ((i > 0) or (Images.Count = 1))) then
              Images[i].Extensions.Delete(j);
          if (Images[i].GraphicControlExtension <> nil) then
          begin
            GCE := Images[i].GraphicControlExtension;
            // Zap GCE if all of the following are true:
            // * No delay or only one image
            // * Not transparent
            // * No prompt
            // * No disposal or only one image
            if ((GCE.Delay = 0) or (Images.Count = 1)) and
              (not GCE.Transparent) and
              (not GCE.UserInput) and
              ((GCE.Disposal in [dmNone, dmNoDisposal]) or (Images.Count = 1)) then
            begin
              GCE.Free;
            end;
          end;
          // Zap frame if it has become empty
          if (Images[i].Empty) and (Images[i].Extensions.Count = 0) then
            Images[i].Free;
        end;
        Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
          Rect(0,0,0,0), sProgressOptimizing);
      end else

      // Reduce color depth
      if (ooReduceColors in Options) then
      begin
        if (ColorReduction = rmPalette) then
          Error(sInvalidReduction);
        { TODO -oanme -cFeature : Implement ooReduceColors option. }
        // Not implemented!
      end;
    finally
      if ExceptObject = nil then
        i := 100
      else
        i := 0;
      Progress(Self, psEnding, i, False, Rect(0,0,0,0), sProgressOptimizing);
    end;
  finally
    FPainters.UnlockList;
  end;
end;

procedure TGIFImage.Pack;
var
  i			: integer;
begin
  // Zap bitmaps and palettes
  FreeBitmap;
  Palette := 0;
  for i := 0 to FImages.Count-1 do
  begin
    FImages[i].Bitmap := nil;
    FImages[i].Palette := 0;
  end;

  // Only pack if no global colormap and a single image
  if (FHeader.ColorMap.Count > 0) or (FImages.Count <> 1) then
    exit;

  // Copy local colormap to global
  FHeader.ColorMap.Assign(FImages[0].ColorMap);
  // Zap local colormap
  FImages[0].ColorMap.Clear;
end;

procedure TGIFImage.SaveToStream(Stream: TStream);
var
  n			: Integer;
begin
  Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressSaving);
  try
    // Write header
    FHeader.SaveToStream(Stream);
    // Write images
    FImages.SaveToStream(Stream);
    // Write trailer
    with TGIFTrailer.Create(self) do
      try
        SaveToStream(Stream);
      finally
        Free;
      end;
  finally
    if ExceptObject = nil then
      n := 100
    else
      n := 0;
    Progress(Self, psEnding, n, True, Rect(0,0,0,0), sProgressSaving);
  end;
end;

procedure TGIFImage.LoadFromStream(Stream: TStream);
var
  n			: Integer;
  Position		: integer;
begin
  Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressLoading);
  try
    // Zap old image
    Clear;
    Position := Stream.Position;
    try
      // Read header
      FHeader.LoadFromStream(Stream);
      // Read images
      FImages.LoadFromStream(Stream, self);
      // Read trailer
      with TGIFTrailer.Create(self) do
        try
          LoadFromStream(Stream);
        finally
          Free;
        end;
    except
      // Restore stream position in case of error.
      // Not required, but &quot;a nice thing to do&quot;
      Stream.Position := Position;
      raise;
    end;
  finally
    if ExceptObject = nil then
      n := 100
    else
      n := 0;
    Progress(Self, psEnding, n, True, Rect(0,0,0,0), sProgressLoading);
  end;
end;

procedure TGIFImage.LoadFromResourceName(Instance: THandle; const ResName: String);
// 2002.07.07
var
  Stream: TCustomMemoryStream;
begin
  Stream := TResourceStream.Create(Instance, ResName, RT_RCDATA);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

function TGIFImage.GetBitmap: TBitmap;
begin
  if not(Empty) then
  begin
    Result := FBitmap;
    if (Result <> nil) then
      exit;
    FBitmap := TBitmap.Create;
    Result := FBitmap;
    FBitmap.OnChange := Changed;
    // Use first image as default
    if (Images.Count > 0) then
    begin
      if (Images[0].Width = Width) and (Images[0].Height = Height) then
      begin
        // Use first image as it has same dimensions
        FBitmap.Assign(Images[0].Bitmap);
      end else
      begin
        // Draw first image on bitmap
        FBitmap.Palette := CopyPalette(Palette);
        FBitmap.Height := Height;
        FBitmap.Width := Width;
        Images[0].Draw(FBitmap.Canvas, FBitmap.Canvas.ClipRect, False, False);
      end;
    end;
  end else
    Result := nil
end;

// Create a new (empty) bitmap
function TGIFImage.NewBitmap: TBitmap;
begin
  Result := FBitmap;
  if (Result <> nil) then
    exit;
  FBitmap := TBitmap.Create;
  Result := FBitmap;
  FBitmap.OnChange := Changed;
  // Draw first image on bitmap
  FBitmap.Palette := CopyPalette(Palette);
  FBitmap.Height := Height;
  FBitmap.Width := Width;
end;

procedure TGIFImage.FreeBitmap;
begin
  if (DrawPainter <> nil) then
    DrawPainter.Stop;

  if (FBitmap <> nil) then
  begin
    FBitmap.Free;
    FBitmap := nil;
  end;
end;

function TGIFImage.Add(Source: TPersistent): integer;
var
  Image			: TGIFSubImage;
begin
  Image := nil; // To avoid compiler warning - not needed.
  if (Source is TGraphic) then
  begin
    Image := TGIFSubImage.Create(self);
    try
      Image.Assign(Source);
      // ***FIXME*** Documentation should explain the inconsistency here:
      // TGIFimage does not take ownership of Source after TGIFImage.Add() and
      // therefore does not delete Source.
    except
      Image.Free;
      raise;
    end;
  end else
  if (Source is TGIFSubImage) then
    Image := TGIFSubImage(Source)
  else
    Error(sUnsupportedClass);

  Result := FImages.Add(Image);

  FreeBitmap;
  Changed(self);
end;

function TGIFImage.GetEmpty: Boolean;
begin
  Result := (FImages.Count = 0);
end;

function TGIFImage.GetHeight: Integer;
begin
  Result := FHeader.Height;
end;

function TGIFImage.GetWidth: Integer;
begin
  Result := FHeader.Width;
end;

function TGIFImage.GetIsTransparent: Boolean;
var
  i			: integer;
begin
  Result := False;
  for i := 0 to Images.Count-1 do
    if (Images[i].GraphicControlExtension <> nil) and
      (Images[i].GraphicControlExtension.Transparent) then
    begin
      Result := True;
      exit;
    end;
end;

function TGIFImage.Equals(Graphic: TGraphic): Boolean;
begin
  Result := (Graphic = self);
end;

function TGIFImage.GetPalette: HPALETTE;
begin
  // Check for recursion
  // (TGIFImage.GetPalette->TGIFSubImage.GetPalette->TGIFImage.GetPalette etc...)
  if (IsInsideGetPalette) then
    Error(sNoColorTable);
  IsInsideGetPalette := True;
  try
    Result := 0;
    if (FBitmap <> nil) and (FBitmap.Palette <> 0) then
      // Use bitmaps own palette if possible
      Result := FBitmap.Palette
    else if (FGlobalPalette <> 0) then
      // Or a previously exported global palette
      Result := FGlobalPalette
    else if (DoDither) then
    begin
      // or create a new dither palette
      FGlobalPalette := WebPalette;
      Result := FGlobalPalette;
    end else
    if (FHeader.ColorMap.Count > 0) then
    begin
      // or create a new if first time
      FGlobalPalette := FHeader.ColorMap.ExportPalette;
      Result := FGlobalPalette;
    end else
    if (FImages.Count > 0) then
      // This can cause a recursion if no global palette exist and image[0]
      // hasn't got one either. Checked by the IsInsideGetPalette semaphor.
      Result := FImages[0].Palette;
  finally
    IsInsideGetPalette := False;
  end;
end;

procedure TGIFImage.SetPalette(Value: HPalette);
var
  NeedNewBitmap		: boolean;
begin
  if (Value <> FGlobalPalette) then
  begin
    // Zap old palette
    if (FGlobalPalette <> 0) then
      DeleteObject(FGlobalPalette);

    // Zap bitmap unless new palette is same as bitmaps own
    NeedNewBitmap := (FBitmap <> nil) and (Value <> FBitmap.Palette);

    // Use new palette
    FGlobalPalette := Value;

    if (NeedNewBitmap) then
    begin
      // Need to create new bitmap and repaint
      FreeBitmap;
      PaletteModified := True;
      Changed(Self);
    end;
  end;
end;

// Obsolete
// procedure TGIFImage.Changed(Sender: TObject);
// begin
//  inherited Changed(Sender);
// end;

procedure TGIFImage.SetHeight(Value: Integer);
var
  i			: integer;
begin
  for i := 0 to Images.Count-1 do
    if (Images[i].Top + Images[i].Height > Value) then
      Error(sBadHeight);
  if (Value <> Header.Height) then
  begin
    Header.Height := Value;
    FreeBitmap;
    Changed(self);
  end;
end;

procedure TGIFImage.SetWidth(Value: Integer);
var
  i			: integer;
begin
  for i := 0 to Images.Count-1 do
    if (Images[i].Left + Images[i].Width > Value) then
      Error(sBadWidth);
  if (Value <> Header.Width) then
  begin
    Header.Width := Value;
    FreeBitmap;
    Changed(self);
  end;
end;

procedure TGIFImage.WriteData(Stream: TStream);
begin
  if (GIFImageOptimizeOnStream) then
    Optimize([ooCrop, ooMerge, ooCleanup, ooColorMap, ooReduceColors], rmNone, dmNearest, 8);

  inherited WriteData(Stream);
end;

procedure TGIFImage.AssignTo(Dest: TPersistent);
begin
  if (Dest is TBitmap) then
    Dest.Assign(Bitmap)
  else
    inherited AssignTo(Dest);
end;

{ TODO 1 -oanme -cImprovement : Better handling of TGIFImage.Assign(Empty TBitmap). }
procedure TGIFImage.Assign(Source: TPersistent);
var
  i			: integer;
  Image			: TGIFSubImage;
begin
  if (Source = self) then
    exit;
  if (Source = nil) then
  begin
    Clear;
  end else
  //
  // TGIFImage import
  //
  if (Source is TGIFImage) then
  begin
    Clear;
    // Temporarily copy event handlers to be able to generate progress events
    // during the copy and handle copy errors
    OnProgress := TGIFImage(Source).OnProgress;
    try
      FOnWarning := TGIFImage(Source).OnWarning;
      Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressCopying);
      try
        FHeader.Assign(TGIFImage(Source).Header);
        FThreadPriority := TGIFImage(Source).ThreadPriority;
        FDrawBackgroundColor := TGIFImage(Source).DrawBackgroundColor;
        FDrawOptions := TGIFImage(Source).DrawOptions;
        FColorReduction := TGIFImage(Source).ColorReduction;
        FDitherMode := TGIFImage(Source).DitherMode;
// 2002.07.07 ->
        FOnWarning:= TGIFImage(Source).FOnWarning;
        FOnStartPaint:= TGIFImage(Source).FOnStartPaint;
        FOnPaint:= TGIFImage(Source).FOnPaint;
        FOnEndPaint:= TGIFImage(Source).FOnEndPaint;
        FOnAfterPaint:= TGIFImage(Source).FOnAfterPaint;
        FOnLoop:= TGIFImage(Source).FOnLoop;
// 2002.07.07 <-
        for i := 0 to TGIFImage(Source).Images.Count-1 do
        begin
          Image := TGIFSubImage.Create(self);
          Image.Assign(TGIFImage(Source).Images[i]);
          Add(Image);
          Progress(Self, psRunning, MulDiv((i+1), 100, TGIFImage(Source).Images.Count),
            False, Rect(0,0,0,0), sProgressCopying);
        end;
      finally
        if ExceptObject = nil then
          i := 100
        else
          i := 0;
        Progress(Self, psEnding, i, False, Rect(0,0,0,0), sProgressCopying);
      end;
    finally
      // Reset event handlers
      FOnWarning := nil;
      OnProgress := nil;
    end;
  end else
  //
  // Import via TGIFSubImage.Assign
  //
  begin
    Clear;
    Image := TGIFSubImage.Create(self);
    try
      Image.Assign(Source);
      Add(Image);
    except
      on E: EConvertError do
      begin
        Image.Free;
        // Unsupported format - fall back to Source.AssignTo
        inherited Assign(Source);
      end;
    else
      // Unknown conversion error
      Image.Free;
      raise;
    end;
  end;
end;

procedure TGIFImage.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
{$IFDEF REGISTER_TGIFIMAGE}
var
  Size			: Longint;
  Buffer		: Pointer;
  Stream		: TMemoryStream;
  Bmp			: TBitmap;
{$ENDIF}  // 2002.07.07
begin  // 2002.07.07
{$IFDEF REGISTER_TGIFIMAGE}  // 2002.07.07
  if (AData = 0) then
    AData := GetClipboardData(AFormat);
  if (AData <> 0) and (AFormat = CF_GIF) then
  begin
    // Get size and pointer to data
    Size := GlobalSize(AData);
    Buffer := GlobalLock(AData);
    try
      Stream := TMemoryStream.Create;
      try
        // Copy data to a stream
        Stream.SetSize(Size);
        Move(Buffer^, Stream.Memory^, Size);
        // Load GIF from stream
        LoadFromStream(Stream);
      finally
        Stream.Free;
      end;
    finally
      GlobalUnlock(AData);
    end;
  end else
  if (AData <> 0) and (AFormat = CF_BITMAP) then
  begin
    // No GIF on clipboard - try loading a bitmap instead
    Bmp := TBitmap.Create;
    try
      Bmp.LoadFromClipboardFormat(AFormat, AData, APalette);
      Assign(Bmp);
    finally
      Bmp.Free;
    end;
  end else
    Error(sUnknownClipboardFormat);
{$ELSE}  // 2002.07.07
  Error(sGIFToClipboard);  // 2002.07.07
{$ENDIF}  // 2002.07.07
end;

procedure TGIFImage.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  var APalette: HPALETTE);
{$IFDEF REGISTER_TGIFIMAGE}
var
  Stream		: TMemoryStream;
  Data			: THandle;
  Buffer		: Pointer;
{$ENDIF}  // 2002.07.07
begin  // 2002.07.07
{$IFDEF REGISTER_TGIFIMAGE}  // 2002.07.07
  if (Empty) then
    exit;
  // First store a bitmap version on the clipboard...
  Bitmap.SaveToClipboardFormat(AFormat, AData, APalette);
  // ...then store a GIF
  Stream := TMemoryStream.Create;
  try
    // Save the GIF to a memory stream
    SaveToStream(Stream);
    Stream.Position := 0;
    // Allocate some memory for the GIF data
    Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
    try
      if (Data <> 0) then
      begin
        Buffer := GlobalLock(Data);
        try
          // Copy GIF data from stream memory to clipboard memory
          Move(Stream.Memory^, Buffer^, Stream.Size);
        finally
          GlobalUnlock(Data);
        end;
        // Transfer data to clipboard
        if (SetClipboardData(CF_GIF, Data) = 0) then
          Error(sFailedPaste);
      end;
    except
      GlobalFree(Data);
      raise;
    end;
  finally
    Stream.Free;
  end;
{$ELSE}  // 2002.07.07
  Error(sGIFToClipboard);  // 2002.07.07
{$ENDIF}  // 2002.07.07
end;

function TGIFImage.GetColorMap: TGIFColorMap;
begin
  Result := FHeader.ColorMap;
end;

function TGIFImage.GetDoDither: boolean;
begin
  Result := (goDither in DrawOptions) and
    (((goAutoDither in DrawOptions) and DoAutoDither) or
      not(goAutoDither in DrawOptions));
end;

{$IFDEF VER9x}
procedure TGIFImage.Progress(Sender: TObject; Stage: TProgressStage;
  PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
  if Assigned(FOnProgress) then
    FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;
{$ENDIF}

procedure TGIFImage.StopDraw;
{$IFNDEF VER14_PLUS}  // 2001.07.23
var
  Msg			: TMsg;
  ThreadWindow		: HWND;
{$ENDIF}  // 2001.07.23
begin
  repeat
    // Use the FPainters threadlist to protect FDrawPainter from being modified
    // by the thread while we mess with it
    with FPainters.LockList do
      try
        if (FDrawPainter = nil) then
          break;

        // Tell thread to terminate
        FDrawPainter.Stop;

        // No need to wait for &quot;thread&quot; to terminate if running in main thread
        if not(goAsync in FDrawPainter.DrawOptions) then
          break;

      finally
        // Release the lock on FPainters to let paint thread kill itself
        FPainters.UnLockList;
      end;

{$IFDEF VER14_PLUS}
// 2002.07.07
    if (GetCurrentThreadID = MainThreadID) then
      while CheckSynchronize do {loop};
{$ELSE}
    // Process Messages to make Synchronize work
    // (Instead of Application.ProcessMessages)
//{$IFDEF VER14_PLUS}  // 2001.07.23
//    Break;  // 2001.07.23
//    Sleep(0); // Yield  // 2001.07.23
//{$ELSE}  // 2001.07.23
    ThreadWindow := FindWindow('TThreadWindow', nil);
    while PeekMessage(Msg, ThreadWindow, CM_DESTROYWINDOW, CM_EXECPROC, PM_REMOVE) do
    begin
      if (Msg.Message <> WM_QUIT) then
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end else
      begin
        PostQuitMessage(Msg.WParam);
        exit;
      end;
    end;
{$ENDIF}  // 2001.07.23
    Sleep(0); // Yield

  until (False);
  FreeBitmap;
end;

procedure TGIFImage.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  Canvas		: TCanvas;
  DestRect		: TRect;
{$IFNDEF VER14_PLUS}  // 2001.07.23
  Msg			: TMsg;
  ThreadWindow		: HWND;
{$ENDIF}  // 2001.07.23

  procedure DrawTile(Rect: TRect; Bitmap: TBitmap);
  var
    Tile		: TRect;
  begin
    if (goTile in FDrawOptions) then
    begin
      // Note: This design does not handle transparency correctly!
      Tile.Left := Rect.Left;
      Tile.Right := Tile.Left + Width;
      while (Tile.Left < Rect.Right) do
      begin
        Tile.Top := Rect.Top;
        Tile.Bottom := Tile.Top + Height;
        while (Tile.Top < Rect.Bottom) do
        begin
          ACanvas.StretchDraw(Tile, Bitmap);
          Tile.Top := Tile.Top + Height;
          Tile.Bottom := Tile.Top + Height;
        end;
        Tile.Left := Tile.Left + Width;
        Tile.Right := Tile.Left + Width;
      end;
    end else
      ACanvas.StretchDraw(Rect, Bitmap);
  end;

begin
  // Prevent recursion(s(s(s)))
  if (IsDrawing) or (FImages.Count = 0) then
    exit;

  IsDrawing := True;
  try
    // Copy bitmap to canvas if we are already drawing
    // (or have drawn but are finished)
    if (FImages.Count = 1) or // Only one image
      (not (goAnimate in FDrawOptions)) then // Don't animate
    begin
      FImages[0].Draw(ACanvas, Rect, (goTransparent in FDrawOptions),
        (goTile in FDrawOptions));
      exit;
    end else
    if (FBitmap <> nil) and not(goDirectDraw in FDrawOptions) then
    begin
      DrawTile(Rect, Bitmap);
      exit;
    end;

    // Use the FPainters threadlist to protect FDrawPainter from being modified
    // by the thread while we mess with it
    with FPainters.LockList do
      try
      // If we are already painting on the canvas in goDirectDraw mode
      // and at the same location, just exit and let the painter do
      // its thing when it's ready
      if (FDrawPainter <> nil) and (FDrawPainter.Canvas = ACanvas) and
        EqualRect(FDrawPainter.Rect, Rect) then
        exit;

      // Kill the current paint thread
      StopDraw;

      if not(goDirectDraw in FDrawOptions) then
      begin
        // Create a bitmap to draw on
        NewBitmap;
        Canvas := FBitmap.Canvas;
        DestRect := Canvas.ClipRect;
        // Initialize bitmap canvas with background image
        Canvas.CopyRect(DestRect, ACanvas, Rect);
      end else
      begin
        Canvas := ACanvas;
        DestRect := Rect;
      end;

      // Create new paint thread
      InternalPaint(@FDrawPainter, Canvas, DestRect, FDrawOptions);

      if (FDrawPainter <> nil) then
      begin
        // Launch thread
        FDrawPainter.Start;

        if not(goDirectDraw in FDrawOptions) then
        begin
{$IFDEF VER14_PLUS}
// 2002.07.07
          while (FDrawPainter <> nil) and (not FDrawPainter.Terminated) and
            (not FDrawPainter.Started) do
          begin
            if not CheckSynchronize then
              Sleep(0); // Yield
          end;
{$ELSE}
//{$IFNDEF VER14_PLUS}  // 2001.07.23
          ThreadWindow := FindWindow('TThreadWindow', nil);
          // Wait for thread to render first frame
          while (FDrawPainter <> nil) and (not FDrawPainter.Terminated) and
            (not FDrawPainter.Started) do
            // Process Messages to make Synchronize work
            // (Instead of Application.ProcessMessages)
            if PeekMessage(Msg, ThreadWindow, CM_DESTROYWINDOW, CM_EXECPROC, PM_REMOVE) then
            begin
              if (Msg.Message <> WM_QUIT) then
              begin
                TranslateMessage(Msg);
                DispatchMessage(Msg);
              end else
              begin
                PostQuitMessage(Msg.WParam);
                exit;
              end;
            end else
              Sleep(0); // Yield
{$ENDIF}  // 2001.07.23
          // Draw frame to destination
          DrawTile(Rect, Bitmap);
        end;
      end;
    finally
      FPainters.UnLockList;
    end;

  finally
    IsDrawing := False;
  end;
end;

// Internal pain(t) routine used by Draw()
function TGIFImage.InternalPaint(Painter: PGifPainter; ACanvas: TCanvas;
  const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
begin
  if (Empty) or (Rect.Left >= Rect.Right) or (Rect.Top >= Rect.Bottom) then
  begin
    Result := nil;
    if (Painter <> nil) then
      Painter^ := Result;
    exit;
  end;

  // Draw in main thread if only one image
  if (Images.Count = 1) then
    Options := Options - [goAsync, goAnimate];

  Result := TGIFPainter.CreateRef(Painter, self, ACanvas, Rect, Options);
  FPainters.Add(Result);
  Result.OnStartPaint := FOnStartPaint;
  Result.OnPaint := FOnPaint;
  Result.OnAfterPaint := FOnAfterPaint;
  Result.OnLoop := FOnLoop;
  Result.OnEndPaint := FOnEndPaint;

  if not(goAsync in Options) then
  begin
    // Run in main thread
    Result.Execute;
    // Note: Painter threads executing in the main thread are freed upon exit
    // from the Execute method, so no need to do it here.
    Result := nil;
    if (Painter <> nil) then
      Painter^ := Result;
  end else
    Result.Priority := FThreadPriority;
end;

function TGIFImage.Paint(ACanvas: TCanvas; const Rect: TRect;
  Options: TGIFDrawOptions): TGIFPainter;
begin
  Result := InternalPaint(nil, ACanvas, Rect, Options);
  if (Result <> nil) then
    // Run in separate thread
    Result.Start;
end;

procedure TGIFImage.PaintStart;
var
  i			: integer;
begin
  with FPainters.LockList do
    try
      for i := 0 to Count-1 do
        TGIFPainter(Items[i]).Start;
    finally
      FPainters.UnLockList;
    end;
end;

procedure TGIFImage.PaintStop;
var
  Ghosts		: integer;
  i			: integer;
{$IFNDEF VER14_PLUS}  // 2001.07.23
  Msg			: TMsg;
  ThreadWindow		: HWND;
{$ENDIF}  // 2001.07.23

{$IFNDEF VER14_PLUS}  // 2001.07.23
  procedure KillThreads;
  var
    i			: integer;
  begin
    with FPainters.LockList do
      try
        for i := Count-1 downto 0 do
          if (goAsync in TGIFPainter(Items[i]).DrawOptions) then
          begin
            TerminateThread(TGIFPainter(Items[i]).Handle, 0);
            Delete(i);
          end;
      finally
        FPainters.UnLockList;
      end;
  end;
{$ENDIF}  // 2001.07.23

begin
  try
    // Loop until all have died
    repeat
      with FPainters.LockList do
        try
          if (Count = 0) then
            exit;

          // Signal painters to terminate
          // Painters will attempt to remove them self from the
          // painter list when they die
          Ghosts := Count;
          for i := Ghosts-1 downto 0 do
          begin
            if not(goAsync in TGIFPainter(Items[i]).DrawOptions) then
              dec(Ghosts);
            TGIFPainter(Items[i]).Stop;
          end;
        finally
          FPainters.UnLockList;
        end;

      // If all painters were synchronous, there's no purpose waiting for them
      // to terminate, because they are running in the main thread.
      if (Ghosts = 0) then
        exit;
{$IFDEF VER14_PLUS}
// 2002.07.07
      if (GetCurrentThreadID = MainThreadID) then
        while CheckSynchronize do {loop};
{$ELSE}
      // Process Messages to make TThread.Synchronize work
      // (Instead of Application.ProcessMessages)
//{$IFDEF VER14_PLUS}  // 2001.07.23
//      Exit;  // 2001.07.23
//{$ELSE}  // 2001.07.23
      ThreadWindow := FindWindow('TThreadWindow', nil);
      if (ThreadWindow = 0) then
      begin
        KillThreads;
        Exit;
      end;
      while PeekMessage(Msg, ThreadWindow, CM_DESTROYWINDOW, CM_EXECPROC, PM_REMOVE) do
      begin
        if (Msg.Message <> WM_QUIT) then
        begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end else
        begin
          KillThreads;
          Exit;
        end;
      end;
{$ENDIF}  // 2001.07.23
      Sleep(0);
    until (False);
  finally
    FreeBitmap;
  end;
end;

procedure TGIFImage.PaintPause;
var
  i			: integer;
begin
  with FPainters.LockList do
    try
      for i := 0 to Count-1 do
        TGIFPainter(Items[i]).Suspend;
    finally
      FPainters.UnLockList;
    end;
end;

procedure TGIFImage.PaintResume;
var
  i			: integer;
begin
  // Implementation is currently same as PaintStart, but don't call PaintStart
  // in case its implementation changes
  with FPainters.LockList do
    try
      for i := 0 to Count-1 do
        TGIFPainter(Items[i]).Start;
    finally
      FPainters.UnLockList;
    end;
end;

procedure TGIFImage.PaintRestart;
var
  i			: integer;
begin
  with FPainters.LockList do
    try
      for i := 0 to Count-1 do
        TGIFPainter(Items[i]).Restart;
    finally
      FPainters.UnLockList;
    end;
end;

procedure TGIFImage.Warning(Sender: TObject; Severity: TGIFSeverity; Message: string);
begin
  if (Assigned(FOnWarning)) then
    FOnWarning(Sender, Severity, Message);
end;

{$IFDEF VER12_PLUS}
  {$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up  // 2001.07.23
type
  TDummyThread = class(TThread)
  protected
    procedure Execute; override;
  end;
procedure TDummyThread.Execute;
begin
end;
  {$ENDIF}  // 2001.07.23
{$ENDIF}

var
  DesktopDC: HDC;
{$IFDEF VER12_PLUS}
  {$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up  // 2001.07.23
  DummyThread: TThread;
  {$ENDIF}  // 2001.07.23
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//
//			Initialization
//
////////////////////////////////////////////////////////////////////////////////

initialization
{$IFDEF REGISTER_TGIFIMAGE}
  TPicture.RegisterFileFormat('GIF', sGIFImageFile, TGIFImage);
  CF_GIF := RegisterClipboardFormat(PChar(sGIFImageFile));
  TPicture.RegisterClipboardFormat(CF_GIF, TGIFImage);
{$ENDIF}
  DesktopDC := GetDC(0);
  try
    PaletteDevice := (GetDeviceCaps(DesktopDC, BITSPIXEL) * GetDeviceCaps(DesktopDC, PLANES) <= 8);
    DoAutoDither := PaletteDevice;
  finally
    ReleaseDC(0, DesktopDC);
  end;

{$IFDEF VER9x}
  // Note: This doesn't return the same palette as the Delphi 3 system palette
  // since the true system palette contains 20 entries and the Delphi 3 system
  // palette only contains 16.
  // For our purpose this doesn't matter since we do not care about the actual
  // colors (or their number) in the palette.
  // Stock objects doesn't have to be deleted.
  SystemPalette16 := GetStockObject(DEFAULT_PALETTE);
{$ENDIF}
{$IFDEF VER12_PLUS}
  // Make sure that at least one thread always exist.
  // This is done to circumvent a race condition bug in Delphi 4.x and later:
  // When threads are deleted and created in rapid succesion, a situation might
  // arise where the thread window is deleted *after* the threads it controls
  // has been created. See the Delphi Bug Lists for more information.
  {$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up  // 2001.07.23
  DummyThread := TDummyThread.Create(True);
  {$ENDIF}  // 2001.07.23
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//
//			Finalization
//
////////////////////////////////////////////////////////////////////////////////
finalization
  ExtensionList.Free;
  AppExtensionList.Free;
{$IFNDEF VER9x}
  {$IFDEF REGISTER_TGIFIMAGE}
    TPicture.UnregisterGraphicClass(TGIFImage);
  {$ENDIF}
  {$IFDEF VER100}
  if (pf8BitBitmap <> nil) then
    pf8BitBitmap.Free;
  {$ENDIF}
{$ENDIF}
{$IFDEF VER12_PLUS}
  {$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up  // 2001.07.23
  if (DummyThread <> nil) then
    DummyThread.Free;
  {$ENDIF}  // 2001.07.23
{$ENDIF}
end.