RichEdit

开发平台：

Delphi

GifImage.pas：源码内容

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 //
// Formatting: 2 space indent, 8 space tabs, 80 columns. //
// //
////////////////////////////////////////////////////////////////////////////////
// Delphi 6 updates and modifications by Alexey Barkovoy (clootie@reactor.ru) //
// Date: 22-Dec-2001 //
// Date: 13-Jun-2003 - Updated for Delphi7 and (possible) up //
// Download from: http://clootie.narod.ru/delphi/download_vcl.html //
////////////////////////////////////////////////////////////////////////////////
// //
// 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}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE VER13_PLUS}
{$DEFINE VER14_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
// Delphi 7.x
{$IFDEF VER150}
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE VER13_PLUS}
{$DEFINE VER14_PLUS}
{$DEFINE VER15_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT}
{$ENDIF}
{$IFDEF conditionalexpressions}
{$IF RTLVersion >= 14.0} // Should be Delphi6 and up
{$DEFINE VER10_PLUS}
{$DEFINE VER11_PLUS}
{$DEFINE VER12_PLUS}
{$DEFINE VER125_PLUS}
{$DEFINE VER13_PLUS}
{$DEFINE VER14_PLUS}
{$DEFINE VER15_PLUS}
{$DEFINE BAD_STACK_ALIGNMENT} // Not sure is this still needed
{$IFEND}
{$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;
procedure SetAnimate(const Value: Boolean);
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);
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;
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;