Backups/SA-MP
1
0
Fork 0
mirror of https://github.com/dashr9230/SA-MP.git synced 2024-12-22 14:37:29 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity
main
SA-MP/exgui/GIFImage.pas
RD42 638b4c0584 [exgui] Add GIFImage 2.2 unit
2023-12-06 23:03:26 +08:00

12561 lines
353 KiB
ObjectPascal
Raw Permalink Blame History

unit GIFImage;
////////////////////////////////////////////////////////////////////////////////
// //
// Project: GIF Graphics Object //
// Module: gifimage //
// Description: TGraphic implementation of the GIF89a graphics format //
// Version: 2.2 //
// Release: 5 //
// Date: 23-MAY-1999 //
// Target: Win32, Delphi 2, 3, 4 & 5, C++ Builder 3 & 4 //
// Author(s): anme: Anders Melander, anders@melander.dk //
// fila: Filip Larsen //
// rps: Reinier Sterkenburg //
// Copyright: (c) 1997-99 Anders Melander. //
// All rights reserved. //
// Formatting: 2 space indent, 8 space tabs, 80 columns. //
// //
////////////////////////////////////////////////////////////////////////////////
// Changed 2001.07.23 by Finn Tolderlund //
// Changed according to e-mail from "Rolf Frei" <rolf@eicom.ch> //
// on 2001.07.23 so that it works in Delphi 6. //
// //
// Changed 2002.07.07 by Finn Tolderlund //
// Incorporated additional modifications by Alexey Barkovoy (clootie@reactor.ru)
// found in his Delphi 6 GifImage.pas (from 22-Dec-2001). //
// Alexey Barkovoy's Delphi 6 gifimage.pas can be downloaded from //
// http://clootie.narod.ru/delphi/download_vcl.html //
// These changes made showing of animated gif files more stable. The code //
// from 2001.07.23 could crash sometimes with an Execption EAccessViolation. //
// //
////////////////////////////////////////////////////////////////////////////////
// //
// Please read the "Conditions of use" in the release notes. //
// //
////////////////////////////////////////////////////////////////////////////////
// Known problems:
//
// * The combination of buffered, tiled and transparent draw will display the
// background incorrectly (scaled).
// If this is a problem for you, use non-buffered (goDirectDraw) drawing
// instead.
//
// * The combination of non-buffered, transparent and stretched draw is
// sometimes distorted with a pattern effect when the image is displayed
// smaller than the real size (shrinked).
//
// * Buffered display flickers when TGIFImage is used by a transparent TImage
// component.
// This is a problem with TImage caused by the fact that TImage was designed
// with static images in mind. Not much I can do about it.
//
////////////////////////////////////////////////////////////////////////////////
// To do (in rough order of priority):
// { TODO -oanme -cFeature : TImage hook for destroy notification. }
// { TODO -oanme -cFeature : TBitmap pool to limit resource consumption on Win95/98. }
// { TODO -oanme -cImprovement : Make BitsPerPixel property writable. }
// { TODO -oanme -cFeature : Visual GIF component. }
// { TODO -oanme -cImprovement : Easier method to determine DrawPainter status. }
// { TODO -oanme -cFeature : Import to 256+ color GIF. }
// { TODO -oanme -cFeature : Make some of TGIFImage's properties persistent (DrawOptions etc). }
// { TODO -oanme -cFeature : Add TGIFImage.Persistent property. Should save published properties in application extension when this options is set. }
// { TODO -oanme -cBugFix : Solution for background buffering in scrollbox. }
//
//////////////////////////////////////////////////////////////////////////////////
{$ifdef BCB}
{$ObjExportAll On}
{$endif}
interface
////////////////////////////////////////////////////////////////////////////////
//
// Conditional Compiler Symbols
//
////////////////////////////////////////////////////////////////////////////////
(*
DEBUG Must be defined if any of the DEBUG_xxx
symbols are defined.
If the symbol is defined the source will not be
optimized and overflow- and range checks will be
enabled.
DEBUG_HASHPERFORMANCE Calculates hash table performance data.
DEBUG_HASHFILLFACTOR Calculates fill factor of hash table -
Interferes with DEBUG_HASHPERFORMANCE.
DEBUG_COMPRESSPERFORMANCE Calculates LZW compressor performance data.
DEBUG_DECOMPRESSPERFORMANCE Calculates LZW decompressor performance data.
DEBUG_DITHERPERFORMANCE Calculates color reduction performance data.
DEBUG_DRAWPERFORMANCE Calculates low level drawing performance data.
The performance data for DEBUG_DRAWPERFORMANCE
will be displayed when you press the Ctrl key.
DEBUG_RENDERPERFORMANCE Calculates performance data for the GIF to
bitmap converter.
The performance data for DEBUG_DRAWPERFORMANCE
will be displayed when you press the Ctrl key.
GIF_NOSAFETY Define this symbol to disable overflow- and
range checks.
Ignored if the DEBUG symbol is defined.
STRICT_MOZILLA Define to mimic Mozilla as closely as possible.
If not defined, a slightly more "optimal"
implementation is used (IMHO).
FAST_AS_HELL Define this symbol to use strictly GIF compliant
(but too fast) animation timing.
Since our paint routines are much faster and
more precise timed than Mozilla's, the standard
GIF and Mozilla values causes animations to loop
faster than they would in Mozilla.
If the symbol is _not_ defined, an alternative
set of tweaked timing values will be used.
The tweaked values are not optimal but are based
on tests performed on my reference system:
- Windows 95
- 133 MHz Pentium
- 64Mb RAM
- Diamond Stealth64/V3000
- 1600*1200 in 256 colors
The alternate values can be modified if you are
not satisfied with my defaults (they can be
found a few pages down).
REGISTER_TGIFIMAGE Define this symbol to register TGIFImage with
the TPicture class and integrate with TImage.
This is required to be able to display GIFs in
the TImage component.
The symbol is defined by default.
Undefine if you use another GIF library to
provide GIF support for TImage.
PIXELFORMAT_TOO_SLOW When this symbol is defined, the internal
PixelFormat routines are used in some places
instead of TBitmap.PixelFormat.
The current implementation (Delphi4, Builder 3)
of TBitmap.PixelFormat can in some situation
degrade performance.
The symbol is defined by default.
CREATEDIBSECTION_SLOW If this symbol is defined, TDIBWriter will
use global memory as scanline storage, instead
of a DIB section.
Benchmarks have shown that a DIB section is
twice as slow as global memory.
The symbol is defined by default.
The symbol requires that PIXELFORMAT_TOO_SLOW
is defined.
SERIALIZE_RENDER Define this symbol to serialize threaded
GIF to bitmap rendering.
When a GIF is displayed with the goAsync option
(the default), the GIF to bitmap rendering is
executed in the context of the draw thread.
If more than one thread is drawing the same GIF
or the GIF is being modified while it is
animating, the GIF to bitmap rendering should be
serialized to guarantee that the bitmap isn't
modified by more than one thread at a time. If
SERIALIZE_RENDER is defined, the draw threads
uses TThread.Synchronize to serialize GIF to
bitmap rendering.
*)
{$DEFINE REGISTER_TGIFIMAGE}
{$DEFINE PIXELFORMAT_TOO_SLOW}
{$DEFINE CREATEDIBSECTION_SLOW}
////////////////////////////////////////////////////////////////////////////////
//
// Determine Delphi and C++ Builder version
//
////////////////////////////////////////////////////////////////////////////////
// Delphi 1.x
{$IFDEF VER80}
'Error: TGIFImage does not support Delphi 1.x'
{$ENDIF}
// Delphi 2.x
{$IFDEF VER90}
{$DEFINE VER9x}
{$ENDIF}
// C++ Builder 1.x
{$IFDEF VER93}
// Good luck...
{$DEFINE VER9x}
{$ENDIF}
// Delphi 3.x
{$IFDEF VER100}
{$DEFINE VER10_PLUS}
{$DEFINE D3_BCB3}
{$ENDIF}
// C++ Builder 3.x
{$IFDEF VER110}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE D3_BCB3}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
// Delphi 4.x
{$IFDEF VER120}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
// C++ Builder 4.x
{$IFDEF VER125}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
// Delphi 5.x
{$IFDEF VER130}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE VER13_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
// Delphi 6.x
{$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}
// Unknown compiler version - assume D4 compatible
{$IFNDEF VER9x}
{$IFNDEF VER10_PLUS}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
{$ENDIF}
////////////////////////////////////////////////////////////////////////////////
//
// Compiler Options required to compile this library
//
////////////////////////////////////////////////////////////////////////////////
{$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}
////////////////////////////////////////////////////////////////////////////////
//
// External dependecies
//
////////////////////////////////////////////////////////////////////////////////
uses
sysutils,
Windows,
Graphics,
Classes;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFImage library version
//
////////////////////////////////////////////////////////////////////////////////
const
GIFVersion = $0202;
GIFVersionMajor = 2;
GIFVersionMinor = 2;
GIFVersionRelease = 5;
////////////////////////////////////////////////////////////////////////////////
//
// Misc constants and support types
//
////////////////////////////////////////////////////////////////////////////////
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}
// * GIFDelayExp:
// The following delay values should all
// be multiplied by this value to
// calculate the effective time (in mS).
// According to the GIF specs, this
// value should be 10.
// Since our paint routines are much
// faster than Mozilla's, you might need
// to increase this value if your
// animations loops too fast. The
// optimal value is impossible to
// determine since it depends on the
// speed of the CPU, the viceo card,
// memory and many other factors.
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}
// * GIFMinimumDelay:
// The minumum delay used in the Mozilla
// source is 10mS. This corresponds to a
// value of 1. However, since our paint
// routines are much faster than
// Mozilla's, a value of 3 or 4 gives
// better results.
GIFMaximumDelay: integer = 1000; // * GIFMaximumDelay:
// Maximum delay when painter is running
// in main thread (goAsync is not set).
// This value guarantees that a very
// long and slow GIF does not hang the
// system.
// (1000 = 10000 mS = 10 Seconds)
type
TGIFVersion = (gvUnknown, gv87a, gv89a);
TGIFVersionRec = array[0..2] of char;
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);
////////////////////////////////////////////////////////////////////////////////
//
// Delphi 2.x support
//
////////////////////////////////////////////////////////////////////////////////
{$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}
////////////////////////////////////////////////////////////////////////////////
//
// Forward declarations
//
////////////////////////////////////////////////////////////////////////////////
type
TGIFImage = class;
TGIFSubImage = class;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFItem
//
////////////////////////////////////////////////////////////////////////////////
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
//
////////////////////////////////////////////////////////////////////////////////
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;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFColorMap
//
////////////////////////////////////////////////////////////////////////////////
// One way to do it:
// TBaseColor = (bcRed, bcGreen, bcBlue);
// TGIFColor = array[bcRed..bcBlue] of BYTE;
// Another way:
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;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFHeader
//
////////////////////////////////////////////////////////////////////////////////
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;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFExtension
//
////////////////////////////////////////////////////////////////////////////////
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;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFSubImage
//
////////////////////////////////////////////////////////////////////////////////
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 : PChar;
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;
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: PChar 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;
property Pixels[x, y: integer]: BYTE read GetPixel;
property Scanline[y: integer]: pointer read GetScanline;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFTrailer
//
////////////////////////////////////////////////////////////////////////////////
TGIFTrailer = class(TGIFItem)
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromStream(Stream: TStream); override;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFGraphicControlExtension
//
////////////////////////////////////////////////////////////////////////////////
// Graphic Control Extension block a.k.a GCE
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;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFTextExtension
//
////////////////////////////////////////////////////////////////////////////////
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
//
////////////////////////////////////////////////////////////////////////////////
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;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFApplicationExtension
//
////////////////////////////////////////////////////////////////////////////////
TGIFIdentifierCode = array[0..7] of char;
TGIFAuthenticationCode = array[0..2] of char;
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;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFUnknownAppExtension
//
////////////////////////////////////////////////////////////////////////////////
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
//
////////////////////////////////////////////////////////////////////////////////
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;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFImage
//
////////////////////////////////////////////////////////////////////////////////
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;
// Compression algorithms
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
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;
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;
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
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}
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 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}
];
// 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...';
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
//
// 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 char;
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 (FormatMessage(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(PChar(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 char;
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 := PChar(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): char; 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): char; 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): char; 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): char; 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): char; 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): char; 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): char; 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): char;
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 := char(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 := char(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): char;
begin
Result := char(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): char;
begin
R := (Red+3) DIV 51;
G := (Green+3) DIV 51;
B := (Blue+3) DIV 51;
Result := char(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): char;
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): char;
begin
Result := char((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): char;
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): char; 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): char; 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): char; 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): char; 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): char; 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): char;
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): char;
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): char;
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): char;
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): char;
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;
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]);
Colors := 236;
Offset := 10;
LogicalPalette.palNumEntries := 256;
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;
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]);
Colors := 236;
Offset := 10;
LogicalPalette.palNumEntries := 256;
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 : PChar;
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
with (Pal.palPalEntry[i]) do
begin
peRed := i;
peGreen := i;
peBlue := i;
peFlags := PC_NOCOLLAPSE;
end;
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
with (Pal.palPalEntry[i]) do
begin
peRed := Values[i];
peGreen := Values[i];
peBlue := Values[i];
peFlags := PC_NOCOLLAPSE;
end;
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
with (Pal.palPalEntry[i]) do
begin
peRed := Values[i];
peGreen := Values[i];
peBlue := Values[i];
peFlags := PC_NOCOLLAPSE;
end;
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);
rmNetscape:
ColorLookup := TNetscapeColorLookup.Create(Palette);
rmGrayScale:
ColorLookup := TGrayScaleLookup.Create(Palette);
rmMonochrome:
ColorLookup := TMonochromeLookup.Create(Palette);
else
ColorLookup := TFastColorLookup.Create(Palette);
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 : PChar;
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 : PChar;
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^ := chr(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 char; { 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 : PChar;
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 : PChar;
begin
Pixel := FSubImage.Data;
LastPixel := Pixel + FSubImage.Width * FSubImage.Height;
(*
** Reorder all pixel to new map
*)
while (Pixel < LastPixel) do
begin
Pixel^ := chr(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 : PChar;
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;
(*
** Initialize the Compression routines
*)
BitsPerCode := InitialBitsPerCode + 1;
ClearCode := 1 SHL InitialBitsPerCode;
EOFCode := ClearCode + 1;
MaxCodeSize := 2 * ClearCode;
MaxCode := ClearCode + 2;
StartBit := 0;
LastBit := 0;
LastByte := 2;
ZeroBlock := False;
get_done := False;
return_clear := TRUE;
Source := @stack;
try
if (Interlaced) then
begin
ypos := 0;
pass := 0;
step := 8;
for i := 0 to Height-1 do
begin
Dest := FData + Width * ypos;
for xpos := 0 to width-1 do
begin
v := readLZW;
if (v < 0) then
exit;
Dest^ := char(v);
Inc(Dest);
end;
Inc(ypos, step);
if (ypos >= height) then
repeat
if (pass > 0) then
step := step DIV 2;
Inc(pass);
ypos := step DIV 2;
until (ypos < height);
end;
end else
begin
Dest := FData;
for ypos := 0 to (height * width)-1 do
begin
v := readLZW;
if (v < 0) then
exit;
Dest^ := char(v);
Inc(Dest);
end;
end;
finally
if (readLZW >= 0) then
;
// raise GIFException.Create('Too much input data, ignoring extra...');
end;
{$ifdef DEBUG_DECOMPRESSPERFORMANCE}
TimeStopDecompress := timeGetTime;
ShowMessage(format('Decompressed %d pixels in %d mS, Rate %d pixels/mS',
[Height*Width, TimeStopDecompress-TimeStartDecompress,
(Height*Width) DIV (TimeStopDecompress-TimeStartDecompress+1)]));
{$endif}
end;
////////////////////////////////////////////////////////////////////////////////
//
// LZW Encoder stuff
//
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// LZW Encoder THashTable
////////////////////////////////////////////////////////////////////////////////
const
HashKeyBits = 13; // Max number of bits per Hash Key
HashSize = 8009; // Size of hash table
// Must be prime
// Must be > than HashMaxCode
// Must be < than HashMaxKey
HashKeyMax = (1 SHL HashKeyBits)-1;// Max hash key value
// 13 bits = 8191
HashKeyMask = HashKeyMax; // $1FFF
GIFCodeMask = GIFCodeMax; // $0FFF
HashEmpty = $000FFFFF; // 20 bits
type
// A Hash Key is 20 bits wide.
// - The lower 8 bits are the postfix character (the new pixel).
// - The upper 12 bits are the prefix code (the GIF token).
// A KeyInt must be able to represent the integer values -1..(2^20)-1
KeyInt = longInt; // 32 bits
CodeInt = SmallInt; // 16 bits
THashArray = array[0..HashSize-1] of KeyInt;
PHashArray = ^THashArray;
THashTable = class
{$ifdef DEBUG_HASHPERFORMANCE}
CountLookupFound : longInt;
CountMissFound : longInt;
CountLookupNotFound : longInt;
CountMissNotFound : longInt;
{$endif}
HashTable: PHashArray;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure Insert(Key: KeyInt; Code: CodeInt);
function Lookup(Key: KeyInt): CodeInt;
end;
function HashKey(Key: KeyInt): CodeInt;
begin
Result := ((Key SHR (GIFCodeBits-8)) XOR Key) MOD HashSize;
end;
function NextHashKey(HKey: CodeInt): CodeInt;
var
disp : CodeInt;
begin
(*
** secondary hash (after G. Knott)
*)
disp := HashSize - HKey;
if (HKey = 0) then
disp := 1;
// disp := 13; // disp should be prime relative to HashSize, but
// it doesn't seem to matter here...
dec(HKey, disp);
if (HKey < 0) then
inc(HKey, HashSize);
Result := HKey;
end;
constructor THashTable.Create;
begin
ASSERT(longInt($FFFFFFFF) = -1, 'TGIFImage implementation assumes $FFFFFFFF = -1');
inherited Create;
GetMem(HashTable, sizeof(THashArray));
Clear;
{$ifdef DEBUG_HASHPERFORMANCE}
CountLookupFound := 0;
CountMissFound := 0;
CountLookupNotFound := 0;
CountMissNotFound := 0;
{$endif}
end;
destructor THashTable.Destroy;
begin
{$ifdef DEBUG_HASHPERFORMANCE}
ShowMessage(
Format('Found: %d HitRate: %.2f',
[CountLookupFound, (CountLookupFound+1)/(CountMissFound+1)])+#13+
Format('Not found: %d HitRate: %.2f',
[CountLookupNotFound, (CountLookupNotFound+1)/(CountMissNotFound+1)]));
{$endif}
FreeMem(HashTable);
inherited Destroy;
end;
// Clear hash table and fill with empty slots (doh!)
procedure THashTable.Clear;
{$ifdef DEBUG_HASHFILLFACTOR}
var
i ,
Count : longInt;
{$endif}
begin
{$ifdef DEBUG_HASHFILLFACTOR}
Count := 0;
for i := 0 to HashSize-1 do
if (HashTable[i] SHR GIFCodeBits <> HashEmpty) then
inc(Count);
ShowMessage(format('Size: %d, Filled: %d, Rate %.4f',
[HashSize, Count, Count/HashSize]));
{$endif}
FillChar(HashTable^, sizeof(THashArray), $FF);
end;
// Insert new key/value pair into hash table
procedure THashTable.Insert(Key: KeyInt; Code: CodeInt);
var
HKey : CodeInt;
begin
// Create hash key from prefix string
HKey := HashKey(Key);
// Scan for empty slot
// while (HashTable[HKey] SHR GIFCodeBits <> HashEmpty) do { Unoptimized }
while (HashTable[HKey] AND (HashEmpty SHL GIFCodeBits) <> (HashEmpty SHL GIFCodeBits)) do { Optimized }
HKey := NextHashKey(HKey);
// Fill slot with key/value pair
HashTable[HKey] := (Key SHL GIFCodeBits) OR (Code AND GIFCodeMask);
end;
// Search for key in hash table.
// Returns value if found or -1 if not
function THashTable.Lookup(Key: KeyInt): CodeInt;
var
HKey : CodeInt;
HTKey : KeyInt;
{$ifdef DEBUG_HASHPERFORMANCE}
n : LongInt;
{$endif}
begin
// Create hash key from prefix string
HKey := HashKey(Key);
{$ifdef DEBUG_HASHPERFORMANCE}
n := 0;
{$endif}
// Scan table for key
// HTKey := HashTable[HKey] SHR GIFCodeBits; { Unoptimized }
Key := Key SHL GIFCodeBits; { Optimized }
HTKey := HashTable[HKey] AND (HashEmpty SHL GIFCodeBits); { Optimized }
// while (HTKey <> HashEmpty) do { Unoptimized }
while (HTKey <> HashEmpty SHL GIFCodeBits) do { Optimized }
begin
if (Key = HTKey) then
begin
// Extract and return value
Result := HashTable[HKey] AND GIFCodeMask;
{$ifdef DEBUG_HASHPERFORMANCE}
inc(CountLookupFound);
inc(CountMissFound, n);
{$endif}
exit;
end;
{$ifdef DEBUG_HASHPERFORMANCE}
inc(n);
{$endif}
// Try next slot
HKey := NextHashKey(HKey);
// HTKey := HashTable[HKey] SHR GIFCodeBits; { Unoptimized }
HTKey := HashTable[HKey] AND (HashEmpty SHL GIFCodeBits); { Optimized }
end;
// Found empty slot - key doesn't exist
Result := -1;
{$ifdef DEBUG_HASHPERFORMANCE}
inc(CountLookupNotFound);
inc(CountMissNotFound, n);
{$endif}
end;
////////////////////////////////////////////////////////////////////////////////
// TGIFStream - Abstract GIF block stream
//
// Descendants from TGIFStream either reads or writes data in blocks
// of up to 255 bytes. These blocks are organized as a leading byte
// containing the number of bytes in the block (exclusing the count
// byte itself), followed by the data (up to 254 bytes of data).
////////////////////////////////////////////////////////////////////////////////
type
TGIFStream = class(TStream)
private
FOnWarning : TGIFWarning;
FStream : TStream;
FOnProgress : TNotifyEvent;
FBuffer : array [BYTE] of Char;
FBufferCount : integer;
protected
constructor Create(Stream: TStream);
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
function Seek(Offset: Longint; Origin: Word): Longint; override;
procedure Progress(Sender: TObject); dynamic;
property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
public
property Warning: TGIFWarning read FOnWarning write FOnWarning;
end;
constructor TGIFStream.Create(Stream: TStream);
begin
inherited Create;
FStream := Stream;
FBufferCount := 1; // Reserve first byte of buffer for length
end;
procedure TGIFStream.Progress(Sender: TObject);
begin
if Assigned(FOnProgress) then
FOnProgress(Sender);
end;
function TGIFStream.Write(const Buffer; Count: Longint): Longint;
begin
raise Exception.Create(sInvalidStream);
end;
function TGIFStream.Read(var Buffer; Count: Longint): Longint;
begin
raise Exception.Create(sInvalidStream);
end;
function TGIFStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
raise Exception.Create(sInvalidStream);
end;
////////////////////////////////////////////////////////////////////////////////
// TGIFReader - GIF block reader
////////////////////////////////////////////////////////////////////////////////
type
TGIFReader = class(TGIFStream)
public
constructor Create(Stream: TStream);
function Read(var Buffer; Count: Longint): Longint; override;
end;
constructor TGIFReader.Create(Stream: TStream);
begin
inherited Create(Stream);
FBufferCount := 0;
end;
function TGIFReader.Read(var Buffer; Count: Longint): Longint;
var
n : integer;
Dst : PChar;
size : BYTE;
begin
Dst := @Buffer;
Result := 0;
while (Count > 0) do
begin
// Get data from buffer
while (FBufferCount > 0) and (Count > 0) do
begin
if (FBufferCount > Count) then
n := Count
else
n := FBufferCount;
Move(FBuffer, Dst^, n);
dec(FBufferCount, n);
dec(Count, n);
inc(Result, n);
inc(Dst, n);
end;
// Refill buffer when it becomes empty
if (FBufferCount <= 0) then
begin
FStream.Read(size, 1);
{ TODO -oanme -cImprovement : Should be handled as a warning instead of an error. }
if (size >= 255) then
Error('GIF block too large');
FBufferCount := size;
if (FBufferCount > 0) then
begin
n := FStream.Read(FBuffer, size);
if (n = FBufferCount) then
begin
Warning(self, gsWarning, sOutOfData);
break;
end;
end else
break;
end;
end;
end;
////////////////////////////////////////////////////////////////////////////////
// TGIFWriter - GIF block writer
////////////////////////////////////////////////////////////////////////////////
type
TGIFWriter = class(TGIFStream)
private
FOutputDirty : boolean;
protected
procedure FlushBuffer;
public
constructor Create(Stream: TStream);
destructor Destroy; override;
function Write(const Buffer; Count: Longint): Longint; override;
function WriteByte(Value: BYTE): Longint;
end;
constructor TGIFWriter.Create(Stream: TStream);
begin
inherited Create(Stream);
FBufferCount := 1; // Reserve first byte of buffer for length
FOutputDirty := False;
end;
destructor TGIFWriter.Destroy;
begin
inherited Destroy;
if (FOutputDirty) then
FlushBuffer;
end;
procedure TGIFWriter.FlushBuffer;
begin
if (FBufferCount <= 0) then
exit;
FBuffer[0] := char(FBufferCount-1); // Block size excluding the count
FStream.WriteBuffer(FBuffer, FBufferCount);
FBufferCount := 1; // Reserve first byte of buffer for length
FOutputDirty := False;
end;
function TGIFWriter.Write(const Buffer; Count: Longint): Longint;
var
n : integer;
Src : PChar;
begin
Result := Count;
FOutputDirty := True;
Src := @Buffer;
while (Count > 0) do
begin
// Move data to the internal buffer in 255 byte chunks
while (FBufferCount < sizeof(FBuffer)) and (Count > 0) do
begin
n := sizeof(FBuffer) - FBufferCount;
if (n > Count) then
n := Count;
Move(Src^, FBuffer[FBufferCount], n);
inc(Src, n);
inc(FBufferCount, n);
dec(Count, n);
end;
// Flush the buffer when it is full
if (FBufferCount >= sizeof(FBuffer)) then
FlushBuffer;
end;
end;
function TGIFWriter.WriteByte(Value: BYTE): Longint;
begin
Result := Write(Value, 1);
end;
////////////////////////////////////////////////////////////////////////////////
// TGIFEncoder - Abstract encoder
////////////////////////////////////////////////////////////////////////////////
type
TGIFEncoder = class(TObject)
protected
FOnWarning : TGIFWarning;
MaxColor : integer;
BitsPerPixel : BYTE; // Bits per pixel of image
Stream : TStream; // Output stream
Width , // Width of image in pixels
Height : integer; // height of image in pixels
Interlace : boolean; // Interlace flag (True = interlaced image)
Data : PChar; // Pointer to pixel data
GIFStream : TGIFWriter; // Output buffer
OutputBucket : longInt; // Output bit bucket
OutputBits : integer; // Current # of bits in bucket
ClearFlag : Boolean; // True if dictionary has just been cleared
BitsPerCode , // Current # of bits per code
InitialBitsPerCode : integer; // Initial # of bits per code after
// dictionary has been cleared
MaxCode : CodeInt; // maximum code, given BitsPerCode
ClearCode : CodeInt; // Special output code to signal "Clear table"
EOFCode : CodeInt; // Special output code to signal EOF
BaseCode : CodeInt; // ...
Pixel : PChar; // Pointer to current pixel
cX , // Current X counter (Width - X)
Y : integer; // Current Y
Pass : integer; // Interlace pass
function MaxCodesFromBits(Bits: integer): CodeInt;
procedure Output(Value: integer); virtual;
procedure Clear; virtual;
function BumpPixel: boolean;
procedure DoCompress; virtual; abstract;
public
procedure Compress(AStream: TStream; ABitsPerPixel: integer;
AWidth, AHeight: integer; AInterlace: boolean; AData: PChar; AMaxColor: integer);
property Warning: TGIFWarning read FOnWarning write FOnWarning;
end;
// Calculate the maximum number of codes that a given number of bits can represent
// MaxCodes := (1^bits)-1
function TGIFEncoder.MaxCodesFromBits(Bits: integer): CodeInt;
begin
Result := (CodeInt(1) SHL Bits) - 1;
end;
// Stuff bits (variable sized codes) into a buffer and output them
// a byte at a time
procedure TGIFEncoder.Output(Value: integer);
const
BitBucketMask: array[0..16] of longInt =
($0000,
$0001, $0003, $0007, $000F,
$001F, $003F, $007F, $00FF,
$01FF, $03FF, $07FF, $0FFF,
$1FFF, $3FFF, $7FFF, $FFFF);
begin
if (OutputBits > 0) then
OutputBucket :=
(OutputBucket AND BitBucketMask[OutputBits]) OR (longInt(Value) SHL OutputBits)
else
OutputBucket := Value;
inc(OutputBits, BitsPerCode);
while (OutputBits >= 8) do
begin
GIFStream.WriteByte(OutputBucket AND $FF);
OutputBucket := OutputBucket SHR 8;
dec(OutputBits, 8);
end;
if (Value = EOFCode) then
begin
// At EOF, write the rest of the buffer.
while (OutputBits > 0) do
begin
GIFStream.WriteByte(OutputBucket AND $FF);
OutputBucket := OutputBucket SHR 8;
dec(OutputBits, 8);
end;
end;
end;
procedure TGIFEncoder.Clear;
begin
// just_cleared = 1;
ClearFlag := TRUE;
Output(ClearCode);
end;
// Bump (X,Y) and data pointer to point to the next pixel
function TGIFEncoder.BumpPixel: boolean;
begin
// Bump the current X position
dec(cX);
// If we are at the end of a scan line, set cX back to the beginning
// If we are interlaced, bump Y to the appropriate spot, otherwise,
// just increment it.
if (cX <= 0) then
begin
if not(Interlace) then
begin
// Done - no more data
Result := False;
exit;
end;
cX := Width;
case (Pass) of
0:
begin
inc(Y, 8);
if (Y >= Height) then
begin
inc(Pass);
Y := 4;
end;
end;
1:
begin
inc(Y, 8);
if (Y >= Height) then
begin
inc(Pass);
Y := 2;
end;
end;
2:
begin
inc(Y, 4);
if (Y >= Height) then
begin
inc(Pass);
Y := 1;
end;
end;
3:
inc(Y, 2);
end;
if (Y >= height) then
begin
// Done - No more data
Result := False;
exit;
end;
Pixel := Data + (Y * Width);
end;
Result := True;
end;
procedure TGIFEncoder.Compress(AStream: TStream; ABitsPerPixel: integer;
AWidth, AHeight: integer; AInterlace: boolean; AData: PChar; AMaxColor: integer);
const
EndBlockByte = $00; // End of block marker
{$ifdef DEBUG_COMPRESSPERFORMANCE}
var
TimeStartCompress ,
TimeStopCompress : DWORD;
{$endif}
begin
MaxColor := AMaxColor;
Stream := AStream;
BitsPerPixel := ABitsPerPixel;
Width := AWidth;
Height := AHeight;
Interlace := AInterlace;
Data := AData;
if (BitsPerPixel <= 1) then
BitsPerPixel := 2;
InitialBitsPerCode := BitsPerPixel + 1;
Stream.Write(BitsPerPixel, 1);
// out_bits_init = init_bits;
BitsPerCode := InitialBitsPerCode;
MaxCode := MaxCodesFromBits(BitsPerCode);
ClearCode := (1 SHL (InitialBitsPerCode - 1));
EOFCode := ClearCode + 1;
BaseCode := EOFCode + 1;
// Clear bit bucket
OutputBucket := 0;
OutputBits := 0;
// Reset pixel counter
if (Interlace) then
cX := Width
else
cX := Width*Height;
// Reset row counter
Y := 0;
Pass := 0;
GIFStream := TGIFWriter.Create(AStream);
try
GIFStream.Warning := Warning;
if (Data <> nil) and (Height > 0) and (Width > 0) then
begin
{$ifdef DEBUG_COMPRESSPERFORMANCE}
TimeStartCompress := timeGetTime;
{$endif}
// Call compress implementation
DoCompress;
{$ifdef DEBUG_COMPRESSPERFORMANCE}
TimeStopCompress := timeGetTime;
ShowMessage(format('Compressed %d pixels in %d mS, Rate %d pixels/mS',
[Height*Width, TimeStopCompress-TimeStartCompress,
DWORD(Height*Width) DIV (TimeStopCompress-TimeStartCompress+1)]));
{$endif}
// Output the final code.
Output(EOFCode);
end else
// Output the final code (and nothing else).
TGIFEncoder(self).Output(EOFCode);
finally
GIFStream.Free;
end;
WriteByte(Stream, EndBlockByte);
end;
////////////////////////////////////////////////////////////////////////////////
// TRLEEncoder - RLE encoder
////////////////////////////////////////////////////////////////////////////////
type
TRLEEncoder = class(TGIFEncoder)
private
MaxCodes : integer;
OutBumpInit ,
OutClearInit : integer;
Prefix : integer; // Current run color
RunLengthTableMax ,
RunLengthTablePixel ,
OutCount ,
OutClear ,
OutBump : integer;
protected
function ComputeTriangleCount(count: integer; nrepcodes: integer): integer;
procedure MaxOutClear;
procedure ResetOutClear;
procedure FlushFromClear(Count: integer);
procedure FlushClearOrRepeat(Count: integer);
procedure FlushWithTable(Count: integer);
procedure Flush(RunLengthCount: integer);
procedure OutputPlain(Value: integer);
procedure Clear; override;
procedure DoCompress; override;
end;
procedure TRLEEncoder.Clear;
begin
OutBump := OutBumpInit;
OutClear := OutClearInit;
OutCount := 0;
RunLengthTableMax := 0;
inherited Clear;
BitsPerCode := InitialBitsPerCode;
end;
procedure TRLEEncoder.OutputPlain(Value: integer);
begin
ClearFlag := False;
Output(Value);
inc(OutCount);
if (OutCount >= OutBump) then
begin
inc(BitsPerCode);
inc(OutBump, 1 SHL (BitsPerCode - 1));
end;
if (OutCount >= OutClear) then
Clear;
end;
function TRLEEncoder.ComputeTriangleCount(count: integer; nrepcodes: integer): integer;
var
PerRepeat : integer;
n : integer;
function iSqrt(x: integer): integer;
var
r, v : integer;
begin
if (x < 2) then
begin
Result := x;
exit;
end else
begin
v := x;
r := 1;
while (v > 0) do
begin
v := v DIV 4;
r := r * 2;
end;
end;
while (True) do
begin
v := ((x DIV r) + r) DIV 2;
if ((v = r) or (v = r+1)) then
begin
Result := r;
exit;
end;
r := v;
end;
end;
begin
Result := 0;
PerRepeat := (nrepcodes * (nrepcodes+1)) DIV 2;
while (Count >= PerRepeat) do
begin
inc(Result, nrepcodes);
dec(Count, PerRepeat);
end;
if (Count > 0) then
begin
n := iSqrt(Count);
while ((n * (n+1)) >= 2*Count) do
dec(n);
while ((n * (n+1)) < 2*Count) do
inc(n);
inc(Result, n);
end;
end;
procedure TRLEEncoder.MaxOutClear;
begin
OutClear := MaxCodes;
end;
procedure TRLEEncoder.ResetOutClear;
begin
OutClear := OutClearInit;
if (OutCount >= OutClear) then
Clear;
end;
procedure TRLEEncoder.FlushFromClear(Count: integer);
var
n : integer;
begin
MaxOutClear;
RunLengthTablePixel := Prefix;
n := 1;
while (Count > 0) do
begin
if (n = 1) then
begin
RunLengthTableMax := 1;
OutputPlain(Prefix);
dec(Count);
end else
if (Count >= n) then
begin
RunLengthTableMax := n;
OutputPlain(BaseCode + n - 2);
dec(Count, n);
end else
if (Count = 1) then
begin
inc(RunLengthTableMax);
OutputPlain(Prefix);
break;
end else
begin
inc(RunLengthTableMax);
OutputPlain(BaseCode + Count - 2);
break;
end;
if (OutCount = 0) then
n := 1
else
inc(n);
end;
ResetOutClear;
end;
procedure TRLEEncoder.FlushClearOrRepeat(Count: integer);
var
WithClear : integer;
begin
WithClear := 1 + ComputeTriangleCount(Count, MaxCodes);
if (WithClear < Count) then
begin
Clear;
FlushFromClear(Count);
end else
while (Count > 0) do
begin
OutputPlain(Prefix);
dec(Count);
end;
end;
procedure TRLEEncoder.FlushWithTable(Count: integer);
var
RepeatMax ,
RepeatLeft ,
LeftOver : integer;
begin
RepeatMax := Count DIV RunLengthTableMax;
LeftOver := Count MOD RunLengthTableMax;
if (LeftOver <> 0) then
RepeatLeft := 1
else
RepeatLeft := 0;
if (OutCount + RepeatMax + RepeatLeft > MaxCodes) then
begin
RepeatMax := MaxCodes - OutCount;
LeftOver := Count - (RepeatMax * RunLengthTableMax);
RepeatLeft := 1 + ComputeTriangleCount(LeftOver, MaxCodes);
end;
if (1 + ComputeTriangleCount(Count, MaxCodes) < RepeatMax + RepeatLeft) then
begin
Clear;
FlushFromClear(Count);
exit;
end;
MaxOutClear;
while (RepeatMax > 0) do
begin
OutputPlain(BaseCode + RunLengthTableMax-2);
dec(RepeatMax);
end;
if (LeftOver > 0) then
begin
if (ClearFlag) then
FlushFromClear(LeftOver)
else if (LeftOver = 1) then
OutputPlain(Prefix)
else
OutputPlain(BaseCode + LeftOver - 2);
end;
ResetOutClear;
end;
procedure TRLEEncoder.Flush(RunLengthCount: integer);
begin
if (RunLengthCount = 1) then
begin
OutputPlain(Prefix);
exit;
end;
if (ClearFlag) then
FlushFromClear(RunLengthCount)
else if ((RunLengthTableMax < 2) or (RunLengthTablePixel <> Prefix)) then
FlushClearOrRepeat(RunLengthCount)
else
FlushWithTable(RunLengthCount);
end;
procedure TRLEEncoder.DoCompress;
var
Color : CodeInt;
RunLengthCount : integer;
begin
OutBumpInit := ClearCode - 1;
// For images with a lot of runs, making OutClearInit larger will
// give better compression.
if (BitsPerPixel <= 3) then
OutClearInit := 9
else
OutClearInit := OutBumpInit - 1;
// max_ocodes = (1 << GIFBITS) - ((1 << (out_bits_init - 1)) + 3);
// <=> MaxCodes := (1 SHL GIFCodeBits) - ((1 SHL (BitsPerCode - 1)) + 3);
// <=> MaxCodes := (1 SHL GIFCodeBits) - ((1 SHL (InitialBitsPerCode - 1)) + 3);
// <=> MaxCodes := (1 SHL GIFCodeBits) - (ClearCode + 3);
// <=> MaxCodes := (1 SHL GIFCodeBits) - (EOFCode + 2);
// <=> MaxCodes := (1 SHL GIFCodeBits) - (BaseCode + 1);
// <=> MaxCodes := MaxCodesFromBits(GIFCodeBits) - BaseCode;
MaxCodes := MaxCodesFromBits(GIFCodeBits) - BaseCode;
Clear;
RunLengthCount := 0;
Pixel := Data;
Prefix := -1; // Dummy value to make Color <> Prefix
repeat
// Fetch the next pixel
Color := CodeInt(Pixel^);
inc(Pixel);
if (Color >= MaxColor) then
Error(sInvalidColor);
if (RunLengthCount > 0) and (Color <> Prefix) then
begin
// End of current run
Flush(RunLengthCount);
RunLengthCount := 0;
end;
if (Color = Prefix) then
// Increment run length
inc(RunLengthCount)
else
begin
// Start new run
Prefix := Color;
RunLengthCount := 1;
end;
until not(BumpPixel);
Flush(RunLengthCount);
end;
////////////////////////////////////////////////////////////////////////////////
// TLZWEncoder - LZW encoder
////////////////////////////////////////////////////////////////////////////////
const
TableMaxMaxCode = (1 SHL GIFCodeBits); //
TableMaxFill = TableMaxMaxCode-1; // Clear table when it fills to
// this point.
// Note: Must be <= GIFCodeMax
type
TLZWEncoder = class(TGIFEncoder)
private
Prefix : CodeInt; // Current run color
FreeEntry : CodeInt; // next unused code in table
HashTable : THashTable;
protected
procedure Output(Value: integer); override;
procedure Clear; override;
procedure DoCompress; override;
end;
procedure TLZWEncoder.Output(Value: integer);
begin
inherited Output(Value);
// If the next entry is going to be too big for the code size,
// then increase it, if possible.
if (FreeEntry > MaxCode) or (ClearFlag) then
begin
if (ClearFlag) then
begin
BitsPerCode := InitialBitsPerCode;
MaxCode := MaxCodesFromBits(BitsPerCode);
ClearFlag := False;
end else
begin
inc(BitsPerCode);
if (BitsPerCode = GIFCodeBits) then
MaxCode := TableMaxMaxCode
else
MaxCode := MaxCodesFromBits(BitsPerCode);
end;
end;
end;
procedure TLZWEncoder.Clear;
begin
inherited Clear;
HashTable.Clear;
FreeEntry := ClearCode + 2;
end;
procedure TLZWEncoder.DoCompress;
var
Color : char;
NewKey : KeyInt;
NewCode : CodeInt;
begin
HashTable := THashTable.Create;
try
// clear hash table and sync decoder
Clear;
Pixel := Data;
Prefix := CodeInt(Pixel^);
inc(Pixel);
if (Prefix >= MaxColor) then
Error(sInvalidColor);
while (BumpPixel) do
begin
// Fetch the next pixel
Color := Pixel^;
inc(Pixel);
if (ord(Color) >= MaxColor) then
Error(sInvalidColor);
// Append Postfix to Prefix and lookup in table...
NewKey := (KeyInt(Prefix) SHL 8) OR ord(Color);
NewCode := HashTable.Lookup(NewKey);
if (NewCode >= 0) then
begin
// ...if found, get next pixel
Prefix := NewCode;
continue;
end;
// ...if not found, output and start over
Output(Prefix);
Prefix := CodeInt(Color);
if (FreeEntry < TableMaxFill) then
begin
HashTable.Insert(NewKey, FreeEntry);
inc(FreeEntry);
end else
Clear;
end;
Output(Prefix);
finally
HashTable.Free;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFSubImage
//
////////////////////////////////////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////
// TGIFSubImage.Compress
/////////////////////////////////////////////////////////////////////////
procedure TGIFSubImage.Compress(Stream: TStream);
var
Encoder : TGIFEncoder;
BitsPerPixel : BYTE;
MaxColors : integer;
begin
if (ColorMap.Count > 0) then
begin
MaxColors := ColorMap.Count;
BitsPerPixel := ColorMap.BitsPerPixel
end else
begin
BitsPerPixel := Image.BitsPerPixel;
MaxColors := 1 SHL BitsPerPixel;
end;
// Create a RLE or LZW GIF encoder
if (Image.Compression = gcRLE) then
Encoder := TRLEEncoder.Create
else
Encoder := TLZWEncoder.Create;
try
Encoder.Warning := Image.Warning;
Encoder.Compress(Stream, BitsPerPixel, Width, Height, Interlaced, FData, MaxColors);
finally
Encoder.Free;
end;
end;
function TGIFExtensionList.GetExtension(Index: Integer): TGIFExtension;
begin
Result := TGIFExtension(Items[Index]);
end;
procedure TGIFExtensionList.SetExtension(Index: Integer; Extension: TGIFExtension);
begin
Items[Index] := Extension;
end;
procedure TGIFExtensionList.LoadFromStream(Stream: TStream; Parent: TObject);
var
b : BYTE;
Extension : TGIFExtension;
ExtensionClass : TGIFExtensionClass;
begin
// Peek ahead to determine block type
if (Stream.Read(b, 1) <> 1) then
exit;
while not(b in [bsTrailer, bsImageDescriptor]) do
begin
if (b = bsExtensionIntroducer) then
begin
ExtensionClass := TGIFExtension.FindExtension(Stream);
if (ExtensionClass = nil) then
Error(sUnknownExtension);
Stream.Seek(-1, soFromCurrent);
Extension := ExtensionClass.Create(Parent as TGIFSubImage);
try
Extension.LoadFromStream(Stream);
Add(Extension);
except
Extension.Free;
raise;
end;
end else
begin
Warning(gsWarning, sBadExtensionLabel);
break;
end;
if (Stream.Read(b, 1) <> 1) then
exit;
end;
Stream.Seek(-1, soFromCurrent);
end;
const
{ image descriptor bit masks }
idLocalColorTable = $80; { set if a local color table follows }
idInterlaced = $40; { set if image is interlaced }
idSort = $20; { set if color table is sorted }
idReserved = $0C; { reserved - must be set to $00 }
idColorTableSize = $07; { size of color table as above }
constructor TGIFSubImage.Create(GIFImage: TGIFImage);
begin
inherited Create(GIFImage);
FExtensions := TGIFExtensionList.Create(GIFImage);
FColorMap := TGIFLocalColorMap.Create(self);
FImageDescriptor.Separator := bsImageDescriptor;
FImageDescriptor.Left := 0;
FImageDescriptor.Top := 0;
FImageDescriptor.Width := 0;
FImageDescriptor.Height := 0;
FImageDescriptor.PackedFields := 0;
FBitmap := nil;
FMask := 0;
FNeedMask := True;
FData := nil;
FDataSize := 0;
FTransparent := False;
FGCE := nil;
// Remember to synchronize with TGIFSubImage.Clear
end;
destructor TGIFSubImage.Destroy;
begin
if (FGIFImage <> nil) then
FGIFImage.Images.Remove(self);
Clear;
FExtensions.Free;
FColorMap.Free;
if (FLocalPalette <> 0) then
DeleteObject(FLocalPalette);
inherited Destroy;
end;
procedure TGIFSubImage.Clear;
begin
FExtensions.Clear;
FColorMap.Clear;
FreeImage;
Height := 0;
Width := 0;
FTransparent := False;
FGCE := nil;
FreeBitmap;
FreeMask;
// Remember to synchronize with TGIFSubImage.Create
end;
function TGIFSubImage.GetEmpty: Boolean;
begin
Result := ((FData = nil) or (FDataSize = 0) or (Height = 0) or (Width = 0));
end;
function TGIFSubImage.GetPalette: HPALETTE;
begin
if (FBitmap <> nil) and (FBitmap.Palette <> 0) then
// Use bitmaps own palette if possible
Result := FBitmap.Palette
else if (FLocalPalette <> 0) then
// Or a previously exported local palette
Result := FLocalPalette
else if (Image.DoDither) then
begin
// or create a new dither palette
FLocalPalette := WebPalette;
Result := FLocalPalette;
end
else if (ColorMap.Count > 0) then
begin
// or create a new if first time
FLocalPalette := ColorMap.ExportPalette;
Result := FLocalPalette;
end else
// Use global palette if everything else fails
Result := Image.Palette;
end;
procedure TGIFSubImage.SetPalette(Value: HPalette);
var
NeedNewBitmap : boolean;
begin
if (Value <> FLocalPalette) then
begin
// Zap old palette
if (FLocalPalette <> 0) then
DeleteObject(FLocalPalette);
// Zap bitmap unless new palette is same as bitmaps own
NeedNewBitmap := (FBitmap <> nil) and (Value <> FBitmap.Palette);
// Use new palette
FLocalPalette := Value;
if (NeedNewBitmap) then
begin
// Need to create new bitmap and repaint
FreeBitmap;
Image.PaletteModified := True;
Image.Changed(Self);
end;
end;
end;
procedure TGIFSubImage.NeedImage;
begin
if (FData = nil) then
NewImage;
if (FDataSize = 0) then
Error(sEmptyImage);
end;
procedure TGIFSubImage.NewImage;
var
NewSize : longInt;
begin
FreeImage;
NewSize := Height * Width;
if (NewSize <> 0) then
begin
GetMem(FData, NewSize);
FillChar(FData^, NewSize, 0);
end else
FData := nil;
FDataSize := NewSize;
end;
procedure TGIFSubImage.FreeImage;
begin
if (FData <> nil) then
FreeMem(FData);
FDataSize := 0;
FData := nil;
end;
function TGIFSubImage.GetHasBitmap: boolean;
begin
Result := (FBitmap <> nil);
end;
procedure TGIFSubImage.SetHasBitmap(Value: boolean);
begin
if (Value <> (FBitmap <> nil)) then
begin
if (Value) then
Bitmap // Referencing Bitmap will automatically create it
else
FreeBitmap;
end;
end;
procedure TGIFSubImage.NewBitmap;
begin
FreeBitmap;
FBitmap := TBitmap.Create;
end;
procedure TGIFSubImage.FreeBitmap;
begin
if (FBitmap <> nil) then
begin
FBitmap.Free;
FBitmap := nil;
end;
end;
procedure TGIFSubImage.FreeMask;
begin
if (FMask <> 0) then
begin
DeleteObject(FMask);
FMask := 0;
end;
FNeedMask := True;
end;
function TGIFSubImage.HasMask: boolean;
begin
if (FNeedMask) and (Transparent) then
begin
// Zap old bitmap
FreeBitmap;
// Create new bitmap and mask
GetBitmap;
end;
Result := (FMask <> 0);
end;
function TGIFSubImage.GetBounds(Index: integer): WORD;
begin
case (Index) of
1: Result := FImageDescriptor.Left;
2: Result := FImageDescriptor.Top;
3: Result := FImageDescriptor.Width;
4: Result := FImageDescriptor.Height;
else
Result := 0; // To avoid compiler warnings
end;
end;
procedure TGIFSubImage.SetBounds(Index: integer; Value: WORD);
begin
case (Index) of
1: DoSetBounds(Value, FImageDescriptor.Top, FImageDescriptor.Width, FImageDescriptor.Height);
2: DoSetBounds(FImageDescriptor.Left, Value, FImageDescriptor.Width, FImageDescriptor.Height);
3: DoSetBounds(FImageDescriptor.Left, FImageDescriptor.Top, Value, FImageDescriptor.Height);
4: DoSetBounds(FImageDescriptor.Left, FImageDescriptor.Top, FImageDescriptor.Width, Value);
end;
end;
{$IFOPT R+}
{$DEFINE R_PLUS}
{$RANGECHECKS OFF}
{$ENDIF}
function TGIFSubImage.DoGetDitherBitmap: TBitmap;
var
ColorLookup : TColorLookup;
Ditherer : TDitherEngine;
DIBResult : TDIB;
Src : PChar;
Dst : PChar;
Row : integer;
Color : TGIFColor;
ColMap : PColorMap;
Index : byte;
TransparentIndex : byte;
IsTransparent : boolean;
WasTransparent : boolean;
MappedTransparentIndex: char;
MaskBits : PChar;
MaskDest : PChar;
MaskRow : PChar;
MaskRowWidth ,
MaskRowBitWidth : integer;
Bit ,
RightBit : BYTE;
begin
Result := TBitmap.Create;
try
{$IFNDEF VER9x}
if (Width*Height > BitmapAllocationThreshold) then
SetPixelFormat(Result, pf1bit); // To reduce resource consumption of resize
{$ENDIF}
if (Empty) then
begin
// Set bitmap width and height
Result.Width := Width;
Result.Height := Height;
// Build and copy palette to bitmap
Result.Palette := CopyPalette(Palette);
exit;
end;
ColorLookup := nil;
Ditherer := nil;
DIBResult := nil;
try // Protect above resources
ColorLookup := TNetscapeColorLookup.Create(Palette);
Ditherer := TFloydSteinbergDitherer.Create(Width, ColorLookup);
// Get DIB buffer for scanline operations
// It is assumed that the source palette is the 216 color Netscape palette
DIBResult := TDIBWriter.Create(Result, pf8bit, Width, Height, Palette);
// Determine if this image is transparent
ColMap := ActiveColorMap.Data;
IsTransparent := FNeedMask and Transparent;
WasTransparent := False;
FNeedMask := False;
TransparentIndex := 0;
MappedTransparentIndex := #0;
if (FMask = 0) and (IsTransparent) then
begin
IsTransparent := True;
TransparentIndex := GraphicControlExtension.TransparentColorIndex;
Color := ColMap[ord(TransparentIndex)];
MappedTransparentIndex := char(Color.Blue DIV 51 +
MulDiv(6, Color.Green, 51) + MulDiv(36, Color.Red, 51)+1);
end;
// Allocate bit buffer for transparency mask
MaskDest := nil;
Bit := $00;
if (IsTransparent) then
begin
MaskRowWidth := ((Width+15) DIV 16) * 2;
MaskRowBitWidth := (Width+7) DIV 8;
RightBit := $01 SHL ((8 - (Width AND $0007)) AND $0007);
GetMem(MaskBits, MaskRowWidth * Height);
FillChar(MaskBits^, MaskRowWidth * Height, 0);
end else
begin
MaskBits := nil;
MaskRowWidth := 0;
MaskRowBitWidth := 0;
RightBit := $00;
end;
try
// Process the image
Row := 0;
MaskRow := MaskBits;
Src := FData;
while (Row < Height) do
begin
if ((Row AND $1F) = 0) then
Image.Progress(Self, psRunning, MulDiv(Row, 100, Height),
False, Rect(0,0,0,0), sProgressRendering);
Dst := DIBResult.ScanLine[Row];
if (IsTransparent) then
begin
// Preset all pixels to transparent
FillChar(Dst^, Width, ord(MappedTransparentIndex));
if (Ditherer.Direction = 1) then
begin
MaskDest := MaskRow;
Bit := $80;
end else
begin
MaskDest := MaskRow + MaskRowBitWidth-1;
Bit := RightBit;
end;
end;
inc(Dst, Ditherer.Column);
while (Ditherer.Column < Ditherer.Width) and (Ditherer.Column >= 0) do
begin
Index := ord(Src^);
Color := ColMap[ord(Index)];
if (IsTransparent) and (Index = TransparentIndex) then
begin
MaskDest^ := char(byte(MaskDest^) OR Bit);
WasTransparent := True;
Ditherer.NextColumn;
end else
begin
// Dither and map a single pixel
Dst^ := Ditherer.Dither(Color.Red, Color.Green, Color.Blue,
Color.Red, Color.Green, Color.Blue);
end;
if (IsTransparent) then
begin
if (Ditherer.Direction = 1) then
begin
Bit := Bit SHR 1;
if (Bit = $00) then
begin
Bit := $80;
inc(MaskDest, 1);
end;
end else
begin
Bit := Bit SHL 1;
if (Bit = $00) then
begin
Bit := $01;
dec(MaskDest, 1);
end;
end;
end;
inc(Src, Ditherer.Direction);
inc(Dst, Ditherer.Direction);
end;
if (IsTransparent) then
Inc(MaskRow, MaskRowWidth);
Inc(Row);
inc(Src, Width-Ditherer.Direction);
Ditherer.NextLine;
end;
// Transparent paint needs a mask bitmap
if (IsTransparent) and (WasTransparent) then
FMask := CreateBitmap(Width, Height, 1, 1, MaskBits);
finally
if (MaskBits <> nil) then
FreeMem(MaskBits);
end;
finally
if (ColorLookup <> nil) then
ColorLookup.Free;
if (Ditherer <> nil) then
Ditherer.Free;
if (DIBResult <> nil) then
DIBResult.Free;
end;
except
Result.Free;
raise;
end;
end;
{$IFDEF R_PLUS}
{$RANGECHECKS ON}
{$UNDEF R_PLUS}
{$ENDIF}
function TGIFSubImage.DoGetBitmap: TBitmap;
var
ScanLineRow : Integer;
DIBResult : TDIB;
DestScanLine ,
Src : PChar;
TransparentIndex : byte;
IsTransparent : boolean;
WasTransparent : boolean;
MaskBits : PChar;
MaskDest : PChar;
MaskRow : PChar;
MaskRowWidth : integer;
Col : integer;
MaskByte : byte;
Bit : byte;
begin
Result := TBitmap.Create;
try
{$IFNDEF VER9x}
if (Width*Height > BitmapAllocationThreshold) then
SetPixelFormat(Result, pf1bit); // To reduce resource consumption of resize
{$ENDIF}
if (Empty) then
begin
// Set bitmap width and height
Result.Width := Width;
Result.Height := Height;
// Build and copy palette to bitmap
Result.Palette := CopyPalette(Palette);
exit;
end;
// Get DIB buffer for scanline operations
DIBResult := TDIBWriter.Create(Result, pf8bit, Width, Height, Palette);
try
// Determine if this image is transparent
IsTransparent := FNeedMask and Transparent;
WasTransparent := False;
FNeedMask := False;
TransparentIndex := 0;
if (FMask = 0) and (IsTransparent) then
begin
IsTransparent := True;
TransparentIndex := GraphicControlExtension.TransparentColorIndex;
end;
// Allocate bit buffer for transparency mask
if (IsTransparent) then
begin
MaskRowWidth := ((Width+15) DIV 16) * 2;
GetMem(MaskBits, MaskRowWidth * Height);
FillChar(MaskBits^, MaskRowWidth * Height, 0);
IsTransparent := (MaskBits <> nil);
end else
begin
MaskBits := nil;
MaskRowWidth := 0;
end;
try
ScanLineRow := 0;
Src := FData;
MaskRow := MaskBits;
while (ScanLineRow < Height) do
begin
DestScanline := DIBResult.ScanLine[ScanLineRow];
if ((ScanLineRow AND $1F) = 0) then
Image.Progress(Self, psRunning, MulDiv(ScanLineRow, 100, Height),
False, Rect(0,0,0,0), sProgressRendering);
Move(Src^, DestScanline^, Width);
Inc(ScanLineRow);
if (IsTransparent) then
begin
Bit := $80;
MaskDest := MaskRow;
MaskByte := 0;
for Col := 0 to Width-1 do
begin
// Set a bit in the mask if the pixel is transparent
if (Src^ = char(TransparentIndex)) then
MaskByte := MaskByte OR Bit;
Bit := Bit SHR 1;
if (Bit = $00) then
begin
// Store a mask byte for each 8 pixels
Bit := $80;
WasTransparent := WasTransparent or (MaskByte <> 0);
MaskDest^ := char(MaskByte);
inc(MaskDest);
MaskByte := 0;
end;
Inc(Src);
end;
// Save the last mask byte in case the width isn't divisable by 8
if (MaskByte <> 0) then
begin
WasTransparent := True;
MaskDest^ := char(MaskByte);
end;
Inc(MaskRow, MaskRowWidth);
end else
Inc(Src, Width);
end;
// Transparent paint needs a mask bitmap
if (IsTransparent) and (WasTransparent) then
FMask := CreateBitmap(Width, Height, 1, 1, MaskBits);
finally
if (MaskBits <> nil) then
FreeMem(MaskBits);
end;
finally
// Free DIB buffer used for scanline operations
DIBResult.Free;
end;
except
Result.Free;
raise;
end;
end;
{$ifdef DEBUG_RENDERPERFORMANCE}
var
ImageCount : DWORD = 0;
RenderTime : DWORD = 0;
{$endif}
function TGIFSubImage.GetBitmap: TBitmap;
var
n : integer;
{$ifdef DEBUG_RENDERPERFORMANCE}
RenderStartTime : DWORD;
{$endif}
begin
{$ifdef DEBUG_RENDERPERFORMANCE}
if (GetAsyncKeyState(VK_CONTROL) <> 0) then
begin
ShowMessage(format('Render %d images in %d mS, Rate %d mS/image (%d images/S)',
[ImageCount, RenderTime,
RenderTime DIV (ImageCount+1),
MulDiv(ImageCount, 1000, RenderTime+1)]));
end;
{$endif}
Result := FBitmap;
if (Result <> nil) or (Empty) then
Exit;
{$ifdef DEBUG_RENDERPERFORMANCE}
inc(ImageCount);
RenderStartTime := timeGetTime;
{$endif}
try
Image.Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressRendering);
try
if (Image.DoDither) then
// Create dithered bitmap
FBitmap := DoGetDitherBitmap
else
// Create "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(PChar(longInt(Scanline[y]) + x)^);
end;
function TGIFSubImage.GetScanline(y: integer): pointer;
begin
if (y < 0) or (y > Height-1) then
Error(sBadPixelCoordinates);
NeedImage;
Result := pointer(longInt(FData) + y * Width);
end;
procedure TGIFSubImage.Prepare;
var
Pack : BYTE;
begin
Pack := FImageDescriptor.PackedFields;
if (ColorMap.Count > 0) then
begin
Pack := idLocalColorTable;
if (ColorMap.Optimized) then
Pack := Pack OR idSort;
Pack := (Pack AND NOT(idColorTableSize)) OR (ColorResolution AND idColorTableSize);
end else
Pack := Pack AND NOT(idLocalColorTable OR idSort OR idColorTableSize);
FImageDescriptor.PackedFields := Pack;
end;
procedure TGIFSubImage.SaveToStream(Stream: TStream);
begin
FExtensions.SaveToStream(Stream);
if (Empty) then
exit;
Prepare;
Stream.Write(FImageDescriptor, sizeof(TImageDescriptor));
ColorMap.SaveToStream(Stream);
Compress(Stream);
end;
procedure TGIFSubImage.LoadFromStream(Stream: TStream);
var
ColorCount : integer;
b : BYTE;
begin
Clear;
FExtensions.LoadFromStream(Stream, self);
// Check for extension without image
if (Stream.Read(b, 1) <> 1) then
exit;
Stream.Seek(-1, soFromCurrent);
if (b = bsTrailer) or (b = 0) then
exit;
ReadCheck(Stream, FImageDescriptor, sizeof(TImageDescriptor));
// From Mozilla source:
// Work around more broken GIF files that have zero image
// width or height
if (FImageDescriptor.Height = 0) or (FImageDescriptor.Width = 0) then
begin
FImageDescriptor.Height := Image.Height;
FImageDescriptor.Width := Image.Width;
Warning(gsWarning, sScreenSizeExceeded);
end;
if (FImageDescriptor.PackedFields AND idLocalColorTable = idLocalColorTable) then
begin
ColorCount := 2 SHL (FImageDescriptor.PackedFields AND idColorTableSize);
if (ColorCount < 2) or (ColorCount > 256) then
Error(sImageBadColorSize);
ColorMap.LoadFromStream(Stream, ColorCount);
end;
Decompress(Stream);
// On-load rendering
if (GIFImageRenderOnLoad) then
// Touch bitmap to force frame to be rendered
Bitmap;
end;
procedure TGIFSubImage.AssignTo(Dest: TPersistent);
begin
if (Dest is TBitmap) then
Dest.Assign(Bitmap)
else
inherited AssignTo(Dest);
end;
procedure TGIFSubImage.Assign(Source: TPersistent);
var
MemoryStream : TMemoryStream;
i : integer;
PixelFormat : TPixelFormat;
DIBSource : TDIB;
ABitmap : TBitmap;
procedure Import8Bit(Dest: PChar);
var
y : integer;
begin
// Copy colormap
{$ifdef VER10_PLUS}
if (FBitmap.HandleType = bmDIB) then
FColorMap.ImportDIBColors(FBitmap.Canvas.Handle)
else
{$ENDIF}
FColorMap.ImportPalette(FBitmap.Palette);
// Copy pixels
for y := 0 to Height-1 do
begin
if ((y AND $1F) = 0) then
Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
Move(DIBSource.Scanline[y]^, Dest^, Width);
inc(Dest, Width);
end;
end;
procedure Import4Bit(Dest: PChar);
var
x, y : integer;
Scanline : PChar;
begin
// Copy colormap
FColorMap.ImportPalette(FBitmap.Palette);
// Copy pixels
for y := 0 to Height-1 do
begin
if ((y AND $1F) = 0) then
Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
ScanLine := DIBSource.Scanline[y];
for x := 0 to Width-1 do
begin
if (x AND $01 = 0) then
Dest^ := chr(ord(ScanLine^) SHR 4)
else
begin
Dest^ := chr(ord(ScanLine^) AND $0F);
inc(ScanLine);
end;
inc(Dest);
end;
end;
end;
procedure Import1Bit(Dest: PChar);
var
x, y : integer;
Scanline : PChar;
Bit : integer;
Byte : integer;
begin
// Copy colormap
FColorMap.ImportPalette(FBitmap.Palette);
// Copy pixels
for y := 0 to Height-1 do
begin
if ((y AND $1F) = 0) then
Image.Progress(Self, psRunning, MulDiv(y, 100, Height), False, Rect(0,0,0,0), sProgressConverting);
ScanLine := DIBSource.Scanline[y];
x := Width;
Bit := 0;
Byte := 0; // To avoid compiler warning
while (x > 0) do
begin
if (Bit = 0) then
begin
Bit := 8;
Byte := ord(ScanLine^);
inc(Scanline);
end;
Dest^ := chr((Byte AND $80) SHR 7);
Byte := Byte SHL 1;
inc(Dest);
dec(Bit);
dec(x);
end;
end;
end;
procedure Import24Bit(Dest: PChar);
type
TCacheEntry = record
Color : TColor;
Index : integer;
end;
const
// Size of palette cache. Must be 2^n.
// The cache holds the palette index of the last "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^ := chr(Cache[i].Index);
LastEntry := i;
goto NextPixel;
end;
if (i = 0) then
i := CacheSize-1
else
dec(i);
until (i = LastEntry);
// Color not found in cache, do it the slow way instead
Dest^ := chr(FColorMap.AddUnique(Pixel));
// Add color and index to cache
LastEntry := (LastEntry + 1) AND (CacheSize-1);
Cache[LastEntry].Color := Pixel;
Cache[LastEntry].Index := ord(Dest^);
NextPixel:
Inc(Dest);
Inc(Scanline);
end;
end;
// Convert colors in colormap from BGR to RGB
ColorMap := FColorMap.Data;
i := FColorMap.Count;
while (i > 0) do
begin
t := ColorMap^[0].Red;
ColorMap^[0].Red := ColorMap^[0].Blue;
ColorMap^[0].Blue := t;
inc(integer(ColorMap), sizeof(TGIFColor));
dec(i);
end;
end;
procedure ImportViaDraw(ABitmap: TBitmap; Graphic: TGraphic);
begin
ABitmap.Height := Graphic.Height;
ABitmap.Width := Graphic.Width;
// Note: Disable the call to SafeSetPixelFormat below to import
// in max number of colors with the risk of having to use
// TCanvas.Pixels to do it (very slow).
// Make things a little easier for TGIFSubImage.Assign by converting
// pfDevice to a more import friendly format
{$ifdef SLOW_BUT_SAFE}
SafeSetPixelFormat(ABitmap, pf8bit);
{$else}
{$ifndef VER9x}
SetPixelFormat(ABitmap, pf24bit);
{$endif}
{$endif}
ABitmap.Canvas.Draw(0, 0, Graphic);
end;
procedure AddMask(Mask: TBitmap);
var
DIBReader : TDIBReader;
TransparentIndex : integer;
i ,
j : integer;
GIFPixel ,
MaskPixel : PChar;
WasTransparent : boolean;
GCE : TGIFGraphicControlExtension;
begin
// Optimize colormap to make room for transparent color
ColorMap.Optimize;
// Can't make transparent if no color or colormap full
if (ColorMap.Count = 0) or (ColorMap.Count = 256) then
exit;
// Add the transparent color to the color map
TransparentIndex := ColorMap.Add(TColor(0));
WasTransparent := False;
DIBReader := TDIBReader.Create(Mask, pf8bit);
try
for i := 0 to Height-1 do
begin
MaskPixel := DIBReader.Scanline[i];
GIFPixel := Scanline[i];
for j := 0 to Width-1 do
begin
// Change all unmasked pixels to transparent
if (MaskPixel^ <> #0) then
begin
GIFPixel^ := chr(TransparentIndex);
WasTransparent := True;
end;
inc(MaskPixel);
inc(GIFPixel);
end;
end;
finally
DIBReader.Free;
end;
// Add a Graphic Control Extension if any part of the mask was transparent
if (WasTransparent) then
begin
GCE := TGIFGraphicControlExtension.Create(self);
GCE.Transparent := True;
GCE.TransparentColorIndex := TransparentIndex;
Extensions.Add(GCE);
end else
// Otherwise removed the transparency color since it wasn't used
ColorMap.Delete(TransparentIndex);
end;
procedure AddMaskOnly(hMask: hBitmap);
var
Mask : TBitmap;
begin
if (hMask = 0) then
exit;
// Encapsulate the mask
Mask := TBitmap.Create;
try
Mask.Handle := hMask;
AddMask(Mask);
finally
Mask.ReleaseHandle;
Mask.Free;
end;
end;
procedure AddIconMask(Icon: TIcon);
var
IconInfo : TIconInfo;
begin
if (not GetIconInfo(Icon.Handle, IconInfo)) then
exit;
// Extract the icon mask
AddMaskOnly(IconInfo.hbmMask);
end;
procedure AddMetafileMask(Metafile: TMetaFile);
var
Mask1 ,
Mask2 : TBitmap;
procedure DrawMetafile(ABitmap: TBitmap; Background: TColor);
begin
ABitmap.Width := Metafile.Width;
ABitmap.Height := Metafile.Height;
{$ifndef VER9x}
SetPixelFormat(ABitmap, pf24bit);
{$endif}
ABitmap.Canvas.Brush.Color := Background;
ABitmap.Canvas.Brush.Style := bsSolid;
ABitmap.Canvas.FillRect(ABitmap.Canvas.ClipRect);
ABitmap.Canvas.Draw(0,0, Metafile);
end;
begin
// Create the metafile mask
Mask1 := TBitmap.Create;
try
Mask2 := TBitmap.Create;
try
DrawMetafile(Mask1, clWhite);
DrawMetafile(Mask2, clBlack);
Mask1.Canvas.CopyMode := cmSrcInvert;
Mask1.Canvas.Draw(0,0, Mask2);
AddMask(Mask1);
finally
Mask2.Free;
end;
finally
Mask1.Free;
end;
end;
begin
if (Source = self) then
exit;
if (Source = nil) then
begin
Clear;
end else
//
// TGIFSubImage import
//
if (Source is TGIFSubImage) then
begin
// Zap existing colormap, extensions and bitmap
Clear;
if (TGIFSubImage(Source).Empty) then
exit;
// Copy source data
FImageDescriptor := TGIFSubImage(Source).FImageDescriptor;
FTransparent := TGIFSubImage(Source).Transparent;
// Copy image data
NewImage;
if (FData <> nil) and (TGIFSubImage(Source).Data <> nil) then
Move(TGIFSubImage(Source).Data^, FData^, FDataSize);
// Copy palette
FColorMap.Assign(TGIFSubImage(Source).ColorMap);
// Copy extensions
if (TGIFSubImage(Source).Extensions.Count > 0) then
begin
MemoryStream := TMemoryStream.Create;
try
TGIFSubImage(Source).Extensions.SaveToStream(MemoryStream);
MemoryStream.Seek(0, soFromBeginning);
Extensions.LoadFromStream(MemoryStream, Self);
finally
MemoryStream.Free;
end;
end;
// Copy bitmap representation
// (Not really nescessary but improves performance if the bitmap is needed
// later on)
if (TGIFSubImage(Source).HasBitmap) then
begin
NewBitmap;
FBitmap.Assign(TGIFSubImage(Source).Bitmap);
end;
end else
//
// Bitmap import
//
if (Source is TBitmap) then
begin
// Zap existing colormap, extensions and bitmap
Clear;
if (TBitmap(Source).Empty) then
exit;
Width := TBitmap(Source).Width;
Height := TBitmap(Source).Height;
PixelFormat := GetPixelFormat(TBitmap(Source));
{$ifdef VER9x}
// Delphi 2 TBitmaps are always DDBs. This means that if a 24 bit
// bitmap is loaded in 8 bit device mode, TBitmap.PixelFormat will
// be pf8bit, but TBitmap.Palette will be 0!
if (TBitmap(Source).Palette = 0) then
PixelFormat := pfDevice;
{$endif}
if (PixelFormat > pf8bit) or (PixelFormat = pfDevice) then
begin
// Convert image to 8 bits/pixel or less
FBitmap := ReduceColors(TBitmap(Source), Image.ColorReduction,
Image.DitherMode, Image.ReductionBits, 0);
PixelFormat := GetPixelFormat(FBitmap);
end else
begin
// Create new bitmap and copy
NewBitmap;
FBitmap.Assign(TBitmap(Source));
end;
// Allocate new buffer
NewImage;
Image.Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressConverting);
try
{$ifdef VER9x}
// This shouldn't happen, but better safe...
if (FBitmap.Palette = 0) then
PixelFormat := pf24bit;
{$endif}
if (not(PixelFormat in [pf1bit, pf4bit, pf8bit, pf24bit])) then
PixelFormat := pf24bit;
DIBSource := TDIBReader.Create(FBitmap, PixelFormat);
try
// Copy pixels
case (PixelFormat) of
pf8bit: Import8Bit(Fdata);
pf4bit: Import4Bit(Fdata);
pf1bit: Import1Bit(Fdata);
else
// Error(sUnsupportedBitmap);
Import24Bit(Fdata);
end;
finally
DIBSource.Free;
end;
{$ifdef VER10_PLUS}
// Add mask for transparent bitmaps
if (TBitmap(Source).Transparent) then
AddMaskOnly(TBitmap(Source).MaskHandle);
{$endif}
finally
if ExceptObject = nil then
i := 100
else
i := 0;
Image.Progress(Self, psEnding, i, Image.PaletteModified, Rect(0,0,0,0), sProgressConverting);
end;
end else
//
// TGraphic import
//
if (Source is TGraphic) then
begin
// Zap existing colormap, extensions and bitmap
Clear;
if (TGraphic(Source).Empty) then
exit;
ABitmap := TBitmap.Create;
try
// Import TIcon and TMetafile by drawing them onto a bitmap...
// ...and then importing the bitmap recursively
if (Source is TIcon) or (Source is TMetafile) then
begin
try
ImportViaDraw(ABitmap, TGraphic(Source))
except
// If import via TCanvas.Draw fails (which it shouldn't), we try the
// Assign mechanism instead
ABitmap.Assign(Source);
end;
end else
try
ABitmap.Assign(Source);
except
// If automatic conversion to bitmap fails, we try and draw the
// graphic on the bitmap instead
ImportViaDraw(ABitmap, TGraphic(Source));
end;
// Convert the bitmap to a GIF frame recursively
Assign(ABitmap);
finally
ABitmap.Free;
end;
// Import transparency mask
if (Source is TIcon) then
AddIconMask(TIcon(Source));
if (Source is TMetaFile) then
AddMetafileMask(TMetaFile(Source));
end else
//
// TPicture import
//
if (Source is TPicture) then
begin
// Recursively import TGraphic
Assign(TPicture(Source).Graphic);
end else
// Unsupported format - fall back to Source.AssignTo
inherited Assign(Source);
end;
// Copied from D3 graphics.pas
// Fixed by Brian Lowe of Acro Technology Inc. 30Jan98
function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
MaskY: Integer): Boolean;
const
ROP_DstCopy = $00AA0029;
var
MemDC ,
OrMaskDC : HDC;
MemBmp ,
OrMaskBmp : HBITMAP;
Save ,
OrMaskSave : THandle;
crText, crBack : TColorRef;
SavePal : HPALETTE;
begin
Result := True;
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (SrcW = DstW) and (SrcH = DstH) then
begin
MemBmp := GDICheck(CreateCompatibleBitmap(SrcDC, 1, 1));
MemBmp := SelectObject(MaskDC, MemBmp);
try
MaskBlt(DstDC, DstX, DstY, DstW, DstH, SrcDC, SrcX, SrcY, MemBmp, MaskX,
MaskY, MakeRop4(ROP_DstCopy, SrcCopy));
finally
MemBmp := SelectObject(MaskDC, MemBmp);
DeleteObject(MemBmp);
end;
Exit;
end;
SavePal := 0;
MemDC := GDICheck(CreateCompatibleDC(DstDC));
try
{ Color bitmap for combining OR mask with source bitmap }
MemBmp := GDICheck(CreateCompatibleBitmap(DstDC, SrcW, SrcH));
try
Save := SelectObject(MemDC, MemBmp);
try
{ This bitmap needs the size of the source but DC of the dest }
OrMaskDC := GDICheck(CreateCompatibleDC(DstDC));
try
{ Need a monochrome bitmap for OR mask!! }
OrMaskBmp := GDICheck(CreateBitmap(SrcW, SrcH, 1, 1, nil));
try
OrMaskSave := SelectObject(OrMaskDC, OrMaskBmp);
try
// OrMask := 1
// Original: BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, OrMaskDC, SrcX, SrcY, WHITENESS);
// Replacement, but not needed: PatBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, WHITENESS);
// OrMask := OrMask XOR Mask
// Not needed: BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, MaskDC, SrcX, SrcY, SrcInvert);
// OrMask := NOT Mask
BitBlt(OrMaskDC, SrcX, SrcY, SrcW, SrcH, MaskDC, SrcX, SrcY, NotSrcCopy);
// Retrieve source palette (with dummy select)
SavePal := SelectPalette(SrcDC, SystemPalette16, False);
// Restore source palette
SelectPalette(SrcDC, SavePal, False);
// Select source palette into memory buffer
if SavePal <> 0 then
SavePal := SelectPalette(MemDC, SavePal, True)
else
SavePal := SelectPalette(MemDC, SystemPalette16, True);
RealizePalette(MemDC);
// Mem := OrMask
BitBlt(MemDC, SrcX, SrcY, SrcW, SrcH, OrMaskDC, SrcX, SrcY, SrcCopy);
// Mem := Mem AND Src
{$IFNDEF GIF_TESTMASK} // Define GIF_TESTMASK if you want to know what it does...
BitBlt(MemDC, SrcX, SrcY, SrcW, SrcH, SrcDC, SrcX, SrcY, SrcAnd);
{$ELSE}
StretchBlt(DstDC, DstX, DstY, DstW DIV 2, DstH, MemDC, SrcX, SrcY, SrcW, SrcH, SrcCopy);
StretchBlt(DstDC, DstX+DstW DIV 2, DstY, DstW DIV 2, DstH, SrcDC, SrcX, SrcY, SrcW, SrcH, SrcCopy);
exit;
{$ENDIF}
finally
if (OrMaskSave <> 0) then
SelectObject(OrMaskDC, OrMaskSave);
end;
finally
DeleteObject(OrMaskBmp);
end;
finally
DeleteDC(OrMaskDC);
end;
crText := SetTextColor(DstDC, $00000000);
crBack := SetBkColor(DstDC, $00FFFFFF);
{ All color rendering is done at 1X (no stretching),
then final 2 masks are stretched to dest DC }
// Neat trick!
// Dst := Dst AND Mask
StretchBlt(DstDC, DstX, DstY, DstW, DstH, MaskDC, SrcX, SrcY, SrcW, SrcH, SrcAnd);
// Dst := Dst OR Mem
StretchBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, SrcX, SrcY, SrcW, SrcH, SrcPaint);
SetTextColor(DstDC, crText);
SetTextColor(DstDC, crBack);
finally
if (Save <> 0) then
SelectObject(MemDC, Save);
end;
finally
DeleteObject(MemBmp);
end;
finally
if (SavePal <> 0) then
SelectPalette(MemDC, SavePal, False);
DeleteDC(MemDC);
end;
end;
procedure TGIFSubImage.Draw(ACanvas: TCanvas; const Rect: TRect;
DoTransparent, DoTile: boolean);
begin
if (DoTile) then
StretchDraw(ACanvas, Rect, DoTransparent, DoTile)
else
StretchDraw(ACanvas, ScaleRect(Rect), DoTransparent, DoTile);
end;
type
// Dummy class used to gain access to protected method TCanvas.Changed
TChangableCanvas = class(TCanvas)
end;
procedure TGIFSubImage.StretchDraw(ACanvas: TCanvas; const Rect: TRect;
DoTransparent, DoTile: boolean);
var
MaskDC : HDC;
Save : THandle;
Tile : TRect;
{$ifdef DEBUG_DRAWPERFORMANCE}
ImageCount ,
TimeStart ,
TimeStop : DWORD;
{$endif}
begin
{$ifdef DEBUG_DRAWPERFORMANCE}
TimeStart := timeGetTime;
ImageCount := 0;
{$endif}
if (DoTransparent) and (Transparent) and (HasMask) then
begin
// Draw transparent using mask
Save := 0;
MaskDC := 0;
try
MaskDC := GDICheck(CreateCompatibleDC(0));
Save := SelectObject(MaskDC, FMask);
if (DoTile) then
begin
Tile.Left := Rect.Left+Left;
Tile.Right := Tile.Left + Width;
while (Tile.Left < Rect.Right) do
begin
Tile.Top := Rect.Top+Top;
Tile.Bottom := Tile.Top + Height;
while (Tile.Top < Rect.Bottom) do
begin
TransparentStretchBlt(ACanvas.Handle, Tile.Left, Tile.Top, Width, Height,
Bitmap.Canvas.Handle, 0, 0, Width, Height, MaskDC, 0, 0);
Tile.Top := Tile.Top + Image.Height;
Tile.Bottom := Tile.Bottom + Image.Height;
{$ifdef DEBUG_DRAWPERFORMANCE}
inc(ImageCount);
{$endif}
end;
Tile.Left := Tile.Left + Image.Width;
Tile.Right := Tile.Right + Image.Width;
end;
end else
TransparentStretchBlt(ACanvas.Handle, Rect.Left, Rect.Top,
Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
Bitmap.Canvas.Handle, 0, 0, Width, Height, MaskDC, 0, 0);
// Since we are not using any of the TCanvas functions (only handle)
// we need to fire the TCanvas.Changed method "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 : PChar;
NewWidth ,
NewHeight : integer;
pSource ,
pDest : PChar;
begin
if (Empty) or (not Transparent) then
exit;
TransparentColorIndex := GraphicControlExtension.TransparentColorIndex;
CropLeft := 0;
CropRight := Width - 1;
CropTop := 0;
CropBottom := Height - 1;
// Find left edge
WasTransparent := True;
while (CropLeft <= CropRight) and (WasTransparent) do
begin
for i := CropTop to CropBottom do
if (Pixels[CropLeft, i] <> TransparentColorIndex) then
begin
WasTransparent := False;
break;
end;
if (WasTransparent) then
inc(CropLeft);
end;
// Find right edge
WasTransparent := True;
while (CropLeft <= CropRight) and (WasTransparent) do
begin
for i := CropTop to CropBottom do
if (pixels[CropRight, i] <> TransparentColorIndex) then
begin
WasTransparent := False;
break;
end;
if (WasTransparent) then
dec(CropRight);
end;
if (CropLeft <= CropRight) then
begin
// Find top edge
WasTransparent := True;
while (CropTop <= CropBottom) and (WasTransparent) do
begin
for i := CropLeft to CropRight do
if (pixels[i, CropTop] <> TransparentColorIndex) then
begin
WasTransparent := False;
break;
end;
if (WasTransparent) then
inc(CropTop);
end;
// Find bottom edge
WasTransparent := True;
while (CropTop <= CropBottom) and (WasTransparent) do
begin
for i := CropLeft to CropRight do
if (pixels[i, CropBottom] <> TransparentColorIndex) then
begin
WasTransparent := False;
break;
end;
if (WasTransparent) then
dec(CropBottom);
end;
end;
if (CropLeft > CropRight) or (CropTop > CropBottom) then
begin
// Cropped to nothing - frame is invisible
Clear;
end else
begin
// Crop frame - move data
NewWidth := CropRight - CropLeft + 1;
Newheight := CropBottom - CropTop + 1;
NewSize := NewWidth * NewHeight;
GetMem(NewData, NewSize);
pSource := PChar(integer(FData) + CropTop * Width + CropLeft);
pDest := NewData;
for i := 0 to NewHeight-1 do
begin
Move(pSource^, pDest^, NewWidth);
inc(pSource, Width);
inc(pDest, NewWidth);
end;
FreeImage;
FData := NewData;
FDataSize := NewSize;
inc(FImageDescriptor.Left, CropLeft);
inc(FImageDescriptor.Top, CropTop);
FImageDescriptor.Width := NewWidth;
FImageDescriptor.Height := NewHeight;
FreeBitmap;
FreeMask
end;
end;
procedure TGIFSubImage.Merge(Previous: TGIFSubImage);
var
SourceIndex ,
DestIndex : byte;
SourceTransparent : boolean;
NeedTransparentColorIndex: boolean;
PreviousRect ,
ThisRect ,
MergeRect : TRect;
PreviousY ,
X ,
Y : integer;
pSource ,
pDest : PChar;
pSourceMap ,
pDestMap : PColorMap;
GCE : TGIFGraphicControlExtension;
function CanMakeTransparent: boolean;
begin
// Is there a local color map...
if (ColorMap.Count > 0) then
// ...and is there room in it?
Result := (ColorMap.Count < 256)
// Is there a global color map...
else if (Image.GlobalColorMap.Count > 0) then
// ...and is there room in it?
Result := (Image.GlobalColorMap.Count < 256)
else
Result := False;
end;
function GetTransparentColorIndex: byte;
var
i : integer;
begin
if (ColorMap.Count > 0) then
begin
// Get the transparent color from the local color map
Result := ColorMap.Add(TColor(0));
end else
begin
// Are any other frames using the global color map for transparency
for i := 0 to Image.Images.Count-1 do
if (Image.Images[i] <> self) and (Image.Images[i].Transparent) and
(Image.Images[i].ColorMap.Count = 0) then
begin
// Use the same transparency color as the other frame
Result := Image.Images[i].GraphicControlExtension.TransparentColorIndex;
exit;
end;
// Get the transparent color from the global color map
Result := Image.GlobalColorMap.Add(TColor(0));
end;
end;
begin
// Determine if it is possible to merge this frame
if (Empty) or (Previous = nil) or (Previous.Empty) or
((Previous.GraphicControlExtension <> nil) and
(Previous.GraphicControlExtension.Disposal in [dmBackground, dmPrevious])) then
exit;
PreviousRect := Previous.BoundsRect;
ThisRect := BoundsRect;
// Cannot merge unless the frames intersect
if (not IntersectRect(MergeRect, PreviousRect, ThisRect)) then
exit;
// If the frame isn't already transparent, determine
// if it is possible to make it so
if (Transparent) then
begin
DestIndex := GraphicControlExtension.TransparentColorIndex;
NeedTransparentColorIndex := False;
end else
begin
if (not CanMakeTransparent) then
exit;
DestIndex := 0; // To avoid compiler warning
NeedTransparentColorIndex := True;
end;
SourceTransparent := Previous.Transparent;
if (SourceTransparent) then
SourceIndex := Previous.GraphicControlExtension.TransparentColorIndex
else
SourceIndex := 0; // To avoid compiler warning
PreviousY := MergeRect.Top - Previous.Top;
pSourceMap := Previous.ActiveColorMap.Data;
pDestMap := ActiveColorMap.Data;
for Y := MergeRect.Top - Top to MergeRect.Bottom - Top-1 do
begin
pSource := PChar(integer(Previous.Scanline[PreviousY]) + MergeRect.Left - Previous.Left);
pDest := PChar(integer(Scanline[Y]) + MergeRect.Left - Left);
for X := MergeRect.Left to MergeRect.Right-1 do
begin
// Ignore pixels if either this frame's or the previous frame's pixel is transparent
if (
not(
((not NeedTransparentColorIndex) and (pDest^ = char(DestIndex))) or
((SourceTransparent) and (pSource^ = char(SourceIndex)))
)
) and (
// Replace same colored pixels with transparency
((pDestMap = pSourceMap) and (pDest^ = pSource^)) or
(CompareMem(@(pDestMap^[ord(pDest^)]), @(pSourceMap^[ord(pSource^)]), sizeof(TGIFColor)))
) then
begin
if (NeedTransparentColorIndex) then
begin
NeedTransparentColorIndex := False;
DestIndex := GetTransparentColorIndex;
end;
pDest^ := char(DestIndex);
end;
inc(pDest);
inc(pSource);
end;
inc(PreviousY);
end;
(*
** Create a GCE if the frame wasn't already transparent and any
** pixels were made transparent
*)
if (not Transparent) and (not NeedTransparentColorIndex) then
begin
if (GraphicControlExtension = nil) then
begin
GCE := TGIFGraphicControlExtension.Create(self);
Extensions.Add(GCE);
end else
GCE := GraphicControlExtension;
GCE.Transparent := True;
GCE.TransparentColorIndex := DestIndex;
end;
FreeBitmap;
FreeMask
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFTrailer
//
////////////////////////////////////////////////////////////////////////////////
procedure TGIFTrailer.SaveToStream(Stream: TStream);
begin
WriteByte(Stream, bsTrailer);
end;
procedure TGIFTrailer.LoadFromStream(Stream: TStream);
var
b : BYTE;
begin
if (Stream.Read(b, 1) <> 1) then
exit;
if (b <> bsTrailer) then
Warning(gsWarning, sBadTrailer);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFExtension registration database
//
////////////////////////////////////////////////////////////////////////////////
type
TExtensionLeadIn = packed record
Introducer: byte; { always $21 }
ExtensionLabel: byte;
end;
PExtRec = ^TExtRec;
TExtRec = record
ExtClass: TGIFExtensionClass;
ExtLabel: BYTE;
end;
TExtensionList = class(TList)
public
constructor Create;
destructor Destroy; override;
procedure Add(eLabel: BYTE; eClass: TGIFExtensionClass);
function FindExt(eLabel: BYTE): TGIFExtensionClass;
procedure Remove(eClass: TGIFExtensionClass);
end;
constructor TExtensionList.Create;
begin
inherited Create;
Add(bsPlainTextExtension, TGIFTextExtension);
Add(bsGraphicControlExtension, TGIFGraphicControlExtension);
Add(bsCommentExtension, TGIFCommentExtension);
Add(bsApplicationExtension, TGIFApplicationExtension);
end;
destructor TExtensionList.Destroy;
var
I: Integer;
begin
for I := 0 to Count-1 do
Dispose(PExtRec(Items[I]));
inherited Destroy;
end;
procedure TExtensionList.Add(eLabel: BYTE; eClass: TGIFExtensionClass);
var
NewRec: PExtRec;
begin
New(NewRec);
with NewRec^ do
begin
ExtLabel := eLabel;
ExtClass := eClass;
end;
inherited Add(NewRec);
end;
function TExtensionList.FindExt(eLabel: BYTE): TGIFExtensionClass;
var
I: Integer;
begin
for I := Count-1 downto 0 do
with PExtRec(Items[I])^ do
if ExtLabel = eLabel then
begin
Result := ExtClass;
Exit;
end;
Result := nil;
end;
procedure TExtensionList.Remove(eClass: TGIFExtensionClass);
var
I: Integer;
P: PExtRec;
begin
for I := Count-1 downto 0 do
begin
P := PExtRec(Items[I]);
if P^.ExtClass.InheritsFrom(eClass) then
begin
Dispose(P);
Delete(I);
end;
end;
end;
var
ExtensionList: TExtensionList = nil;
function GetExtensionList: TExtensionList;
begin
if (ExtensionList = nil) then
ExtensionList := TExtensionList.Create;
Result := ExtensionList;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFExtension
//
////////////////////////////////////////////////////////////////////////////////
function TGIFExtension.GetVersion: TGIFVersion;
begin
Result := gv89a;
end;
class procedure TGIFExtension.RegisterExtension(eLabel: BYTE; eClass: TGIFExtensionClass);
begin
GetExtensionList.Add(eLabel, eClass);
end;
class function TGIFExtension.FindExtension(Stream: TStream): TGIFExtensionClass;
var
eLabel : BYTE;
SubClass : TGIFExtensionClass;
Pos : LongInt;
begin
Pos := Stream.Position;
if (Stream.Read(eLabel, 1) <> 1) then
begin
Result := nil;
exit;
end;
Result := GetExtensionList.FindExt(eLabel);
while (Result <> nil) do
begin
SubClass := Result.FindSubExtension(Stream);
if (SubClass = Result) then
break;
Result := SubClass;
end;
Stream.Position := Pos;
end;
class function TGIFExtension.FindSubExtension(Stream: TStream): TGIFExtensionClass;
begin
Result := self;
end;
constructor TGIFExtension.Create(ASubImage: TGIFSubImage);
begin
inherited Create(ASubImage.Image);
FSubImage := ASubImage;
end;
destructor TGIFExtension.Destroy;
begin
if (FSubImage <> nil) then
FSubImage.Extensions.Remove(self);
inherited Destroy;
end;
procedure TGIFExtension.SaveToStream(Stream: TStream);
var
ExtensionLeadIn : TExtensionLeadIn;
begin
ExtensionLeadIn.Introducer := bsExtensionIntroducer;
ExtensionLeadIn.ExtensionLabel := ExtensionType;
Stream.Write(ExtensionLeadIn, sizeof(ExtensionLeadIn));
end;
function TGIFExtension.DoReadFromStream(Stream: TStream): TGIFExtensionType;
var
ExtensionLeadIn : TExtensionLeadIn;
begin
ReadCheck(Stream, ExtensionLeadIn, sizeof(ExtensionLeadIn));
if (ExtensionLeadIn.Introducer <> bsExtensionIntroducer) then
Error(sBadExtensionLabel);
Result := ExtensionLeadIn.ExtensionLabel;
end;
procedure TGIFExtension.LoadFromStream(Stream: TStream);
begin
// Seek past lead-in
// Stream.Seek(sizeof(TExtensionLeadIn), soFromCurrent);
if (DoReadFromStream(Stream) <> ExtensionType) then
Error(sBadExtensionInstance);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFGraphicControlExtension
//
////////////////////////////////////////////////////////////////////////////////
const
{ Extension flag bit masks }
efInputFlag = $02; { 00000010 }
efDisposal = $1C; { 00011100 }
efTransparent = $01; { 00000001 }
efReserved = $E0; { 11100000 }
constructor TGIFGraphicControlExtension.Create(ASubImage: TGIFSubImage);
begin
inherited Create(ASubImage);
FGCExtension.BlockSize := 4;
FGCExtension.PackedFields := $00;
FGCExtension.DelayTime := 0;
FGCExtension.TransparentColorIndex := 0;
FGCExtension.Terminator := 0;
if (ASubImage.FGCE = nil) then
ASubImage.FGCE := self;
end;
destructor TGIFGraphicControlExtension.Destroy;
begin
// Clear transparent flag in sub image
if (Transparent) then
SubImage.FTransparent := False;
if (SubImage.FGCE = self) then
SubImage.FGCE := nil;
inherited Destroy;
end;
function TGIFGraphicControlExtension.GetExtensionType: TGIFExtensionType;
begin
Result := bsGraphicControlExtension;
end;
function TGIFGraphicControlExtension.GetTransparent: boolean;
begin
Result := (FGCExtension.PackedFields AND efTransparent) <> 0;
end;
procedure TGIFGraphicControlExtension.SetTransparent(Value: boolean);
begin
// Set transparent flag in sub image
SubImage.FTransparent := Value;
if (Value) then
FGCExtension.PackedFields := FGCExtension.PackedFields OR efTransparent
else
FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efTransparent);
end;
function TGIFGraphicControlExtension.GetTransparentColor: TColor;
begin
Result := SubImage.ActiveColorMap[TransparentColorIndex];
end;
procedure TGIFGraphicControlExtension.SetTransparentColor(Color: TColor);
begin
FGCExtension.TransparentColorIndex := Subimage.ActiveColorMap.AddUnique(Color);
end;
function TGIFGraphicControlExtension.GetTransparentColorIndex: BYTE;
begin
Result := FGCExtension.TransparentColorIndex;
end;
procedure TGIFGraphicControlExtension.SetTransparentColorIndex(Value: BYTE);
begin
if ((Value >= SubImage.ActiveColorMap.Count) and (SubImage.ActiveColorMap.Count > 0)) then
begin
Warning(gsWarning, sBadColorIndex);
Value := 0;
end;
FGCExtension.TransparentColorIndex := Value;
end;
function TGIFGraphicControlExtension.GetDelay: WORD;
begin
Result := FGCExtension.DelayTime;
end;
procedure TGIFGraphicControlExtension.SetDelay(Value: WORD);
begin
FGCExtension.DelayTime := Value;
end;
function TGIFGraphicControlExtension.GetUserInput: boolean;
begin
Result := (FGCExtension.PackedFields AND efInputFlag) <> 0;
end;
procedure TGIFGraphicControlExtension.SetUserInput(Value: boolean);
begin
if (Value) then
FGCExtension.PackedFields := FGCExtension.PackedFields OR efInputFlag
else
FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efInputFlag);
end;
function TGIFGraphicControlExtension.GetDisposal: TDisposalMethod;
begin
Result := TDisposalMethod((FGCExtension.PackedFields AND efDisposal) SHR 2);
end;
procedure TGIFGraphicControlExtension.SetDisposal(Value: TDisposalMethod);
begin
FGCExtension.PackedFields := FGCExtension.PackedFields AND NOT(efDisposal)
OR ((ord(Value) SHL 2) AND efDisposal);
end;
procedure TGIFGraphicControlExtension.SaveToStream(Stream: TStream);
begin
inherited SaveToStream(Stream);
Stream.Write(FGCExtension, sizeof(FGCExtension));
end;
procedure TGIFGraphicControlExtension.LoadFromStream(Stream: TStream);
begin
inherited LoadFromStream(Stream);
if (Stream.Read(FGCExtension, sizeof(FGCExtension)) <> sizeof(FGCExtension)) then
begin
Warning(gsWarning, sOutOfData);
exit;
end;
// Set transparent flag in sub image
if (Transparent) then
SubImage.FTransparent := True;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFTextExtension
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFTextExtension.Create(ASubImage: TGIFSubImage);
begin
inherited Create(ASubImage);
FText := TStringList.Create;
FPlainTextExtension.BlockSize := 12;
FPlainTextExtension.Left := 0;
FPlainTextExtension.Top := 0;
FPlainTextExtension.Width := 0;
FPlainTextExtension.Height := 0;
FPlainTextExtension.CellWidth := 0;
FPlainTextExtension.CellHeight := 0;
FPlainTextExtension.TextFGColorIndex := 0;
FPlainTextExtension.TextBGColorIndex := 0;
end;
destructor TGIFTextExtension.Destroy;
begin
FText.Free;
inherited Destroy;
end;
function TGIFTextExtension.GetExtensionType: TGIFExtensionType;
begin
Result := bsPlainTextExtension;
end;
function TGIFTextExtension.GetForegroundColor: TColor;
begin
Result := SubImage.ColorMap[ForegroundColorIndex];
end;
procedure TGIFTextExtension.SetForegroundColor(Color: TColor);
begin
ForegroundColorIndex := SubImage.ActiveColorMap.AddUnique(Color);
end;
function TGIFTextExtension.GetBackgroundColor: TColor;
begin
Result := SubImage.ActiveColorMap[BackgroundColorIndex];
end;
procedure TGIFTextExtension.SetBackgroundColor(Color: TColor);
begin
BackgroundColorIndex := SubImage.ColorMap.AddUnique(Color);
end;
function TGIFTextExtension.GetBounds(Index: integer): WORD;
begin
case (Index) of
1: Result := FPlainTextExtension.Left;
2: Result := FPlainTextExtension.Top;
3: Result := FPlainTextExtension.Width;
4: Result := FPlainTextExtension.Height;
else
Result := 0; // To avoid compiler warnings
end;
end;
procedure TGIFTextExtension.SetBounds(Index: integer; Value: WORD);
begin
case (Index) of
1: FPlainTextExtension.Left := Value;
2: FPlainTextExtension.Top := Value;
3: FPlainTextExtension.Width := Value;
4: FPlainTextExtension.Height := Value;
end;
end;
function TGIFTextExtension.GetCharWidthHeight(Index: integer): BYTE;
begin
case (Index) of
1: Result := FPlainTextExtension.CellWidth;
2: Result := FPlainTextExtension.CellHeight;
else
Result := 0; // To avoid compiler warnings
end;
end;
procedure TGIFTextExtension.SetCharWidthHeight(Index: integer; Value: BYTE);
begin
case (Index) of
1: FPlainTextExtension.CellWidth := Value;
2: FPlainTextExtension.CellHeight := Value;
end;
end;
function TGIFTextExtension.GetColorIndex(Index: integer): BYTE;
begin
case (Index) of
1: Result := FPlainTextExtension.TextFGColorIndex;
2: Result := FPlainTextExtension.TextBGColorIndex;
else
Result := 0; // To avoid compiler warnings
end;
end;
procedure TGIFTextExtension.SetColorIndex(Index: integer; Value: BYTE);
begin
case (Index) of
1: FPlainTextExtension.TextFGColorIndex := Value;
2: FPlainTextExtension.TextBGColorIndex := Value;
end;
end;
procedure TGIFTextExtension.SaveToStream(Stream: TStream);
begin
inherited SaveToStream(Stream);
Stream.Write(FPlainTextExtension, sizeof(FPlainTextExtension));
WriteStrings(Stream, FText);
end;
procedure TGIFTextExtension.LoadFromStream(Stream: TStream);
begin
inherited LoadFromStream(Stream);
ReadCheck(Stream, FPlainTextExtension, sizeof(FPlainTextExtension));
ReadStrings(Stream, FText);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFCommentExtension
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFCommentExtension.Create(ASubImage: TGIFSubImage);
begin
inherited Create(ASubImage);
FText := TStringList.Create;
end;
destructor TGIFCommentExtension.Destroy;
begin
FText.Free;
inherited Destroy;
end;
function TGIFCommentExtension.GetExtensionType: TGIFExtensionType;
begin
Result := bsCommentExtension;
end;
procedure TGIFCommentExtension.SaveToStream(Stream: TStream);
begin
inherited SaveToStream(Stream);
WriteStrings(Stream, FText);
end;
procedure TGIFCommentExtension.LoadFromStream(Stream: TStream);
begin
inherited LoadFromStream(Stream);
ReadStrings(Stream, FText);
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFApplicationExtension registration database
//
////////////////////////////////////////////////////////////////////////////////
type
PAppExtRec = ^TAppExtRec;
TAppExtRec = record
AppClass: TGIFAppExtensionClass;
Ident: TGIFApplicationRec;
end;
TAppExtensionList = class(TList)
public
constructor Create;
destructor Destroy; override;
procedure Add(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
function FindExt(eIdent: TGIFApplicationRec): TGIFAppExtensionClass;
procedure Remove(eClass: TGIFAppExtensionClass);
end;
constructor TAppExtensionList.Create;
const
NSLoopIdent: array[0..1] of TGIFApplicationRec =
((Identifier: 'NETSCAPE'; Authentication: '2.0'),
(Identifier: 'ANIMEXTS'; Authentication: '1.0'));
begin
inherited Create;
Add(NSLoopIdent[0], TGIFAppExtNSLoop);
Add(NSLoopIdent[1], TGIFAppExtNSLoop);
end;
destructor TAppExtensionList.Destroy;
var
I: Integer;
begin
for I := 0 to Count-1 do
Dispose(PAppExtRec(Items[I]));
inherited Destroy;
end;
procedure TAppExtensionList.Add(eIdent: TGIFApplicationRec; eClass: TGIFAppExtensionClass);
var
NewRec: PAppExtRec;
begin
New(NewRec);
NewRec^.Ident := eIdent;
NewRec^.AppClass := eClass;
inherited Add(NewRec);
end;
function TAppExtensionList.FindExt(eIdent: TGIFApplicationRec): TGIFAppExtensionClass;
var
I: Integer;
begin
for I := Count-1 downto 0 do
with PAppExtRec(Items[I])^ do
if CompareMem(@Ident, @eIdent, sizeof(TGIFApplicationRec)) then
begin
Result := AppClass;
Exit;
end;
Result := nil;
end;
procedure TAppExtensionList.Remove(eClass: TGIFAppExtensionClass);
var
I: Integer;
P: PAppExtRec;
begin
for I := Count-1 downto 0 do
begin
P := PAppExtRec(Items[I]);
if P^.AppClass.InheritsFrom(eClass) then
begin
Dispose(P);
Delete(I);
end;
end;
end;
var
AppExtensionList: TAppExtensionList = nil;
function GetAppExtensionList: TAppExtensionList;
begin
if (AppExtensionList = nil) then
AppExtensionList := TAppExtensionList.Create;
Result := AppExtensionList;
end;
class procedure TGIFApplicationExtension.RegisterExtension(eIdent: TGIFApplicationRec;
eClass: TGIFAppExtensionClass);
begin
GetAppExtensionList.Add(eIdent, eClass);
end;
class function TGIFApplicationExtension.FindSubExtension(Stream: TStream): TGIFExtensionClass;
var
eIdent : TGIFApplicationRec;
OldPos : longInt;
Size : BYTE;
begin
OldPos := Stream.Position;
Result := nil;
if (Stream.Read(Size, 1) <> 1) then
exit;
// Some old Adobe export filters mistakenly uses a value of 10
if (Size = 10) then
begin
{ TODO -oanme -cImprovement : replace with seek or read and check contents = 'Adobe' }
if (Stream.Read(eIdent, 10) <> 10) then
exit;
Result := TGIFUnknownAppExtension;
exit;
end else
if (Size <> sizeof(TGIFApplicationRec)) or
(Stream.Read(eIdent, sizeof(eIdent)) <> sizeof(eIdent)) then
begin
Stream.Position := OldPos;
Result := inherited FindSubExtension(Stream);
end else
begin
Result := GetAppExtensionList.FindExt(eIdent);
if (Result = nil) then
Result := TGIFUnknownAppExtension;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFApplicationExtension
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFApplicationExtension.Create(ASubImage: TGIFSubImage);
begin
inherited Create(ASubImage);
FillChar(FIdent, sizeof(FIdent), 0);
end;
destructor TGIFApplicationExtension.Destroy;
begin
inherited Destroy;
end;
function TGIFApplicationExtension.GetExtensionType: TGIFExtensionType;
begin
Result := bsApplicationExtension;
end;
function TGIFApplicationExtension.GetAuthentication: string;
begin
Result := FIdent.Authentication;
end;
procedure TGIFApplicationExtension.SetAuthentication(const Value: string);
begin
if (Length(Value) < sizeof(TGIFAuthenticationCode)) then
FillChar(FIdent.Authentication, sizeof(TGIFAuthenticationCode), 32);
StrLCopy(@(FIdent.Authentication[0]), PChar(Value), sizeof(TGIFAuthenticationCode));
end;
function TGIFApplicationExtension.GetIdentifier: string;
begin
Result := FIdent.Identifier;
end;
procedure TGIFApplicationExtension.SetIdentifier(const Value: string);
begin
if (Length(Value) < sizeof(TGIFIdentifierCode)) then
FillChar(FIdent.Identifier, sizeof(TGIFIdentifierCode), 32);
StrLCopy(@(FIdent.Identifier[0]), PChar(Value), sizeof(TGIFIdentifierCode));
end;
procedure TGIFApplicationExtension.SaveToStream(Stream: TStream);
begin
inherited SaveToStream(Stream);
WriteByte(Stream, sizeof(FIdent)); // Block size
Stream.Write(FIdent, sizeof(FIdent));
SaveData(Stream);
end;
procedure TGIFApplicationExtension.LoadFromStream(Stream: TStream);
var
i : integer;
begin
inherited LoadFromStream(Stream);
i := ReadByte(Stream);
// Some old Adobe export filters mistakenly uses a value of 10
if (i = 10) then
FillChar(FIdent, sizeOf(FIdent), 0)
else
if (i < 11) then
Error(sBadBlockSize);
ReadCheck(Stream, FIdent, sizeof(FIdent));
Dec(i, sizeof(FIdent));
// Ignore extra data
Stream.Seek(i, soFromCurrent);
// ***FIXME***
// If self class is TGIFApplicationExtension, this will cause an "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;
{
Disposal mode algorithm:
Step 1: Copy destination to backup buffer
Always executed before first frame and only once.
Done in constructor.
Step 2: Clear previous frame (implementation is same as step 6)
Done implicitly by implementation.
Only done explicitly on first frame if goClearOnLoop option is set.
Step 3: Copy backup buffer to frame buffer
Step 4: Draw frame
Step 5: Copy buffer to destination
Step 6: Clear frame from backup buffer
+------------+------------------+---------------------+------------------------+
|New \ Old | dmNone | dmBackground | dmPrevious |
+------------+------------------+---------------------+------------------------+
|dmNone | | | |
| |4. Paint on backup|4. Paint on backup |4. Paint on backup |
| |5. Restore |5. Restore |5. Restore |
+------------+------------------+---------------------+------------------------+
|dmBackground| | | |
| |4. Paint on backup|4. Paint on backup |4. Paint on backup |
| |5. Restore |5. Restore |5. Restore |
| |6. Clear backup |6. Clear backup |6. Clear backup |
+------------+------------------+---------------------+------------------------+
|dmPrevious | | | |
| | |3. Copy backup to buf|3. Copy backup to buf |
| |4. Paint on dest |4. Paint on buf |4. Paint on buf |
| | |5. Copy buf to dest |5. Copy buf to dest |
+------------+------------------+---------------------+------------------------+
}
case (Disposal) of
dmNone, dmNoDisposal:
begin
DrawDestination := BackupBuffer.Canvas;
DrawRect := BackupBuffer.Canvas.ClipRect;
DoStep5 := True;
end;
dmBackground:
begin
DrawDestination := BackupBuffer.Canvas;
DrawRect := BackupBuffer.Canvas.ClipRect;
DoStep5 := True;
DoStep6 := True;
end;
dmPrevious:
case (OldDisposal) of
dmNone, dmNoDisposal:
begin
DrawDestination := FCanvas;
DrawRect := FRect;
end;
dmBackground, dmPrevious:
begin
DrawDestination := FrameBuffer.Canvas;
DrawRect := FrameBuffer.Canvas.ClipRect;
DoStep3 := True;
DoStep5 := True;
end;
end;
end;
// Find source palette
SourcePal := FImage.Images[ActiveImage].Palette;
if (SourcePal = 0) then
SourcePal := SystemPalette16; // This should never happen
SavePal := SelectPalette(DrawDestination.Handle, SourcePal, False);
RealizePalette(DrawDestination.Handle);
// Step 2: Clear previous frame
if (DoStep2) then
ClearBackup;
// Step 3: Copy backup buffer to frame buffer
if (DoStep3) then
FrameBuffer.Canvas.CopyRect(FrameBuffer.Canvas.ClipRect,
BackupBuffer.Canvas, BackupBuffer.Canvas.ClipRect);
// Step 4: Draw frame
if (DrawDestination <> nil) then
FImage.Images[ActiveImage].Draw(DrawDestination, DrawRect,
(goTransparent in FDrawOptions), (goTile in FDrawOptions));
// Step 5: Copy buffer to destination
if (DoStep5) then
begin
FCanvas.CopyMode := cmSrcCopy;
FCanvas.CopyRect(FRect, DrawDestination, DrawRect);
end;
if (SavePal <> 0) then
SelectPalette(DrawDestination.Handle, SavePal, False);
// Step 6: Clear frame from backup buffer
if (DoStep6) then
ClearBackup;
FStarted := True;
end;
// Prefetch bitmap
// Used to force the GIF image to be rendered as a bitmap
{$ifdef SERIALIZE_RENDER}
procedure TGIFPainter.PrefetchBitmap;
begin
// Touch current bitmap to force bitmap to be rendered
if not((FImage.Images[ActiveImage].Empty) or (FImage.Images[ActiveImage].HasBitmap)) then
FImage.Images[ActiveImage].Bitmap;
end;
{$endif}
// Main thread execution loop - This is where it all happens...
procedure TGIFPainter.Execute;
var
i : integer;
LoopCount ,
LoopPoint : integer;
Looping : boolean;
Ext : TGIFExtension;
Msg : TMsg;
Delay ,
OldDelay ,
DelayUsed : longInt;
DelayStart ,
NewDelayStart : DWORD;
procedure FireEvent(Event: TNotifyEvent);
begin
if not(Assigned(Event)) then
exit;
FEvent := Event;
try
DoSynchronize(DoEvent);
finally
FEvent := nil;
end;
end;
begin
{
Disposal:
dmNone: Same as dmNodisposal
dmNoDisposal: Do not dispose
dmBackground: Clear with background color *)
dmPrevious: Previous image
*) Note: Background color should either be a BROWSER SPECIFIED Background
color (DrawBackgroundColor) or the background image if any frames are
transparent.
}
try
try
if (goValidateCanvas in FDrawOptions) then
ValidateDC := FCanvas.Handle;
DoRestart := True;
// Loop to restart paint
while (DoRestart) and not(Terminated) do
begin
FActiveImage := 0;
// Fire OnStartPaint event
// Note: ActiveImage may be altered by the event handler
FireEvent(FOnStartPaint);
FStarted := False;
DoRestart := False;
LoopCount := 1;
LoopPoint := FActiveImage;
Looping := False;
if (goAsync in DrawOptions) then
Delay := 0
else
Delay := 1; // Dummy to process messages
OldDisposal := dmNoDisposal;
// Fetch delay start time
DelayStart := timeGetTime;
OldDelay := 0;
// Loop to loop - duh!
while ((LoopCount <> 0) or (goLoopContinously in DrawOptions)) and
not(Terminated or DoRestart) do
begin
FActiveImage := LoopPoint;
// Fire OnLoopPaint event
// Note: ActiveImage may be altered by the event handler
if (FStarted) then
FireEvent(FOnLoop);
// Loop to animate
while (ActiveImage < FImage.Images.Count) and not(Terminated or DoRestart) do
begin
// Ignore empty images
if (FImage.Images[ActiveImage].Empty) then
break;
// Delay from previous image
if (Delay > 0) then
begin
// Prefetch frame bitmap
{$ifdef SERIALIZE_RENDER}
DoSynchronize(PrefetchBitmap);
{$else}
FImage.Images[ActiveImage].Bitmap;
{$endif}
// Calculate inter frame delay
NewDelayStart := timeGetTime;
if (FAnimationSpeed > 0) then
begin
// Calculate number of mS used in prefetch and display
try
DelayUsed := integer(NewDelayStart-DelayStart)-OldDelay;
// Prevent feedback oscillations caused by over/undercompensation.
DelayUsed := DelayUsed DIV 2;
// Convert delay value to mS and...
// ...Adjust for time already spent converting GIF to bitmap and...
// ...Adjust for Animation Speed factor.
Delay := MulDiv(Delay * GIFDelayExp - DelayUsed, 100, FAnimationSpeed);
OldDelay := Delay;
except
Delay := GIFMaximumDelay * GIFDelayExp;
OldDelay := 0;
end;
end else
begin
if (goAsync in DrawOptions) then
Delay := longInt(INFINITE)
else
Delay := GIFMaximumDelay * GIFDelayExp;
end;
// Fetch delay start time
DelayStart := NewDelayStart;
// Sleep in one chunk if we are running in a thread
if (goAsync in DrawOptions) then
begin
// Use of WaitForSingleObject allows TGIFPainter.Stop to wake us up
if (Delay > 0) or (FAnimationSpeed = 0) then
begin
if (WaitForSingleObject(FEventHandle, DWORD(Delay)) <> WAIT_TIMEOUT) then
begin
// Don't use interframe delay feedback adjustment if delay
// were prematurely aborted (e.g. because the animation
// speed were changed)
OldDelay := 0;
DelayStart := longInt(timeGetTime);
end;
end;
end else
begin
if (Delay <= 0) then
Delay := 1;
// Fetch start time
NewDelayStart := timeGetTime;
// If we are not running in a thread we Sleep in small chunks
// and give the user a chance to abort
while (Delay > 0) and not(Terminated or DoRestart) do
begin
if (Delay < 100) then
Sleep(Delay)
else
Sleep(100);
// Calculate number of mS delayed in this chunk
DelayUsed := integer(timeGetTime - NewDelayStart);
dec(Delay, DelayUsed);
// Reset start time for chunk
NewDelaySTart := timeGetTime;
// Application.ProcessMessages wannabe
while (not(Terminated or DoRestart)) and
(PeekMessage(Msg, 0, 0, 0, PM_REMOVE)) do
begin
if (Msg.Message <> WM_QUIT) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end else
begin
// Put WM_QUIT back in queue and get out of here fast
PostQuitMessage(Msg.WParam);
Terminate;
end;
end;
end;
end;
end else
Sleep(0); // Yield
if (Terminated) then
break;
// Fire OnPaint event
// Note: ActiveImage may be altered by the event handler
FireEvent(FOnPaint);
if (Terminated) then
break;
// Pre-draw processing of extensions
Disposal := dmNoDisposal;
for i := 0 to FImage.Images[ActiveImage].Extensions.Count-1 do
begin
Ext := FImage.Images[ActiveImage].Extensions[i];
if (Ext is TGIFAppExtNSLoop) then
begin
// Recursive loops not supported (or defined)
if (Looping) then
continue;
Looping := True;
LoopCount := TGIFAppExtNSLoop(Ext).Loops;
if ((LoopCount = 0) or (goLoopContinously in DrawOptions)) and
(goAsync in DrawOptions) then
LoopCount := -1; // Infinite if running in separate thread
{$IFNDEF STRICT_MOZILLA}
// Loop from this image and on
// Note: This is not standard behavior
LoopPoint := ActiveImage;
{$ENDIF}
end else
if (Ext is TGIFGraphicControlExtension) then
Disposal := TGIFGraphicControlExtension(Ext).Disposal;
end;
// Paint the image
if (BackupBuffer <> nil) then
DoSynchronize(DoPaintFrame)
else
DoSynchronize(DoPaint);
OldDisposal := Disposal;
if (Terminated) then
break;
Delay := GIFDefaultDelay; // Default delay
// Post-draw processing of extensions
if (FImage.Images[ActiveImage].GraphicControlExtension <> nil) then
if (FImage.Images[ActiveImage].GraphicControlExtension.Delay > 0) then
begin
Delay := FImage.Images[ActiveImage].GraphicControlExtension.Delay;
// Enforce minimum animation delay in compliance with Mozilla
if (Delay < GIFMinimumDelay) then
Delay := GIFMinimumDelay;
// Do not delay more than 10 seconds if running in main thread
if (Delay > GIFMaximumDelay) and not(goAsync in DrawOptions) then
Delay := GIFMaximumDelay; // Max 10 seconds
end;
// Fire OnAfterPaint event
// Note: ActiveImage may be altered by the event handler
i := FActiveImage;
FireEvent(FOnAfterPaint);
if (Terminated) then
break;
// Don't increment frame counter if event handler modified
// current frame
if (FActiveImage = i) then
Inc(FActiveImage);
// Nothing more to do unless we are animating
if not(goAnimate in DrawOptions) then
break;
end;
if (LoopCount > 0) then
Dec(LoopCount);
if ([goAnimate, goLoop] * DrawOptions <> [goAnimate, goLoop]) then
break;
end;
if (Terminated) then // 2001.07.23
break; // 2001.07.23
end;
FActiveImage := -1;
// Fire OnEndPaint event
FireEvent(FOnEndPaint);
finally
// If we are running in the main thread we will have to zap our self
if not(goAsync in DrawOptions) then
Free;
end;
except
on E: Exception do
begin
// Eat exception and terminate thread...
// If we allow the exception to abort the thread at this point, the
// application will hang since the thread destructor will never be called
// and the application will wait forever for the thread to die!
Terminate;
// Clone exception
ExceptObject := E.Create(E.Message);
ExceptAddress := ExceptAddr;
end;
end;
end;
procedure TGIFPainter.Start;
begin
if (goAsync in FDrawOptions) then
Resume;
end;
procedure TGIFPainter.Stop;
begin
Terminate;
if (goAsync in FDrawOptions) then
begin
// Signal WaitForSingleObject delay to abort
if (FEventHandle <> 0) then
SetEvent(FEventHandle);
Priority := tpNormal;
if (Suspended) then
Resume; // Must be running before we can terminate
end;
end;
procedure TGIFPainter.Restart;
begin
DoRestart := True;
if (Suspended) and (goAsync in FDrawOptions) then
Resume; // Must be running before we can terminate
end;
////////////////////////////////////////////////////////////////////////////////
//
// TColorMapOptimizer
//
////////////////////////////////////////////////////////////////////////////////
// Used by TGIFImage to optimize local color maps to a single global color map.
// The following algorithm is used:
// 1) Build a histogram for each image
// 2) Merge histograms
// 3) Sum equal colors and adjust max # of colors
// 4) Map entries > max to entries <= 256
// 5) Build new color map
// 6) Map images to new color map
////////////////////////////////////////////////////////////////////////////////
type
POptimizeEntry = ^TOptimizeEntry;
TColorRec = record
case byte of
0: (Value: integer);
1: (Color: TGIFColor);
2: (SameAs: POptimizeEntry); // Used if TOptimizeEntry.Count = 0
end;
TOptimizeEntry = record
Count : integer; // Usage count
OldIndex : integer; // Color OldIndex
NewIndex : integer; // NewIndex color OldIndex
Color : TColorRec; // Color value
end;
TOptimizeEntries = array[0..255] of TOptimizeEntry;
POptimizeEntries = ^TOptimizeEntries;
THistogram = class(TObject)
private
PHistogram : POptimizeEntries;
FCount : integer;
FColorMap : TGIFColorMap;
FList : TList;
FImages : TList;
public
constructor Create(AColorMap: TGIFColorMap);
destructor Destroy; override;
function ProcessSubImage(Image: TGIFSubImage): boolean;
function Prune: integer;
procedure MapImages(UseTransparency: boolean; NewTransparentColorIndex: byte);
property Count: integer read FCount;
property ColorMap: TGIFColorMap read FColorMap;
property List: TList read FList;
end;
TColorMapOptimizer = class(TObject)
private
FImage : TGIFImage;
FHistogramList : TList;
FHistogram : TList;
FColorMap : TColorMap;
FFinalCount : integer;
FUseTransparency : boolean;
FNewTransparentColorIndex: byte;
protected
procedure ProcessImage;
procedure MergeColors;
procedure MapColors;
procedure ReplaceColorMaps;
public
constructor Create(AImage: TGIFImage);
destructor Destroy; override;
procedure Optimize;
end;
function CompareColor(Item1, Item2: Pointer): integer;
begin
Result := POptimizeEntry(Item2)^.Color.Value - POptimizeEntry(Item1)^.Color.Value;
end;
function CompareCount(Item1, Item2: Pointer): integer;
begin
Result := POptimizeEntry(Item2)^.Count - POptimizeEntry(Item1)^.Count;
end;
constructor THistogram.Create(AColorMap: TGIFColorMap);
var
i : integer;
begin
inherited Create;
FCount := AColorMap.Count;
FColorMap := AColorMap;
FImages := TList.Create;
// Allocate memory for histogram
GetMem(PHistogram, FCount * sizeof(TOptimizeEntry));
FList := TList.Create;
FList.Capacity := FCount;
// Move data to histogram and initialize
for i := 0 to FCount-1 do
with PHistogram^[i] do
begin
FList.Add(@PHistogram^[i]);
OldIndex := i;
Count := 0;
Color.Value := 0;
Color.Color := AColorMap.Data^[i];
NewIndex := 256; // Used to signal unmapped
end;
end;
destructor THistogram.Destroy;
begin
FImages.Free;
FList.Free;
FreeMem(PHistogram);
inherited Destroy;
end;
//: Build a color histogram
function THistogram.ProcessSubImage(Image: TGIFSubImage): boolean;
var
Size : integer;
Pixel : PChar;
IsTransparent ,
WasTransparent : boolean;
OldTransparentColorIndex: byte;
begin
Result := False;
if (Image.Empty) then
exit;
FImages.Add(Image);
Pixel := Image.data;
Size := Image.Width * Image.Height;
IsTransparent := Image.Transparent;
if (IsTransparent) then
OldTransparentColorIndex := Image.GraphicControlExtension.TransparentColorIndex
else
OldTransparentColorIndex := 0; // To avoid compiler warning
WasTransparent := False;
(*
** Sum up usage count for each color
*)
while (Size > 0) do
begin
// Ignore transparent pixels
if (not IsTransparent) or (ord(Pixel^) <> OldTransparentColorIndex) then
begin
// Check for invalid color index
if (ord(Pixel^) >= FCount) then
begin
Pixel^ := #0; // ***FIXME*** Isn't this an error condition?
Image.Warning(gsWarning, sInvalidColor);
end;
with PHistogram^[ord(Pixel^)] do
begin
// Stop if any color reaches the max count
if (Count = high(integer)) then
break;
inc(Count);
end;
end else
WasTransparent := WasTransparent or IsTransparent;
inc(Pixel);
dec(Size);
end;
(*
** Clear frames transparency flag if the frame claimed to
** be transparent, but wasn't
*)
if (IsTransparent and not WasTransparent) then
begin
Image.GraphicControlExtension.TransparentColorIndex := 0;
Image.GraphicControlExtension.Transparent := False;
end;
Result := WasTransparent;
end;
//: Removed unused color entries from the histogram
function THistogram.Prune: integer;
var
i, j : integer;
begin
(*
** Sort by usage count
*)
FList.Sort(CompareCount);
(*
** Determine number of used colors
*)
for i := 0 to FCount-1 do
// Find first unused color entry
if (POptimizeEntry(FList[i])^.Count = 0) then
begin
// Zap unused colors
for j := i to FCount-1 do
POptimizeEntry(FList[j])^.Count := -1; // Use -1 to signal unused entry
// Remove unused entries
FCount := i;
FList.Count := FCount;
break;
end;
Result := FCount;
end;
//: Convert images from old color map to new color map
procedure THistogram.MapImages(UseTransparency: boolean; NewTransparentColorIndex: byte);
var
i : integer;
Size : integer;
Pixel : PChar;
ReverseMap : array[byte] of byte;
IsTransparent : boolean;
OldTransparentColorIndex: byte;
begin
(*
** Build NewIndex map
*)
for i := 0 to List.Count-1 do
ReverseMap[POptimizeEntry(List[i])^.OldIndex] := POptimizeEntry(List[i])^.NewIndex;
(*
** Reorder all images using this color map
*)
for i := 0 to FImages.Count-1 do
with TGIFSubImage(FImages[i]) do
begin
Pixel := Data;
Size := Width * Height;
// Determine frame transparency
IsTransparent := (Transparent) and (UseTransparency);
if (IsTransparent) then
begin
OldTransparentColorIndex := GraphicControlExtension.TransparentColorIndex;
// Map transparent color
GraphicControlExtension.TransparentColorIndex := NewTransparentColorIndex;
end else
OldTransparentColorIndex := 0; // To avoid compiler warning
// Map all pixels to new color map
while (Size > 0) do
begin
// Map transparent pixels to the new transparent color index and...
if (IsTransparent) and (ord(Pixel^) = OldTransparentColorIndex) then
Pixel^ := char(NewTransparentColorIndex)
else
// ... all other pixels to their new color index
Pixel^ := char(ReverseMap[ord(Pixel^)]);
dec(size);
inc(Pixel);
end;
end;
end;
constructor TColorMapOptimizer.Create(AImage: TGIFImage);
begin
inherited Create;
FImage := AImage;
FHistogramList := TList.Create;
FHistogram := TList.Create;
end;
destructor TColorMapOptimizer.Destroy;
var
i : integer;
begin
FHistogram.Free;
for i := FHistogramList.Count-1 downto 0 do
THistogram(FHistogramList[i]).Free;
FHistogramList.Free;
inherited Destroy;
end;
procedure TColorMapOptimizer.ProcessImage;
var
Hist : THistogram;
i : integer;
ProcessedImage : boolean;
begin
FUseTransparency := False;
(*
** First process images using global color map
*)
if (FImage.GlobalColorMap.Count > 0) then
begin
Hist := THistogram.Create(FImage.GlobalColorMap);
ProcessedImage := False;
// Process all images that are using the global color map
for i := 0 to FImage.Images.Count-1 do
if (FImage.Images[i].ColorMap.Count = 0) and (not FImage.Images[i].Empty) then
begin
ProcessedImage := True;
// Note: Do not change order of statements. Shortcircuit evaluation not desired!
FUseTransparency := Hist.ProcessSubImage(FImage.Images[i]) or FUseTransparency;
end;
// Keep the histogram if any images used the global color map...
if (ProcessedImage) then
FHistogramList.Add(Hist)
else // ... otherwise delete it
Hist.Free;
end;
(*
** Next process images that have a local color map
*)
for i := 0 to FImage.Images.Count-1 do
if (FImage.Images[i].ColorMap.Count > 0) and (not FImage.Images[i].Empty) then
begin
Hist := THistogram.Create(FImage.Images[i].ColorMap);
FHistogramList.Add(Hist);
// Note: Do not change order of statements. Shortcircuit evaluation not desired!
FUseTransparency := Hist.ProcessSubImage(FImage.Images[i]) or FUseTransparency;
end;
end;
procedure TColorMapOptimizer.MergeColors;
var
Entry, SameEntry : POptimizeEntry;
i : integer;
begin
(*
** Sort by color value
*)
FHistogram.Sort(CompareColor);
(*
** Merge same colors
*)
SameEntry := POptimizeEntry(FHistogram[0]);
for i := 1 to FHistogram.Count-1 do
begin
Entry := POptimizeEntry(FHistogram[i]);
ASSERT(Entry^.Count > 0, 'Unused entry exported from THistogram');
if (Entry^.Color.Value = SameEntry^.Color.Value) then
begin
// Transfer usage count to first entry
inc(SameEntry^.Count, Entry^.Count);
Entry^.Count := 0; // Use 0 to signal merged entry
Entry^.Color.SameAs := SameEntry; // Point to master
end else
SameEntry := Entry;
end;
end;
procedure TColorMapOptimizer.MapColors;
var
i, j : integer;
Delta, BestDelta : integer;
BestIndex : integer;
MaxColors : integer;
begin
(*
** Sort by usage count
*)
FHistogram.Sort(CompareCount);
(*
** Handle transparency
*)
if (FUseTransparency) then
MaxColors := 255
else
MaxColors := 256;
(*
** Determine number of colors used (max 256)
*)
FFinalCount := FHistogram.Count;
for i := 0 to FFinalCount-1 do
if (i >= MaxColors) or (POptimizeEntry(FHistogram[i])^.Count = 0) then
begin
FFinalCount := i;
break;
end;
(*
** Build color map and reverse map for final entries
*)
for i := 0 to FFinalCount-1 do
begin
POptimizeEntry(FHistogram[i])^.NewIndex := i;
FColorMap[i] := POptimizeEntry(FHistogram[i])^.Color.Color;
end;
(*
** Map colors > 256 to colors <= 256 and build NewIndex color map
*)
for i := FFinalCount to FHistogram.Count-1 do
with POptimizeEntry(FHistogram[i])^ do
begin
// Entries with a usage count of -1 is unused
ASSERT(Count <> -1, 'Internal error: Unused entry exported');
// Entries with a usage count of 0 has been merged with another entry
if (Count = 0) then
begin
// Use mapping of master entry
ASSERT(Color.SameAs.NewIndex < 256, 'Internal error: Mapping to unmapped color');
NewIndex := Color.SameAs.NewIndex;
end else
begin
// Search for entry with nearest color value
BestIndex := 0;
BestDelta := 255*3;
for j := 0 to FFinalCount-1 do
begin
Delta := ABS((POptimizeEntry(FHistogram[j])^.Color.Color.Red - Color.Color.Red) +
(POptimizeEntry(FHistogram[j])^.Color.Color.Green - Color.Color.Green) +
(POptimizeEntry(FHistogram[j])^.Color.Color.Blue - Color.Color.Blue));
if (Delta < BestDelta) then
begin
BestDelta := Delta;
BestIndex := j;
end;
end;
NewIndex := POptimizeEntry(FHistogram[BestIndex])^.NewIndex;;
end;
end;
(*
** Add transparency color to new color map
*)
if (FUseTransparency) then
begin
FNewTransparentColorIndex := FFinalCount;
FColorMap[FFinalCount].Red := 0;
FColorMap[FFinalCount].Green := 0;
FColorMap[FFinalCount].Blue := 0;
inc(FFinalCount);
end;
end;
procedure TColorMapOptimizer.ReplaceColorMaps;
var
i : integer;
begin
// Zap all local color maps
for i := 0 to FImage.Images.Count-1 do
if (FImage.Images[i].ColorMap <> nil) then
FImage.Images[i].ColorMap.Clear;
// Store optimized global color map
FImage.GlobalColorMap.ImportColorMap(FColorMap, FFinalCount);
FImage.GlobalColorMap.Optimized := True;
end;
procedure TColorMapOptimizer.Optimize;
var
Total : integer;
i, j : integer;
begin
// Stop all painters during optimize...
FImage.PaintStop;
// ...and prevent any new from starting while we are doing our thing
FImage.Painters.LockList;
try
(*
** Process all sub images
*)
ProcessImage;
// Prune histograms and calculate total number of colors
Total := 0;
for i := 0 to FHistogramList.Count-1 do
inc(Total, THistogram(FHistogramList[i]).Prune);
// Allocate global histogram
FHistogram.Clear;
FHistogram.Capacity := Total;
// Move data pointers from local histograms to global histogram
for i := 0 to FHistogramList.Count-1 do
with THistogram(FHistogramList[i]) do
for j := 0 to Count-1 do
begin
ASSERT(POptimizeEntry(List[j])^.Count > 0, 'Unused entry exported from THistogram');
FHistogram.Add(List[j]);
end;
(*
** Merge same colors
*)
MergeColors;
(*
** Build color map and NewIndex map for final entries
*)
MapColors;
(*
** Replace local colormaps with global color map
*)
ReplaceColorMaps;
(*
** Process images for each color map
*)
for i := 0 to FHistogramList.Count-1 do
THistogram(FHistogramList[i]).MapImages(FUseTransparency, FNewTransparentColorIndex);
(*
** Delete the frame's old bitmaps and palettes
*)
for i := 0 to FImage.Images.Count-1 do
begin
FImage.Images[i].HasBitmap := False;
FImage.Images[i].Palette := 0;
end;
finally
FImage.Painters.UnlockList;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// TGIFImage
//
////////////////////////////////////////////////////////////////////////////////
constructor TGIFImage.Create;
begin
inherited Create;
FImages := TGIFImageList.Create(self);
FHeader := TGIFHeader.Create(self);
FPainters := TThreadList.Create;
FGlobalPalette := 0;
// Load defaults
FDrawOptions := GIFImageDefaultDrawOptions;
ColorReduction := GIFImageDefaultColorReduction;
FReductionBits := GIFImageDefaultColorReductionBits;
FDitherMode := GIFImageDefaultDitherMode;
FCompression := GIFImageDefaultCompression;
FThreadPriority := GIFImageDefaultThreadPriority;
FAnimationSpeed := GIFImageDefaultAnimationSpeed;
FDrawBackgroundColor := clNone;
IsDrawing := False;
IsInsideGetPalette := False;
NewImage;
end;
destructor TGIFImage.Destroy;
var
i : integer;
begin
PaintStop;
with FPainters.LockList do
try
for i := Count-1 downto 0 do
TGIFPainter(Items[i]).FImage := nil;
finally
FPainters.UnLockList;
end;
Clear;
FPainters.Free;
FImages.Free;
FHeader.Free;
inherited Destroy;
end;
procedure TGIFImage.Clear;
begin
PaintStop;
FreeBitmap;
FImages.Clear;
FHeader.ColorMap.Clear;
FHeader.Height := 0;
FHeader.Width := 0;
FHeader.Prepare;
Palette := 0;
end;
procedure TGIFImage.NewImage;
begin
Clear;
end;
function TGIFImage.GetVersion: TGIFVersion;
var
v : TGIFVersion;
i : integer;
begin
Result := gvUnknown;
for i := 0 to FImages.Count-1 do
begin
v := FImages[i].Version;
if (v > Result) then
Result := v;
if (v >= high(TGIFVersion)) then
break;
end;
end;
function TGIFImage.GetColorResolution: integer;
var
i : integer;
begin
Result := FHeader.ColorResolution;
for i := 0 to FImages.Count-1 do
if (FImages[i].ColorResolution > Result) then
Result := FImages[i].ColorResolution;
end;
function TGIFImage.GetBitsPerPixel: integer;
var
i : integer;
begin
Result := FHeader.BitsPerPixel;
for i := 0 to FImages.Count-1 do
if (FImages[i].BitsPerPixel > Result) then
Result := FImages[i].BitsPerPixel;
end;
function TGIFImage.GetBackgroundColorIndex: BYTE;
begin
Result := FHeader.BackgroundColorIndex;
end;
procedure TGIFImage.SetBackgroundColorIndex(const Value: BYTE);
begin
FHeader.BackgroundColorIndex := Value;
end;
function TGIFImage.GetBackgroundColor: TColor;
begin
Result := FHeader.BackgroundColor;
end;
procedure TGIFImage.SetBackgroundColor(const Value: TColor);
begin
FHeader.BackgroundColor := Value;
end;
function TGIFImage.GetAspectRatio: BYTE;
begin
Result := FHeader.AspectRatio;
end;
procedure TGIFImage.SetAspectRatio(const Value: BYTE);
begin
FHeader.AspectRatio := Value;
end;
procedure TGIFImage.SetDrawOptions(Value: TGIFDrawOptions);
begin
if (FDrawOptions = Value) then
exit;
if (DrawPainter <> nil) then
DrawPainter.Stop;
FDrawOptions := Value;
// Zap all bitmaps
Pack;
Changed(self);
end;
function TGIFImage.GetAnimate: Boolean;
begin // 2002.07.07
Result:= goAnimate in DrawOptions;
end;
procedure TGIFImage.SetAnimate(const Value: Boolean);
begin // 2002.07.07
if Value then
DrawOptions:= DrawOptions + [goAnimate]
else
DrawOptions:= DrawOptions - [goAnimate];
end;
procedure TGIFImage.SetAnimationSpeed(Value: integer);
begin
if (Value < 0) then
Value := 0
else if (Value > 1000) then
Value := 1000;
if (Value <> FAnimationSpeed) then
begin
FAnimationSpeed := Value;
// Use the FPainters threadlist to protect FDrawPainter from being modified
// by the thread while we mess with it
with FPainters.LockList do
try
if (FDrawPainter <> nil) then
FDrawPainter.AnimationSpeed := FAnimationSpeed;
finally
// Release the lock on FPainters to let paint thread kill itself
FPainters.UnLockList;
end;
end;
end;
procedure TGIFImage.SetReductionBits(Value: integer);
begin
if (Value < 3) or (Value > 8) then
Error(sInvalidBitSize);
FReductionBits := Value;
end;
procedure TGIFImage.OptimizeColorMap;
var
ColorMapOptimizer : TColorMapOptimizer;
begin
ColorMapOptimizer := TColorMapOptimizer.Create(self);
try
ColorMapOptimizer.Optimize;
finally
ColorMapOptimizer.Free;
end;
end;
procedure TGIFImage.Optimize(Options: TGIFOptimizeOptions;
ColorReduction: TColorReduction; DitherMode: TDitherMode;
ReductionBits: integer);
var
i ,
j : integer;
Delay : integer;
GCE : TGIFGraphicControlExtension;
ThisRect ,
NextRect ,
MergeRect : TRect;
Prog ,
MaxProg : integer;
function Scan(Buf: PChar; Value: Byte; Count: integer): boolean; assembler;
asm
PUSH EDI
MOV EDI, Buf
MOV ECX, Count
MOV AL, Value
REPNE SCASB
MOV EAX, False
JNE @@1
MOV EAX, True
@@1:POP EDI
end;
begin
if (Empty) then
exit;
// Stop all painters during optimize...
PaintStop;
// ...and prevent any new from starting while we are doing our thing
FPainters.LockList;
try
Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressOptimizing);
try
Prog := 0;
MaxProg := Images.Count*6;
// Sort color map by usage and remove unused entries
if (ooColorMap in Options) then
begin
// Optimize global color map
if (GlobalColorMap.Count > 0) then
GlobalColorMap.Optimize;
// Optimize local color maps
for i := 0 to Images.Count-1 do
begin
inc(Prog);
if (Images[i].ColorMap.Count > 0) then
begin
Images[i].ColorMap.Optimize;
Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
Rect(0,0,0,0), sProgressOptimizing);
end;
end;
end;
// Remove passive elements, pass 1
if (ooCleanup in Options) then
begin
// Check for transparency flag without any transparent pixels
for i := 0 to Images.Count-1 do
begin
inc(Prog);
if (Images[i].Transparent) then
begin
if not(Scan(Images[i].Data,
Images[i].GraphicControlExtension.TransparentColorIndex,
Images[i].DataSize)) then
begin
Images[i].GraphicControlExtension.Transparent := False;
Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
Rect(0,0,0,0), sProgressOptimizing);
end;
end;
end;
// Change redundant disposal modes
for i := 0 to Images.Count-2 do
begin
inc(Prog);
if (Images[i].GraphicControlExtension <> nil) and
(Images[i].GraphicControlExtension.Disposal in [dmPrevious, dmBackground]) and
(not Images[i+1].Transparent) then
begin
ThisRect := Images[i].BoundsRect;
NextRect := Images[i+1].BoundsRect;
if (not IntersectRect(MergeRect, ThisRect, NextRect)) then
continue;
// If the next frame completely covers the current frame,
// change the disposal mode to dmNone
if (EqualRect(MergeRect, NextRect)) then
Images[i].GraphicControlExtension.Disposal := dmNone;
Progress(Self, psRunning, MulDiv(Prog, 100, MaxProg), False,
Rect(0,0,0,0), sProgressOptimizing);
end;
end;
end else
inc(Prog, 2*Images.Count);
// Merge layers of equal pixels (remove redundant pixels)
if (ooMerge in Options) then
begin
// Merge from last to first to avoid intefering with merge
for i := Images.Count-1 downto 1 do
begin
inc(Prog);
j := i-1;
// If the "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;
procedure TGIFImage.LoadFromStream(Stream: TStream);
var
n : Integer;
Position : integer;
begin
Progress(Self, psStarting, 0, False, Rect(0,0,0,0), sProgressLoading);
try
// Zap old image
Clear;
Position := Stream.Position;
try
// Read header
FHeader.LoadFromStream(Stream);
// Read images
FImages.LoadFromStream(Stream, self);
// Read trailer
with TGIFTrailer.Create(self) do
try
LoadFromStream(Stream);
finally
Free;
end;
except
// Restore stream position in case of error.
// Not required, but "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;
// 2002.07.07 ->
FOnWarning:= TGIFImage(Source).FOnWarning;
FOnStartPaint:= TGIFImage(Source).FOnStartPaint;
FOnPaint:= TGIFImage(Source).FOnPaint;
FOnEndPaint:= TGIFImage(Source).FOnEndPaint;
FOnAfterPaint:= TGIFImage(Source).FOnAfterPaint;
FOnLoop:= TGIFImage(Source).FOnLoop;
// 2002.07.07 <-
for i := 0 to TGIFImage(Source).Images.Count-1 do
begin
Image := TGIFSubImage.Create(self);
Image.Assign(TGIFImage(Source).Images[i]);
Add(Image);
Progress(Self, psRunning, MulDiv((i+1), 100, TGIFImage(Source).Images.Count),
False, Rect(0,0,0,0), sProgressCopying);
end;
finally
if ExceptObject = nil then
i := 100
else
i := 0;
Progress(Self, psEnding, i, False, Rect(0,0,0,0), sProgressCopying);
end;
finally
// Reset event handlers
FOnWarning := nil;
OnProgress := nil;
end;
end else
//
// Import via TGIFSubImage.Assign
//
begin
Clear;
Image := TGIFSubImage.Create(self);
try
Image.Assign(Source);
Add(Image);
except
on E: EConvertError do
begin
Image.Free;
// Unsupported format - fall back to Source.AssignTo
inherited Assign(Source);
end;
else
// Unknown conversion error
Image.Free;
raise;
end;
end;
end;
procedure TGIFImage.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE);
{$IFDEF REGISTER_TGIFIMAGE}
var
Size : Longint;
Buffer : Pointer;
Stream : TMemoryStream;
Bmp : TBitmap;
{$ENDIF} // 2002.07.07
begin // 2002.07.07
{$IFDEF REGISTER_TGIFIMAGE} // 2002.07.07
if (AData = 0) then
AData := GetClipboardData(AFormat);
if (AData <> 0) and (AFormat = CF_GIF) then
begin
// Get size and pointer to data
Size := GlobalSize(AData);
Buffer := GlobalLock(AData);
try
Stream := TMemoryStream.Create;
try
// Copy data to a stream
Stream.SetSize(Size);
Move(Buffer^, Stream.Memory^, Size);
// Load GIF from stream
LoadFromStream(Stream);
finally
Stream.Free;
end;
finally
GlobalUnlock(AData);
end;
end else
if (AData <> 0) and (AFormat = CF_BITMAP) then
begin
// No GIF on clipboard - try loading a bitmap instead
Bmp := TBitmap.Create;
try
Bmp.LoadFromClipboardFormat(AFormat, AData, APalette);
Assign(Bmp);
finally
Bmp.Free;
end;
end else
Error(sUnknownClipboardFormat);
{$ELSE} // 2002.07.07
Error(sGIFToClipboard); // 2002.07.07
{$ENDIF} // 2002.07.07
end;
procedure TGIFImage.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE);
{$IFDEF REGISTER_TGIFIMAGE}
var
Stream : TMemoryStream;
Data : THandle;
Buffer : Pointer;
{$ENDIF} // 2002.07.07
begin // 2002.07.07
{$IFDEF REGISTER_TGIFIMAGE} // 2002.07.07
if (Empty) then
exit;
// First store a bitmap version on the clipboard...
Bitmap.SaveToClipboardFormat(AFormat, AData, APalette);
// ...then store a GIF
Stream := TMemoryStream.Create;
try
// Save the GIF to a memory stream
SaveToStream(Stream);
Stream.Position := 0;
// Allocate some memory for the GIF data
Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
try
if (Data <> 0) then
begin
Buffer := GlobalLock(Data);
try
// Copy GIF data from stream memory to clipboard memory
Move(Stream.Memory^, Buffer^, Stream.Size);
finally
GlobalUnlock(Data);
end;
// Transfer data to clipboard
if (SetClipboardData(CF_GIF, Data) = 0) then
Error(sFailedPaste);
end;
except
GlobalFree(Data);
raise;
end;
finally
Stream.Free;
end;
{$ELSE} // 2002.07.07
Error(sGIFToClipboard); // 2002.07.07
{$ENDIF} // 2002.07.07
end;
function TGIFImage.GetColorMap: TGIFColorMap;
begin
Result := FHeader.ColorMap;
end;
function TGIFImage.GetDoDither: boolean;
begin
Result := (goDither in DrawOptions) and
(((goAutoDither in DrawOptions) and DoAutoDither) or
not(goAutoDither in DrawOptions));
end;
{$IFDEF VER9x}
procedure TGIFImage.Progress(Sender: TObject; Stage: TProgressStage;
PercentDone: Byte; RedrawNow: Boolean; const R: TRect; const Msg: string);
begin
if Assigned(FOnProgress) then
FOnProgress(Sender, Stage, PercentDone, RedrawNow, R, Msg);
end;
{$ENDIF}
procedure TGIFImage.StopDraw;
{$IFNDEF VER14_PLUS} // 2001.07.23
var
Msg : TMsg;
ThreadWindow : HWND;
{$ENDIF} // 2001.07.23
begin
repeat
// Use the FPainters threadlist to protect FDrawPainter from being modified
// by the thread while we mess with it
with FPainters.LockList do
try
if (FDrawPainter = nil) then
break;
// Tell thread to terminate
FDrawPainter.Stop;
// No need to wait for "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
FImages[0].Draw(ACanvas, Rect, (goTransparent in FDrawOptions),
(goTile in FDrawOptions));
exit;
end else
if (FBitmap <> nil) and not(goDirectDraw in FDrawOptions) then
begin
DrawTile(Rect, Bitmap);
exit;
end;
// Use the FPainters threadlist to protect FDrawPainter from being modified
// by the thread while we mess with it
with FPainters.LockList do
try
// If we are already painting on the canvas in goDirectDraw mode
// and at the same location, just exit and let the painter do
// its thing when it's ready
if (FDrawPainter <> nil) and (FDrawPainter.Canvas = ACanvas) and
EqualRect(FDrawPainter.Rect, Rect) then
exit;
// Kill the current paint thread
StopDraw;
if not(goDirectDraw in FDrawOptions) then
begin
// Create a bitmap to draw on
NewBitmap;
Canvas := FBitmap.Canvas;
DestRect := Canvas.ClipRect;
// Initialize bitmap canvas with background image
Canvas.CopyRect(DestRect, ACanvas, Rect);
end else
begin
Canvas := ACanvas;
DestRect := Rect;
end;
// Create new paint thread
InternalPaint(@FDrawPainter, Canvas, DestRect, FDrawOptions);
if (FDrawPainter <> nil) then
begin
// Launch thread
FDrawPainter.Start;
if not(goDirectDraw in FDrawOptions) then
begin
{$IFDEF VER14_PLUS}
// 2002.07.07
while (FDrawPainter <> nil) and (not FDrawPainter.Terminated) and
(not FDrawPainter.Started) do
begin
if not CheckSynchronize then
Sleep(0); // Yield
end;
{$ELSE}
//{$IFNDEF VER14_PLUS} // 2001.07.23
ThreadWindow := FindWindow('TThreadWindow', nil);
// Wait for thread to render first frame
while (FDrawPainter <> nil) and (not FDrawPainter.Terminated) and
(not FDrawPainter.Started) do
// Process Messages to make Synchronize work
// (Instead of Application.ProcessMessages)
if PeekMessage(Msg, ThreadWindow, CM_DESTROYWINDOW, CM_EXECPROC, PM_REMOVE) then
begin
if (Msg.Message <> WM_QUIT) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end else
begin
PostQuitMessage(Msg.WParam);
exit;
end;
end else
Sleep(0); // Yield
{$ENDIF} // 2001.07.23
// Draw frame to destination
DrawTile(Rect, Bitmap);
end;
end;
finally
FPainters.UnLockList;
end;
finally
IsDrawing := False;
end;
end;
// Internal pain(t) routine used by Draw()
function TGIFImage.InternalPaint(Painter: PGifPainter; ACanvas: TCanvas;
const Rect: TRect; Options: TGIFDrawOptions): TGIFPainter;
begin
if (Empty) or (Rect.Left >= Rect.Right) or (Rect.Top >= Rect.Bottom) then
begin
Result := nil;
if (Painter <> nil) then
Painter^ := Result;
exit;
end;
// Draw in main thread if only one image
if (Images.Count = 1) then
Options := Options - [goAsync, goAnimate];
Result := TGIFPainter.CreateRef(Painter, self, ACanvas, Rect, Options);
FPainters.Add(Result);
Result.OnStartPaint := FOnStartPaint;
Result.OnPaint := FOnPaint;
Result.OnAfterPaint := FOnAfterPaint;
Result.OnLoop := FOnLoop;
Result.OnEndPaint := FOnEndPaint;
if not(goAsync in Options) then
begin
// Run in main thread
Result.Execute;
// Note: Painter threads executing in the main thread are freed upon exit
// from the Execute method, so no need to do it here.
Result := nil;
if (Painter <> nil) then
Painter^ := Result;
end else
Result.Priority := FThreadPriority;
end;
function TGIFImage.Paint(ACanvas: TCanvas; const Rect: TRect;
Options: TGIFDrawOptions): TGIFPainter;
begin
Result := InternalPaint(nil, ACanvas, Rect, Options);
if (Result <> nil) then
// Run in separate thread
Result.Start;
end;
procedure TGIFImage.PaintStart;
var
i : integer;
begin
with FPainters.LockList do
try
for i := 0 to Count-1 do
TGIFPainter(Items[i]).Start;
finally
FPainters.UnLockList;
end;
end;
procedure TGIFImage.PaintStop;
var
Ghosts : integer;
i : integer;
{$IFNDEF VER14_PLUS} // 2001.07.23
Msg : TMsg;
ThreadWindow : HWND;
{$ENDIF} // 2001.07.23
{$IFNDEF VER14_PLUS} // 2001.07.23
procedure KillThreads;
var
i : integer;
begin
with FPainters.LockList do
try
for i := Count-1 downto 0 do
if (goAsync in TGIFPainter(Items[i]).DrawOptions) then
begin
TerminateThread(TGIFPainter(Items[i]).Handle, 0);
Delete(i);
end;
finally
FPainters.UnLockList;
end;
end;
{$ENDIF} // 2001.07.23
begin
try
// Loop until all have died
repeat
with FPainters.LockList do
try
if (Count = 0) then
exit;
// Signal painters to terminate
// Painters will attempt to remove them self from the
// painter list when they die
Ghosts := Count;
for i := Ghosts-1 downto 0 do
begin
if not(goAsync in TGIFPainter(Items[i]).DrawOptions) then
dec(Ghosts);
TGIFPainter(Items[i]).Stop;
end;
finally
FPainters.UnLockList;
end;
// If all painters were synchronous, there's no purpose waiting for them
// to terminate, because they are running in the main thread.
if (Ghosts = 0) then
exit;
{$IFDEF VER14_PLUS}
// 2002.07.07
if (GetCurrentThreadID = MainThreadID) then
while CheckSynchronize do {loop};
{$ELSE}
// Process Messages to make TThread.Synchronize work
// (Instead of Application.ProcessMessages)
//{$IFDEF VER14_PLUS} // 2001.07.23
// Exit; // 2001.07.23
//{$ELSE} // 2001.07.23
ThreadWindow := FindWindow('TThreadWindow', nil);
if (ThreadWindow = 0) then
begin
KillThreads;
Exit;
end;
while PeekMessage(Msg, ThreadWindow, CM_DESTROYWINDOW, CM_EXECPROC, PM_REMOVE) do
begin
if (Msg.Message <> WM_QUIT) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end else
begin
KillThreads;
Exit;
end;
end;
{$ENDIF} // 2001.07.23
Sleep(0);
until (False);
finally
FreeBitmap;
end;
end;
procedure TGIFImage.PaintPause;
var
i : integer;
begin
with FPainters.LockList do
try
for i := 0 to Count-1 do
TGIFPainter(Items[i]).Suspend;
finally
FPainters.UnLockList;
end;
end;
procedure TGIFImage.PaintResume;
var
i : integer;
begin
// Implementation is currently same as PaintStart, but don't call PaintStart
// in case its implementation changes
with FPainters.LockList do
try
for i := 0 to Count-1 do
TGIFPainter(Items[i]).Start;
finally
FPainters.UnLockList;
end;
end;
procedure TGIFImage.PaintRestart;
var
i : integer;
begin
with FPainters.LockList do
try
for i := 0 to Count-1 do
TGIFPainter(Items[i]).Restart;
finally
FPainters.UnLockList;
end;
end;
procedure TGIFImage.Warning(Sender: TObject; Severity: TGIFSeverity; Message: string);
begin
if (Assigned(FOnWarning)) then
FOnWarning(Sender, Severity, Message);
end;
{$IFDEF VER12_PLUS}
{$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up // 2001.07.23
type
TDummyThread = class(TThread)
protected
procedure Execute; override;
end;
procedure TDummyThread.Execute;
begin
end;
{$ENDIF} // 2001.07.23
{$ENDIF}
var
DesktopDC: HDC;
{$IFDEF VER12_PLUS}
{$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up // 2001.07.23
DummyThread: TThread;
{$ENDIF} // 2001.07.23
{$ENDIF}
////////////////////////////////////////////////////////////////////////////////
//
// Initialization
//
////////////////////////////////////////////////////////////////////////////////
initialization
{$IFDEF REGISTER_TGIFIMAGE}
TPicture.RegisterFileFormat('GIF', sGIFImageFile, TGIFImage);
CF_GIF := RegisterClipboardFormat(PChar(sGIFImageFile));
TPicture.RegisterClipboardFormat(CF_GIF, TGIFImage);
{$ENDIF}
DesktopDC := GetDC(0);
try
PaletteDevice := (GetDeviceCaps(DesktopDC, BITSPIXEL) * GetDeviceCaps(DesktopDC, PLANES) <= 8);
DoAutoDither := PaletteDevice;
finally
ReleaseDC(0, DesktopDC);
end;
{$IFDEF VER9x}
// Note: This doesn't return the same palette as the Delphi 3 system palette
// since the true system palette contains 20 entries and the Delphi 3 system
// palette only contains 16.
// For our purpose this doesn't matter since we do not care about the actual
// colors (or their number) in the palette.
// Stock objects doesn't have to be deleted.
SystemPalette16 := GetStockObject(DEFAULT_PALETTE);
{$ENDIF}
{$IFDEF VER12_PLUS}
// Make sure that at least one thread always exist.
// This is done to circumvent a race condition bug in Delphi 4.x and later:
// When threads are deleted and created in rapid succesion, a situation might
// arise where the thread window is deleted *after* the threads it controls
// has been created. See the Delphi Bug Lists for more information.
{$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up // 2001.07.23
DummyThread := TDummyThread.Create(True);
{$ENDIF} // 2001.07.23
{$ENDIF}
////////////////////////////////////////////////////////////////////////////////
//
// Finalization
//
////////////////////////////////////////////////////////////////////////////////
finalization
ExtensionList.Free;
AppExtensionList.Free;
{$IFNDEF VER9x}
{$IFDEF REGISTER_TGIFIMAGE}
TPicture.UnregisterGraphicClass(TGIFImage);
{$ENDIF}
{$IFDEF VER100}
if (pf8BitBitmap <> nil) then
pf8BitBitmap.Free;
{$ENDIF}
{$ENDIF}
{$IFDEF VER12_PLUS}
{$IFNDEF VER14_PLUS} // not anymore need for Delphi 6 and up // 2001.07.23
if (DummyThread <> nil) then
DummyThread.Free;
{$ENDIF} // 2001.07.23
{$ENDIF}
end.
Reference in New Issue View Git Blame Copy Permalink