GifImage2.pas

unit GIFImage2;
{$ifdef BCB}
{$ObjExportAll On}
{$endif}

interface

{$DEFINE REGISTER_TGIFIMAGE}
{$DEFINE PIXELFORMAT_TOO_SLOW}
{$DEFINE CREATEDIBSECTION_SLOW}
{$DEFINE FIXHEADER_WIDTHHEIGHT_SILENT}
{$DEFINE DEFAULT_GOCLEARLOOP}

{$IFDEF VER130}
  {$DEFINE VER10_PLUS}
  {$DEFINE VER11_PLUS}
  {$DEFINE VER12_PLUS}
  {$DEFINE VER125_PLUS}
  {$DEFINE VER13_PLUS}
  {$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}

{$IFDEF VER140}
{$WARN SYMBOL_PLATFORM OFF}
  {$DEFINE VER10_PLUS}
  {$DEFINE VER11_PLUS}
  {$DEFINE VER12_PLUS}
  {$DEFINE VER125_PLUS}
  {$DEFINE VER13_PLUS}
  {$DEFINE VER14_PLUS}
  {$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}

{$IFDEF VER150}
{$WARN SYMBOL_PLATFORM OFF}
  {$DEFINE VER10_PLUS}
  {$DEFINE VER11_PLUS}
  {$DEFINE VER12_PLUS}
  {$DEFINE VER125_PLUS}
  {$DEFINE VER13_PLUS}
  {$DEFINE VER14_PLUS}
  {$DEFINE VER15_PLUS}
  {$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}

{$IFNDEF VER9x}
{$IFNDEF VER10_PLUS}
  {$WARN SYMBOL_PLATFORM OFF}
    {$DEFINE VER10_PLUS}
    {$DEFINE VER11_PLUS}
    {$DEFINE VER12_PLUS}
    {$DEFINE VER125_PLUS}
    {$DEFINE VER13_PLUS}
    {$DEFINE VER14_PLUS}
    {$DEFINE VER15_PLUS}
    {$DEFINE BAD_STACK_ALIGNMENT}
  {$ENDIF}
{$ENDIF}
{$A+,B-,H+,J+,K-,M-,T-,X+}

// Debug control - You can safely change these settings
{$IFDEF DEBUG}
  {$C+}	// ASSERTIONS
  {$O-}	// OPTIMIZATION
  {$Q+}	// OVERFLOWCHECKS
  {$R+}	// RANGECHECKS
{$ELSE}
  {$C-}	// ASSERTIONS
  {$IFDEF GIF_NOSAFETY}
    {$Q-}// OVERFLOWCHECKS
    {$R-}// RANGECHECKS
  {$ENDIF}
{$ENDIF}

// Special options for Time2Help parser
{$ifdef TIME2HELP}
{$UNDEF PIXELFORMAT_TOO_SLOW}
{$endif}
{$IFDEF VER230} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER330} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER320} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER310} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER300} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER290} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER280} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER270} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER260} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER250} {$DEFINE isVER230} {$ENDIF}
{$IFDEF VER240} {$DEFINE isVER230} {$ENDIF}
uses
  sysutils,
  Windows,
  AnsiStrings,
  Graphics,
  Types,
  Classes;

const
  GIFVersion		= $0202;
  GIFVersionMajor	= 2;
  GIFVersionMinor	= 2;
  GIFVersionRelease	= 5;

const
  GIFMaxColors	= 256;			// Max number of colors supported by GIF
  					// Don't bother changing this value!

  BitmapAllocationThreshold = 500000;	// Bitmap pixel count limit at which
  					// a newly allocated bitmap will be
                                        // converted to 1 bit format before
                                        // being resized and converted to 8 bit.

var
{$IFDEF FAST_AS_HELL}
  GIFDelayExp: integer = 10;		// Delay multiplier in mS.
{$ELSE}
  GIFDelayExp: integer = 12;		// Delay multiplier in mS. Tweaked.
{$ENDIF}

  GIFDefaultDelay: integer = 10;	// * GIFDefaultDelay:
  					// Default animation delay.
  					// This value is used if no GCE is
                                        // defined.
                                        // (10 = 100 mS)

{$IFDEF FAST_AS_HELL}
  GIFMinimumDelay: integer = 1;		// Minimum delay (from Mozilla source).
  					// (1 = 10 mS)
{$ELSE}
  GIFMinimumDelay: integer = 3;		// Minimum delay - Tweaked.
{$ENDIF}

  GIFMaximumDelay: integer = 1000;	// * GIFMaximumDelay:

type
  TGIFVersion = (gvUnknown, gv87a, gv89a);
  TGIFVersionRec = array[0..2] of ansichar;

const
  GIFVersions : array[gv87a..gv89a] of TGIFVersionRec = ('87a', '89a');

type
  // TGIFImage mostly throws exceptions of type GIFException
  GIFException = class(EInvalidGraphic);

  // Severity level as indicated in the Warning methods and the OnWarning event
  TGIFSeverity = (gsInfo, gsWarning, gsError);

{$IFDEF VER9x}
// Delphi 2 doesn't support TBitmap.PixelFormat
{$DEFINE PIXELFORMAT_TOO_SLOW}
type
  // TThreadList from Delphi 3 classes.pas
  TThreadList = class
  private
    FList: TList;
    FLock: TRTLCriticalSection;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Add(Item: Pointer);
    procedure Clear;
    function  LockList: TList;
    procedure Remove(Item: Pointer);
    procedure UnlockList;
  end;

  // From Delphi 3 sysutils.pas
  EOutOfMemory = class(Exception);

  // From Delphi 3 classes.pas
  EOutOfResources = class(EOutOfMemory);

  // From Delphi 3 windows.pas
  PMaxLogPalette = ^TMaxLogPalette;
  TMaxLogPalette = packed record
    palVersion: Word;
    palNumEntries: Word;
    palPalEntry: array [Byte] of TPaletteEntry;
  end; { TMaxLogPalette }

  // From Delphi 3 graphics.pas. Used by the D3 TGraphic class.
  TProgressStage = (psStarting, psRunning, psEnding);
  TProgressEvent = procedure (Sender: TObject; Stage: TProgressStage;
    PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string) of object;

  // From Delphi 3 windows.pas
  PRGBTriple = ^TRGBTriple;
{$ENDIF}

type
  TGIFImage = class;
  TGIFSubImage = class;

  TGIFItem = class(TPersistent)
  private
    FGIFImage: TGIFImage;
  protected
    function GetVersion: TGIFVersion; virtual;
    procedure Warning(Severity: TGIFSeverity; Message: string); virtual;
  public
    constructor Create(GIFImage: TGIFImage); virtual;

    procedure SaveToStream(Stream: TStream); virtual; abstract;
    procedure LoadFromStream(Stream: TStream); virtual; abstract;
    procedure SaveToFile(const Filename: string); virtual;
    procedure LoadFromFile(const Filename: string); virtual;
    property Version: TGIFVersion read GetVersion;
    property Image: TGIFImage read FGIFImage;
  end;

  TGIFList = class(TPersistent)
  private
    FItems: TList;
    FImage: TGIFImage;
  protected
    function GetItem(Index: Integer): TGIFItem;
    procedure SetItem(Index: Integer; Item: TGIFItem);
    function GetCount: Integer;
    procedure Warning(Severity: TGIFSeverity; Message: string); virtual;
  public
    constructor Create(Image: TGIFImage);
    destructor Destroy; override;

    function Add(Item: TGIFItem): Integer;
    procedure Clear;
    procedure Delete(Index: Integer);
    procedure Exchange(Index1, Index2: Integer);
    function First: TGIFItem;
    function IndexOf(Item: TGIFItem): Integer;
    procedure Insert(Index: Integer; Item: TGIFItem);
    function Last: TGIFItem;
    procedure Move(CurIndex, NewIndex: Integer);
    function Remove(Item: TGIFItem): Integer;
    procedure SaveToStream(Stream: TStream); virtual;
    procedure LoadFromStream(Stream: TStream; Parent: TObject); virtual; abstract;

    property Items[Index: Integer]: TGIFItem read GetItem write SetItem; default;
    property Count: Integer read GetCount;
    property List: TList read FItems;
    property Image: TGIFImage read FImage;
  end;

  TGIFColor = packed record
    Red: byte;
    Green: byte;
    Blue: byte;
  end;

  TColorMap = packed array[0..GIFMaxColors-1] of TGIFColor;
  PColorMap = ^TColorMap;

  TUsageCount = record
    Count		: integer;	// # of pixels using color index
    Index		: integer;	// Color index
  end;
  TColormapHistogram = array[0..255] of TUsageCount;
  TColormapReverse = array[0..255] of byte;

  TGIFColorMap = class(TPersistent)
  private
    FColorMap		: PColorMap;
    FCount		: integer;
    FCapacity		: integer;
    FOptimized		: boolean;
  protected
    function GetColor(Index: integer): TColor;
    procedure SetColor(Index: integer; Value: TColor);
    function GetBitsPerPixel: integer;
    function DoOptimize: boolean;
    procedure SetCapacity(Size: integer);
    procedure Warning(Severity: TGIFSeverity; Message: string); virtual; abstract;
    procedure BuildHistogram(var Histogram: TColormapHistogram); virtual; abstract;
    procedure MapImages(var Map: TColormapReverse); virtual; abstract;

  public
    constructor Create;
    destructor Destroy; override;
    class function Color2RGB(Color: TColor): TGIFColor;
    class function RGB2Color(Color: TGIFColor): TColor;
    procedure SaveToStream(Stream: TStream);
    procedure LoadFromStream(Stream: TStream; Count: integer);
    procedure Assign(Source: TPersistent); override;
    function IndexOf(Color: TColor): integer;
    function Add(Color: TColor): integer;
    function AddUnique(Color: TColor): integer;
    procedure Delete(Index: integer);
    procedure Clear;
    function Optimize: boolean; virtual; abstract;
    procedure Changed; virtual; abstract;
    procedure ImportPalette(Palette: HPalette);
    procedure ImportColorTable(Pal: pointer; Count: integer);
    procedure ImportDIBColors(Handle: HDC);
    procedure ImportColorMap(Map: TColorMap; Count: integer);
    function ExportPalette: HPalette;
    property Colors[Index: integer]: TColor read GetColor write SetColor; default;
    property Data: PColorMap read FColorMap;
    property Count: integer read FCount;
    property Optimized: boolean read FOptimized write FOptimized;
    property BitsPerPixel: integer read GetBitsPerPixel;
  end;
  TLogicalScreenDescriptor = packed record
    ScreenWidth: word;              { logical screen width }
    ScreenHeight: word;             { logical screen height }
    PackedFields: byte;             { packed fields }
    BackgroundColorIndex: byte;     { index to global color table }
    AspectRatio: byte;              { actual ratio = (AspectRatio + 15) / 64 }
  end;

  TGIFHeader = class(TGIFItem)
  private
    FLogicalScreenDescriptor: TLogicalScreenDescriptor;
    FColorMap		: TGIFColorMap;
    procedure Prepare;
  protected
    function GetVersion: TGIFVersion; override;
    function GetBackgroundColor: TColor;
    procedure SetBackgroundColor(Color: TColor);
    procedure SetBackgroundColorIndex(Index: BYTE);
    function GetBitsPerPixel: integer;
    function GetColorResolution: integer;
  public
    constructor Create(GIFImage: TGIFImage); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure Clear;
    property Version: TGIFVersion read GetVersion;
    property Width: WORD read FLogicalScreenDescriptor.ScreenWidth
                         write FLogicalScreenDescriptor.ScreenWidth;
    property Height: WORD read FLogicalScreenDescriptor.ScreenHeight
                          write FLogicalScreenDescriptor.Screenheight;
    property BackgroundColorIndex: BYTE read FLogicalScreenDescriptor.BackgroundColorIndex
                                        write SetBackgroundColorIndex;
    property BackgroundColor: TColor read GetBackgroundColor
                                     write SetBackgroundColor;
    property AspectRatio: BYTE read FLogicalScreenDescriptor.AspectRatio
                               write FLogicalScreenDescriptor.AspectRatio;
    property ColorMap: TGIFColorMap read FColorMap;
    property BitsPerPixel: integer read GetBitsPerPixel;
    property ColorResolution: integer read GetColorResolution;
  end;
  TGIFExtensionType = BYTE;
  TGIFExtension = class;
  TGIFExtensionClass = class of TGIFExtension;

  TGIFGraphicControlExtension = class;

  TGIFExtension = class(TGIFItem)
  private
    FSubImage: TGIFSubImage;
  protected
    function GetExtensionType: TGIFExtensionType; virtual; abstract;
    function GetVersion: TGIFVersion; override;
    function DoReadFromStream(Stream: TStream): TGIFExtensionType;
    class procedure RegisterExtension(elabel: BYTE; eClass: TGIFExtensionClass);
    class function FindExtension(Stream: TStream): TGIFExtensionClass;
    class function FindSubExtension(Stream: TStream): TGIFExtensionClass; virtual;
  public
     // Ignore compiler warning about hiding base class constructor
    constructor Create(ASubImage: TGIFSubImage); {$IFDEF VER12_PLUS} reintroduce; {$ENDIF} virtual;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    property ExtensionType: TGIFExtensionType read GetExtensionType;
    property SubImage: TGIFSubImage read FSubImage;
  end;

  TGIFExtensionList = class(TGIFList)
  protected
    function GetExtension(Index: Integer): TGIFExtension;
    procedure SetExtension(Index: Integer; Extension: TGIFExtension);
  public
    procedure LoadFromStream(Stream: TStream; Parent: TObject); override;
    property Extensions[Index: Integer]: TGIFExtension read GetExtension write SetExtension; default;
  end;

  TImageDescriptor = packed record
    Separator: byte;	{ fixed value of ImageSeparator }
    Left: word;		{ Column in pixels in respect to left edge of logical screen }
    Top: word;		{ row in pixels in respect to top of logical screen }
    Width: word;	{ width of image in pixels }
    Height: word;	{ height of image in pixels }
    PackedFields: byte;	{ Bit fields }
  end;

  TGIFSubImage = class(TGIFItem)
  private
    FBitmap		: TBitmap;
    FMask		: HBitmap;
    FNeedMask		: boolean;
    FLocalPalette	: HPalette;
    FData		: PAnsiChar;
    FDataSize		: integer;
    FColorMap		: TGIFColorMap;
    FImageDescriptor	: TImageDescriptor;
    FExtensions		: TGIFExtensionList;
    FTransparent	: boolean;
    FGCE		: TGIFGraphicControlExtension;
    procedure Prepare;
    procedure Compress(Stream: TStream);
    procedure Decompress(Stream: TStream);
  protected
    function GetVersion: TGIFVersion; override;
    function GetInterlaced: boolean;
    procedure SetInterlaced(Value: boolean);
    function GetColorResolution: integer;
    function GetBitsPerPixel: integer;
    procedure AssignTo(Dest: TPersistent); override;
    function DoGetBitmap: TBitmap;
    function DoGetDitherBitmap: TBitmap;
    function GetBitmap: TBitmap;
    procedure SetBitmap(Value: TBitmap);
    procedure FreeMask;
    function GetEmpty: Boolean;
    function GetPalette: HPALETTE;
    procedure SetPalette(Value: HPalette);
    function GetActiveColorMap: TGIFColorMap;
    function GetBoundsRect: TRect;
    procedure SetBoundsRect(const Value: TRect);
    procedure DoSetBounds(ALeft, ATop, AWidth, AHeight: integer);
    function GetClientRect: TRect;
    function GetPixel(x, y: integer): BYTE;
// 2006.10.09 ->
    procedure SetPixel(x, y: integer; Value: BYTE);
// 2006.10.09 <-
    function GetScanline(y: integer): pointer;
    procedure NewBitmap;
    procedure FreeBitmap;
    procedure NewImage;
    procedure FreeImage;
    procedure NeedImage;
    function ScaleRect(DestRect: TRect): TRect;
    function HasMask: boolean;
    function GetBounds(Index: integer): WORD;
    procedure SetBounds(Index: integer; Value: WORD);
    function GetHasBitmap: boolean;
    procedure SetHasBitmap(Value: boolean);
  public
    constructor Create(GIFImage: TGIFImage); override;
    destructor Destroy; override;
    procedure Clear;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure Assign(Source: TPersistent); override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect;
      DoTransparent, DoTile: boolean);
    procedure StretchDraw(ACanvas: TCanvas; const Rect: TRect;
      DoTransparent, DoTile: boolean);
    procedure Crop;
    procedure Merge(Previous: TGIFSubImage);
    property HasBitmap: boolean read GetHasBitmap write SetHasBitmap;
    property Left: WORD index 1 read GetBounds write SetBounds;
    property Top: WORD index 2 read GetBounds write SetBounds;
    property Width: WORD index 3 read GetBounds write SetBounds;
    property Height: WORD index 4 read GetBounds write SetBounds;
    property BoundsRect: TRect read GetBoundsRect write SetBoundsRect;
    property ClientRect: TRect read GetClientRect;
    property Interlaced: boolean read GetInterlaced write SetInterlaced;
    property ColorMap: TGIFColorMap read FColorMap;
    property ActiveColorMap: TGIFColorMap read GetActiveColorMap;
    property Data: PAnsiChar read FData;
    property DataSize: integer read FDataSize;
    property Extensions: TGIFExtensionList read FExtensions;
    property Version: TGIFVersion read GetVersion;
    property ColorResolution: integer read GetColorResolution;
    property BitsPerPixel: integer read GetBitsPerPixel;
    property Bitmap: TBitmap read GetBitmap write SetBitmap;
    property Mask: HBitmap read FMask;
    property Palette: HPALETTE read GetPalette write SetPalette;
    property Empty: boolean read GetEmpty;
    property Transparent: boolean read FTransparent;
    property GraphicControlExtension: TGIFGraphicControlExtension read FGCE;
// 2006.10.09 ->
//  property Pixels[x, y: integer]: BYTE read GetPixel;
    property Pixels[x, y: integer]: BYTE read GetPixel write SetPixel;
// 2006.10.09 <-
    property Scanline[y: integer]: pointer read GetScanline;
  end;
  TGIFTrailer = class(TGIFItem)
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
  end;
  TGIFGCERec = packed record
    BlockSize: byte;         { should be 4 }
    PackedFields: Byte;
    DelayTime: Word;         { in centiseconds }
    TransparentColorIndex: Byte;
    Terminator: Byte;
  end;

  TDisposalMethod = (dmNone, dmNoDisposal, dmBackground, dmPrevious);

  TGIFGraphicControlExtension = class(TGIFExtension)
  private
    FGCExtension: TGIFGCERec;
  protected
    function GetExtensionType: TGIFExtensionType; override;
    function GetTransparent: boolean;
    procedure SetTransparent(Value: boolean);
    function GetTransparentColor: TColor;
    procedure SetTransparentColor(Color: TColor);
    function GetTransparentColorIndex: BYTE;
    procedure SetTransparentColorIndex(Value: BYTE);
    function GetDelay: WORD;
    procedure SetDelay(Value: WORD);
    function GetUserInput: boolean;
    procedure SetUserInput(Value: boolean);
    function GetDisposal: TDisposalMethod;
    procedure SetDisposal(Value: TDisposalMethod);

  public
    constructor Create(ASubImage: TGIFSubImage); override;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    property Delay: WORD read GetDelay write SetDelay;
    property Transparent: boolean read GetTransparent write SetTransparent;
    property TransparentColorIndex: BYTE read GetTransparentColorIndex
                                            write SetTransparentColorIndex;
    property TransparentColor: TColor read GetTransparentColor write SetTransparentColor;
    property UserInput: boolean read GetUserInput write SetUserInput;
    property Disposal: TDisposalMethod read GetDisposal write SetDisposal;
  end;
  TGIFPlainTextExtensionRec = packed record
    BlockSize: byte;         { should be 12 }
    Left, Top, Width, Height: Word;
    CellWidth, CellHeight: Byte;
    TextFGColorIndex,
    TextBGColorIndex: Byte;
  end;

  TGIFTextExtension = class(TGIFExtension)
  private
    FText		: TStrings;
    FPlainTextExtension	: TGIFPlainTextExtensionRec;
  protected
    function GetExtensionType: TGIFExtensionType; override;
    function GetForegroundColor: TColor;
    procedure SetForegroundColor(Color: TColor);
    function GetBackgroundColor: TColor;
    procedure SetBackgroundColor(Color: TColor);
    function GetBounds(Index: integer): WORD;
    procedure SetBounds(Index: integer; Value: WORD);
    function GetCharWidthHeight(Index: integer): BYTE;
    procedure SetCharWidthHeight(Index: integer; Value: BYTE);
    function GetColorIndex(Index: integer): BYTE;
    procedure SetColorIndex(Index: integer; Value: BYTE);
  public
    constructor Create(ASubImage: TGIFSubImage); override;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    property Left: WORD index 1 read GetBounds write SetBounds;
    property Top: WORD index 2 read GetBounds write SetBounds;
    property GridWidth: WORD index 3 read GetBounds write SetBounds;
    property GridHeight: WORD index 4 read GetBounds write SetBounds;
    property CharWidth: BYTE index 1 read GetCharWidthHeight write SetCharWidthHeight;
    property CharHeight: BYTE index 2 read GetCharWidthHeight write SetCharWidthHeight;
    property ForegroundColorIndex: BYTE index 1 read GetColorIndex write SetColorIndex;
    property ForegroundColor: TColor read GetForegroundColor;
    property BackgroundColorIndex: BYTE  index 2 read GetColorIndex write SetColorIndex;
    property BackgroundColor: TColor read GetBackgroundColor;
    property Text: TStrings read FText write FText;
  end;
  TGIFCommentExtension = class(TGIFExtension)
  private
    FText		: TStrings;
  protected
    function GetExtensionType: TGIFExtensionType; override;
  public
    constructor Create(ASubImage: TGIFSubImage); override;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    property Text: TStrings read FText;
  end;
  TGIFIdentifierCode = array[0..7] of ansichar;
  TGIFAuthenticationCode = array[0..2] of ansichar;
  TGIFApplicationRec = packed record
    Identifier		: TGIFIdentifierCode;
    Authentication	: TGIFAuthenticationCode;
  end;

  TGIFApplicationExtension = class;
  TGIFAppExtensionClass = class of TGIFApplicationExtension;

  TGIFApplicationExtension = class(TGIFExtension)
  private
    FIdent		: TGIFApplicationRec;
    function GetAuthentication: string;
    function GetIdentifier: string;
  protected
    function GetExtensionType: TGIFExtensionType; override;
    procedure SetAuthentication(const Value: string);
    procedure SetIdentifier(const Value: string);
    procedure SaveData(Stream: TStream); virtual; abstract;
    procedure LoadData(Stream: TStream); virtual; abstract;
  public
    constructor Create(ASubImage: TGIFSubImage); override;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    class procedure RegisterExtension(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
    class function FindSubExtension(Stream: TStream): TGIFExtensionClass; override;
    property Identifier: string read GetIdentifier write SetIdentifier;
    property Authentication: string read GetAuthentication write SetAuthentication;
  end;
  TGIFBlock = class(TObject)
  private
    FSize		: BYTE;
    FData		: pointer;
  public
    constructor Create(ASize: integer);
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream);
    procedure LoadFromStream(Stream: TStream);
    property Size: BYTE read FSize;
    property Data: pointer read FData;
  end;

  TGIFUnknownAppExtension = class(TGIFApplicationExtension)
  private
    FBlocks		: TList;
  protected
    procedure SaveData(Stream: TStream); override;
    procedure LoadData(Stream: TStream); override;
  public
    constructor Create(ASubImage: TGIFSubImage); override;
    destructor Destroy; override;
    property Blocks: TList read FBlocks;
  end;
  TGIFAppExtNSLoop = class(TGIFApplicationExtension)
  private
    FLoops		: WORD;
    FBufferSize		: DWORD;
  protected
    procedure SaveData(Stream: TStream); override;
    procedure LoadData(Stream: TStream); override;
  public
    constructor Create(ASubImage: TGIFSubImage); override;
    property Loops: WORD read FLoops write FLoops;
    property BufferSize: DWORD read FBufferSize write FBufferSize;
  end;
  TGIFImageList = class(TGIFList)
  protected
    function GetImage(Index: Integer): TGIFSubImage;
    procedure SetImage(Index: Integer; SubImage: TGIFSubImage);
  public
    procedure LoadFromStream(Stream: TStream; Parent: TObject); override;
    procedure SaveToStream(Stream: TStream); override;
    property SubImages[Index: Integer]: TGIFSubImage read GetImage write SetImage; default;
  end;
  TGIFCompression =
    (gcLZW,			// Normal LZW compression
     gcRLE			// GIF compatible RLE compression
    );

  // Color reduction methods
  TColorReduction =
    (rmNone,			// Do not perform color reduction
     rmWindows20,		// Reduce to the Windows 20 color system palette
     rmWindows256,		// Reduce to the Windows 256 color halftone palette (Only works in 256 color display mode)
     rmWindowsGray,		// Reduce to the Windows 4 grayscale colors
     rmMonochrome,		// Reduce to a black/white monochrome palette
     rmGrayScale,		// Reduce to a uniform 256 shade grayscale palette
     rmNetscape,		// Reduce to the Netscape 216 color palette
     rmQuantize,		// Reduce to optimal 2^n color palette
     rmQuantizeWindows,		// Reduce to optimal 256 color windows palette
     rmPalette			// Reduce to custom palette
    );
  TDitherMode =
    (dmNearest,			// Nearest color matching w/o error correction
     dmFloydSteinberg,		// Floyd Steinberg Error Diffusion dithering
     dmStucki,			// Stucki Error Diffusion dithering
     dmSierra,			// Sierra Error Diffusion dithering
     dmJaJuNI,			// Jarvis, Judice & Ninke Error Diffusion dithering
     dmSteveArche,		// Stevenson & Arche Error Diffusion dithering
     dmBurkes			// Burkes Error Diffusion dithering
     // dmOrdered,		// Ordered dither
    );

  // Optimization options
  TGIFOptimizeOption =
    (ooCrop,			// Crop animated GIF frames
     ooMerge,			// Merge pixels of same color
     ooCleanup,			// Remove comments and application extensions
     ooColorMap,		// Sort color map by usage and remove unused entries
     ooReduceColors		// Reduce color depth ***NOT IMPLEMENTED***
    );
  TGIFOptimizeOptions = set of TGIFOptimizeOption;

  TGIFDrawOption =
    (goAsync,			// Asyncronous draws (paint in thread)
     goTransparent,		// Transparent draws
     goAnimate,			// Animate draws
     goLoop,			// Loop animations
     goLoopContinously,		// Ignore loop count and loop forever
     goValidateCanvas,		// Validate canvas in threaded paint ***NOT IMPLEMENTED***
     goDirectDraw,		// Draw() directly on canvas
     goClearOnLoop,		// Clear animation on loop
     goTile,			// Tiled display
     goDither,			// Dither to Netscape palette
     goAutoDither		// Only dither on 256 color systems
    );
  TGIFDrawOptions = set of TGIFDrawOption;
  // Note: if goAsync is not set then goDirectDraw should be set. Otherwise
  // the image will not be displayed.

  PGIFPainter = ^TGIFPainter;

  TGIFPainter = class(TThread)
  private
    {$IFDEF isVER230}
    FsSuspended: boolean; //The suspended state directive
    {$ENDIF}
    FImage		: TGIFImage;	// The TGIFImage that owns this painter
    FCanvas		: TCanvas;	// Destination canvas
    FRect		: TRect;	// Destination rect
    FDrawOptions	: TGIFDrawOptions;// Paint options
    FAnimationSpeed	: integer;	// Animation speed %
    FActiveImage	: integer;	// Current frame
    Disposal		,		// Used by synchronized paint
    OldDisposal		: TDisposalMethod;// Used by synchronized paint
    BackupBuffer	: TBitmap;	// Used by synchronized paint
    FrameBuffer		: TBitmap;	// Used by synchronized paint
    Background		: TBitmap;	// Used by synchronized paint
    ValidateDC		: HDC;
    DoRestart		: boolean;	// Flag used to restart animation
    FStarted		: boolean;	// Flag used to signal start of paint
    PainterRef		: PGIFPainter;	// Pointer to var referencing painter
    FEventHandle	: THandle;	// Animation delay event
    ExceptObject	: Exception;	// Eaten exception
    ExceptAddress	: pointer;	// Eaten exceptions address
    FEvent		: TNotifyEvent;	// Used by synchronized events
    FOnStartPaint	: TNotifyEvent;
    FOnPaint		: TNotifyEvent;
    FOnAfterPaint	: TNotifyEvent;
    FOnLoop		: TNotifyEvent;
    FOnEndPaint		: TNotifyEvent;
    procedure DoOnTerminate(Sender: TObject);// Sync. shutdown procedure
    procedure DoSynchronize(Method: TThreadMethod);// Conditional sync stub
{$ifdef SERIALIZE_RENDER}
    procedure PrefetchBitmap;		// Sync. bitmap prefetch
{$endif}
    procedure DoPaintFrame;		// Sync. buffered paint procedure
    procedure DoPaint;			// Sync. paint procedure
    procedure DoEvent;
    procedure SetActiveImage(const Value: integer);// Sync. event procedure
  protected
    procedure Execute; override;
    procedure SetAnimationSpeed(Value: integer);
  public
    constructor Create(AImage: TGIFImage; ACanvas: TCanvas; ARect: TRect;
      Options: TGIFDrawOptions);
    constructor CreateRef(Painter: PGIFPainter; AImage: TGIFImage; ACanvas: TCanvas; ARect: TRect;
      Options: TGIFDrawOptions);
    destructor Destroy; override;
    procedure Start;
    procedure Stop;
    procedure Restart;
    property Image: TGIFImage read FImage;
    property Canvas: TCanvas read FCanvas;
    property Rect: TRect read FRect write FRect;
    property DrawOptions: TGIFDrawOptions read FDrawOptions write FDrawOptions;
    property AnimationSpeed: integer read FAnimationSpeed write SetAnimationSpeed;
    property Started: boolean read FStarted;
    property ActiveImage: integer read FActiveImage write SetActiveImage;
    property OnStartPaint: TNotifyEvent read FOnStartPaint write FOnStartPaint;
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
    property OnAfterPaint: TNotifyEvent read FOnAfterPaint write FOnAfterPaint;
    property OnLoop: TNotifyEvent read FOnLoop write FOnLoop;
    property OnEndPaint	: TNotifyEvent read FOnEndPaint	 write FOnEndPaint	;
    property EventHandle: THandle read FEventHandle;
    {$IFDEF isVER230}
    procedure Suspenden;
    procedure Resumenden;
    {$ENDIF}
  end;

  TGIFWarning = procedure(Sender: TObject; Severity: TGIFSeverity; Message: string) of object;

  TGIFImage = class(TGraphic)
  private
    IsDrawing		: Boolean;
    IsInsideGetPalette	: boolean;
    FImages		: TGIFImageList;
    FHeader		: TGIFHeader;
    FGlobalPalette	: HPalette;
    FPainters		: TThreadList;
    FDrawOptions	: TGIFDrawOptions;
    FColorReduction	: TColorReduction;
    FReductionBits	: integer;
    FDitherMode		: TDitherMode;
    FCompression	: TGIFCompression;
    FOnWarning		: TGIFWarning;
    FBitmap		: TBitmap;
    FDrawPainter	: TGIFPainter;
    FThreadPriority	: TThreadPriority;
    FAnimationSpeed	: integer;
    FForceFrame: Integer;  // 2004.03.09
    FDrawBackgroundColor: TColor;
    FOnStartPaint	: TNotifyEvent;
    FOnPaint		: TNotifyEvent;
    FOnAfterPaint	: TNotifyEvent;
    FOnLoop		: TNotifyEvent;
    FOnEndPaint		: TNotifyEvent;
{$IFDEF VER9x}
    FPaletteModified	: Boolean;
    FOnProgress		: TProgressEvent;
{$ENDIF}
    function GetAnimate: Boolean;  // 2002.07.07
    procedure SetAnimate(const Value: Boolean);  // 2002.07.07
    procedure SetForceFrame(const Value: Integer);  // 2004.03.09
  protected
    // Obsolete: procedure Changed(Sender: TObject); {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
    function GetHeight: Integer; override;
    procedure SetHeight(Value: Integer); override;
    function GetWidth: Integer; override;
    procedure SetWidth(Value: Integer); override;
    procedure AssignTo(Dest: TPersistent); override;
    function InternalPaint(Painter: PGIFPainter; ACanvas: TCanvas; const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function Equals(Graphic: TGraphic): Boolean; override;
    function GetPalette: HPALETTE; {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
    procedure SetPalette(Value: HPalette); {$IFDEF VER9x} virtual; {$ELSE} override; {$ENDIF}
    function GetEmpty: Boolean; override;
    procedure WriteData(Stream: TStream); override;
    function GetIsTransparent: Boolean;
    function GetVersion: TGIFVersion;
    function GetColorResolution: integer;
    function GetBitsPerPixel: integer;
    function GetBackgroundColorIndex: BYTE;
    procedure SetBackgroundColorIndex(const Value: BYTE);
    function GetBackgroundColor: TColor;
    procedure SetBackgroundColor(const Value: TColor);
    function GetAspectRatio: BYTE;
    procedure SetAspectRatio(const Value: BYTE);
    procedure SetDrawOptions(Value: TGIFDrawOptions);
    procedure SetAnimationSpeed(Value: integer);
    procedure SetReductionBits(Value: integer);
    procedure NewImage;
    function GetBitmap: TBitmap;
    function NewBitmap: TBitmap;
    procedure FreeBitmap;
    function GetColorMap: TGIFColorMap;
    function GetDoDither: boolean;
    property DrawPainter: TGIFPainter read FDrawPainter; // Extremely volatile
    property DoDither: boolean read GetDoDither;
{$IFDEF VER9x}
    procedure Progress(Sender: TObject; Stage: TProgressStage;
      PercentDone: Byte;  RedrawNow: Boolean; const R: TRect; const Msg: string); dynamic;
{$ENDIF}
{$IFDEF FIXHEADER_WIDTHHEIGHT_SILENT}
    procedure FixHeaderWidthHeight;  // 2006.07.09
{$ENDIF}
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure LoadFromResourceName(Instance: THandle; const ResName: String);  // 2002.07.07
    function Add(Source: TPersistent): integer;
    procedure Pack;
    procedure OptimizeColorMap;
    procedure Optimize(Options: TGIFOptimizeOptions;
      ColorReduction: TColorReduction; DitherMode: TDitherMode;
      ReductionBits: integer);
    procedure Clear;
    procedure StopDraw;
    function Paint(ACanvas: TCanvas; const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
    procedure PaintStart;
    procedure PaintPause;
    procedure PaintStop;
    procedure PaintResume;
    procedure PaintRestart;
    procedure Warning(Sender: TObject; Severity: TGIFSeverity; Message: string); virtual;
    procedure Assign(Source: TPersistent); override;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE); override;
    property GlobalColorMap: TGIFColorMap read GetColorMap;
    property Version: TGIFVersion read GetVersion;
    property Images: TGIFImageList read FImages;
    property ColorResolution: integer read GetColorResolution;
    property BitsPerPixel: integer read GetBitsPerPixel;
    property BackgroundColorIndex: BYTE read GetBackgroundColorIndex write SetBackgroundColorIndex;
    property BackgroundColor: TColor read GetBackgroundColor write SetBackgroundColor;
    property AspectRatio: BYTE read GetAspectRatio write SetAspectRatio;
    property Header: TGIFHeader read FHeader; // ***OBSOLETE***
    property IsTransparent: boolean read GetIsTransparent;
    property DrawOptions: TGIFDrawOptions read FDrawOptions write SetDrawOptions;
    property DrawBackgroundColor: TColor read FDrawBackgroundColor write FDrawBackgroundColor;
    property ColorReduction: TColorReduction read FColorReduction write FColorReduction;
    property ReductionBits: integer read FReductionBits write SetReductionBits;
    property DitherMode: TDitherMode read FDitherMode write FDitherMode;
    property Compression: TGIFCompression read FCompression write FCompression;
    property AnimationSpeed: integer read FAnimationSpeed write SetAnimationSpeed;
    property Animate: Boolean read GetAnimate write SetAnimate;  // 2002.07.07
    property ForceFrame: Integer read FForceFrame write SetForceFrame;  // 2004.03.09
    property Painters: TThreadList read FPainters;
    property ThreadPriority: TThreadPriority read FThreadPriority write FThreadPriority;
    property Bitmap: TBitmap read GetBitmap; // Volatile - beware!
    property OnWarning: TGIFWarning read FOnWarning write FOnWarning;
    property OnStartPaint: TNotifyEvent read FOnStartPaint write FOnStartPaint;
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
    property OnAfterPaint: TNotifyEvent read FOnAfterPaint write FOnAfterPaint;
    property OnLoop: TNotifyEvent read FOnLoop write FOnLoop;
    property OnEndPaint	: TNotifyEvent read FOnEndPaint	 write FOnEndPaint	;
{$IFDEF VER9x}
    property Palette: HPALETTE read GetPalette write SetPalette;
    property PaletteModified: Boolean read FPaletteModified write FPaletteModified;
    property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
{$ENDIF}
  end;

////////////////////////////////////////////////////////////////////////////////
//
//                      Utility routines
//
////////////////////////////////////////////////////////////////////////////////
  // WebPalette creates a 216 color uniform palette a.k.a. the Netscape Palette
  function WebPalette: HPalette;

  // ReduceColors
  // Map colors in a bitmap to their nearest representation in a palette using
  // the methods specified by the ColorReduction and DitherMode parameters.
  // The ReductionBits parameter specifies the desired number of colors (bits
  // per pixel) when the reduction method is rmQuantize. The CustomPalette
  // specifies the palette when the rmPalette reduction method is used.
  function ReduceColors(Bitmap: TBitmap; ColorReduction: TColorReduction;
    DitherMode: TDitherMode; ReductionBits: integer; CustomPalette: hPalette): TBitmap;

  // CreateOptimizedPaletteFromManyBitmaps
  //: Performs Color Quantization on multiple bitmaps.
  // The Bitmaps parameter is a list of bitmaps. Returns an optimized palette.
  function CreateOptimizedPaletteFromManyBitmaps(Bitmaps: TList; Colors, ColorBits: integer;
    Windows: boolean): hPalette;

{$IFDEF VER9x}
  // From Delphi 3 graphics.pas
type
  TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom);
{$ENDIF}

  procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
    var ImageSize: longInt; PixelFormat: TPixelFormat);
  function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
   var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;

////////////////////////////////////////////////////////////////////////////////
//
//                      Global variables
//
////////////////////////////////////////////////////////////////////////////////
// GIF Clipboard format identifier for use by LoadFromClipboardFormat and
// SaveToClipboardFormat.
// Set in Initialization section.
var
  CF_GIF: WORD;

////////////////////////////////////////////////////////////////////////////////
//
//                      Library defaults
//
////////////////////////////////////////////////////////////////////////////////
var
  //: Default options for TGIFImage.DrawOptions.
  GIFImageDefaultDrawOptions : TGIFDrawOptions =
    [goAsync, goLoop, goTransparent, goAnimate, goDither, goAutoDither
{$IFDEF STRICT_MOZILLA}
     ,goClearOnLoop
{$ENDIF}
{$IFDEF DEFAULT_GOCLEARLOOP} // 2006.07.10
     ,goClearOnLoop
{$ENDIF}
    ];

  // WARNING! Do not use goAsync and goDirectDraw unless you have absolute
  // control of the destination canvas.
  // TGIFPainter will continue to write on the canvas even after the canvas has
  // been deleted, unless *you* prevent it.
  // The goValidateCanvas option will fix this problem if it is ever implemented.

  //: Default color reduction methods for bitmap import.
  // These are the fastest settings, but also the ones that gives the
  // worst result (in most cases).
  GIFImageDefaultColorReduction: TColorReduction = rmNetscape;
  GIFImageDefaultColorReductionBits: integer = 8; // Range 3 - 8
  GIFImageDefaultDitherMode: TDitherMode = dmNearest;

  //: Default encoder compression method.
  GIFImageDefaultCompression: TGIFCompression = gcLZW;

  //: Default painter thread priority
  GIFImageDefaultThreadPriority: TThreadPriority = tpNormal;

  //: Default animation speed in % of normal speed (range 0 - 1000)
  GIFImageDefaultAnimationSpeed: integer = 100;

  // DoAutoDither is set to True in the initializaion section if the desktop DC
  // supports 256 colors or less.
  // It can be modified in your application to disable/enable Auto Dithering
  DoAutoDither: boolean = False;

  // Palette is set to True in the initialization section if the desktop DC
  // supports 256 colors or less.
  // You should NOT modify it.
  PaletteDevice: boolean = False;

  // Set GIFImageRenderOnLoad to True to render (convert to bitmap) the
  // GIF frames as they are loaded instead of rendering them on-demand.
  // This might increase resource consumption and will increase load time,
  // but will cause animated GIFs to display more smoothly.
  GIFImageRenderOnLoad: boolean = False;

  // If GIFImageOptimizeOnStream is true, the GIF will be optimized
  // before it is streamed to the DFM file.
  // This will not affect TGIFImage.SaveToStream or SaveToFile.
  GIFImageOptimizeOnStream: boolean = False;

////////////////////////////////////////////////////////////////////////////////
//
//                      Design Time support
//
////////////////////////////////////////////////////////////////////////////////
// Dummy component registration for design time support of GIFs in TImage
procedure Register;

////////////////////////////////////////////////////////////////////////////////
//
//                      Error messages
//
////////////////////////////////////////////////////////////////////////////////
{$ifndef VER9x}
resourcestring
{$else}
const
{$endif}
  // GIF Error messages
  sOutOfData		= 'Premature end of data';
  sTooManyColors	= 'Color table overflow';
  sBadColorIndex	= 'Invalid color index';
  sBadVersion		= 'Unsupported GIF version';
  sBadSignature		= 'Invalid GIF signature';
  sScreenBadColorSize	= 'Invalid number of colors specified in Screen Descriptor';
  sImageBadColorSize	= 'Invalid number of colors specified in Image Descriptor';
  sUnknownExtension	= 'Unknown extension type';
  sBadExtensionLabel	= 'Invalid extension introducer';
  sOutOfMemDIB		= 'Failed to allocate memory for GIF DIB';
  sDIBCreate		= 'Failed to create DIB from Bitmap';
  sDecodeTooFewBits	= 'Decoder bit buffer under-run';
  sDecodeCircular	= 'Circular decoder table entry';
  sBadTrailer		= 'Invalid Image trailer';
  sBadExtensionInstance	= 'Internal error: Extension Instance does not match Extension Label';
  sBadBlockSize		= 'Unsupported Application Extension block size';
  sBadBlock		= 'Unknown GIF block type';
  sUnsupportedClass	= 'Object type not supported for operation';
  sInvalidData		= 'Invalid GIF data';
  sBadHeight		= 'Image height too small for contained frames';
  sBadWidth		= 'Image width too small for contained frames';
{$IFNDEF REGISTER_TGIFIMAGE}
  sGIFToClipboard	= 'Clipboard operations not supported for GIF objects';
{$ELSE}
  sFailedPaste		= 'Failed to store GIF on clipboard';
{$IFDEF VER9x}
  sUnknownClipboardFormat= 'Unsupported clipboard format';
{$ENDIF}
{$ENDIF}
  sScreenSizeExceeded	= 'Image exceeds Logical Screen size';
  sNoColorTable		= 'No global or local color table defined';
  sBadPixelCoordinates	= 'Invalid pixel coordinates';
  sUnsupportedBitmap	= 'Unsupported bitmap format';
  sInvalidPixelFormat	= 'Unsupported PixelFormat';
  sBadDimension		= 'Invalid image dimensions';
  sNoDIB		= 'Image has no DIB';
  sInvalidStream	= 'Invalid stream operation';
  sInvalidColor		= 'Color not in color table';
  sInvalidBitSize	= 'Invalid Bits Per Pixel value';
  sEmptyColorMap	= 'Color table is empty';
  sEmptyImage		= 'Image is empty';
  sInvalidBitmapList	= 'Invalid bitmap list';
  sInvalidReduction	= 'Invalid reduction method';
{$IFDEF VER9x}
  // From Delphi 3 consts.pas
  SOutOfResources	= 'Out of system resources';
  SInvalidBitmap	= 'Bitmap image is not valid';
  SScanLine		= 'Scan line index out of range';
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//
//                      Misc texts
//
////////////////////////////////////////////////////////////////////////////////
  // File filter name
  sGIFImageFile		= 'GIF Image';

  // Progress messages
  sProgressLoading	= 'Loading...';
  sProgressSaving	= 'Saving...';
  sProgressConverting	= 'Converting...';
  sProgressRendering	= 'Rendering...';
  sProgressCopying	= 'Copying...';
  sProgressOptimizing	= 'Optimizing...';

function SuspendThread (hThread: THandle): DWORD; StdCall;
External 'Kernel32.dll' Name 'SuspendThread';
function ResumeThread (hThread: THandle): DWORD; StdCall;
External 'Kernel32.dll' Name 'ResumeThread';
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
//
//			Implementation
//
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
implementation

{ This makes me long for the C preprocessor... }
{$ifdef DEBUG}
  {$ifdef DEBUG_COMPRESSPERFORMANCE}
    {$define DEBUG_PERFORMANCE}
  {$else}
    {$ifdef DEBUG_DECOMPRESSPERFORMANCE}
      {$define DEBUG_PERFORMANCE}
    {$else}
      {$ifdef DEBUG_DITHERPERFORMANCE}
        {$define DEBUG_PERFORMANCE}
      {$else}
        {$ifdef DEBUG_DITHERPERFORMANCE}
          {$define DEBUG_PERFORMANCE}
        {$else}
          {$ifdef DEBUG_DRAWPERFORMANCE}
            {$define DEBUG_PERFORMANCE}
          {$else}
            {$ifdef DEBUG_RENDERPERFORMANCE}
              {$define DEBUG_PERFORMANCE}
            {$endif}
          {$endif}
        {$endif}
      {$endif}
    {$endif}
  {$endif}
{$endif}

uses
{$ifdef DEBUG}
  dialogs,
{$endif}
  mmsystem, // timeGetTime()
  messages,
  Consts;


////////////////////////////////////////////////////////////////////////////////
//
//			Misc consts
//
////////////////////////////////////////////////////////////////////////////////
const
  { Extension/block label values }
  bsPlainTextExtension		= $01;
  bsGraphicControlExtension	= $F9;
  bsCommentExtension		= $FE;
  bsApplicationExtension	= $FF;

  bsImageDescriptor		= Ord(',');
  bsExtensionIntroducer		= Ord('!');
  bsTrailer			= ord(';');

  // Thread messages - Used by TThread.Synchronize()
  CM_DESTROYWINDOW	= $8FFE; // Defined in classes.pas
  CM_EXECPROC 		= $8FFF; // Defined in classes.pas


////////////////////////////////////////////////////////////////////////////////
//
//                      Design Time support
//
////////////////////////////////////////////////////////////////////////////////
//: Dummy component registration to add design-time support of GIFs to TImage.
// Since TGIFImage isn't a component there's nothing to register here, but
// since Register is only called at design time we can set the design time
// GIF paint options here (modify as you please):
procedure Register;
begin
  // Don't loop animations at design-time. Animated GIFs will animate once and
  // then stop thus not using CPU resources and distracting the developer.
  Exclude(GIFImageDefaultDrawOptions, goLoop);
end;

////////////////////////////////////////////////////////////////////////////////
//
//			Utilities
//
////////////////////////////////////////////////////////////////////////////////
//: Creates a 216 color uniform non-dithering Netscape palette.
function WebPalette: HPalette;
type
  TLogWebPalette	= packed record
    palVersion		: word;
    palNumEntries	: word;
    PalEntries		: array[0..5,0..5,0..5] of TPaletteEntry;
  end;
var
  r, g, b		: byte;
  LogWebPalette		: TLogWebPalette;
  LogPalette		: TLogpalette absolute LogWebPalette; // Stupid typecast
begin
  with LogWebPalette do
  begin
    palVersion:= $0300;
    palNumEntries:= 216;
    for r:=0 to 5 do
      for g:=0 to 5 do
        for b:=0 to 5 do
        begin
          with PalEntries[r,g,b] do
          begin
            peRed := 51 * r;
            peGreen := 51 * g;
            peBlue := 51 * b;
            peFlags := 0;
          end;
        end;
  end;
  Result := CreatePalette(Logpalette);
end;

(*
**  GDI Error handling
**  Adapted from graphics.pas
*)
{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
{$ifdef D3_BCB3}
function GDICheck(Value: Integer): Integer;
{$else}
function GDICheck(Value: Cardinal): Cardinal;
{$endif}
var
  ErrorCode		: integer;
  Buf			: array [byte] of ansichar;

  function ReturnAddr: Pointer;
  // From classes.pas
  asm
    MOV		EAX,[EBP+4] // sysutils.pas says [EBP-4], but this works !
  end;

begin
  if (Value = 0) then
  begin
    ErrorCode := GetLastError;
    if (ErrorCode <> 0) and (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM, nil,
      ErrorCode, LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil) <> 0) then
      raise EOutOfResources.Create(Buf) at ReturnAddr
    else
      raise EOutOfResources.Create(SOutOfResources) at ReturnAddr;
  end;
  Result := Value;
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

(*
**  Raise error condition
*)
procedure Error(msg: string);
  function ReturnAddr: Pointer;
  // From classes.pas
  asm
    MOV		EAX,[EBP+4] // sysutils.pas says [EBP-4] !
  end;
begin
  raise GIFException.Create(msg) at ReturnAddr;
end;

(*
**  Return number bytes required to
**  hold a given number of bits.
*)
function ByteAlignBit(Bits: Cardinal): Cardinal;
begin
  Result := (Bits+7) SHR 3;
end;
// Rounded up to nearest 2
function WordAlignBit(Bits: Cardinal): Cardinal;
begin
  Result := ((Bits+15) SHR 4) SHL 1;
end;
// Rounded up to nearest 4
function DWordAlignBit(Bits: Cardinal): Cardinal;
begin
  Result := ((Bits+31) SHR 5) SHL 2;
end;
// Round to arbitrary number of bits
function AlignBit(Bits, BitsPerPixel, Alignment: Cardinal): Cardinal;
begin
  Dec(Alignment);
  Result := ((Bits * BitsPerPixel) + Alignment) and not Alignment;
  Result := Result SHR 3;
end;

(*
**  Compute Bits per Pixel from Number of Colors
**  (Return the ceiling log of n)
*)
function Colors2bpp(Colors: integer): integer;
var
  MaxColor		: integer;
begin
  (*
  ** This might be faster computed by multiple if then else statements
  *)

  if (Colors = 0) then
    Result := 0
  else
  begin
    Result := 1;
    MaxColor := 2;
    while (Colors > MaxColor) do
    begin
      inc(Result);
      MaxColor := MaxColor SHL 1;
    end;
  end;
end;

(*
**  Write an ordinal byte value to a stream
*)
procedure WriteByte(Stream: TStream; b: BYTE);
begin
  Stream.Write(b, 1);
end;

(*
**  Read an ordinal byte value from a stream
*)
function ReadByte(Stream: TStream): BYTE;
begin
  Stream.Read(Result, 1);
end;

(*
**  Read data from stream and raise exception of EOF
*)
procedure ReadCheck(Stream: TStream; var Buffer; Size: LongInt);
var
  ReadSize		: integer;
begin
  ReadSize := Stream.Read(Buffer, Size);
  if (ReadSize <> Size) then
    Error(sOutOfData);
end;

(*
**  Write a string list to a stream as multiple blocks
**  of max 255 characters in each.
*)
procedure WriteStrings(Stream: TStream; Text: TStrings);
var
  i			: integer;
  b			: BYTE;
  size			: integer;
  s			: string;
begin
  for i := 0 to Text.Count-1 do
  begin
    s := Text[i];
    size := length(s);
    if (size > 255) then
      b := 255
    else
      b := size;
    while (size > 0) do
    begin
      dec(size, b);
      WriteByte(Stream, b);
      Stream.Write(PAnsiChar(AnsiString(s))^, b);
      delete(s, 1, b);
      if (b > size) then
        b := size;
    end;
  end;
  // Terminating zero (length = 0)
  WriteByte(Stream, 0);
end;


(*
**  Read a string list from a stream as multiple blocks
**  of max 255 characters in each.
*)
{ TODO -oanme -cImprovement : Replace ReadStrings with TGIFReader. }
procedure ReadStrings(Stream: TStream; Text: TStrings);
var
  size			: BYTE;
  buf			: array[0..255] of ansichar;
begin
  Text.Clear;
  if (Stream.Read(size, 1) <> 1) then
    exit;
  while (size > 0) do
  begin
    ReadCheck(Stream, buf, size);
    buf[size] := #0;
    Text.Add(Buf);
    if (Stream.Read(size, 1) <> 1) then
      exit;
  end;
end;


////////////////////////////////////////////////////////////////////////////////
//
//		Delphi 2.x / C++ Builder 1.x support
//
////////////////////////////////////////////////////////////////////////////////
{$IFDEF VER9x}
var
  // From Delphi 3 graphics.pas
  SystemPalette16: HPalette; // 16 color palette that maps to the system palette

type
  TPixelFormats = set of TPixelFormat;

const
  // Only pf1bit, pf4bit and pf8bit is supported since they are the only ones
  // with palettes
  SupportedPixelformats: TPixelFormats = [pf1bit, pf4bit, pf8bit];
{$ENDIF}


// --------------------------
// InitializeBitmapInfoHeader
// --------------------------
// Fills a TBitmapInfoHeader with the values of a bitmap when converted to a
// DIB of a specified PixelFormat.
//
// Parameters:
// Bitmap	The handle of the source bitmap.
// Info		The TBitmapInfoHeader buffer that will receive the values.
// PixelFormat	The pixel format of the destination DIB.
//
{$IFDEF BAD_STACK_ALIGNMENT}
  // Disable optimization to circumvent optimizer bug...
  {$IFOPT O+}
    {$DEFINE O_PLUS}
    {$O-}
  {$ENDIF}
{$ENDIF}
procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var Info: TBitmapInfoHeader;
  PixelFormat: TPixelFormat);
// From graphics.pas, "optimized" for our use
var
  DIB		: TDIBSection;
  Bytes		: Integer;
begin
  DIB.dsbmih.biSize := 0;
  Bytes := GetObject(Bitmap, SizeOf(DIB), @DIB);
  if (Bytes = 0) then
    Error(sInvalidBitmap);

  if (Bytes >= (sizeof(DIB.dsbm) + sizeof(DIB.dsbmih))) and
    (DIB.dsbmih.biSize >= sizeof(DIB.dsbmih)) then
    Info := DIB.dsbmih
  else
  begin
    FillChar(Info, sizeof(Info), 0);
    with Info, DIB.dsbm do
    begin
      biSize := SizeOf(Info);
      biWidth := bmWidth;
      biHeight := bmHeight;
    end;
  end;
  case PixelFormat of
    pf1bit: Info.biBitCount := 1;
    pf4bit: Info.biBitCount := 4;
    pf8bit: Info.biBitCount := 8;
    pf24bit: Info.biBitCount := 24;
  else
    Error(sInvalidPixelFormat);
    // Info.biBitCount := DIB.dsbm.bmBitsPixel * DIB.dsbm.bmPlanes;
  end;
  Info.biPlanes := 1;
  Info.biCompression := BI_RGB; // Always return data in RGB format
  Info.biSizeImage := AlignBit(Info.biWidth, Info.biBitCount, 32) * Cardinal(abs(Info.biHeight));
end;
{$IFDEF O_PLUS}
  {$O+}
  {$UNDEF O_PLUS}
{$ENDIF}

// -------------------
// InternalGetDIBSizes
// -------------------
// Calculates the buffer sizes nescessary for convertion of a bitmap to a DIB
// of a specified PixelFormat.
// See the GetDIBSizes API function for more info.
//
// Parameters:
// Bitmap	The handle of the source bitmap.
// InfoHeaderSize
//		The returned size of a buffer that will receive the DIB's
//		TBitmapInfo structure.
// ImageSize	The returned size of a buffer that will receive the DIB's
//		pixel data.
// PixelFormat	The pixel format of the destination DIB.
//
procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  var ImageSize: longInt; PixelFormat: TPixelFormat);
// From graphics.pas, "optimized" for our use
var
  Info		: TBitmapInfoHeader;
begin
  InitializeBitmapInfoHeader(Bitmap, Info, PixelFormat);
  // Check for palette device format
  if (Info.biBitCount > 8) then
  begin
    // Header but no palette
    InfoHeaderSize := SizeOf(TBitmapInfoHeader);
    if ((Info.biCompression and BI_BITFIELDS) <> 0) then
      Inc(InfoHeaderSize, 12);
  end else
    // Header and palette
    InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * (1 shl Info.biBitCount);
  ImageSize := Info.biSizeImage;
end;

// --------------
// InternalGetDIB
// --------------
// Converts a bitmap to a DIB of a specified PixelFormat.
//
// Parameters:
// Bitmap	The handle of the source bitmap.
// Pal		The handle of the source palette.
// BitmapInfo	The buffer that will receive the DIB's TBitmapInfo structure.
//		A buffer of sufficient size must have been allocated prior to
//		calling this function.
// Bits		The buffer that will receive the DIB's pixel data.
//		A buffer of sufficient size must have been allocated prior to
//		calling this function.
// PixelFormat	The pixel format of the destination DIB.
//
// Returns:
// True on success, False on failure.
//
// Note: The InternalGetDIBSizes function can be used to calculate the
// nescessary sizes of the BitmapInfo and Bits buffers.
//
function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
  var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;
// From graphics.pas, "optimized" for our use
var
  OldPal	: HPALETTE;
  DC		: HDC;
begin
  InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), PixelFormat);
  OldPal := 0;
  DC := CreateCompatibleDC(0);
  try
    if (Palette <> 0) then
    begin
      OldPal := SelectPalette(DC, Palette, False);
      RealizePalette(DC);
    end;
    Result := (GetDIBits(DC, Bitmap, 0, abs(TBitmapInfoHeader(BitmapInfo).biHeight),
      @Bits, TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0);
  finally
    if (OldPal <> 0) then
      SelectPalette(DC, OldPal, False);
    DeleteDC(DC);
  end;
end;

// ----------
// DIBFromBit
// ----------
// Converts a bitmap to a DIB of a specified PixelFormat.
// The DIB is returned in a TMemoryStream ready for streaming to a BMP file.
//
// Note: As opposed to D2's DIBFromBit function, the returned stream also
// contains a TBitmapFileHeader at offset 0.
//
// Parameters:
// Stream	The TMemoryStream used to store the bitmap data.
//		The stream must be allocated and freed by the caller prior to
//		calling this function.
// Src		The handle of the source bitmap.
// Pal		The handle of the source palette.
// PixelFormat	The pixel format of the destination DIB.
// DIBHeader	A pointer to the DIB's TBitmapInfo (or TBitmapInfoHeader)
//		structure in the memory stream.
//		The size of the structure can either be deduced from the
//		pixel format (i.e. number of colors) or calculated by
//		subtracting the DIBHeader pointer from the DIBBits pointer.
// DIBBits	A pointer to the DIB's pixel data in the memory stream.
//
procedure DIBFromBit(Stream: TMemoryStream; Src: HBITMAP;
  Pal: HPALETTE; PixelFormat: TPixelFormat; var DIBHeader, DIBBits: Pointer);
// (From D2 graphics.pas, "optimized" for our use)
var
  HeaderSize		: integer;
  FileSize		: longInt;
  ImageSize		: longInt;
  BitmapFileHeader	: PBitmapFileHeader;
begin
  if (Src = 0) then
    Error(sInvalidBitmap);
  // Get header- and pixel data size for new pixel format
  InternalGetDIBSizes(Src, HeaderSize, ImageSize, PixelFormat);
  // Make room in stream for a TBitmapInfo and pixel data
  FileSize := sizeof(TBitmapFileHeader) + HeaderSize + ImageSize;
  Stream.SetSize(FileSize);
  // Get pointer to TBitmapFileHeader
  BitmapFileHeader := Stream.Memory;
  // Get pointer to TBitmapInfo
  DIBHeader := Pointer(Longint(BitmapFileHeader) + sizeof(TBitmapFileHeader));
  // Get pointer to pixel data
  DIBBits := Pointer(Longint(DIBHeader) + HeaderSize);
  // Initialize file header
  FillChar(BitmapFileHeader^, sizeof(TBitmapFileHeader), 0);
  with BitmapFileHeader^ do
  begin
    bfType := $4D42; // 'BM' = Windows BMP signature
    bfSize := FileSize; // File size (not needed)
    bfOffBits := sizeof(TBitmapFileHeader) + HeaderSize; // Offset of pixel data
  end;
  // Get pixel data in new pixel format
  InternalGetDIB(Src, Pal, DIBHeader^, DIBBits^, PixelFormat);
end;

// --------------
// GetPixelFormat
// --------------
// Returns the current pixel format of a bitmap.
//
// Replacement for delphi 3 TBitmap.PixelFormat getter.
//
// Parameters:
// Bitmap	The bitmap which pixel format is returned.
//
// Returns:
// The PixelFormat of the bitmap
//
function GetPixelFormat(Bitmap: TBitmap): TPixelFormat;
{$IFDEF VER9x}
// From graphics.pas, "optimized" for our use
var
  DIBSection		: TDIBSection;
  Bytes			: Integer;
  Handle		: HBitmap;
begin
  Result := pfCustom; // This value is never returned
  // BAD_STACK_ALIGNMENT 
  // Note: To work around an optimizer bug, we do not use Bitmap.Handle
  // directly. Instead we store the value and use it indirectly. Unless we do
  // this, the register containing Bitmap.Handle will be overwritten!
  Handle := Bitmap.Handle;
  if (Handle <> 0) then
  begin
    Bytes := GetObject(Handle, SizeOf(DIBSection), @DIBSection);
    if (Bytes = 0) then
      Error(sInvalidBitmap);

    with (DIBSection) do
    begin
      // Check for NT bitmap
      if (Bytes < (SizeOf(dsbm) + SizeOf(dsbmih))) or (dsbmih.biSize < SizeOf(dsbmih)) then
        DIBSection.dsBmih.biBitCount := dsbm.bmBitsPixel * dsbm.bmPlanes;

      case (dsBmih.biBitCount) of
        0: Result := pfDevice;
        1: Result := pf1bit;
        4: Result := pf4bit;
        8: Result := pf8bit;
        16: case (dsBmih.biCompression) of
              BI_RGB:
                Result := pf15Bit;
              BI_BITFIELDS:
                if (dsBitFields[1] = $07E0) then
                  Result := pf16Bit;
            end;
        24: Result := pf24Bit;
        32: if (dsBmih.biCompression = BI_RGB) then
              Result := pf32Bit;
      else
        Error(sUnsupportedBitmap);
      end;
    end;
  end else
//    Result := pfDevice;
    Error(sUnsupportedBitmap);
end;
{$ELSE}
begin
  Result := Bitmap.PixelFormat;
end;
{$ENDIF}

// --------------
// SetPixelFormat
// --------------
// Changes the pixel format of a TBitmap.
//
// Replacement for delphi 3 TBitmap.PixelFormat setter.
// The returned TBitmap will always be a DIB.
//
// Note: Under Delphi 3.x this function will leak a palette handle each time it
//       converts a TBitmap to pf8bit format!
//       If possible, use SafeSetPixelFormat instead to avoid this.
//
// Parameters:
// Bitmap	The bitmap to modify.
// PixelFormat	The pixel format to convert to.
//
procedure SetPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat);
{$IFDEF VER9x}
var
  Stream	: TMemoryStream;
  Header	,
  Bits		: Pointer;
begin
  // Can't change anything without a handle
  if (Bitmap.Handle = 0) then
    Error(sInvalidBitmap);

  // Only convert to supported formats
  if not(PixelFormat in SupportedPixelformats) then
    Error(sInvalidPixelFormat);

  // No need to convert to same format
  if (GetPixelFormat(Bitmap) = PixelFormat) then
    exit;

  Stream := TMemoryStream.Create;
  try
    // Convert to DIB file in memory stream
    DIBFromBit(Stream, Bitmap.Handle, Bitmap.Palette, PixelFormat, Header, Bits);
    // Load DIB from stream
    Stream.Position := 0;
    Bitmap.LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;
{$ELSE}
begin
  Bitmap.PixelFormat := PixelFormat;
end;
{$ENDIF}

{$IFDEF VER100}
var
  pf8BitBitmap: TBitmap = nil;
{$ENDIF}

// ------------------
// SafeSetPixelFormat
// ------------------
// Changes the pixel format of a TBitmap but doesn't preserve the contents.
//
// Replacement for Delphi 3 TBitmap.PixelFormat setter.
// The returned TBitmap will always be an empty DIB of the same size as the
// original bitmap.
//
// This function is used to avoid the palette handle leak that Delphi 3's
// SetPixelFormat and TBitmap.PixelFormat suffers from.
//
// Parameters:
// Bitmap	The bitmap to modify.
// PixelFormat	The pixel format to convert to.
//
procedure SafeSetPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat);
{$IFDEF VER9x}
begin
  SetPixelFormat(Bitmap, PixelFormat);
end;
{$ELSE}
{$IFNDEF VER100}
var
  Palette		: hPalette;
begin
  Bitmap.PixelFormat := PixelFormat;

  // Work around a bug in TBitmap:
  // When converting to pf8bit format, the palette assigned to TBitmap.Palette
  // will be a half tone palette (which only contains the 20 system colors).
  // Unfortunately this is not the palette used to render the bitmap and it
  // is also not the palette saved with the bitmap.
  if (PixelFormat = pf8bit) then
  begin
    // Disassociate the wrong palette from the bitmap (without affecting
    // the DIB color table)
    Palette := Bitmap.ReleasePalette;
    if (Palette <> 0) then
      DeleteObject(Palette);
    // Recreate the palette from the DIB color table
    Bitmap.Palette;
  end;
end;
{$ELSE}
var
  Width			,
  Height		: integer;
begin
  if (PixelFormat = pf8bit) then
  begin
    // Partial solution to "TBitmap.PixelFormat := pf8bit" leak
    // by Greg Chapman <glc@well.com>
    if (pf8BitBitmap = nil) then
    begin
      // Create a "template" bitmap
      // The bitmap is deleted in the finalization section of the unit.
      pf8BitBitmap:= TBitmap.Create;
      // Convert template to pf8bit format
      // This will leak 1 palette handle, but only once
      pf8BitBitmap.PixelFormat:= pf8Bit;
    end;
    // Store the size of the original bitmap
    Width := Bitmap.Width;
    Height := Bitmap.Height;
    // Convert to pf8bit format by copying template
    Bitmap.Assign(pf8BitBitmap);
    // Restore the original size
    Bitmap.Width := Width;
    Bitmap.Height := Height;
  end else
    // This is safe since only pf8bit leaks
    Bitmap.PixelFormat := PixelFormat;
end;
{$ENDIF}
{$ENDIF}


{$IFDEF VER9x}

// -----------
// CopyPalette
// -----------
// Copies a HPALETTE.
//
// Copied from D3 graphics.pas.
// This is declared private in some old versions of Delphi 2 so we have to
// implement it here to support those old versions.
//
// Parameters:
// Palette	The palette to copy.
//
// Returns:
// The handle to a new palette.
//
function CopyPalette(Palette: HPALETTE): HPALETTE;
var
  PaletteSize: Integer;
  LogPal: TMaxLogPalette;
begin
  Result := 0;
  if Palette = 0 then Exit;
  PaletteSize := 0;
  if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
  if PaletteSize = 0 then Exit;
  with LogPal do
  begin
    palVersion := $0300;
    palNumEntries := PaletteSize;
    GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
  end;
  Result := CreatePalette(PLogPalette(@LogPal)^);
end;


// TThreadList implementation from Delphi 3 classes.pas
constructor TThreadList.Create;
begin
  inherited Create;
  InitializeCriticalSection(FLock);
  FList := TList.Create;
end;

destructor TThreadList.Destroy;
begin
  LockList;    // Make sure nobody else is inside the list.
  try
    FList.Free;
    inherited Destroy;
  finally
    UnlockList;
    DeleteCriticalSection(FLock);
  end;
end;

procedure TThreadList.Add(Item: Pointer);
begin
  LockList;
  try
    if FList.IndexOf(Item) = -1 then
      FList.Add(Item);
  finally
    UnlockList;
  end;
end;

procedure TThreadList.Clear;
begin
  LockList;
  try
    FList.Clear;
  finally
    UnlockList;
  end;
end;

function  TThreadList.LockList: TList;
begin
  EnterCriticalSection(FLock);
  Result := FList;
end;

procedure TThreadList.Remove(Item: Pointer);
begin
  LockList;
  try
    FList.Remove(Item);
  finally
    UnlockList;
  end;
end;

procedure TThreadList.UnlockList;
begin
  LeaveCriticalSection(FLock);
end;
// End of TThreadList implementation

// From Delphi 3 sysutils.pas
{ CompareMem performs a binary compare of Length bytes of memory referenced
  by P1 to that of P2.  CompareMem returns True if the memory referenced by
  P1 is identical to that of P2. }
function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
asm
        PUSH    ESI
        PUSH    EDI
        MOV     ESI,P1
        MOV     EDI,P2
        MOV     EDX,ECX
        XOR     EAX,EAX
        AND     EDX,3
        SHR     ECX,1
        SHR     ECX,1
        REPE    CMPSD
        JNE     @@2
        MOV     ECX,EDX
        REPE    CMPSB
        JNE     @@2
@@1:    INC     EAX
@@2:    POP     EDI
        POP     ESI
end;

// Dummy ASSERT procedure since ASSERT does not exist in Delphi 2.x
procedure ASSERT(Condition: boolean; Message: string);
begin
end;

{$ENDIF} // Delphi 2.x stuff

////////////////////////////////////////////////////////////////////////////////
//
//			TDIB Classes
//
//  These classes gives read and write access to TBitmap's pixel data
//  independently of the Delphi version used.
//
////////////////////////////////////////////////////////////////////////////////
type
  TDIB = class(TObject)
  private
    FBitmap		: TBitmap;
    FPixelFormat	: TPixelFormat;
  protected
    function GetScanline(Row: integer): pointer; virtual; abstract;
    constructor Create(ABitmap: TBitmap; APixelFormat: TPixelFormat);
  public
    property Scanline[Row: integer]: pointer read GetScanline;
    property Bitmap: TBitmap read FBitmap;
    property PixelFormat: TPixelFormat read FPixelFormat;
  end;

  TDIBReader = class(TDIB)
  private
{$ifdef VER9x}
    FDIB		: TDIBSection;
    FDC			: HDC;
    FScanLine		: pointer;
    FLastRow		: integer;
    FInfo		: PBitmapInfo;
    FBytes		: integer;
{$endif}
  protected
    function GetScanline(Row: integer): pointer; override;
  public
    constructor Create(ABitmap: TBitmap; APixelFormat: TPixelFormat);
    destructor Destroy; override;
  end;

  TDIBWriter = class(TDIB)
  private
{$ifdef PIXELFORMAT_TOO_SLOW}
    FDIBInfo		: PBitmapInfo;
    FDIBBits		: pointer;
    FDIBInfoSize	: integer;
    FDIBBitsSize	: longInt;
{$ifndef CREATEDIBSECTION_SLOW}
    FDIB		: HBITMAP;
{$endif}
{$endif}
    FPalette		: HPalette;
    FHeight		: integer;
    FWidth		: integer;
  protected
    procedure CreateDIB;
    procedure FreeDIB;
    procedure NeedDIB;
    function GetScanline(Row: integer): pointer; override;
  public
    constructor Create(ABitmap: TBitmap; APixelFormat: TPixelFormat;
      AWidth, AHeight: integer; APalette: HPalette);
    destructor Destroy; override;
    procedure UpdateBitmap;
    property Width: integer read FWidth;
    property Height: integer read FHeight;
    property Palette: HPalette read FPalette;
  end;

////////////////////////////////////////////////////////////////////////////////
constructor TDIB.Create(ABitmap: TBitmap; APixelFormat: TPixelFormat);
begin
  inherited Create;
  FBitmap := ABitmap;
  FPixelFormat := APixelFormat;
end;

////////////////////////////////////////////////////////////////////////////////
constructor TDIBReader.Create(ABitmap: TBitmap; APixelFormat: TPixelFormat);
{$ifdef VER9x}
var
  InfoHeaderSize	: integer;
  ImageSize		: longInt;
{$endif}
begin
  inherited Create(ABitmap, APixelFormat);
{$ifndef VER9x}
  SetPixelFormat(FBitmap, FPixelFormat);
{$else}
  FDC := CreateCompatibleDC(0);
  SelectPalette(FDC, FBitmap.Palette, False);

  // Allocate DIB info structure
  InternalGetDIBSizes(ABitmap.Handle, InfoHeaderSize, ImageSize, APixelFormat);
  GetMem(FInfo, InfoHeaderSize);
  // Get DIB info
  InitializeBitmapInfoHeader(ABitmap.Handle, FInfo^.bmiHeader, APixelFormat);

  // Allocate scan line buffer
  GetMem(FScanLine, ImageSize DIV abs(FInfo^.bmiHeader.biHeight));

  FLastRow := -1;
{$endif}
end;

destructor TDIBReader.Destroy;
begin
{$ifdef VER9x}
  DeleteDC(FDC);
  FreeMem(FScanLine);
  FreeMem(FInfo);
{$endif}
  inherited Destroy;
end;

function TDIBReader.GetScanline(Row: integer): pointer;
begin
{$ifdef VER9x}
  if (Row < 0) or (Row >= FBitmap.Height) then
    raise EInvalidGraphicOperation.Create(SScanLine);
  GDIFlush;

  Result := FScanLine;
  if (Row = FLastRow) then
    exit;
  FLastRow := Row;

  if (FInfo^.bmiHeader.biHeight > 0) then  // bottom-up DIB
    Row := FInfo^.bmiHeader.biHeight - Row - 1;
  GetDIBits(FDC, FBitmap.Handle, Row, 1, FScanLine, FInfo^, DIB_RGB_COLORS);

{$else}
  Result := FBitmap.ScanLine[Row];
{$endif}
end;

////////////////////////////////////////////////////////////////////////////////
constructor TDIBWriter.Create(ABitmap: TBitmap; APixelFormat: TPixelFormat;
  AWidth, AHeight: integer; APalette: HPalette);
begin
  inherited Create(ABitmap, APixelFormat);

  // DIB writer only supports 8 or 24 bit bitmaps
  if not(APixelFormat in [pf8bit, pf24bit]) then
    Error(sInvalidPixelFormat);
  if (AWidth = 0) or (AHeight = 0) then
    Error(sBadDimension);

  FHeight := AHeight;
  FWidth := AWidth;
{$ifndef PIXELFORMAT_TOO_SLOW}
  FBitmap.Palette := 0;
  FBitmap.Height := FHeight;
  FBitmap.Width := FWidth;
  SafeSetPixelFormat(FBitmap, FPixelFormat);
  FPalette := CopyPalette(APalette);
  FBitmap.Palette := FPalette;
{$else}
  FPalette := APalette;
  FDIBInfo := nil;
  FDIBBits := nil;
{$ifndef CREATEDIBSECTION_SLOW}
  FDIB := 0;
{$endif}
{$endif}
end;

destructor TDIBWriter.Destroy;
begin
  UpdateBitmap;
  FreeDIB;
  inherited Destroy;
end;

function TDIBWriter.GetScanline(Row: integer): pointer;
begin
{$ifdef PIXELFORMAT_TOO_SLOW}
  NeedDIB;

  if (FDIBBits = nil) then
    Error(sNoDIB);
  with FDIBInfo^.bmiHeader do
  begin
    if (Row < 0) or (Row >= Height) then
      raise EInvalidGraphicOperation.Create(SScanLine);
    GDIFlush;

    if biHeight > 0 then  // bottom-up DIB
      Row := biHeight - Row - 1;
    Result := PAnsiChar(Cardinal(FDIBBits) + Cardinal(Row) * AlignBit(biWidth, biBitCount, 32));
  end;
{$else}
  Result := FBitmap.ScanLine[Row];
{$endif}
end;

procedure TDIBWriter.CreateDIB;
{$IFDEF PIXELFORMAT_TOO_SLOW}
var
  SrcColors		: WORD;
//  ScreenDC		: HDC;

  // From Delphi 3.02 graphics.pas
  // There is a bug in the ByteSwapColors from Delphi 3.0!
  procedure ByteSwapColors(var Colors; Count: Integer);
  var   // convert RGB to BGR and vice-versa.  TRGBQuad <-> TPaletteEntry
    SysInfo: TSystemInfo;
  begin
    GetSystemInfo(SysInfo);
    asm
          MOV   EDX, Colors
          MOV   ECX, Count
          DEC   ECX
          JS    @@END
          LEA   EAX, SysInfo
          CMP   [EAX].TSystemInfo.wProcessorLevel, 3
          JE    @@386
    @@1:  MOV   EAX, [EDX+ECX*4]
          BSWAP EAX
          SHR   EAX,8
          MOV   [EDX+ECX*4],EAX
          DEC   ECX
          JNS   @@1
          JMP   @@END
    @@386:
          PUSH  EBX
    @@2:  XOR   EBX,EBX
          MOV   EAX, [EDX+ECX*4]
          MOV   BH, AL
          MOV   BL, AH
          SHR   EAX,16
          SHL   EBX,8
          MOV   BL, AL
          MOV   [EDX+ECX*4],EBX
          DEC   ECX
          JNS   @@2
          POP   EBX
      @@END:
    end;
  end;
{$ENDIF}
begin
{$ifdef PIXELFORMAT_TOO_SLOW}
  FreeDIB;

  if (PixelFormat = pf8bit) then
    // 8 bit: Header and palette
    FDIBInfoSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * (1 shl 8)
  else
    // 24 bit: Header but no palette
    FDIBInfoSize := SizeOf(TBitmapInfoHeader);

  // Allocate TBitmapInfo structure
  GetMem(FDIBInfo, FDIBInfoSize);
  try
    FDIBInfo^.bmiHeader.biSize := SizeOf(FDIBInfo^.bmiHeader);
    FDIBInfo^.bmiHeader.biWidth := Width;
    FDIBInfo^.bmiHeader.biHeight := Height;
    FDIBInfo^.bmiHeader.biPlanes := 1;
    FDIBInfo^.bmiHeader.biSizeImage := 0;
    FDIBInfo^.bmiHeader.biCompression := BI_RGB;

    if (PixelFormat = pf8bit) then
    begin
      FDIBInfo^.bmiHeader.biBitCount := 8;
      // Find number of colors defined by palette
      if (Palette <> 0) and
        (GetObject(Palette, sizeof(SrcColors), @SrcColors) <> 0) and
        (SrcColors <> 0) then
      begin
        // Copy all colors...
        GetPaletteEntries(Palette, 0, SrcColors, FDIBInfo^.bmiColors[0]);
        // ...and convert BGR to RGB
        ByteSwapColors(FDIBInfo^.bmiColors[0], SrcColors);
      end else
        SrcColors := 0;

      // Finally zero any unused entried
      if (SrcColors < 256) then
        FillChar(pointer(LongInt(@FDIBInfo^.bmiColors)+SizeOf(TRGBQuad)*SrcColors)^,
          256 - SrcColors, 0);
      FDIBInfo^.bmiHeader.biClrUsed := 256;
      FDIBInfo^.bmiHeader.biClrImportant := SrcColors;
    end else
    begin
      FDIBInfo^.bmiHeader.biBitCount := 24;
      FDIBInfo^.bmiHeader.biClrUsed := 0;
      FDIBInfo^.bmiHeader.biClrImportant := 0;
    end;
    FDIBBitsSize := AlignBit(Width, FDIBInfo^.bmiHeader.biBitCount, 32) * Cardinal(abs(Height));

{$ifdef CREATEDIBSECTION_SLOW}
    FDIBBits := GlobalAllocPtr(GMEM_MOVEABLE, FDIBBitsSize);
    if (FDIBBits = nil) then
      raise EOutOfMemory.Create(sOutOfMemDIB);
{$else}
//    ScreenDC := GDICheck(GetDC(0));
    try
      // Allocate DIB section
      // Note: You can ignore warnings about the HDC parameter being 0. The
      // parameter is not used for 24 bit bitmaps
      FDIB := GDICheck(CreateDIBSection(0 {ScreenDC}, FDIBInfo^, DIB_RGB_COLORS,
        FDIBBits,
        {$IFDEF VER9x} nil, {$ELSE} 0, {$ENDIF}
        0));
    finally
//      ReleaseDC(0, ScreenDC);
    end;
{$endif}

  except
    FreeDIB;
    raise;
  end;
{$endif}
end;

procedure TDIBWriter.FreeDIB;
begin
{$ifdef PIXELFORMAT_TOO_SLOW}
  if (FDIBInfo <> nil) then
    FreeMem(FDIBInfo);
{$ifdef CREATEDIBSECTION_SLOW}
  if (FDIBBits <> nil) then
    GlobalFreePtr(FDIBBits);
{$else}
  if (FDIB <> 0) then
    DeleteObject(FDIB);
  FDIB := 0;
{$endif}
  FDIBInfo := nil;
  FDIBBits := nil;
{$endif}
end;

procedure TDIBWriter.NeedDIB;
begin
{$ifdef PIXELFORMAT_TOO_SLOW}
{$ifdef CREATEDIBSECTION_SLOW}
  if (FDIBBits = nil) then
{$else}
  if (FDIB = 0) then
{$endif}
    CreateDIB;
{$endif}
end;

// Convert the DIB created by CreateDIB back to a TBitmap
procedure TDIBWriter.UpdateBitmap;
{$ifdef PIXELFORMAT_TOO_SLOW}
var
  Stream		: TMemoryStream;
  FileSize		: longInt;
  BitmapFileHeader	: TBitmapFileHeader;
{$endif}
begin
{$ifdef PIXELFORMAT_TOO_SLOW}

{$ifdef CREATEDIBSECTION_SLOW}
  if (FDIBBits = nil) then
{$else}
  if (FDIB = 0) then
{$endif}
    exit;

  // Win95 and NT differs in what solution performs best
{$ifndef CREATEDIBSECTION_SLOW}
{$ifdef VER10_PLUS}
  if (Win32Platform = VER_PLATFORM_WIN32_NT) then
  begin
    // Assign DIB to bitmap
    FBitmap.Handle := FDIB;
    FDIB := 0;
    FBitmap.Palette := CopyPalette(Palette);
  end else
{$endif}
{$endif}
  begin
    // Write DIB to a stream in the BMP file format
    Stream := TMemoryStream.Create;
    try
      // Make room in stream for a TBitmapInfo and pixel data
      FileSize := sizeof(TBitmapFileHeader) + FDIBInfoSize + FDIBBitsSize;
      Stream.SetSize(FileSize);
      // Initialize file header
      FillChar(BitmapFileHeader, sizeof(TBitmapFileHeader), 0);
      with BitmapFileHeader do
      begin
        bfType := $4D42; // 'BM' = Windows BMP signature
        bfSize := FileSize; // File size (not needed)
        bfOffBits := sizeof(TBitmapFileHeader) + FDIBInfoSize; // Offset of pixel data
      end;
      // Save file header
      Stream.Write(BitmapFileHeader, sizeof(TBitmapFileHeader));
      // Save TBitmapInfo structure
      Stream.Write(FDIBInfo^, FDIBInfoSize);
      // Save pixel data
      Stream.Write(FDIBBits^, FDIBBitsSize);

      // Rewind and load bitmap from stream
      Stream.Position := 0;
      FBitmap.LoadFromStream(Stream);
    finally
      Stream.Free;
    end;
  end;
{$endif}
end;

////////////////////////////////////////////////////////////////////////////////
//
//			Color Mapping
//
////////////////////////////////////////////////////////////////////////////////
type
  TColorLookup = class(TObject)
  private
    FColors		: integer;
  public
    constructor Create(Palette: hPalette); virtual;
    function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; virtual; abstract;
    property Colors: integer read FColors;
  end;

  PRGBQuadArray = ^TRGBQuadArray;		// From Delphi 3 graphics.pas
  TRGBQuadArray = array[Byte] of TRGBQuad;	// From Delphi 3 graphics.pas

  BGRArray = array[0..0] of TRGBTriple;
  PBGRArray = ^BGRArray;

  PalArray =  array[byte] of TPaletteEntry;
  PPalArray = ^PalArray;

  // TFastColorLookup implements a simple but reasonably fast generic color
  // mapper. It trades precision for speed by reducing the size of the color
  // space.
  // Using a class instead of inline code results in a speed penalty of
  // approx. 15% but reduces the complexity of the color reduction routines that
  // uses it. If bitmap to GIF conversion speed is really important to you, the
  // implementation can easily be inlined again.
  TInverseLookup = array[0..1 SHL 15-1] of SmallInt;
  PInverseLookup = ^TInverseLookup;

  TFastColorLookup = class(TColorLookup)
  private
    FPaletteEntries	: PPalArray;
    FInverseLookup	: PInverseLookup;
  public
    constructor Create(Palette: hPalette); override;
    destructor Destroy; override;
    function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; override;
  end;

  // TSlowColorLookup implements a precise but very slow generic color mapper.
  // It uses the GetNearestPaletteIndex GDI function.
  // Note: Tests has shown TFastColorLookup to be more precise than
  // TSlowColorLookup in many cases. I can't explain why...
  TSlowColorLookup = class(TColorLookup)
  private
    FPaletteEntries	: PPalArray;
    FPalette		: hPalette;
  public
    constructor Create(Palette: hPalette); override;
    destructor Destroy; override;
    function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; override;
  end;

  // TNetscapeColorLookup maps colors to the netscape 6*6*6 color cube.
  TNetscapeColorLookup = class(TColorLookup)
  public
    constructor Create(Palette: hPalette); override;
    function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; override;
  end;

  // TGrayWindowsLookup maps colors to 4 shade palette.
  TGrayWindowsLookup = class(TSlowColorLookup)
  public
    constructor Create(Palette: hPalette); override;
    function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; override;
  end;

  // TGrayScaleLookup maps colors to a uniform 256 shade palette.
  TGrayScaleLookup = class(TColorLookup)
  public
    constructor Create(Palette: hPalette); override;
    function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; override;
  end;

  // TMonochromeLookup maps colors to a black/white palette.
  TMonochromeLookup = class(TColorLookup)
  public
    constructor Create(Palette: hPalette); override;
    function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; override;
  end;

constructor TColorLookup.Create(Palette: hPalette);
begin
  inherited Create;
end;

constructor TFastColorLookup.Create(Palette: hPalette);
var
  i			: integer;
  InverseIndex		: integer;
begin
  inherited Create(Palette);

  GetMem(FPaletteEntries, sizeof(TPaletteEntry) * 256);
  FColors := GetPaletteEntries(Palette, 0, 256, FPaletteEntries^);

  New(FInverseLookup);
  for i := low(TInverseLookup) to high(TInverseLookup) do
    FInverseLookup^[i] := -1;

  // Premap palette colors
  if (FColors > 0) then
    for i := 0 to FColors-1 do
      with FPaletteEntries^[i] do
      begin
        InverseIndex := (peRed SHR 3) OR ((peGreen AND $F8) SHL 2) OR ((peBlue AND $F8) SHL 7);
        if (FInverseLookup^[InverseIndex] = -1) then
          FInverseLookup^[InverseIndex] := i;
      end;
end;

destructor TFastColorLookup.Destroy;
begin
  if (FPaletteEntries <> nil) then
    FreeMem(FPaletteEntries);
  if (FInverseLookup <> nil) then
    Dispose(FInverseLookup);

  inherited Destroy;
end;

// Map color to arbitrary palette
function TFastColorLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar;
var
  i			: integer;
  InverseIndex		: integer;
  Delta			,
  MinDelta		,
  MinColor		: integer;
begin
  // Reduce color space with 3 bits in each dimension
  InverseIndex := (Red SHR 3) OR ((Green AND $F8) SHL 2) OR ((Blue AND $F8) SHL 7);

  if (FInverseLookup^[InverseIndex] <> -1) then
    Result := ansichar(FInverseLookup^[InverseIndex])
  else
  begin
    // Sequential scan for nearest color to minimize euclidian distance
    MinDelta := 3 * (256 * 256);
    MinColor := 0;
    for i := 0 to FColors-1 do
      with FPaletteEntries[i] do
      begin
        Delta := ABS(peRed - Red) + ABS(peGreen - Green) + ABS(peBlue - Blue);
        if (Delta < MinDelta) then
        begin
          MinDelta := Delta;
          MinColor := i;
        end;
      end;
    Result := ansichar(MinColor);
    FInverseLookup^[InverseIndex] := MinColor;
  end;

  with FPaletteEntries^[ord(Result)] do
  begin
    R := peRed;
    G := peGreen;
    B := peBlue;
  end;
end;

constructor TSlowColorLookup.Create(Palette: hPalette);
begin
  inherited Create(Palette);
  FPalette := Palette;
  FColors := GetPaletteEntries(Palette, 0, 256, nil^);
  if (FColors > 0) then
  begin
    GetMem(FPaletteEntries, sizeof(TPaletteEntry) * FColors);
    FColors := GetPaletteEntries(Palette, 0, 256, FPaletteEntries^);
  end;
end;

destructor TSlowColorLookup.Destroy;
begin
  if (FPaletteEntries <> nil) then
    FreeMem(FPaletteEntries);

  inherited Destroy;
end;

// Map color to arbitrary palette
function TSlowColorLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar;
begin
  Result := ansichar(GetNearestPaletteIndex(FPalette, Red OR (Green SHL 8) OR (Blue SHL 16)));
  if (FPaletteEntries <> nil) then
    with FPaletteEntries^[ord(Result)] do
    begin
      R := peRed;
      G := peGreen;
      B := peBlue;
    end;
end;

constructor TNetscapeColorLookup.Create(Palette: hPalette);
begin
  inherited Create(Palette);
  FColors := 6*6*6; // This better be true or something is wrong
end;

// Map color to netscape 6*6*6 color cube
function TNetscapeColorLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar;
begin
  R := (Red+3) DIV 51;
  G := (Green+3) DIV 51;
  B := (Blue+3) DIV 51;
  Result := ansichar(B + 6*G + 36*R);
  R := R * 51;
  G := G * 51;
  B := B * 51;
end;

constructor TGrayWindowsLookup.Create(Palette: hPalette);
begin
  inherited Create(Palette);
  FColors := 4;
end;

// Convert color to windows grays
function TGrayWindowsLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar;
begin
  Result := inherited Lookup(MulDiv(Red, 77, 256),
    MulDiv(Green, 150, 256), MulDiv(Blue, 29, 256), R, G, B);
end;

constructor TGrayScaleLookup.Create(Palette: hPalette);
begin
  inherited Create(Palette);
  FColors := 256;
end;

// Convert color to grayscale
function TGrayScaleLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar;
begin
  Result := ansichar((Blue*29 + Green*150 + Red*77) DIV 256);
  R := ord(Result);
  G := ord(Result);
  B := ord(Result);
end;

constructor TMonochromeLookup.Create(Palette: hPalette);
begin
  inherited Create(Palette);
  FColors := 2;
end;

// Convert color to black/white
function TMonochromeLookup.Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar;
begin
  if ((Blue*29 + Green*150 + Red*77) > 32512) then
  begin
    Result := #1;
    R := 255;
    G := 255;
    B := 255;
  end else
  begin
    Result := #0;
    R := 0;
    G := 0;
    B := 0;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//			Dithering engine
//
////////////////////////////////////////////////////////////////////////////////
type
  TDitherEngine = class
  private
  protected
    FDirection		: integer;
    FColumn		: integer;
    FLookup		: TColorLookup;
    Width		: integer;
  public
    constructor Create(AWidth: integer; Lookup: TColorLookup); virtual;
    function Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; virtual;
    procedure NextLine; virtual;
    procedure NextColumn;

    property Direction: integer read FDirection;
    property Column: integer read FColumn;
  end;

  // Note: TErrorTerm does only *need* to be 16 bits wide, but since
  // it is *much* faster to use native machine words (32 bit), we sacrifice
  // some bytes (a lot actually) to improve performance.
  TErrorTerm		= Integer;
  TErrors		= array[0..0] of TErrorTerm;
  PErrors		= ^TErrors;

  TFloydSteinbergDitherer = class(TDitherEngine)
  private
    ErrorsR		,
    ErrorsG		,
    ErrorsB		: PErrors;
    ErrorR		,
    ErrorG		,
    ErrorB		: PErrors;
    CurrentErrorR	,		// Current error or pixel value
    CurrentErrorG	,
    CurrentErrorB	,
    BelowErrorR		,		// Error for pixel below current
    BelowErrorG		,
    BelowErrorB		,
    BelowPrevErrorR	,		// Error for pixel below previous pixel
    BelowPrevErrorG	,
    BelowPrevErrorB	: TErrorTerm;
  public
    constructor Create(AWidth: integer; Lookup: TColorLookup); override;
    destructor Destroy; override;
    function Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; override;
    procedure NextLine; override;
  end;

  T5by3Ditherer = class(TDitherEngine)
  private
    ErrorsR0		,
    ErrorsG0		,
    ErrorsB0		,
    ErrorsR1		,
    ErrorsG1		,
    ErrorsB1		,
    ErrorsR2		,
    ErrorsG2		,
    ErrorsB2		: PErrors;
    ErrorR0		,
    ErrorG0		,
    ErrorB0		,
    ErrorR1		,
    ErrorG1		,
    ErrorB1		,
    ErrorR2		,
    ErrorG2		,
    ErrorB2		: PErrors;
    FDirection2		: integer;
  protected
    FDivisor		: integer;
    procedure Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer); virtual; abstract;
  public
    constructor Create(AWidth: integer; Lookup: TColorLookup); override;
    destructor Destroy; override;
    function Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; override;
    procedure NextLine; override;
  end;

  TStuckiDitherer = class(T5by3Ditherer)
  protected
    procedure Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer); override;
  public
    constructor Create(AWidth: integer; Lookup: TColorLookup); override;
  end;

  TSierraDitherer = class(T5by3Ditherer)
  protected
    procedure Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer); override;
  public
    constructor Create(AWidth: integer; Lookup: TColorLookup); override;
  end;

  TJaJuNiDitherer = class(T5by3Ditherer)
  protected
    procedure Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer); override;
  public
    constructor Create(AWidth: integer; Lookup: TColorLookup); override;
  end;

  TSteveArcheDitherer = class(TDitherEngine)
  private
    ErrorsR0		,
    ErrorsG0		,
    ErrorsB0		,
    ErrorsR1		,
    ErrorsG1		,
    ErrorsB1		,
    ErrorsR2		,
    ErrorsG2		,
    ErrorsB2		,
    ErrorsR3		,
    ErrorsG3		,
    ErrorsB3		: PErrors;
    ErrorR0		,
    ErrorG0		,
    ErrorB0		,
    ErrorR1		,
    ErrorG1		,
    ErrorB1		,
    ErrorR2		,
    ErrorG2		,
    ErrorB2		,
    ErrorR3		,
    ErrorG3		,
    ErrorB3		: PErrors;
    FDirection2		,
    FDirection3		: integer;
  public
    constructor Create(AWidth: integer; Lookup: TColorLookup); override;
    destructor Destroy; override;
    function Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; override;
    procedure NextLine; override;
  end;

  TBurkesDitherer = class(TDitherEngine)
  private
    ErrorsR0		,
    ErrorsG0		,
    ErrorsB0		,
    ErrorsR1		,
    ErrorsG1		,
    ErrorsB1		: PErrors;
    ErrorR0		,
    ErrorG0		,
    ErrorB0		,
    ErrorR1		,
    ErrorG1		,
    ErrorB1		: PErrors;
    FDirection2		: integer;
  public
    constructor Create(AWidth: integer; Lookup: TColorLookup); override;
    destructor Destroy; override;
    function Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar; override;
    procedure NextLine; override;
  end;

////////////////////////////////////////////////////////////////////////////////
//	TDitherEngine
constructor TDitherEngine.Create(AWidth: integer; Lookup: TColorLookup);
begin
  inherited Create;

  FLookup := Lookup;
  Width := AWidth;

  FDirection := 1;
  FColumn := 0;
end;

function TDitherEngine.Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar;
begin
  // Map color to palette
  Result := FLookup.Lookup(Red, Green, Blue, R, G, B);
  NextColumn;
end;

procedure TDitherEngine.NextLine;
begin
  FDirection := -FDirection;
  if (FDirection = 1) then
    FColumn := 0
  else
    FColumn := Width-1;
end;

procedure TDitherEngine.NextColumn;
begin
  inc(FColumn, FDirection);
end;

////////////////////////////////////////////////////////////////////////////////
//	TFloydSteinbergDitherer
constructor TFloydSteinbergDitherer.Create(AWidth: integer; Lookup: TColorLookup);
begin
  inherited Create(AWidth, Lookup);

  // The Error arrays has (columns + 2) entries; the extra entry at
  // each end saves us from special-casing the first and last pixels.
  // We can get away with a single array (holding one row's worth of errors)
  // by using it to store the current row's errors at pixel columns not yet
  // processed, but the next row's errors at columns already processed.  We
  // need only a few extra variables to hold the errors immediately around the
  // current column.  (If we are lucky, those variables are in registers, but
  // even if not, they're probably cheaper to access than array elements are.)
  GetMem(ErrorsR, sizeof(TErrorTerm)*(Width+2));
  GetMem(ErrorsG, sizeof(TErrorTerm)*(Width+2));
  GetMem(ErrorsB, sizeof(TErrorTerm)*(Width+2));
  FillChar(ErrorsR^, sizeof(TErrorTerm)*(Width+2), 0);
  FillChar(ErrorsG^, sizeof(TErrorTerm)*(Width+2), 0);
  FillChar(ErrorsB^, sizeof(TErrorTerm)*(Width+2), 0);
  ErrorR := ErrorsR;
  ErrorG := ErrorsG;
  ErrorB := ErrorsB;
  CurrentErrorR := 0;
  CurrentErrorG := CurrentErrorR;
  CurrentErrorB := CurrentErrorR;
  BelowErrorR := CurrentErrorR;
  BelowErrorG := CurrentErrorR;
  BelowErrorB := CurrentErrorR;
  BelowPrevErrorR := CurrentErrorR;
  BelowPrevErrorG := CurrentErrorR;
  BelowPrevErrorB := CurrentErrorR;
end;

destructor TFloydSteinbergDitherer.Destroy;
begin
  FreeMem(ErrorsR);
  FreeMem(ErrorsG);
  FreeMem(ErrorsB);
  inherited Destroy;
end;

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
function TFloydSteinbergDitherer.Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar;
var
  BelowNextError	: TErrorTerm;
  Delta			: TErrorTerm;
begin
  CurrentErrorR := Red + (CurrentErrorR + ErrorR[0] + 8) DIV 16;
//  CurrentErrorR := Red + (CurrentErrorR + ErrorR[Direction] + 8) DIV 16;
  if (CurrentErrorR < 0) then
    CurrentErrorR := 0
  else if (CurrentErrorR > 255) then
    CurrentErrorR := 255;

  CurrentErrorG := Green + (CurrentErrorG + ErrorG[0] + 8) DIV 16;
//  CurrentErrorG := Green + (CurrentErrorG + ErrorG[Direction] + 8) DIV 16;
  if (CurrentErrorG < 0) then
    CurrentErrorG := 0
  else if (CurrentErrorG > 255) then
    CurrentErrorG := 255;

  CurrentErrorB := Blue + (CurrentErrorB + ErrorB[0] + 8) DIV 16;
//  CurrentErrorB := Blue + (CurrentErrorB + ErrorB[Direction] + 8) DIV 16;
  if (CurrentErrorB < 0) then
    CurrentErrorB := 0
  else if (CurrentErrorB > 255) then
    CurrentErrorB := 255;

  // Map color to palette
  Result := inherited Dither(CurrentErrorR, CurrentErrorG, CurrentErrorB, R, G, B);

  // Propagate Floyd-Steinberg error terms.
  // Errors are accumulated into the error arrays, at a resolution of
  // 1/16th of a pixel count.  The error at a given pixel is propagated
  // to its not-yet-processed neighbors using the standard F-S fractions,
  //		...	(here)	7/16
  //		3/16	5/16	1/16
  // We work left-to-right on even rows, right-to-left on odd rows.

  // Red component
  CurrentErrorR := CurrentErrorR - R;
  if (CurrentErrorR <> 0) then
  begin
    BelowNextError := CurrentErrorR;			// Error * 1

    Delta := CurrentErrorR * 2;
    inc(CurrentErrorR, Delta);
    ErrorR[0] := BelowPrevErrorR + CurrentErrorR;	// Error * 3

    inc(CurrentErrorR, Delta);
    BelowPrevErrorR := BelowErrorR + CurrentErrorR;	// Error * 5

    BelowErrorR := BelowNextError;			// Error * 1

    inc(CurrentErrorR, Delta);				// Error * 7
  end;

  // Green component
  CurrentErrorG := CurrentErrorG - G;
  if (CurrentErrorG <> 0) then
  begin
    BelowNextError := CurrentErrorG;			// Error * 1

    Delta := CurrentErrorG * 2;
    inc(CurrentErrorG, Delta);
    ErrorG[0] := BelowPrevErrorG + CurrentErrorG;	// Error * 3

    inc(CurrentErrorG, Delta);
    BelowPrevErrorG := BelowErrorG + CurrentErrorG;	// Error * 5

    BelowErrorG := BelowNextError;			// Error * 1

    inc(CurrentErrorG, Delta);				// Error * 7
  end;

  // Blue component
  CurrentErrorB := CurrentErrorB - B;
  if (CurrentErrorB <> 0) then
  begin
    BelowNextError := CurrentErrorB;			// Error * 1

    Delta := CurrentErrorB * 2;
    inc(CurrentErrorB, Delta);
    ErrorB[0] := BelowPrevErrorB + CurrentErrorB;	// Error * 3

    inc(CurrentErrorB, Delta);
    BelowPrevErrorB := BelowErrorB + CurrentErrorB;	// Error * 5

    BelowErrorB := BelowNextError;			// Error * 1

    inc(CurrentErrorB, Delta);				// Error * 7
  end;

  // Move on to next column
  if (Direction = 1) then
  begin
    inc(longInt(ErrorR), sizeof(TErrorTerm));
    inc(longInt(ErrorG), sizeof(TErrorTerm));
    inc(longInt(ErrorB), sizeof(TErrorTerm));
  end else
  begin
    dec(longInt(ErrorR), sizeof(TErrorTerm));
    dec(longInt(ErrorG), sizeof(TErrorTerm));
    dec(longInt(ErrorB), sizeof(TErrorTerm));
  end;
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
procedure TFloydSteinbergDitherer.NextLine;
begin
  ErrorR[0] := BelowPrevErrorR;
  ErrorG[0] := BelowPrevErrorG;
  ErrorB[0] := BelowPrevErrorB;

  // Note: The optimizer produces better code for this construct:
  //   a := 0; b := a; c := a;
  // compared to this construct:
  //   a := 0; b := 0; c := 0;
  CurrentErrorR := 0;
  CurrentErrorG := CurrentErrorR;
  CurrentErrorB := CurrentErrorG;
  BelowErrorR := CurrentErrorG;
  BelowErrorG := CurrentErrorG;
  BelowErrorB := CurrentErrorG;
  BelowPrevErrorR := CurrentErrorG;
  BelowPrevErrorG := CurrentErrorG;
  BelowPrevErrorB := CurrentErrorG;

  inherited NextLine;

  if (Direction = 1) then
  begin
    ErrorR := ErrorsR;
    ErrorG := ErrorsG;
    ErrorB := ErrorsB;
  end else
  begin
    ErrorR := @ErrorsR[Width+1];
    ErrorG := @ErrorsG[Width+1];
    ErrorB := @ErrorsB[Width+1];
  end;
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//	T5by3Ditherer
constructor T5by3Ditherer.Create(AWidth: integer; Lookup: TColorLookup);
begin
  inherited Create(AWidth, Lookup);

  GetMem(ErrorsR0, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsG0, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsB0, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsR1, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsG1, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsB1, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsR2, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsG2, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsB2, sizeof(TErrorTerm)*(Width+4));
  FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsR1^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsG1^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsB1^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsR2^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsG2^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsB2^, sizeof(TErrorTerm)*(Width+4), 0);

  FDivisor := 1;
  FDirection2 := 2 * Direction;
  ErrorR0 := PErrors(longInt(ErrorsR0)+2*sizeof(TErrorTerm));
  ErrorG0 := PErrors(longInt(ErrorsG0)+2*sizeof(TErrorTerm));
  ErrorB0 := PErrors(longInt(ErrorsB0)+2*sizeof(TErrorTerm));
  ErrorR1 := PErrors(longInt(ErrorsR1)+2*sizeof(TErrorTerm));
  ErrorG1 := PErrors(longInt(ErrorsG1)+2*sizeof(TErrorTerm));
  ErrorB1 := PErrors(longInt(ErrorsB1)+2*sizeof(TErrorTerm));
  ErrorR2 := PErrors(longInt(ErrorsR2)+2*sizeof(TErrorTerm));
  ErrorG2 := PErrors(longInt(ErrorsG2)+2*sizeof(TErrorTerm));
  ErrorB2 := PErrors(longInt(ErrorsB2)+2*sizeof(TErrorTerm));
end;

destructor T5by3Ditherer.Destroy;
begin
  FreeMem(ErrorsR0);
  FreeMem(ErrorsG0);
  FreeMem(ErrorsB0);
  FreeMem(ErrorsR1);
  FreeMem(ErrorsG1);
  FreeMem(ErrorsB1);
  FreeMem(ErrorsR2);
  FreeMem(ErrorsG2);
  FreeMem(ErrorsB2);
  inherited Destroy;
end;

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
function T5by3Ditherer.Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar;
var
  ColorR		,
  ColorG		,
  ColorB		: integer; // Error for current pixel
begin
  // Apply red component error correction
  ColorR := Red + (ErrorR0[0] + FDivisor DIV 2) DIV FDivisor;
  if (ColorR < 0) then
    ColorR := 0
  else if (ColorR > 255) then
    ColorR := 255;

  // Apply green component error correction
  ColorG := Green + (ErrorG0[0] + FDivisor DIV 2) DIV FDivisor;
  if (ColorG < 0) then
    ColorG := 0
  else if (ColorG > 255) then
    ColorG := 255;

  // Apply blue component error correction
  ColorB := Blue + (ErrorB0[0] + FDivisor DIV 2) DIV FDivisor;
  if (ColorB < 0) then
    ColorB := 0
  else if (ColorB > 255) then
    ColorB := 255;

  // Map color to palette
  Result := inherited Dither(ColorR, ColorG, ColorB, R, G, B);

  // Propagate red component error
  Propagate(ErrorR0, ErrorR1, ErrorR2, ColorR - R);
  // Propagate green component error
  Propagate(ErrorG0, ErrorG1, ErrorG2, ColorG - G);
  // Propagate blue component error
  Propagate(ErrorB0, ErrorB1, ErrorB2, ColorB - B);

  // Move on to next column
  if (Direction = 1) then
  begin
    inc(longInt(ErrorR0), sizeof(TErrorTerm));
    inc(longInt(ErrorG0), sizeof(TErrorTerm));
    inc(longInt(ErrorB0), sizeof(TErrorTerm));
    inc(longInt(ErrorR1), sizeof(TErrorTerm));
    inc(longInt(ErrorG1), sizeof(TErrorTerm));
    inc(longInt(ErrorB1), sizeof(TErrorTerm));
    inc(longInt(ErrorR2), sizeof(TErrorTerm));
    inc(longInt(ErrorG2), sizeof(TErrorTerm));
    inc(longInt(ErrorB2), sizeof(TErrorTerm));
  end else
  begin
    dec(longInt(ErrorR0), sizeof(TErrorTerm));
    dec(longInt(ErrorG0), sizeof(TErrorTerm));
    dec(longInt(ErrorB0), sizeof(TErrorTerm));
    dec(longInt(ErrorR1), sizeof(TErrorTerm));
    dec(longInt(ErrorG1), sizeof(TErrorTerm));
    dec(longInt(ErrorB1), sizeof(TErrorTerm));
    dec(longInt(ErrorR2), sizeof(TErrorTerm));
    dec(longInt(ErrorG2), sizeof(TErrorTerm));
    dec(longInt(ErrorB2), sizeof(TErrorTerm));
  end;
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
procedure T5by3Ditherer.NextLine;
var
  TempErrors		: PErrors;
begin
  FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+4), 0);

  // Swap lines
  TempErrors := ErrorsR0;
  ErrorsR0 := ErrorsR1;
  ErrorsR1 := ErrorsR2;
  ErrorsR2 := TempErrors;

  TempErrors := ErrorsG0;
  ErrorsG0 := ErrorsG1;
  ErrorsG1 := ErrorsG2;
  ErrorsG2 := TempErrors;

  TempErrors := ErrorsB0;
  ErrorsB0 := ErrorsB1;
  ErrorsB1 := ErrorsB2;
  ErrorsB2 := TempErrors;

  inherited NextLine;

  FDirection2 := 2 * Direction;
  if (Direction = 1) then
  begin
    // ErrorsR0[1] gives compiler error, so we
    // use PErrors(longInt(ErrorsR0)+sizeof(TErrorTerm)) instead...
    ErrorR0 := PErrors(longInt(ErrorsR0)+2*sizeof(TErrorTerm));
    ErrorG0 := PErrors(longInt(ErrorsG0)+2*sizeof(TErrorTerm));
    ErrorB0 := PErrors(longInt(ErrorsB0)+2*sizeof(TErrorTerm));
    ErrorR1 := PErrors(longInt(ErrorsR1)+2*sizeof(TErrorTerm));
    ErrorG1 := PErrors(longInt(ErrorsG1)+2*sizeof(TErrorTerm));
    ErrorB1 := PErrors(longInt(ErrorsB1)+2*sizeof(TErrorTerm));
    ErrorR2 := PErrors(longInt(ErrorsR2)+2*sizeof(TErrorTerm));
    ErrorG2 := PErrors(longInt(ErrorsG2)+2*sizeof(TErrorTerm));
    ErrorB2 := PErrors(longInt(ErrorsB2)+2*sizeof(TErrorTerm));
  end else
  begin
    ErrorR0 := @ErrorsR0[Width+1];
    ErrorG0 := @ErrorsG0[Width+1];
    ErrorB0 := @ErrorsB0[Width+1];
    ErrorR1 := @ErrorsR1[Width+1];
    ErrorG1 := @ErrorsG1[Width+1];
    ErrorB1 := @ErrorsB1[Width+1];
    ErrorR2 := @ErrorsR2[Width+1];
    ErrorG2 := @ErrorsG2[Width+1];
    ErrorB2 := @ErrorsB2[Width+1];
  end;
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//	TStuckiDitherer
constructor TStuckiDitherer.Create(AWidth: integer; Lookup: TColorLookup);
begin
  inherited Create(AWidth, Lookup);
  FDivisor := 42;
end;

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
procedure TStuckiDitherer.Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer);
begin
  if (Error = 0) then
    exit;
  // Propagate Stucki error terms:
  //	...	...	(here)	8/42	4/42
  //	2/42	4/42	8/42	4/42	2/42
  //	1/42	2/42	4/42	2/42	1/42
  inc(Errors2[FDirection2], Error);	// Error * 1
  inc(Errors2[-FDirection2], Error);	// Error * 1

  Error := Error + Error;
  inc(Errors1[FDirection2], Error);	// Error * 2
  inc(Errors1[-FDirection2], Error);	// Error * 2
  inc(Errors2[Direction], Error);	// Error * 2
  inc(Errors2[-Direction], Error);	// Error * 2

  Error := Error + Error;
  inc(Errors0[FDirection2], Error);	// Error * 4
  inc(Errors1[-Direction], Error);	// Error * 4
  inc(Errors1[Direction], Error);	// Error * 4
  inc(Errors2[0], Error);		// Error * 4

  Error := Error + Error;
  inc(Errors0[Direction], Error);	// Error * 8
  inc(Errors1[0], Error);		// Error * 8
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//	TSierraDitherer
constructor TSierraDitherer.Create(AWidth: integer; Lookup: TColorLookup);
begin
  inherited Create(AWidth, Lookup);
  FDivisor := 32;
end;

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
procedure TSierraDitherer.Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer);
var
  TempError		: integer;
begin
  if (Error = 0) then
    exit;
  // Propagate Sierra error terms:
  //	...	...	(here)	5/32	3/32
  //	2/32	4/32	5/32	4/32	2/32
  //	...	2/32	3/32	2/32	...
  TempError := Error + Error;
  inc(Errors1[FDirection2], TempError);	// Error * 2
  inc(Errors1[-FDirection2], TempError);// Error * 2
  inc(Errors2[Direction], TempError);	// Error * 2
  inc(Errors2[-Direction], TempError);	// Error * 2

  inc(TempError, Error);
  inc(Errors0[FDirection2], TempError);	// Error * 3
  inc(Errors2[0], TempError);		// Error * 3

  inc(TempError, Error);
  inc(Errors1[-Direction], TempError);	// Error * 4
  inc(Errors1[Direction], TempError);	// Error * 4

  inc(TempError, Error);
  inc(Errors0[Direction], TempError);	// Error * 5
  inc(Errors1[0], TempError);		// Error * 5
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//	TJaJuNiDitherer
constructor TJaJuNiDitherer.Create(AWidth: integer; Lookup: TColorLookup);
begin
  inherited Create(AWidth, Lookup);
  FDivisor := 38;
end;

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
procedure TJaJuNiDitherer.Propagate(Errors0, Errors1, Errors2: PErrors; Error: integer);
var
  TempError		: integer;
begin
  if (Error = 0) then
    exit;
  // Propagate Jarvis, Judice and Ninke error terms:
  //	...	...	(here)	8/38	4/38
  //	2/38	4/38	8/38	4/38	2/38
  //	1/38	2/38	4/38	2/38	1/38
  inc(Errors2[FDirection2], Error);	// Error * 1
  inc(Errors2[-FDirection2], Error);	// Error * 1

  TempError := Error + Error;
  inc(Error, TempError);
  inc(Errors1[FDirection2], Error);	// Error * 3
  inc(Errors1[-FDirection2], Error);	// Error * 3
  inc(Errors2[Direction], Error);	// Error * 3
  inc(Errors2[-Direction], Error);	// Error * 3

  inc(Error, TempError);
  inc(Errors0[FDirection2], Error);	// Error * 5
  inc(Errors1[-Direction], Error);	// Error * 5
  inc(Errors1[Direction], Error);	// Error * 5
  inc(Errors2[0], Error);		// Error * 5

  inc(Error, TempError);
  inc(Errors0[Direction], Error);	// Error * 7
  inc(Errors1[0], Error);		// Error * 7
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//	TSteveArcheDitherer
constructor TSteveArcheDitherer.Create(AWidth: integer; Lookup: TColorLookup);
begin
  inherited Create(AWidth, Lookup);

  GetMem(ErrorsR0, sizeof(TErrorTerm)*(Width+6));
  GetMem(ErrorsG0, sizeof(TErrorTerm)*(Width+6));
  GetMem(ErrorsB0, sizeof(TErrorTerm)*(Width+6));
  GetMem(ErrorsR1, sizeof(TErrorTerm)*(Width+6));
  GetMem(ErrorsG1, sizeof(TErrorTerm)*(Width+6));
  GetMem(ErrorsB1, sizeof(TErrorTerm)*(Width+6));
  GetMem(ErrorsR2, sizeof(TErrorTerm)*(Width+6));
  GetMem(ErrorsG2, sizeof(TErrorTerm)*(Width+6));
  GetMem(ErrorsB2, sizeof(TErrorTerm)*(Width+6));
  GetMem(ErrorsR3, sizeof(TErrorTerm)*(Width+6));
  GetMem(ErrorsG3, sizeof(TErrorTerm)*(Width+6));
  GetMem(ErrorsB3, sizeof(TErrorTerm)*(Width+6));
  FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsR1^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsG1^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsB1^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsR2^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsG2^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsB2^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsR3^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsG3^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsB3^, sizeof(TErrorTerm)*(Width+6), 0);

  FDirection2 := 2 * Direction;
  FDirection3 := 3 * Direction;

  ErrorR0 := PErrors(longInt(ErrorsR0)+3*sizeof(TErrorTerm));
  ErrorG0 := PErrors(longInt(ErrorsG0)+3*sizeof(TErrorTerm));
  ErrorB0 := PErrors(longInt(ErrorsB0)+3*sizeof(TErrorTerm));
  ErrorR1 := PErrors(longInt(ErrorsR1)+3*sizeof(TErrorTerm));
  ErrorG1 := PErrors(longInt(ErrorsG1)+3*sizeof(TErrorTerm));
  ErrorB1 := PErrors(longInt(ErrorsB1)+3*sizeof(TErrorTerm));
  ErrorR2 := PErrors(longInt(ErrorsR2)+3*sizeof(TErrorTerm));
  ErrorG2 := PErrors(longInt(ErrorsG2)+3*sizeof(TErrorTerm));
  ErrorB2 := PErrors(longInt(ErrorsB2)+3*sizeof(TErrorTerm));
  ErrorR3 := PErrors(longInt(ErrorsR3)+3*sizeof(TErrorTerm));
  ErrorG3 := PErrors(longInt(ErrorsG3)+3*sizeof(TErrorTerm));
  ErrorB3 := PErrors(longInt(ErrorsB3)+3*sizeof(TErrorTerm));
end;

destructor TSteveArcheDitherer.Destroy;
begin
  FreeMem(ErrorsR0);
  FreeMem(ErrorsG0);
  FreeMem(ErrorsB0);
  FreeMem(ErrorsR1);
  FreeMem(ErrorsG1);
  FreeMem(ErrorsB1);
  FreeMem(ErrorsR2);
  FreeMem(ErrorsG2);
  FreeMem(ErrorsB2);
  FreeMem(ErrorsR3);
  FreeMem(ErrorsG3);
  FreeMem(ErrorsB3);
  inherited Destroy;
end;

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
function TSteveArcheDitherer.Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar;
var
  ColorR		,
  ColorG		,
  ColorB		: integer; // Error for current pixel

  // Propagate Stevenson & Arche error terms:
  //	...	...	...	(here)	...	32/200	...
  //    12/200	...	26/200	...	30/200	...	16/200
  //	...	12/200	...	26/200	...	12/200	...
  //	5/200	...	12/200	...	12/200	...	5/200
  procedure Propagate(Errors0, Errors1, Errors2, Errors3: PErrors; Error: integer);
  var
    TempError		: integer;
  begin
    if (Error = 0) then
      exit;
    TempError := 5 * Error;
    inc(Errors3[FDirection3], TempError);	// Error * 5
    inc(Errors3[-FDirection3], TempError);	// Error * 5

    TempError := 12 * Error;
    inc(Errors1[-FDirection3], TempError);	// Error * 12
    inc(Errors2[-FDirection2], TempError);	// Error * 12
    inc(Errors2[FDirection2], TempError);	// Error * 12
    inc(Errors3[-Direction], TempError);	// Error * 12
    inc(Errors3[Direction], TempError);		// Error * 12

    inc(Errors1[FDirection3], 16 * TempError);	// Error * 16

    TempError := 26 * Error;
    inc(Errors1[-Direction], TempError);	// Error * 26
    inc(Errors2[0], TempError);			// Error * 26

    inc(Errors1[Direction], 30 * Error);	// Error * 30

    inc(Errors0[FDirection2], 32 * Error);	// Error * 32
  end;

begin
  // Apply red component error correction
  ColorR := Red + (ErrorR0[0] + 100) DIV 200;
  if (ColorR < 0) then
    ColorR := 0
  else if (ColorR > 255) then
    ColorR := 255;

  // Apply green component error correction
  ColorG := Green + (ErrorG0[0] + 100) DIV 200;
  if (ColorG < 0) then
    ColorG := 0
  else if (ColorG > 255) then
    ColorG := 255;

  // Apply blue component error correction
  ColorB := Blue + (ErrorB0[0] + 100) DIV 200;
  if (ColorB < 0) then
    ColorB := 0
  else if (ColorB > 255) then
    ColorB := 255;

  // Map color to palette
  Result := inherited Dither(ColorR, ColorG, ColorB, R, G, B);

  // Propagate red component error
  Propagate(ErrorR0, ErrorR1, ErrorR2, ErrorR3, ColorR - R);
  // Propagate green component error
  Propagate(ErrorG0, ErrorG1, ErrorG2, ErrorG3, ColorG - G);
  // Propagate blue component error
  Propagate(ErrorB0, ErrorB1, ErrorB2, ErrorB3, ColorB - B);

  // Move on to next column
  if (Direction = 1) then
  begin
    inc(longInt(ErrorR0), sizeof(TErrorTerm));
    inc(longInt(ErrorG0), sizeof(TErrorTerm));
    inc(longInt(ErrorB0), sizeof(TErrorTerm));
    inc(longInt(ErrorR1), sizeof(TErrorTerm));
    inc(longInt(ErrorG1), sizeof(TErrorTerm));
    inc(longInt(ErrorB1), sizeof(TErrorTerm));
    inc(longInt(ErrorR2), sizeof(TErrorTerm));
    inc(longInt(ErrorG2), sizeof(TErrorTerm));
    inc(longInt(ErrorB2), sizeof(TErrorTerm));
    inc(longInt(ErrorR3), sizeof(TErrorTerm));
    inc(longInt(ErrorG3), sizeof(TErrorTerm));
    inc(longInt(ErrorB3), sizeof(TErrorTerm));
  end else
  begin
    dec(longInt(ErrorR0), sizeof(TErrorTerm));
    dec(longInt(ErrorG0), sizeof(TErrorTerm));
    dec(longInt(ErrorB0), sizeof(TErrorTerm));
    dec(longInt(ErrorR1), sizeof(TErrorTerm));
    dec(longInt(ErrorG1), sizeof(TErrorTerm));
    dec(longInt(ErrorB1), sizeof(TErrorTerm));
    dec(longInt(ErrorR2), sizeof(TErrorTerm));
    dec(longInt(ErrorG2), sizeof(TErrorTerm));
    dec(longInt(ErrorB2), sizeof(TErrorTerm));
    dec(longInt(ErrorR3), sizeof(TErrorTerm));
    dec(longInt(ErrorG3), sizeof(TErrorTerm));
    dec(longInt(ErrorB3), sizeof(TErrorTerm));
  end;
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
procedure TSteveArcheDitherer.NextLine;
var
  TempErrors		: PErrors;
begin
  FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+6), 0);
  FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+6), 0);

  // Swap lines
  TempErrors := ErrorsR0;
  ErrorsR0 := ErrorsR1;
  ErrorsR1 := ErrorsR2;
  ErrorsR2 := ErrorsR3;
  ErrorsR3 := TempErrors;

  TempErrors := ErrorsG0;
  ErrorsG0 := ErrorsG1;
  ErrorsG1 := ErrorsG2;
  ErrorsG2 := ErrorsG3;
  ErrorsG3 := TempErrors;

  TempErrors := ErrorsB0;
  ErrorsB0 := ErrorsB1;
  ErrorsB1 := ErrorsB2;
  ErrorsB2 := ErrorsB3;
  ErrorsB3 := TempErrors;

  inherited NextLine;

  FDirection2 := 2 * Direction;
  FDirection3 := 3 * Direction;

  if (Direction = 1) then
  begin
    // ErrorsR0[1] gives compiler error, so we
    // use PErrors(longInt(ErrorsR0)+sizeof(TErrorTerm)) instead...
    ErrorR0 := PErrors(longInt(ErrorsR0)+3*sizeof(TErrorTerm));
    ErrorG0 := PErrors(longInt(ErrorsG0)+3*sizeof(TErrorTerm));
    ErrorB0 := PErrors(longInt(ErrorsB0)+3*sizeof(TErrorTerm));
    ErrorR1 := PErrors(longInt(ErrorsR1)+3*sizeof(TErrorTerm));
    ErrorG1 := PErrors(longInt(ErrorsG1)+3*sizeof(TErrorTerm));
    ErrorB1 := PErrors(longInt(ErrorsB1)+3*sizeof(TErrorTerm));
    ErrorR2 := PErrors(longInt(ErrorsR2)+3*sizeof(TErrorTerm));
    ErrorG2 := PErrors(longInt(ErrorsG2)+3*sizeof(TErrorTerm));
    ErrorB2 := PErrors(longInt(ErrorsB2)+3*sizeof(TErrorTerm));
    ErrorR3 := PErrors(longInt(ErrorsR3)+3*sizeof(TErrorTerm));
    ErrorG3 := PErrors(longInt(ErrorsG3)+3*sizeof(TErrorTerm));
    ErrorB3 := PErrors(longInt(ErrorsB3)+3*sizeof(TErrorTerm));
  end else
  begin
    ErrorR0 := @ErrorsR0[Width+2];
    ErrorG0 := @ErrorsG0[Width+2];
    ErrorB0 := @ErrorsB0[Width+2];
    ErrorR1 := @ErrorsR1[Width+2];
    ErrorG1 := @ErrorsG1[Width+2];
    ErrorB1 := @ErrorsB1[Width+2];
    ErrorR2 := @ErrorsR2[Width+2];
    ErrorG2 := @ErrorsG2[Width+2];
    ErrorB2 := @ErrorsB2[Width+2];
    ErrorR3 := @ErrorsR2[Width+2];
    ErrorG3 := @ErrorsG2[Width+2];
    ErrorB3 := @ErrorsB2[Width+2];
  end;
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//	TBurkesDitherer
constructor TBurkesDitherer.Create(AWidth: integer; Lookup: TColorLookup);
begin
  inherited Create(AWidth, Lookup);

  GetMem(ErrorsR0, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsG0, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsB0, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsR1, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsG1, sizeof(TErrorTerm)*(Width+4));
  GetMem(ErrorsB1, sizeof(TErrorTerm)*(Width+4));
  FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsR1^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsG1^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsB1^, sizeof(TErrorTerm)*(Width+4), 0);

  FDirection2 := 2 * Direction;
  ErrorR0 := PErrors(longInt(ErrorsR0)+2*sizeof(TErrorTerm));
  ErrorG0 := PErrors(longInt(ErrorsG0)+2*sizeof(TErrorTerm));
  ErrorB0 := PErrors(longInt(ErrorsB0)+2*sizeof(TErrorTerm));
  ErrorR1 := PErrors(longInt(ErrorsR1)+2*sizeof(TErrorTerm));
  ErrorG1 := PErrors(longInt(ErrorsG1)+2*sizeof(TErrorTerm));
  ErrorB1 := PErrors(longInt(ErrorsB1)+2*sizeof(TErrorTerm));
end;

destructor TBurkesDitherer.Destroy;
begin
  FreeMem(ErrorsR0);
  FreeMem(ErrorsG0);
  FreeMem(ErrorsB0);
  FreeMem(ErrorsR1);
  FreeMem(ErrorsG1);
  FreeMem(ErrorsB1);
  inherited Destroy;
end;

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
function TBurkesDitherer.Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): ansichar;
var
  ErrorR		,
  ErrorG		,
  ErrorB		: integer; // Error for current pixel

  // Propagate Burkes error terms:
  //	...	...	(here)	8/32	4/32
  //	2/32	4/32	8/32	4/32	2/32
  procedure Propagate(Errors0, Errors1: PErrors; Error: integer);
  begin
    if (Error = 0) then
      exit;
    inc(Error, Error);
    inc(Errors1[FDirection2], Error);	// Error * 2
    inc(Errors1[-FDirection2], Error);	// Error * 2

    inc(Error, Error);
    inc(Errors0[FDirection2], Error);	// Error * 4
    inc(Errors1[-Direction], Error);	// Error * 4
    inc(Errors1[Direction], Error);	// Error * 4

    inc(Error, Error);
    inc(Errors0[Direction], Error);	// Error * 8
    inc(Errors1[0], Error);		// Error * 8
  end;

begin
  // Apply red component error correction
  ErrorR := Red + (ErrorR0[0] + 16) DIV 32;
  if (ErrorR < 0) then
    ErrorR := 0
  else if (ErrorR > 255) then
    ErrorR := 255;

  // Apply green component error correction
  ErrorG := Green + (ErrorG0[0] + 16) DIV 32;
  if (ErrorG < 0) then
    ErrorG := 0
  else if (ErrorG > 255) then
    ErrorG := 255;

  // Apply blue component error correction
  ErrorB := Blue + (ErrorB0[0] + 16) DIV 32;
  if (ErrorB < 0) then
    ErrorB := 0
  else if (ErrorB > 255) then
    ErrorB := 255;

  // Map color to palette
  Result := inherited Dither(ErrorR, ErrorG, ErrorB, R, G, B);

  // Propagate red component error
  Propagate(ErrorR0, ErrorR1, ErrorR - R);
  // Propagate green component error
  Propagate(ErrorG0, ErrorG1, ErrorG - G);
  // Propagate blue component error
  Propagate(ErrorB0, ErrorB1, ErrorB - B);

  // Move on to next column
  if (Direction = 1) then
  begin
    inc(longInt(ErrorR0), sizeof(TErrorTerm));
    inc(longInt(ErrorG0), sizeof(TErrorTerm));
    inc(longInt(ErrorB0), sizeof(TErrorTerm));
    inc(longInt(ErrorR1), sizeof(TErrorTerm));
    inc(longInt(ErrorG1), sizeof(TErrorTerm));
    inc(longInt(ErrorB1), sizeof(TErrorTerm));
  end else
  begin
    dec(longInt(ErrorR0), sizeof(TErrorTerm));
    dec(longInt(ErrorG0), sizeof(TErrorTerm));
    dec(longInt(ErrorB0), sizeof(TErrorTerm));
    dec(longInt(ErrorR1), sizeof(TErrorTerm));
    dec(longInt(ErrorG1), sizeof(TErrorTerm));
    dec(longInt(ErrorB1), sizeof(TErrorTerm));
  end;
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
procedure TBurkesDitherer.NextLine;
var
  TempErrors		: PErrors;
begin
  FillChar(ErrorsR0^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsG0^, sizeof(TErrorTerm)*(Width+4), 0);
  FillChar(ErrorsB0^, sizeof(TErrorTerm)*(Width+4), 0);

  // Swap lines
  TempErrors := ErrorsR0;
  ErrorsR0 := ErrorsR1;
  ErrorsR1 := TempErrors;

  TempErrors := ErrorsG0;
  ErrorsG0 := ErrorsG1;
  ErrorsG1 := TempErrors;

  TempErrors := ErrorsB0;
  ErrorsB0 := ErrorsB1;
  ErrorsB1 := TempErrors;

  inherited NextLine;

  FDirection2 := 2 * Direction;
  if (Direction = 1) then
  begin
    // ErrorsR0[1] gives compiler error, so we
    // use PErrors(longInt(ErrorsR0)+sizeof(TErrorTerm)) instead...
    ErrorR0 := PErrors(longInt(ErrorsR0)+2*sizeof(TErrorTerm));
    ErrorG0 := PErrors(longInt(ErrorsG0)+2*sizeof(TErrorTerm));
    ErrorB0 := PErrors(longInt(ErrorsB0)+2*sizeof(TErrorTerm));
    ErrorR1 := PErrors(longInt(ErrorsR1)+2*sizeof(TErrorTerm));
    ErrorG1 := PErrors(longInt(ErrorsG1)+2*sizeof(TErrorTerm));
    ErrorB1 := PErrors(longInt(ErrorsB1)+2*sizeof(TErrorTerm));
  end else
  begin
    ErrorR0 := @ErrorsR0[Width+1];
    ErrorG0 := @ErrorsG0[Width+1];
    ErrorB0 := @ErrorsB0[Width+1];
    ErrorR1 := @ErrorsR1[Width+1];
    ErrorG1 := @ErrorsG1[Width+1];
    ErrorB1 := @ErrorsB1[Width+1];
  end;
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//
//			Octree Color Quantization Engine
//
////////////////////////////////////////////////////////////////////////////////
//  Adapted from Earl F. Glynn's ColorQuantizationLibrary, March 1998
////////////////////////////////////////////////////////////////////////////////
type
  TOctreeNode = class;	// Forward definition so TReducibleNodes can be declared

  TReducibleNodes = array[0..7] of TOctreeNode;

  TOctreeNode = Class(TObject)
  public
    IsLeaf		: Boolean;
    PixelCount		: integer;
    RedSum		: integer;
    GreenSum		: integer;
    BlueSum		: integer;
    Next		: TOctreeNode;
    Child		: TReducibleNodes;

    constructor Create(Level: integer; ColorBits: integer; var LeafCount: integer;
      var ReducibleNodes: TReducibleNodes);
    destructor Destroy; override;
  end;

  TColorQuantizer = class(TObject)
  private
    FTree		: TOctreeNode;
    FLeafCount		: integer;
    FReducibleNodes	: TReducibleNodes;
    FMaxColors		: integer;
    FColorBits		: integer;

  protected
    procedure AddColor(var Node: TOctreeNode; r, g, b: byte; ColorBits: integer;
      Level: integer; var LeafCount: integer; var ReducibleNodes: TReducibleNodes);
    procedure DeleteTree(var Node: TOctreeNode);
    procedure GetPaletteColors(const Node: TOctreeNode;
      var RGBQuadArray: TRGBQuadArray; var Index: integer);
    procedure ReduceTree(ColorBits: integer; var LeafCount: integer;
      var ReducibleNodes: TReducibleNodes);

  public
    constructor Create(MaxColors: integer; ColorBits: integer);
    destructor Destroy; override;

    procedure GetColorTable(var RGBQuadArray: TRGBQuadArray);
    function ProcessImage(const DIB: TDIBReader): boolean;

    property ColorCount: integer read FLeafCount;
  end;

constructor TOctreeNode.Create(Level: integer; ColorBits: integer;
  var LeafCount: integer; var ReducibleNodes: TReducibleNodes);
var
  i			: integer;
begin
  PixelCount := 0;
  RedSum := 0;
  GreenSum := 0;
  BlueSum := 0;
  for i := Low(Child) to High(Child) do
    Child[i] := nil;

  IsLeaf := (Level = ColorBits);
  if (IsLeaf) then
  begin
    Next := nil;
    inc(LeafCount);
  end else
  begin
    Next := ReducibleNodes[Level];
    ReducibleNodes[Level] := self;
  end;
end;

destructor TOctreeNode.Destroy;
var
  i			: integer;
begin
  for i := High(Child) downto Low(Child) do
    Child[i].Free;
end;

constructor TColorQuantizer.Create(MaxColors: integer; ColorBits: integer);
var
  i			: integer;
begin
  ASSERT(ColorBits <= 8, 'ColorBits must be 8 or less');

  FTree := nil;
  FLeafCount := 0;

  // Initialize all nodes even though only ColorBits+1 of them are needed
  for i := Low(FReducibleNodes) to High(FReducibleNodes) do
    FReducibleNodes[i] := nil;

  FMaxColors := MaxColors;
  FColorBits := ColorBits;
end;

destructor TColorQuantizer.Destroy;
begin
  if (FTree <> nil) then
    DeleteTree(FTree);
end;

procedure TColorQuantizer.GetColorTable(var RGBQuadArray: TRGBQuadArray);
var
  Index			: integer;
begin
  Index := 0;
  GetPaletteColors(FTree, RGBQuadArray, Index);
end;

// Handles passed to ProcessImage should refer to DIB sections, not DDBs.
// In certain cases, specifically when it's called upon to process 1, 4, or
// 8-bit per pixel images on systems with palettized display adapters,
// ProcessImage can produce incorrect results if it's passed a handle to a
// DDB.
function TColorQuantizer.ProcessImage(const DIB: TDIBReader): boolean;
var
  i			,
  j			: integer;
  ScanLine		: pointer;
  Pixel			: PRGBTriple;
begin
  Result := True;

  for j := 0 to DIB.Bitmap.Height-1 do
  begin
    Scanline := DIB.Scanline[j];
    Pixel := ScanLine;
    for i := 0 to DIB.Bitmap.Width-1 do
    begin
      with Pixel^ do
        AddColor(FTree, rgbtRed, rgbtGreen, rgbtBlue,
                 FColorBits, 0, FLeafCount, FReducibleNodes);

      while FLeafCount > FMaxColors do
        ReduceTree(FColorbits, FLeafCount, FReducibleNodes);
      inc(Pixel);
    end;
  end;
end;

procedure TColorQuantizer.AddColor(var Node: TOctreeNode; r,g,b: byte;
  ColorBits: integer; Level: integer; var LeafCount: integer;
  var ReducibleNodes: TReducibleNodes);
const
  Mask:  array[0..7] of BYTE = ($80, $40, $20, $10, $08, $04, $02, $01);
var
  Index			: integer;
  Shift			: integer;
begin
  // If the node doesn't exist, create it.
  if (Node = nil) then
    Node := TOctreeNode.Create(Level, ColorBits, LeafCount, ReducibleNodes);

  if (Node.IsLeaf) then
  begin
    inc(Node.PixelCount);
    inc(Node.RedSum, r);
    inc(Node.GreenSum, g);
    inc(Node.BlueSum, b);
  end else
  begin
    // Recurse a level deeper if the node is not a leaf.
    Shift := 7 - Level;

    Index := (((r and mask[Level]) SHR Shift) SHL 2)  or
             (((g and mask[Level]) SHR Shift) SHL 1)  or
              ((b and mask[Level]) SHR Shift);
    AddColor(Node.Child[Index], r, g, b, ColorBits, Level+1, LeafCount, ReducibleNodes);
  end;
end;

procedure TColorQuantizer.DeleteTree(var Node: TOctreeNode);
var
  i			: integer;
begin
  for i := High(TReducibleNodes) downto Low(TReducibleNodes) do
    if (Node.Child[i] <> nil) then
      DeleteTree(Node.Child[i]);

  Node.Free;
  Node := nil;
end;

procedure TColorQuantizer.GetPaletteColors(const Node: TOctreeNode;
  var RGBQuadArray: TRGBQuadArray; var Index: integer);
var
  i			: integer;
begin
  if (Node.IsLeaf) then
  begin
    with RGBQuadArray[Index] do
    begin
      if (Node.PixelCount <> 0) then
      begin
        rgbRed   := BYTE(Node.RedSum   DIV Node.PixelCount);
        rgbGreen := BYTE(Node.GreenSum DIV Node.PixelCount);
        rgbBlue  := BYTE(Node.BlueSum  DIV Node.PixelCount);
      end else
      begin
        rgbRed := 0;
        rgbGreen := 0;
        rgbBlue := 0;
      end;
      rgbReserved := 0;
    end;
    inc(Index);
  end else
  begin
    for i := Low(Node.Child) to High(Node.Child) do
      if (Node.Child[i] <> nil) then
        GetPaletteColors(Node.Child[i], RGBQuadArray, Index);
  end;
end;

procedure TColorQuantizer.ReduceTree(ColorBits: integer; var LeafCount: integer;
  var ReducibleNodes: TReducibleNodes);
var
  RedSum		,
  GreenSum		,
  BlueSum 		: integer;
  Children		: integer;
  i			: integer;
  Node			: TOctreeNode;
begin
  // Find the deepest level containing at least one reducible node
  i := Colorbits - 1;
  while (i > 0) and (ReducibleNodes[i] = nil) do
    dec(i);

  // Reduce the node most recently added to the list at level i.
  Node := ReducibleNodes[i];
  ReducibleNodes[i] := Node.Next;

  RedSum   := 0;
  GreenSum := 0;
  BlueSum  := 0;
  Children := 0;

  for i := Low(ReducibleNodes) to High(ReducibleNodes) do
    if (Node.Child[i] <> nil) then
    begin
      inc(RedSum, Node.Child[i].RedSum);
      inc(GreenSum, Node.Child[i].GreenSum);
      inc(BlueSum, Node.Child[i].BlueSum);
      inc(Node.PixelCount, Node.Child[i].PixelCount);
      Node.Child[i].Free;
      Node.Child[i] := nil;
      inc(Children);
    end;

  Node.IsLeaf := TRUE;
  Node.RedSum := RedSum;
  Node.GreenSum := GreenSum;
  Node.BlueSum := BlueSum;
  dec(LeafCount, Children-1);
end;

////////////////////////////////////////////////////////////////////////////////
//
//			Octree Color Quantization Wrapper
//
////////////////////////////////////////////////////////////////////////////////
//	Adapted from Earl F. Glynn's PaletteLibrary, March 1998
////////////////////////////////////////////////////////////////////////////////

// Wrapper for internal use - uses TDIBReader for bitmap access
function doCreateOptimizedPaletteFromSingleBitmap(const DIB: TDIBReader;
  Colors, ColorBits: integer; Windows: boolean): hPalette;
var
  SystemPalette		: HPalette;
  ColorQuantizer	: TColorQuantizer;
  i			: integer;
  LogicalPalette	: TMaxLogPalette;
  RGBQuadArray		: TRGBQuadArray;
  Offset		: integer;
begin
  LogicalPalette.palVersion := $0300;
  LogicalPalette.palNumEntries := Colors;
// 2003.03.06 ->
  {reset palette to black}
  FillChar(LogicalPalette.palPalEntry, SizeOf(LogicalPalette.palPalEntry), 0);
  for i := 0 to 255 do
    LogicalPalette.palPalEntry[i].peFlags := PC_NOCOLLAPSE;
// 2003.03.06 <-

  if (Windows) then
  begin
    // Get the windows 20 color system palette
    SystemPalette := GetStockObject(DEFAULT_PALETTE);
    GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
    //GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[245]);  // wrong offset
    GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[246]);  // 2003.03.06
    Colors := 236;
    Offset := 10;
    LogicalPalette.palNumEntries := 256;
{ Test code
// 2003.03.06 ->
    // Get the windows 20 color system palette
    SystemPalette := GetStockObject(DEFAULT_PALETTE);
    GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
    GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[10]);
    Colors := 236;
    Offset := 20;
    LogicalPalette.palNumEntries := 256;
// 2003.03.06 <-
}
  end else
    Offset := 0;

  // Normally for 24-bit images, use ColorBits of 5 or 6.  For 8-bit images
  // use ColorBits = 8.
  ColorQuantizer := TColorQuantizer.Create(Colors, ColorBits);
  try
    ColorQuantizer.ProcessImage(DIB);
    ColorQuantizer.GetColorTable(RGBQuadArray);
  finally
    ColorQuantizer.Free;
  end;

  for i := 0 to Colors-1 do
    with LogicalPalette.palPalEntry[i+Offset] do
    begin
      peRed   := RGBQuadArray[i].rgbRed;
      peGreen := RGBQuadArray[i].rgbGreen;
      peBlue  := RGBQuadArray[i].rgbBlue;
      peFlags := RGBQuadArray[i].rgbReserved;
    end;
  Result := CreatePalette(pLogPalette(@LogicalPalette)^);
end;

function CreateOptimizedPaletteFromSingleBitmap(const Bitmap: TBitmap;
  Colors, ColorBits: integer; Windows: boolean): hPalette;
var
  DIB			: TDIBReader;
begin
  DIB := TDIBReader.Create(Bitmap, pf24bit);
  try
    Result := doCreateOptimizedPaletteFromSingleBitmap(DIB, Colors, ColorBits, Windows);
  finally
    DIB.Free;
  end;
end;

function CreateOptimizedPaletteFromManyBitmaps(Bitmaps: TList; Colors, ColorBits: integer;
  Windows: boolean): hPalette;
var
  SystemPalette		: HPalette;
  ColorQuantizer	: TColorQuantizer;
  i			: integer;
  LogicalPalette	: TMaxLogPalette;
  RGBQuadArray		: TRGBQuadArray;
  Offset		: integer;
  DIB			: TDIBReader;
begin
  if (Bitmaps = nil) or (Bitmaps.Count = 0) then
    Error(sInvalidBitmapList);

  LogicalPalette.palVersion := $0300;
  LogicalPalette.palNumEntries := Colors;
// 2003.03.06 ->
  {reset palette to black}
  FillChar(LogicalPalette.palPalEntry, SizeOf(LogicalPalette.palPalEntry), 0);
  for i := 0 to 255 do
    LogicalPalette.palPalEntry[i].peFlags := PC_NOCOLLAPSE;
// 2003.03.06 <-

  if (Windows) then
  begin
    // Get the windows 20 color system palette
    SystemPalette := GetStockObject(DEFAULT_PALETTE);
    GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
    //GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[245]);  // wrong offset
    GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[246]);  // 2003.03.06
    Colors := 236;
    Offset := 10;
    LogicalPalette.palNumEntries := 256;
{ Test code
// 2003.03.06 ->
    // Get the windows 20 color system palette
    SystemPalette := GetStockObject(DEFAULT_PALETTE);
    GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
    GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[10]);
    Colors := 236;
    Offset := 20;
    LogicalPalette.palNumEntries := 256;
// 2003.03.06 <-
}
  end else
    Offset := 0;

  // Normally for 24-bit images, use ColorBits of 5 or 6.  For 8-bit images
  // use ColorBits = 8.
  ColorQuantizer := TColorQuantizer.Create(Colors, ColorBits);
  try
    for i := 0 to Bitmaps.Count-1 do
    begin
      DIB := TDIBReader.Create(TBitmap(Bitmaps[i]), pf24bit);
      try
        ColorQuantizer.ProcessImage(DIB);
      finally
        DIB.Free;
      end;
    end;
    ColorQuantizer.GetColorTable(RGBQuadArray);
  finally
    ColorQuantizer.Free;
  end;

  for i := 0 to Colors-1 do
    with LogicalPalette.palPalEntry[i+Offset] do
    begin
      peRed   := RGBQuadArray[i].rgbRed;
      peGreen := RGBQuadArray[i].rgbGreen;
      peBlue  := RGBQuadArray[i].rgbBlue;
      peFlags := RGBQuadArray[i].rgbReserved;
    end;
  Result := CreatePalette(pLogPalette(@LogicalPalette)^);
end;

////////////////////////////////////////////////////////////////////////////////
//
//			Color reduction
//
////////////////////////////////////////////////////////////////////////////////
{$IFOPT R+}
  {$DEFINE R_PLUS}
  {$RANGECHECKS OFF}
{$ENDIF}
//: Reduces the color depth of a bitmap using color quantization and dithering.
function ReduceColors(Bitmap: TBitmap; ColorReduction: TColorReduction;
  DitherMode: TDitherMode; ReductionBits: integer; CustomPalette: hPalette): TBitmap;
var
  Palette		: hPalette;
  ColorLookup		: TColorLookup;
  Ditherer		: TDitherEngine;
  Row			: Integer;
  DIBResult		: TDIBWriter;
  DIBSource		: TDIBReader;
  SrcScanLine		,
  Src			: PRGBTriple;
  DstScanLine		,
  Dst			: PAnsiChar;
  BGR			: TRGBTriple;
{$ifdef DEBUG_DITHERPERFORMANCE}
  TimeStart		,
  TimeStop		: DWORD;
{$endif}

  function GrayScalePalette: hPalette;
  var
    i			: integer;
    Pal			: TMaxLogPalette;
  begin
    Pal.palVersion := $0300;
    Pal.palNumEntries := 256;
    for i := 0 to 255 do
    begin
        Pal.palPalEntry[i].peRed := i;
        Pal.palPalEntry[i].peGreen := i;
        Pal.palPalEntry[i].peBlue  := i;
        Pal.palPalEntry[i].peFlags := PC_NOCOLLAPSE;
    end;
    Result := CreatePalette(pLogPalette(@Pal)^);
  end;

  function MonochromePalette: hPalette;
  var
    i			: integer;
    Pal			: TMaxLogPalette;
  const
    Values		: array[0..1] of byte
    			= (0, 255);
  begin
    Pal.palVersion := $0300;
    Pal.palNumEntries := 2;
    for i := 0 to 1 do
    begin
        Pal.palPalEntry[i].peRed := Values[i];
        Pal.palPalEntry[i].peGreen := Values[i];
        Pal.palPalEntry[i].peBlue  := Values[i];
        Pal.palPalEntry[i].peFlags := PC_NOCOLLAPSE;
    end;
    Result := CreatePalette(pLogPalette(@Pal)^);
  end;

  function WindowsGrayScalePalette: hPalette;
  var
    i			: integer;
    Pal			: TMaxLogPalette;
  const
    Values		: array[0..3] of byte
    			= (0, 128, 192, 255);
  begin
    Pal.palVersion := $0300;
    Pal.palNumEntries := 4;
    for i := 0 to 3 do
    begin
        Pal.palPalEntry[i].peRed := Values[i];
        Pal.palPalEntry[i].peGreen := Values[i];
        Pal.palPalEntry[i].peBlue  := Values[i];
        Pal.palPalEntry[i].peFlags := PC_NOCOLLAPSE;
    end;
    Result := CreatePalette(pLogPalette(@Pal)^);
  end;

  function WindowsHalftonePalette: hPalette;
  var
    DC			: HDC;
  begin
    DC := GDICheck(GetDC(0));
    try
      Result := CreateHalfTonePalette(DC);
    finally
      ReleaseDC(0, DC);
    end;
  end;

begin
{$ifdef DEBUG_DITHERPERFORMANCE}
  timeBeginPeriod(5);
  TimeStart := timeGetTime;
{$endif}

  Result := TBitmap.Create;
  try

    if (ColorReduction = rmNone) then
    begin
      Result.Assign(Bitmap);
{$ifndef VER9x}
      SetPixelFormat(Result, pf24bit);
{$endif}
      exit;
    end;

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

    ColorLookup := nil;
    Ditherer := nil;
    DIBResult := nil;
    DIBSource := nil;
    Palette := 0;
    try // Protect above resources

      // Dithering and color mapper only supports 24 bit bitmaps,
      // so we have convert the source bitmap to the appropiate format.
      DIBSource := TDIBReader.Create(Bitmap, pf24bit);

      // Create a palette based on current options
      case (ColorReduction) of
        rmQuantize:
          Palette := doCreateOptimizedPaletteFromSingleBitmap(DIBSource, 1 SHL ReductionBits, 8, False);
        rmQuantizeWindows:
          Palette := CreateOptimizedPaletteFromSingleBitmap(Bitmap, 256, 8, True);
        rmNetscape:
          Palette := WebPalette;
        rmGrayScale:
          Palette := GrayScalePalette;
        rmMonochrome:
          Palette := MonochromePalette;
        rmWindowsGray:
          Palette := WindowsGrayScalePalette;
        rmWindows20:
          Palette := GetStockObject(DEFAULT_PALETTE);
        rmWindows256:
          Palette := WindowsHalftonePalette;
        rmPalette:
          Palette := CopyPalette(CustomPalette);
      else
        exit;
      end;

      { TODO -oanme -cImprovement : Gray scale conversion should be done prior to dithering/mapping. Otherwise corrected values will be converted multiple times. }

      // Create a color mapper based on current options
      case (ColorReduction) of
        // For some strange reason my fast and dirty color lookup
        // is more precise that Windows GetNearestPaletteIndex...
        // rmWindows20:
        //  ColorLookup := TSlowColorLookup.Create(Palette);
        // rmWindowsGray:
        //  ColorLookup := TGrayWindowsLookup.Create(Palette);
        rmQuantize:
//          ColorLookup := TFastColorLookup.Create(Palette);
          ColorLookup := TSlowColorLookup.Create(Palette);  // 2003-03-06
        rmNetscape:
          ColorLookup := TNetscapeColorLookup.Create(Palette);
        rmGrayScale:
          ColorLookup := TGrayScaleLookup.Create(Palette);
        rmMonochrome:
          ColorLookup := TMonochromeLookup.Create(Palette);
      else
//        ColorLookup := TFastColorLookup.Create(Palette);
        ColorLookup := TSlowColorLookup.Create(Palette);  // 2003-03-06
      end;

      // Nothing to do if palette doesn't contain any colors
      if (ColorLookup.Colors = 0) then
        exit;

      // Create a ditherer based on current options
      case (DitherMode) of
        dmNearest:
          Ditherer := TDitherEngine.Create(Bitmap.Width, ColorLookup);
        dmFloydSteinberg:
          Ditherer := TFloydSteinbergDitherer.Create(Bitmap.Width, ColorLookup);
        dmStucki:
          Ditherer := TStuckiDitherer.Create(Bitmap.Width, ColorLookup);
        dmSierra:
          Ditherer := TSierraDitherer.Create(Bitmap.Width, ColorLookup);
        dmJaJuNI:
          Ditherer := TJaJuNIDitherer.Create(Bitmap.Width, ColorLookup);
        dmSteveArche:
          Ditherer := TSteveArcheDitherer.Create(Bitmap.Width, ColorLookup);
        dmBurkes:
          Ditherer := TBurkesDitherer.Create(Bitmap.Width, ColorLookup);
      else
        exit;
      end;

      // The processed bitmap is returned in pf8bit format
      DIBResult := TDIBWriter.Create(Result, pf8bit, Bitmap.Width, Bitmap.Height,
        Palette);

      // Process the image
      Row := 0;
      while (Row < Bitmap.Height) do
      begin
        SrcScanline := DIBSource.ScanLine[Row];
        DstScanline := DIBResult.ScanLine[Row];
        Src := pointer(longInt(SrcScanLine) + Ditherer.Column*sizeof(TRGBTriple));
        Dst := pointer(longInt(DstScanLine) + Ditherer.Column);

        while (Ditherer.Column < Ditherer.Width) and (Ditherer.Column >= 0) do
        begin
          BGR := Src^;
          // Dither and map a single pixel
          Dst^ := Ditherer.Dither(BGR.rgbtRed, BGR.rgbtGreen, BGR.rgbtBlue,
            BGR.rgbtRed, BGR.rgbtGreen, BGR.rgbtBlue);

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

        Inc(Row);
        Ditherer.NextLine;
      end;
    finally
      if (ColorLookup <> nil) then
        ColorLookup.Free;
      if (Ditherer <> nil) then
        Ditherer.Free;
      if (DIBResult <> nil) then
        DIBResult.Free;
      if (DIBSource <> nil) then
        DIBSource.Free;
      // Must delete palette after TDIBWriter since TDIBWriter uses palette 
      if (Palette <> 0) then
        DeleteObject(Palette);
    end;
  except
    Result.Free;
    raise;
  end;

{$ifdef DEBUG_DITHERPERFORMANCE}
  TimeStop := timeGetTime;
  ShowMessage(format('Dithered %d pixels in %d mS, Rate %d pixels/mS (%d pixels/S)',
    [Bitmap.Height*Bitmap.Width, TimeStop-TimeStart,
    MulDiv(Bitmap.Height, Bitmap.Width, TimeStop-TimeStart+1),
    MulDiv(Bitmap.Height, Bitmap.Width * 1000, TimeStop-TimeStart+1)]));
  timeEndPeriod(5);
{$endif}
end;
{$IFDEF R_PLUS}
  {$RANGECHECKS ON}
  {$UNDEF R_PLUS}
{$ENDIF}

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFColorMap
//
////////////////////////////////////////////////////////////////////////////////
const
  InitColorMapSize = 16;
  DeltaColorMapSize = 32;

//: Creates an instance of a TGIFColorMap object.
constructor TGIFColorMap.Create;
begin
  inherited Create;
  FColorMap := nil;
  FCapacity := 0;
  FCount := 0;
  FOptimized := False;
end;

//: Destroys an instance of a TGIFColorMap object.
destructor TGIFColorMap.Destroy;
begin
  Clear;
  Changed;
  inherited Destroy;
end;

//: Empties the color map.
procedure TGIFColorMap.Clear;
begin
  if (FColorMap <> nil) then
    FreeMem(FColorMap);
  FColorMap := nil;
  FCapacity := 0;
  FCount := 0;
  FOptimized := False;
end;

//: Converts a Windows color value to a RGB value.
class function TGIFColorMap.Color2RGB(Color: TColor): TGIFColor;
begin
  Result.Blue := (Color shr 16) and $FF;
  Result.Green := (Color shr 8) and $FF;
  Result.Red  := Color and $FF;
end;

//: Converts a RGB value to a Windows color value.
class function TGIFColorMap.RGB2Color(Color: TGIFColor): TColor;
begin
  Result := (Color.Blue SHL 16) OR (Color.Green SHL 8) OR Color.Red;
end;

//: Saves the color map to a stream.
procedure TGIFColorMap.SaveToStream(Stream: TStream);
var
  Dummies		: integer;
  Dummy			: TGIFColor;
begin
  if (FCount = 0) then
    exit;
  Stream.WriteBuffer(FColorMap^, FCount*sizeof(TGIFColor));
  Dummies := (1 SHL BitsPerPixel)-FCount;
  Dummy.Red := 0;
  Dummy.Green := 0;
  Dummy.Blue := 0;
  while (Dummies > 0) do
  begin
    Stream.WriteBuffer(Dummy, sizeof(TGIFColor));
    dec(Dummies);
  end;
end;

//: Loads the color map from a stream.
procedure TGIFColorMap.LoadFromStream(Stream: TStream; Count: integer);
begin
  Clear;
  SetCapacity(Count);
  ReadCheck(Stream, FColorMap^, Count*sizeof(TGIFColor));
  FCount := Count;
end;

//: Returns the position of a color in the color map.
function TGIFColorMap.IndexOf(Color: TColor): integer;
var
  RGB			: TGIFColor;
begin
  RGB := Color2RGB(Color);
  if (FOptimized) then
  begin
    // Optimized palette has most frequently occuring entries first
    Result := 0;
    // Reverse search to (hopefully) check latest colors first
    while (Result < FCount) do
      with (FColorMap^[Result]) do
      begin
        if (RGB.Red = Red) and (RGB.Green = Green) and (RGB.Blue = Blue) then
          exit;
        Inc(Result);
      end;
    Result := -1;
  end else
  begin
    Result := FCount-1;
    // Reverse search to (hopefully) check latest colors first
    while (Result >= 0) do
      with (FColorMap^[Result]) do
      begin
        if (RGB.Red = Red) and (RGB.Green = Green) and (RGB.Blue = Blue) then
          exit;
        Dec(Result);
      end;
  end;
end;

procedure TGIFColorMap.SetCapacity(Size: integer);
begin
  if (Size >= FCapacity) then
  begin
    if (Size <= InitColorMapSize) then
      FCapacity := InitColorMapSize
    else
      FCapacity := (Size + DeltaColorMapSize - 1) DIV DeltaColorMapSize * DeltaColorMapSize;
    if (FCapacity > GIFMaxColors) then
      FCapacity := GIFMaxColors;
    ReallocMem(FColorMap, FCapacity * sizeof(TGIFColor));
  end;
end;

//: Imports a Windows palette into the color map.
procedure TGIFColorMap.ImportPalette(Palette: HPalette);
type
  PalArray =  array[byte] of TPaletteEntry;
var
  Pal			: PalArray;
  NewCount		: integer;
  i			: integer;
begin
  Clear;
  NewCount := GetPaletteEntries(Palette, 0, 256, pal);
  if (NewCount = 0) then
    exit;
  SetCapacity(NewCount);
  for i := 0 to NewCount-1 do
    with FColorMap[i], Pal[i] do
    begin
      Red := peRed;
      Green := peGreen;
      Blue := peBlue;
    end;
  FCount := NewCount;
  Changed;
end;

//: Imports a color map structure into the color map.
procedure TGIFColorMap.ImportColorMap(Map: TColorMap; Count: integer);
begin
  Clear;
  if (Count = 0) then
    exit;
  SetCapacity(Count);
  FCount := Count;

  System.Move(Map, FColorMap^, FCount * sizeof(TGIFColor));

  Changed;
end;

//: Imports a Windows palette structure into the color map.
procedure TGIFColorMap.ImportColorTable(Pal: pointer; Count: integer);
var
  i			: integer;
begin
  Clear;
  if (Count = 0) then
    exit;
  SetCapacity(Count);
  for i := 0 to Count-1 do
    with FColorMap[i], PRGBQuadArray(Pal)[i] do
    begin
      Red := rgbRed;
      Green := rgbGreen;
      Blue := rgbBlue;
    end;
  FCount := Count;
  Changed;
end;

//: Imports the color table of a DIB into the color map.
procedure TGIFColorMap.ImportDIBColors(Handle: HDC);
var
  Pal			: Pointer;
  NewCount		: integer;
begin
  Clear;
  GetMem(Pal, sizeof(TRGBQuad) * 256);
  try
    NewCount := GetDIBColorTable(Handle, 0, 256, Pal^);
    ImportColorTable(Pal, NewCount);
  finally
    FreeMem(Pal);
  end;
  Changed;
end;

//: Creates a Windows palette from the color map.
function TGIFColorMap.ExportPalette: HPalette;
var
  Pal			: TMaxLogPalette;
  i			: Integer;
begin
  if (Count = 0) then
  begin
    Result := 0;
    exit;
  end;
  Pal.palVersion := $300;
  Pal.palNumEntries := Count;
  for i := 0 to Count-1 do
    with FColorMap[i], Pal.palPalEntry[i] do
    begin
      peRed := Red;
      peGreen := Green;
      peBlue := Blue;
      peFlags := PC_NOCOLLAPSE; { TODO -oanme -cImprovement : Verify that PC_NOCOLLAPSE is the correct value to use. }
    end;
  Result := CreatePalette(PLogPalette(@Pal)^);
end;

//: Adds a color to the color map.
function TGIFColorMap.Add(Color: TColor): integer;
begin
  if (FCount >= GIFMaxColors) then
    // Color map full
    Error(sTooManyColors);

  Result := FCount;
  if (Result >= FCapacity) then
    SetCapacity(FCount+1);
  FColorMap^[FCount] := Color2RGB(Color);
  inc(FCount);
  FOptimized := False;
  Changed;
end;

function TGIFColorMap.AddUnique(Color: TColor): integer;
begin
  // Look up color before add (same as IndexOf)
  Result := IndexOf(Color);
  if (Result >= 0) then
    // Color already in map
    exit;

  Result := Add(Color);
end;

//: Removes a color from the color map.
procedure TGIFColorMap.Delete(Index: integer);
begin
  if (Index < 0) or (Index >= FCount) then
    // Color index out of range
    Error(sBadColorIndex);
  dec(FCount);
  if (Index < FCount) then
    System.Move(FColorMap^[Index + 1], FColorMap^[Index], (FCount - Index)* sizeof(TGIFColor));
  FOptimized := False;
  Changed;
end;

function TGIFColorMap.GetColor(Index: integer): TColor;
begin
  if (Index < 0) or (Index >= FCount) then
  begin
    // Color index out of range
    Warning(gsWarning, sBadColorIndex);
    // Raise an exception if the color map is empty
    if (FCount = 0) then
      Error(sEmptyColorMap);
    // Default to color index 0
    Index := 0;
  end;
  Result := RGB2Color(FColorMap^[Index]);
end;

procedure TGIFColorMap.SetColor(Index: integer; Value: TColor);
begin
  if (Index < 0) or (Index >= FCount) then
    // Color index out of range
    Error(sBadColorIndex);
  FColorMap^[Index] := Color2RGB(Value);
  Changed;
end;

function TGIFColorMap.DoOptimize: boolean;
var
  Usage			: TColormapHistogram;
  TempMap		: array[0..255] of TGIFColor;
  ReverseMap		: TColormapReverse;
  i			: integer;
  LastFound		: boolean;
  NewCount		: integer;
  T			: TUsageCount;
  Pivot			: integer;

  procedure QuickSort(iLo, iHi: Integer);
  var
    Lo, Hi: Integer;
  begin
    repeat
      Lo := iLo;
      Hi := iHi;
      Pivot := Usage[(iLo + iHi) SHR 1].Count;
      repeat
        while (Usage[Lo].Count - Pivot > 0) do inc(Lo);
        while (Usage[Hi].Count - Pivot < 0) do dec(Hi);
        if (Lo <= Hi) then
        begin
          T := Usage[Lo];
          Usage[Lo] := Usage[Hi];
          Usage[Hi] := T;
          inc(Lo);
          dec(Hi);
        end;
      until (Lo > Hi);
      if (iLo < Hi) then
        QuickSort(iLo, Hi);
      iLo := Lo;
    until (Lo >= iHi);
  end;

begin
  if (FCount <= 1) then
  begin
    Result := False;
    exit;
  end;

  FOptimized := True;
  Result := True;

  BuildHistogram(Usage);

  (*
  **  Sort according to usage count
  *)
  QuickSort(0, FCount-1);

  (*
  ** Test for table already sorted
  *)
  for i := 0 to FCount-1 do
    if (Usage[i].Index <> i) then
      break;
  if (i = FCount) then
    exit;

  (*
  ** Build old to new map
  *)
  for i := 0 to FCount-1 do
    ReverseMap[Usage[i].Index] := i;


  MapImages(ReverseMap);

  (*
  **  Reorder colormap
  *)
  LastFound := False;
  NewCount := FCount;
  Move(FColorMap^, TempMap, FCount * sizeof(TGIFColor));
  for i := 0 to FCount-1 do
  begin
    FColorMap^[ReverseMap[i]] := TempMap[i];
    // Find last used color index
    if (Usage[i].Count = 0) and not(LastFound) then
    begin
      LastFound := True;
      NewCount := i;
    end;
  end;

  FCount := NewCount;

  Changed;
end;

function TGIFColorMap.GetBitsPerPixel: integer;
begin
  Result := Colors2bpp(FCount);
end;

//: Copies one color map to another.
procedure TGIFColorMap.Assign(Source: TPersistent);
begin
  if (Source is TGIFColorMap) then
  begin
    Clear;
    FCapacity := TGIFColorMap(Source).FCapacity;
    FCount := TGIFColorMap(Source).FCount;
    FOptimized := TGIFColorMap(Source).FOptimized;
    FColorMap := AllocMem(FCapacity * sizeof(TGIFColor));
    System.Move(TGIFColorMap(Source).FColorMap^, FColorMap^, FCount * sizeof(TGIFColor));
    Changed;
  end else
    inherited Assign(Source);
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFItem
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFItem.Create(GIFImage: TGIFImage);
begin
  inherited Create;

  FGIFImage := GIFImage;
end;

procedure TGIFItem.Warning(Severity: TGIFSeverity; Message: string);
begin
  FGIFImage.Warning(self, Severity, Message);
end;

function TGIFItem.GetVersion: TGIFVersion;
begin
  Result := gv87a;
end;

procedure TGIFItem.LoadFromFile(const Filename: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(Filename, fmOpenRead OR fmShareDenyWrite);
  try
    LoadFromStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TGIFItem.SaveToFile(const Filename: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(Filename, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFList
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFList.Create(Image: TGIFImage);
begin
  inherited Create;
  FImage := Image;
  FItems := TList.Create;
end;

destructor TGIFList.Destroy;
begin
  Clear;
  FItems.Free;
  inherited Destroy;
end;

function TGIFList.GetItem(Index: Integer): TGIFItem;
begin
  Result := TGIFItem(FItems[Index]);
end;

procedure TGIFList.SetItem(Index: Integer; Item: TGIFItem);
begin
  FItems[Index] := Item;
end;

function TGIFList.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TGIFList.Add(Item: TGIFItem): Integer;
begin
  Result := FItems.Add(Item);
end;

procedure TGIFList.Clear;
begin
  while (FItems.Count > 0) do
    Delete(0);
end;

procedure TGIFList.Delete(Index: Integer);
var
  Item			: TGIFItem;
begin
  Item := TGIFItem(FItems[Index]);
  // Delete before item is destroyed to avoid recursion
  FItems.Delete(Index);
  Item.Free;
end;

procedure TGIFList.Exchange(Index1, Index2: Integer);
begin
  FItems.Exchange(Index1, Index2);
end;

function TGIFList.First: TGIFItem;
begin
  Result := TGIFItem(FItems.First);
end;

function TGIFList.IndexOf(Item: TGIFItem): Integer;
begin
  Result := FItems.IndexOf(Item);
end;

procedure TGIFList.Insert(Index: Integer; Item: TGIFItem);
begin
  FItems.Insert(Index, Item);
end;

function TGIFList.Last: TGIFItem;
begin
  Result := TGIFItem(FItems.Last);
end;

procedure TGIFList.Move(CurIndex, NewIndex: Integer);
begin
  FItems.Move(CurIndex, NewIndex);
end;

function TGIFList.Remove(Item: TGIFItem): Integer;
begin
  // Note: TGIFList.Remove must not destroy item
  Result := FItems.Remove(Item);
end;

procedure TGIFList.SaveToStream(Stream: TStream);
var
  i			: integer;
begin
  for i := 0 to FItems.Count-1 do
    TGIFItem(FItems[i]).SaveToStream(Stream);
end;

procedure TGIFList.Warning(Severity: TGIFSeverity; Message: string);
begin
  Image.Warning(self, Severity, Message);
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFGlobalColorMap
//
////////////////////////////////////////////////////////////////////////////////
type
  TGIFGlobalColorMap = class(TGIFColorMap)
  private
    FHeader	: TGIFHeader;
  protected
    procedure Warning(Severity: TGIFSeverity; Message: string); override;
    procedure BuildHistogram(var Histogram: TColormapHistogram); override;
    procedure MapImages(var Map: TColormapReverse); override;
  public
    constructor Create(HeaderItem: TGIFHeader);
    function Optimize: boolean; override;
    procedure Changed; override;
  end;

constructor TGIFGlobalColorMap.Create(HeaderItem: TGIFHeader);
begin
  Inherited Create;
  FHeader := HeaderItem;
end;

procedure TGIFGlobalColorMap.Warning(Severity: TGIFSeverity; Message: string);
begin
  FHeader.Image.Warning(self, Severity, Message);
end;

procedure TGIFGlobalColorMap.BuildHistogram(var Histogram: TColormapHistogram);
var
  Pixel			,
  LastPixel		: PAnsiChar;
  i			: integer;
begin
  (*
  ** Init histogram
  *)
  for i := 0 to Count-1 do
  begin
    Histogram[i].Index := i;
    Histogram[i].Count := 0;
  end;

  for i := 0 to FHeader.Image.Images.Count-1 do
    if (FHeader.Image.Images[i].ActiveColorMap = self) then
    begin
      Pixel := FHeader.Image.Images[i].Data;
      LastPixel := Pixel + FHeader.Image.Images[i].Width * FHeader.Image.Images[i].Height;

      (*
      ** Sum up usage count for each color
      *)
      while (Pixel < LastPixel) do
      begin
        inc(Histogram[ord(Pixel^)].Count);
        inc(Pixel);
      end;
    end;
end;

procedure TGIFGlobalColorMap.MapImages(var Map: TColormapReverse);
var
  Pixel			,
  LastPixel		: PAnsiChar;
  i			: integer;
begin
  for i := 0 to FHeader.Image.Images.Count-1 do
    if (FHeader.Image.Images[i].ActiveColorMap = self) then
    begin
      Pixel := FHeader.Image.Images[i].Data;
      LastPixel := Pixel + FHeader.Image.Images[i].Width * FHeader.Image.Images[i].Height;

      (*
      **  Reorder all pixel to new map
      *)
      while (Pixel < LastPixel) do
      begin
        Pixel^ := ansichar(Map[ord(Pixel^)]);
        inc(Pixel);
      end;

      (*
      **  Reorder transparent colors
      *)
      if (FHeader.Image.Images[i].Transparent) then
        FHeader.Image.Images[i].GraphicControlExtension.TransparentColorIndex :=
          Map[FHeader.Image.Images[i].GraphicControlExtension.TransparentColorIndex];
    end;
end;

function TGIFGlobalColorMap.Optimize: boolean;
begin
  { Optimize with first image, Remove unused colors if only one image }
  if (FHeader.Image.Images.Count > 0) then
    Result := DoOptimize
  else
    Result := False;
end;

procedure TGIFGlobalColorMap.Changed;
begin
  FHeader.Image.Palette := 0;
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFHeader
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFHeader.Create(GIFImage: TGIFImage);
begin
  inherited Create(GIFImage);
  FColorMap := TGIFGlobalColorMap.Create(self);
  Clear;
end;

destructor TGIFHeader.Destroy;
begin
  FColorMap.Free;
  inherited Destroy;
end;

procedure TGIFHeader.Clear;
begin
  FColorMap.Clear;
  FLogicalScreenDescriptor.ScreenWidth := 0;
  FLogicalScreenDescriptor.ScreenHeight := 0;
  FLogicalScreenDescriptor.PackedFields := 0;
  FLogicalScreenDescriptor.BackgroundColorIndex := 0;
  FLogicalScreenDescriptor.AspectRatio := 0;
end;

procedure TGIFHeader.Assign(Source: TPersistent);
begin
  if (Source is TGIFHeader) then
  begin
    ColorMap.Assign(TGIFHeader(Source).ColorMap);
    FLogicalScreenDescriptor := TGIFHeader(Source).FLogicalScreenDescriptor;
  end else
  if (Source is TGIFColorMap) then
  begin
    Clear;
    ColorMap.Assign(TGIFColorMap(Source));
  end else
    inherited Assign(Source);
end;

type
  TGIFHeaderRec = packed record
    Signature: array[0..2] of ansichar; { contains 'GIF' }
    Version: TGIFVersionRec;   { '87a' or '89a' }
  end;

const
  { logical screen descriptor packed field masks }
  lsdGlobalColorTable	= $80;		{ set if global color table follows L.S.D. }
  lsdColorResolution	= $70;		{ Color resolution - 3 bits }
  lsdSort		= $08;		{ set if global color table is sorted - 1 bit }
  lsdColorTableSize	= $07;		{ size of global color table - 3 bits }
  					{ Actual size = 2^value+1    - value is 3 bits }
procedure TGIFHeader.Prepare;
var
  pack			: BYTE;
begin
  Pack := $00;
  if (ColorMap.Count > 0) then
  begin
    Pack := lsdGlobalColorTable;
    if (ColorMap.Optimized) then
      Pack := Pack OR lsdSort;
  end;
  // Note: The SHL below was SHL 5 in the original source, but that looks wrong
  Pack := Pack OR ((Image.ColorResolution SHL 4) AND lsdColorResolution);
  Pack := Pack OR ((Image.BitsPerPixel-1) AND lsdColorTableSize);
  FLogicalScreenDescriptor.PackedFields := Pack;
end;

procedure TGIFHeader.SaveToStream(Stream: TStream);
var
  GifHeader		: TGIFHeaderRec;
  v			: TGIFVersion;
begin
  v := Image.Version;
  if (v = gvUnknown) then
    Error(sBadVersion);

  GifHeader.Signature := 'GIF';
  GifHeader.Version := GIFVersions[v];

  Prepare;
  Stream.Write(GifHeader, sizeof(GifHeader));
  Stream.Write(FLogicalScreenDescriptor, sizeof(FLogicalScreenDescriptor));
  if (FLogicalScreenDescriptor.PackedFields AND lsdGlobalColorTable = lsdGlobalColorTable) then
    ColorMap.SaveToStream(Stream);
end;

procedure TGIFHeader.LoadFromStream(Stream: TStream);
var
  GifHeader		: TGIFHeaderRec;
  ColorCount		: integer;
  Position		: integer;
begin
  Position := Stream.Position;

  ReadCheck(Stream, GifHeader, sizeof(GifHeader));
  if (uppercase(GifHeader.Signature) <> 'GIF') then
  begin
    // Attempt recovery in case we are reading a GIF stored in a form by rxLib
    Stream.Position := Position;
    // Seek past size stored in stream
    Stream.Seek(sizeof(longInt), soFromCurrent);
    // Attempt to read signature again
    ReadCheck(Stream, GifHeader, sizeof(GifHeader));
    if (uppercase(GifHeader.Signature) <> 'GIF') then
      Error(sBadSignature);
  end;

  ReadCheck(Stream, FLogicalScreenDescriptor, sizeof(FLogicalScreenDescriptor));

  if (FLogicalScreenDescriptor.PackedFields AND lsdGlobalColorTable = lsdGlobalColorTable) then
  begin
    ColorCount := 2 SHL (FLogicalScreenDescriptor.PackedFields AND lsdColorTableSize);
    if (ColorCount < 2) or (ColorCount > 256) then
      Error(sScreenBadColorSize);
    ColorMap.LoadFromStream(Stream, ColorCount)
  end else
    ColorMap.Clear;
end;

function TGIFHeader.GetVersion: TGIFVersion;
begin
  if (FColorMap.Optimized) or (AspectRatio <> 0) then
    Result := gv89a
  else
    Result := inherited GetVersion;
end;

function TGIFHeader.GetBackgroundColor: TColor;
begin
  Result := FColorMap[BackgroundColorIndex];
end;

procedure TGIFHeader.SetBackgroundColor(Color: TColor);
begin
  BackgroundColorIndex := FColorMap.AddUnique(Color);
end;

procedure TGIFHeader.SetBackgroundColorIndex(Index: BYTE);
begin
  if ((Index >= FColorMap.Count) and (FColorMap.Count > 0)) then
  begin
    Warning(gsWarning, sBadColorIndex);
    Index := 0;
  end;
  FLogicalScreenDescriptor.BackgroundColorIndex := Index;
end;

function TGIFHeader.GetBitsPerPixel: integer;
begin
  Result := FColorMap.BitsPerPixel;
end;

function TGIFHeader.GetColorResolution: integer;
begin
  Result := FColorMap.BitsPerPixel-1;
end;

////////////////////////////////////////////////////////////////////////////////
//
//			TGIFLocalColorMap
//
////////////////////////////////////////////////////////////////////////////////
type
  TGIFLocalColorMap = class(TGIFColorMap)
  private
    FSubImage		: TGIFSubImage;
  protected
    procedure Warning(Severity: TGIFSeverity; Message: string); override;
    procedure BuildHistogram(var Histogram: TColormapHistogram); override;
    procedure MapImages(var Map: TColormapReverse); override;
  public
    constructor Create(SubImage: TGIFSubImage);
    function Optimize: boolean; override;
    procedure Changed; override;
  end;

constructor TGIFLocalColorMap.Create(SubImage: TGIFSubImage);
begin
  Inherited Create;
  FSubImage := SubImage;
end;

procedure TGIFLocalColorMap.Warning(Severity: TGIFSeverity; Message: string);
begin
  FSubImage.Image.Warning(self, Severity, Message);
end;

procedure TGIFLocalColorMap.BuildHistogram(var Histogram: TColormapHistogram);
var
  Pixel			,
  LastPixel		: PAnsiChar;
  i			: integer;
begin
  Pixel := FSubImage.Data;
  LastPixel := Pixel + FSubImage.Width * FSubImage.Height;

  (*
  ** Init histogram
  *)
  for i := 0 to Count-1 do
  begin
    Histogram[i].Index := i;
    Histogram[i].Count := 0;
  end;

  (*
  ** Sum up usage count for each color
  *)
  while (Pixel < LastPixel) do
  begin
    inc(Histogram[ord(Pixel^)].Count);
    inc(Pixel);
  end;
end;

procedure TGIFLocalColorMap.MapImages(var Map: TColormapReverse);
var
  Pixel			,
  LastPixel		: PAnsiChar;
begin
  Pixel := FSubImage.Data;
  LastPixel := Pixel + FSubImage.Width * FSubImage.Height;

  (*
  **  Reorder all pixel to new map
  *)
  while (Pixel < LastPixel) do
  begin
    Pixel^ := ansichar(Map[ord(Pixel^)]);
    inc(Pixel);
  end;

  (*
  **  Reorder transparent colors
  *)
  if (FSubImage.Transparent) then
    FSubImage.GraphicControlExtension.TransparentColorIndex :=
      Map[FSubImage.GraphicControlExtension.TransparentColorIndex];
end;

function TGIFLocalColorMap.Optimize: boolean;
begin
  Result := DoOptimize;
end;

procedure TGIFLocalColorMap.Changed;
begin
  FSubImage.Palette := 0;
end;


////////////////////////////////////////////////////////////////////////////////
//
//			LZW Decoder
//
////////////////////////////////////////////////////////////////////////////////
const
  GIFCodeBits		= 12;			// Max number of bits per GIF token code
  GIFCodeMax		= (1 SHL GIFCodeBits)-1;// Max GIF token code
  						// 12 bits = 4095
  StackSize		= (2 SHL GIFCodeBits);	// Size of decompression stack
  TableSize		= (1 SHL GIFCodeBits);	// Size of decompression table

procedure TGIFSubImage.Decompress(Stream: TStream);
var
  table0		: array[0..TableSize-1] of integer;
  table1		: array[0..TableSize-1] of integer;
  firstcode, oldcode	: integer;
  buf			: array[0..257] of BYTE;

  Dest			: PAnsiChar;
  v			,
  xpos, ypos, pass	: integer;

  stack			: array[0..StackSize-1] of integer;
  Source			: ^integer;
  BitsPerCode		: integer;		// number of CodeTableBits/code
  InitialBitsPerCode	: BYTE;

  MaxCode		: integer;		// maximum code, given BitsPerCode
  MaxCodeSize		: integer;
  ClearCode		: integer;		// Special code to signal "Clear table"
  EOFCode		: integer;		// Special code to signal EOF
  step			: integer;
  i			: integer;

  StartBit		,			// Index of bit buffer start
  LastBit		,			// Index of last bit in buffer
  LastByte		: integer;		// Index of last byte in buffer
  get_done		,
  return_clear		,
  ZeroBlock		: boolean;
  ClearValue		: BYTE;
{$ifdef DEBUG_DECOMPRESSPERFORMANCE}
  TimeStartDecompress	,
  TimeStopDecompress	: DWORD;
{$endif}

  function nextCode(BitsPerCode: integer): integer;
  const
    masks: array[0..15] of integer =
      ($0000, $0001, $0003, $0007,
       $000f, $001f, $003f, $007f,
       $00ff, $01ff, $03ff, $07ff,
       $0fff, $1fff, $3fff, $7fff);
  var
    StartIndex, EndIndex		: integer;
    ret			: integer;
    EndBit		: integer;
    count		: BYTE;
  begin
    if (return_clear) then
    begin
      return_clear := False;
      Result := ClearCode;
      exit;
    end;

    EndBit := StartBit + BitsPerCode;

    if (EndBit >= LastBit) then
    begin
      if (get_done) then
      begin
        if (StartBit >= LastBit) then
          Warning(gsWarning, sDecodeTooFewBits);
        Result := -1;
        exit;
      end;
      buf[0] := buf[LastByte-2];
      buf[1] := buf[LastByte-1];

      if (Stream.Read(count, 1) <> 1) then
      begin
        Result := -1;
        exit;
      end;
      if (count = 0) then
      begin
        ZeroBlock := True;
        get_done := TRUE;
      end else
      begin
        // Handle premature end of file
        if (Stream.Size - Stream.Position < Count) then
        begin
          Warning(gsWarning, sOutOfData);
          // Not enough data left - Just read as much as we can get
          Count := Stream.Size - Stream.Position;
        end;
        if (Count <> 0) then
          ReadCheck(Stream, Buf[2], Count);
      end;

      LastByte := 2 + count;
      StartBit := (StartBit - LastBit) + 16;
      LastBit := LastByte * 8;

      EndBit := StartBit + BitsPerCode;
    end;

    EndIndex := EndBit DIV 8;
    StartIndex := StartBit DIV 8;

    ASSERT(StartIndex <= high(buf), 'StartIndex too large');
    if (StartIndex = EndIndex) then
      ret := buf[StartIndex]
    else
      if (StartIndex + 1 = EndIndex) then
        ret := buf[StartIndex] OR (buf[StartIndex+1] SHL 8)
      else
        ret := buf[StartIndex] OR (buf[StartIndex+1] SHL 8) OR (buf[StartIndex+2] SHL 16);

    ret := (ret SHR (StartBit AND $0007)) AND masks[BitsPerCode];

    Inc(StartBit, BitsPerCode);

    Result := ret;
  end;

  function NextLZW: integer;
  var
    code, incode	: integer;
    i			: integer;
    b			: BYTE;
  begin
    code := nextCode(BitsPerCode);
    while (code >= 0) do
    begin
      if (code = ClearCode) then
      begin
        ASSERT(ClearCode < TableSize, 'ClearCode too large');
        for i := 0 to ClearCode-1 do
        begin
          table0[i] := 0;
          table1[i] := i;
        end;
        for i := ClearCode to TableSize-1 do
        begin
          table0[i] := 0;
          table1[i] := 0;
        end;
        BitsPerCode := InitialBitsPerCode+1;
        MaxCodeSize := 2 * ClearCode;
        MaxCode := ClearCode + 2;
        Source := @stack;
        repeat
          firstcode := nextCode(BitsPerCode);
          oldcode := firstcode;
        until (firstcode <> ClearCode);

        Result := firstcode;
        exit;
      end;
      if (code = EOFCode) then
      begin
        Result := -2;
        if (ZeroBlock) then
          exit;
        // Eat rest of data blocks
        if (Stream.Read(b, 1) <> 1) then
          exit;
        while (b <> 0) do
        begin
          Stream.Seek(b, soFromCurrent);
          if (Stream.Read(b, 1) <> 1) then
            exit;
        end;
        exit;
      end;

      incode := code;

      if (code >= MaxCode) then
      begin
        Source^ := firstcode;
        Inc(Source);
        code := oldcode;
      end;

      ASSERT(Code < TableSize, 'Code too large');
      while (code >= ClearCode) do
      begin
        Source^ := table1[code];
        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;
// 2006.07.29 ->
  if InitialBitsPerCode > 8 then
    InitialBitsPerCode := 8;
// 2006.07.29 <-
  (*
  **  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^ := ansichar(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^ := ansichar(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 ansiChar;
    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			: PAnsiChar;
  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] := ansichar(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			: PAnsiChar;
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		: PAnsiChar;	// 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 "Clear table"
    EOFCode		: CodeInt;	// Special output code to signal EOF
    BaseCode		: CodeInt;	// ...

    Pixel		: PAnsiChar;	// 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: PAnsiChar; 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: PAnsiChar; 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			: ansichar;
  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			: PAnsiChar;
  Dst			: PAnsiChar;

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

  MaskBits		: PAnsiChar;
  MaskDest		: PAnsiChar;
  MaskRow		: PAnsiChar;
  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 := ansichar(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^ := ansichar(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			: PAnsiChar;
  TransparentIndex	: byte;
  IsTransparent		: boolean;
  WasTransparent	: boolean;

  MaskBits		: PAnsiChar;
  MaskDest		: PAnsiChar;
  MaskRow		: PAnsiChar;
  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^ = ansichar(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^ := ansichar(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^ := ansichar(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 "regular" 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 & 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(PAnsiChar(longInt(Scanline[y]) + x)^);
end;

// 2006.10.09 ->
procedure TGIFSubImage.SetPixel(x, y: integer; Value: BYTE );
begin
  if (x < 0) or (x > Width-1) or (y < 0) or (y > Height-1) then
    Error(sBadPixelCoordinates);
  if Value >= ActiveColorMap.FCount then
    Error(sBadColorIndex);
  BYTE(PAnsiChar(longInt(Scanline[y]) + x)^) := Value;
end;
// 2006.10.09 <-

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: PAnsiChar);
  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: PAnsiChar);
  var
    x, y		: integer;
    Scanline		: PAnsiChar;
  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^ := ansichar(ord(ScanLine^) SHR 4)
        else
        begin
          Dest^ := ansichar(ord(ScanLine^) AND $0F);
          inc(ScanLine);
        end;
        inc(Dest);
      end;
    end;
  end;

  procedure Import1Bit(Dest: PAnsiChar);
  var
    x, y		: integer;
    Scanline		: PAnsiChar;
    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^ := ansichar((Byte AND $80) SHR 7);
        Byte := Byte SHL 1;
        inc(Dest);
        dec(Bit);
        dec(x);
      end;
    end;
  end;

  procedure Import24Bit(Dest: PAnsiChar);
  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 "CacheSize" 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^ := ansichar(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^ := ansichar(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		: PAnsiChar;
    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^ := ansichar(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;  // 2003.08.04
      Mask.Handle := Windows.CopyImage(hMask, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG);  // 2003.08.04
      AddMask(Mask);
    finally
//      Mask.ReleaseHandle;  // 2003.08.04
      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 "manually".
      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		: PAnsiChar;
  NewWidth		,
  NewHeight		: integer;
  pSource		,
  pDest			: PAnsiChar;
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 := PAnsiChar(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			: PAnsiChar;
  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 := PAnsiChar(integer(Previous.Scanline[PreviousY]) + MergeRect.Left - Previous.Left);
    pDest := PAnsiChar(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^ = ansichar(DestIndex))) or
              ((SourceTransparent) and (pSource^ = ansichar(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^ := ansichar(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);
  AnsiStrings.StrLCopy(@(FIdent.Authentication[0]), PAnsiChar(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);
  AnsiStrings.StrLCopy(@(FIdent.Identifier[0]), PAnsiChar(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 "abstract
  // error".
  // 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 "dispatcher" - 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;
  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
  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
    {$IFDEF isVER230}Resumenden{$ELSE}Resume{$ENDIF};
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
      {$IFDEF isVER230}Resumenden{$ELSE}Resume{$ENDIF}; // Must be running before we can terminate
  end;
end;

procedure TGIFPainter.Resumenden;
var
  SuspendCount: Integer;
begin
  SuspendCount := ResumeThread(Self.Handle);
  Self.CheckThreadError(SuspendCount >= 0);
  if SuspendCount = 1 then
    Self.FsSuspended := False;
end;

procedure TGIFPainter.Suspenden;
var
  OldSuspend: Boolean;
begin
  OldSuspend := Self.FsSuspended;
  try
    Self.FsSuspended := True;
    Self.CheckThreadError(Integer(SuspendThread(Self.Handle)) >= 0);
  except
    Self.FsSuspended := OldSuspend;
    raise;
  End;
end;
procedure TGIFPainter.Restart;
begin
  DoRestart := True;
  if (Suspended) and (goAsync in FDrawOptions) then
    {$IFDEF isVER230}Resumenden{$ELSE}Resume{$ENDIF}; // 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			: PAnsiChar;
  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			: PAnsiChar;
  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^ := ansichar(NewTransparentColorIndex)
        else
          // ... all other pixels to their new color index
          Pixel^ := ansichar(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;
  FForceFrame := -1;  // 2004.03.09
  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.SetForceFrame(const Value: Integer);
begin  // 2004.03.09
  FForceFrame := Value;
  Changed(Self);
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: PAnsiChar; 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 "previous" 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;

// 2006.07.09 ->
{$IFDEF FIXHEADER_WIDTHHEIGHT_SILENT}
procedure TGIFImage.FixHeaderWidthHeight;
var
  i, w, h: Integer;
begin
  for i := 0 to Images.Count - 1 do
  begin
    w := Images.SubImages[i].Left + Images.SubImages[i].Width;
    h := Images.SubImages[i].Top + Images.SubImages[i].Height;
    if w > Header.Width then
      Header.Width := w;
    if h > Header.Height then
      Header.Height := h;
  end;
end;
{$ENDIF}
// 2006.07.09 <-

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);
      {$IFDEF FIXHEADER_WIDTHHEIGHT_SILENT}
      FixHeaderWidthHeight;  // 2006.07.09
      {$ENDIF}
      // Read trailer
      with TGIFTrailer.Create(self) do
        try
          LoadFromStream(Stream);
        finally
          Free;
        end;
    except
      // Restore stream position in case of error.
      // Not required, but "a nice thing to do"
      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;
        FForceFrame := TGIFImage(Source).ForceFrame;  // 2004.03.09
// 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;
        {$IFDEF FIXHEADER_WIDTHHEIGHT_SILENT}
        FixHeaderWidthHeight;  // 2006.07.09
        {$ENDIF}
      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 "thread" 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
      // 2004.03.09 ->
      if (FForceFrame >= 0) and (FForceFrame < FImages.Count) then
        FImages[FForceFrame].Draw(ACanvas, Rect, (goTransparent in FDrawOptions), (goTile in FDrawOptions))
      else
      // 2004.03.09 <-
        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]).{$IFDEF isVER230}Suspenden{$ELSE}Suspend{$ENDIF};
    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 := RegisterClipboardFormatA(PAnsiChar(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
// 2006.10.16 ->
//    DummyThread.Free;
  begin
    DummyThread.Resume;
    DummyThread.WaitFor;
    DummyThread.Free;
  end;
// 2006.10.16 <-
  {$ENDIF}  // 2001.07.23
{$ENDIF}
end.