paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-05-11 00:42:49 +02:00
Code Issues Packages Projects Releases Wiki Activity
26f7cbe3b9
lazarus/components/htmllite/litedith.pas
mattias 1428729afd added htmllite 
git-svn-id: trunk@3744 -
2002-12-27 17:54:54 +00:00

1746 lines
49 KiB
ObjectPascal
Raw Blame History

{Version 7.5}
{***************************************************************}
{* LiteDith.PAS *}
{* *}
{* Thanks to Anders Melander, anders@melander.dk, for the *}
{* color dithering code in this module. This code was *}
{* extracted from his excellent TGifImage.pas unit. *}
{* *}
{* *}
{* Bugs introduced by Dave Baldwin *}
{***************************************************************}
// Copyright (c) 1997,98 Anders Melander. //
// All rights reserved. //
// //
////////////////////////////////////////////////////////////////////////////////
// //
// This software is copyrighted as noted above. It may be freely copied, //
// modified, and redistributed, provided that the copyright notice(s) is //
// preserved on all copies. //
// //
// TGIFImage is freeware and I would like it to remain so. This means that it //
// may not be bundled with commercial libraries or sold as shareware. You are //
// welcome to use it in commercial and shareware applications providing you //
// do not charge for the functionality provided by TGIFImage. //
// If you are in doubt, please contact me and I will explain this. //
// //
// There is no warranty or other guarantee of fitness for this software, it //
// is provided solely "as is". Bug reports or fixes may be sent to the //
// author, who may or may not act on them as he desires. //
// //
// If you redistribute this code in binary form (i.e. as a library or linked //
// into an application), the accompanying documentation should state that //
// "this software is based, in part, on the work of Anders Melander" or words //
// to that effect. //
// //
// If you modify this software, you should include a notice in the revision //
// history in the history.txt file giving the date and the name of the person //
// performing the modification and a brief description of the modification. //
// //
unit LiteDith;
{$i LiteCons.inc}
interface
{$DEFINE PIXELFORMAT_TOO_SLOW}
{$IFDEF HL_LAZARUS}
{$DEFINE VER10x}
{$DEFINE VER11_PLUS}
{$DEFINE D4_BCB3}
{$ELSE}
////////////////////////////////////////////////////////////////////////////////
//
// Determine Delphi and C++ Builder version
//
////////////////////////////////////////////////////////////////////////////////
// Delphi 2.x
{$IFDEF VER90}
Error: This module not used with Delphi 2
{$ENDIF}
// Delphi 3.x
{$IFDEF VER100}
{$DEFINE VER10x}
{$ENDIF}
// C++ Builder 3.x
{$IFDEF VER110}
{$DEFINE VER10x}
{$DEFINE VER11_PLUS}
{$DEFINE D4_BCB3}
{$ENDIF}
// Delphi 4.x
{$IFDEF VER120}
{$DEFINE VER10x}
{$DEFINE VER11_PLUS}
{$DEFINE D4_BCB3}
{$ENDIF}
{$ifdef Ver130} {Delphi 5 and C++Builder 5}
{$DEFINE VER10x}
{$DEFINE VER11_PLUS}
{$DEFINE D4_BCB3}
{$ENDIF}
{$ifdef ver125} {C++Builder 4}
{$DEFINE VER11_PLUS}
{$DEFINE D4_BCB3}
{$endif}
{$ENDIF not HL_LAZARUS}
////////////////////////////////////////////////////////////////////////////////
//
// External dependecies
//
////////////////////////////////////////////////////////////////////////////////
uses
{$IFDEF HL_LAZARUS}
Classes, SysUtils, VCLGlobals, LCLType, GraphType, Graphics;
{$ELSE}
sysutils,
Windows,
Graphics,
Classes;
{$ENDIF}
////////////////////////////////////////////////////////////////////////////////
//
// Misc constants and support types
//
////////////////////////////////////////////////////////////////////////////////
type
// TGIFImage mostly throws exceptions of type GIFException
GIFException = class(EInvalidGraphic);
// 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)
rmNetscape, // Reduce to the Netscape 216 color palette
rmMyPalette,
rmQuantizeWindows // Reduce to optimal 256 color windows palette
);
TDitherMode =
(dmNearest, // Nearest color matching w/o error correction
dmFloydSteinberg // Floyd Steinberg Error Diffusion dithering
// dmOrdered, // Ordered dither
// dmCustom // Custom palette
);
////////////////////////////////////////////////////////////////////////////////
//
// 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.
function ReduceColors(Bitmap: TBitmap; ColorReduction: TColorReduction;
DitherMode: TDitherMode): TBitmap;
////////////////////////////////////////////////////////////////////////////////
//
// Error messages
//
////////////////////////////////////////////////////////////////////////////////
resourcestring
// GIF Error messages
sOutOfData = 'Premature end of data';
sOutOfMemDIB = 'Failed to allocate memory for GIF DIB';
sDIBCreate = 'Failed to create DIB from Bitmap';
sNoDIB = 'Image has no DIB';
sInvalidBitmap = 'Bitmap image is not valid';
SInvalidPixelFormat = 'Invalid pixel format';
SScanLine = 'Scan line index out of range';
function GetBitmap(Source: TPersistent): TBitmap; {LDB}
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
//
// Implementation
//
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
implementation
{$IFDEF HL_LAZARUS}
function WebPalette: HPalette;
begin
Result := 0;
end;
function GetBitmap(Source: TPersistent): TBitmap; {LDB}
begin
Result:=TBitmap.Create;
Result.Assign(Source);
end;
function ReduceColors(Bitmap: TBitmap; ColorReduction: TColorReduction;
DitherMode: TDitherMode): TBitmap;
begin
Result:=TBitmap.Create;
Result.Assign(Bitmap);
end;
{$ELSE}
uses
{$ifdef DEBUG}
dialogs,
{$endif}
mmsystem, // timeGetTime()
messages,
LiteUn2;
////////////////////////////////////////////////////////////////////////////////
//
// Utilities
//
////////////////////////////////////////////////////////////////////////////////
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;
(*
** 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;
// 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;
type
TPixelFormats = set of TPixelFormat;
// --------------------------
// 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 D4_BCB3}
// Disable optimization to circumvent D4/BCB3 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
FillChar(DIB, sizeof(DIB), 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.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;
// --------------
// 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;
begin
Result := Bitmap.PixelFormat;
end;
// --------------
// 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);
begin
Bitmap.PixelFormat := PixelFormat;
end;
// ------------------
// 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 SetPixelFormat
// and TBitmap.PixelFormat suffers from.
//
// Parameters:
// Bitmap The bitmap to modify.
// PixelFormat The pixel format to convert to.
{$IFDEF VER11_PLUS}
procedure SafeSetPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat);
begin
Bitmap.PixelFormat := PixelFormat;
end;
{$ELSE}
var
pf8BitBitmap: TBitmap = nil;
procedure SafeSetPixelFormat(Bitmap: TBitmap; PixelFormat: TPixelFormat);
var
Width ,
Height : integer;
begin
if (PixelFormat = pf8bit) then
begin
// 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}
////////////////////////////////////////////////////////////////////////////////
//
// TDIB Class
//
// These classes gives read and write access to TBitmap's pixel data
// independantly of the Delphi version used.
//
////////////////////////////////////////////////////////////////////////////////
type
TDIB = class(TObject)
private
FBitmap : TBitmap;
FPixelFormat : TPixelFormat;
protected
function GetScanline(Row: integer): pointer; virtual; abstract;
public
constructor Create(ABitmap: TBitmap; APixelFormat: TPixelFormat); virtual;
property Scanline[Row: integer]: pointer read GetScanline;
property Bitmap: TBitmap read FBitmap;
end;
TDIBReader = class(TDIB)
protected
function GetScanline(Row: integer): pointer; override;
public
constructor Create(ABitmap: TBitmap; APixelFormat: TPixelFormat); override;
destructor Destroy; override;
end;
TDIBWriter = class(TDIB)
private
{$ifdef PIXELFORMAT_TOO_SLOW}
FDIBInfo : PBitmapInfo;
FDIBBits : pointer;
FDIBInfoSize : integer;
FDIBBitsSize : longInt;
{$endif}
protected
procedure CreateDIB;
procedure FreeDIB;
procedure NeedDIB;
function GetScanline(Row: integer): pointer; override;
public
constructor Create(ABitmap: TBitmap; APixelFormat: TPixelFormat); override;
destructor Destroy; override;
procedure UpdateBitmap;
end;
////////////////////////////////////////////////////////////////////////////////
constructor TDIB.Create(ABitmap: TBitmap; APixelFormat: TPixelFormat);
begin
inherited Create;
FBitmap := ABitmap;
FPixelFormat := APixelFormat;
end;
////////////////////////////////////////////////////////////////////////////////
constructor TDIBReader.Create(ABitmap: TBitmap; APixelFormat: TPixelFormat);
begin
inherited Create(ABitmap, APixelFormat);
SetPixelFormat(FBitmap, FPixelFormat);
end;
destructor TDIBReader.Destroy;
begin
inherited Destroy;
end;
function TDIBReader.GetScanline(Row: integer): pointer;
begin
Result := FBitmap.ScanLine[Row];
end;
////////////////////////////////////////////////////////////////////////////////
constructor TDIBWriter.Create(ABitmap: TBitmap; APixelFormat: TPixelFormat);
{$ifndef PIXELFORMAT_TOO_SLOW}
var
SavePalette : HPalette;
{$endif}
begin
inherited Create(ABitmap, APixelFormat);
{$ifndef PIXELFORMAT_TOO_SLOW}
SavePalette := FBitmap.ReleasePalette;
try
SafeSetPixelFormat(FBitmap, FPixelFormat);
finally
FBitmap.Palette := SavePalette;
end;
{$else}
FDIBInfo := nil;
FDIBBits := nil;
{$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 >= FBitmap.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 ,
DstColors : WORD;
// 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}
if (FBitmap.Handle = 0) then
Error(sInvalidBitmap);
FreeDIB;
// Get header- and pixel data size
InternalGetDIBSizes(FBitmap.Handle, FDIBInfoSize, FDIBBitsSize, FPixelFormat);
// Allocate TBitmapInfo structure
GetMem(FDIBInfo, FDIBInfoSize);
try
// Allocate pixel buffer
FDIBBits := GlobalAllocPtr(GMEM_MOVEABLE, FDIBBitsSize);
if (FDIBBits = nil) then
raise EOutOfMemory.Create(sOutOfMemDIB);
// Get pixel data
if not(InternalGetDIB(FBitmap.Handle, FBitmap.Palette, FDIBInfo^, FDIBBits^, FPixelFormat)) then
Error(sDIBCreate);
if (FPixelFormat <= pf8bit) then
begin
// Find number of colors defined by palette
if (FBitmap.Palette = 0) or
(GetObject(FBitmap.Palette, sizeof(SrcColors), @SrcColors) = 0) or
(SrcColors = 0) then
exit;
// Determine how many colors there are room for in DIB header
DstColors := FDIBInfo^.bmiHeader.biClrUsed;
if (DstColors = 0) then
DstColors := 1 SHL FDIBInfo^.bmiHeader.biBitCount;
// Don't copy any more colors than there are room for
if (DstColors <> 0) and (DstColors < SrcColors) then
SrcColors := DstColors;
// Copy all colors...
GetPaletteEntries(FBitmap.Palette, 0, SrcColors, FDIBInfo^.bmiColors[0]);
// ...and convert BGR to RGB
ByteSwapColors(FDIBInfo^.bmiColors[0], SrcColors);
// Finally zero any unused entried
if (SrcColors < DstColors) then
FillChar(pointer(LongInt(@FDIBInfo^.bmiColors)+SizeOf(TRGBQuad)*SrcColors)^,
DstColors - SrcColors, 0);
{.$ENDIF}
end;
except
FreeDIB;
raise;
end;
{$endif}
end;
procedure TDIBWriter.FreeDIB;
begin
{$ifdef PIXELFORMAT_TOO_SLOW}
if (FDIBInfo <> nil) then
FreeMem(FDIBInfo);
if (FDIBBits <> nil) then
GlobalFreePtr(FDIBBits);
FDIBInfo := nil;
FDIBBits := nil;
{$endif}
end;
procedure TDIBWriter.NeedDIB;
begin
{$ifdef PIXELFORMAT_TOO_SLOW}
if (FDIBBits = nil) then
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}
if (FDIBInfo = nil) or (FDIBBits = nil) then
exit;
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 DIB into bitmap
Stream.Position := 0;
FBitmap.LoadFromStream(Stream);
finally
Stream.Free;
end;
{$endif}
end;
////////////////////////////////////////////////////////////////////////////////
//
// Color Mapping
//
////////////////////////////////////////////////////////////////////////////////
type
TColorLookup = class(TObject)
private
FColors : integer;
function Lookup(Red, Green, Blue: BYTE; var R, G, B: BYTE): char; virtual; abstract;
public
constructor Create(Palette: hPalette); virtual;
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;
// 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;
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 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;
////////////////////////////////////////////////////////////////////////////////
//
// Dithering engine
//
////////////////////////////////////////////////////////////////////////////////
type
TDitherEngine = class
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;
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;
TFloydSteinbergEngine = 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;
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);
inc(FColumn, FDirection);
end;
procedure TDitherEngine.NextLine;
begin
FDirection := -FDirection;
if (FDirection = 1) then
FColumn := 0
else
FColumn := Width-1;
end;
constructor TFloydSteinbergEngine.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 TFloydSteinbergEngine.Destroy;
begin
FreeMem(ErrorsR);
FreeMem(ErrorsG);
FreeMem(ErrorsB);
inherited Destroy;
end;
{$IFOPT R+}
{$DEFINE R_PLUS}
{$RANGECHECKS OFF}
{$ENDIF}
function TFloydSteinbergEngine.Dither(Red, Green, Blue: BYTE; var R, G, B: BYTE): char;
var
BelowNextError : TErrorTerm;
Delta : TErrorTerm;
begin
CurrentErrorR := Red + (CurrentErrorR + ErrorR[FDirection] + 8) DIV 16;
if (CurrentErrorR < 0) then
CurrentErrorR := 0
else if (CurrentErrorR > 255) then
CurrentErrorR := 255;
CurrentErrorG := Green + (CurrentErrorG + ErrorG[FDirection] + 8) DIV 16;
if (CurrentErrorG < 0) then
CurrentErrorG := 0
else if (CurrentErrorG > 255) then
CurrentErrorG := 255;
CurrentErrorB := Blue + (CurrentErrorB + ErrorB[FDirection] + 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;
BelowNextError := CurrentErrorR; // Error * 1
Delta := CurrentErrorR * 2;
CurrentErrorR := CurrentErrorR + Delta;
ErrorR[0] := BelowPrevErrorR + CurrentErrorR; // Error * 3
CurrentErrorR := CurrentErrorR + Delta;
BelowPrevErrorR := BelowErrorR + CurrentErrorR; // Error * 5
BelowErrorR := BelowNextError; // Error * 1
CurrentErrorR := CurrentErrorR + Delta; // Error * 7
// Green component
CurrentErrorG := CurrentErrorG - G;
BelowNextError := CurrentErrorG; // Error * 1
Delta := CurrentErrorG * 2;
CurrentErrorG := CurrentErrorG + Delta;
ErrorG[0] := BelowPrevErrorG + CurrentErrorG; // Error * 3
CurrentErrorG := CurrentErrorG + Delta;
BelowPrevErrorG := BelowErrorG + CurrentErrorG; // Error * 5
BelowErrorG := BelowNextError; // Error * 1
CurrentErrorG := CurrentErrorG + Delta; // Error * 7
// Blue component
CurrentErrorB := CurrentErrorB - B;
BelowNextError := CurrentErrorB; // Error * 1
Delta := CurrentErrorB * 2;
CurrentErrorB := CurrentErrorB + Delta;
ErrorB[0] := BelowPrevErrorB + CurrentErrorB; // Error * 3
CurrentErrorB := CurrentErrorB + Delta;
BelowPrevErrorB := BelowErrorB + CurrentErrorB; // Error * 5
BelowErrorB := BelowNextError; // Error * 1
CurrentErrorB := CurrentErrorB + Delta; // Error * 7
// Move on to next column
if (FDirection = 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 TFloydSteinbergEngine.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 (FDirection = 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}
////////////////////////////////////////////////////////////////////////////////
//
// Octree Color Quantization Engine
//
////////////////////////////////////////////////////////////////////////////////
// Adapted from Earl F. Glynn's ColorQuantizationLibrary, March 1998
////////////////////////////////////////////////////////////////////////////////
type
TOctreeNode = class; // Forward definition so TReducibleNodes can be declared
TReducibleNodes = array[0..7] of TOctreeNode;
TOctreeNode = Class(TObject)
public
IsLeaf : Boolean;
PixelCount : integer;
RedSum : integer;
GreenSum : integer;
BlueSum : integer;
Next : TOctreeNode;
Child : TReducibleNodes;
constructor Create(Level: integer; ColorBits: integer; var LeafCount: integer;
var ReducibleNodes: TReducibleNodes);
destructor Destroy; override;
end;
TColorQuantizer = class(TObject)
private
FTree : TOctreeNode;
FLeafCount : integer;
FReducibleNodes : TReducibleNodes;
FMaxColors : integer;
FColorBits : integer;
protected
procedure AddColor(var Node: TOctreeNode; r, g, b: byte; ColorBits: integer;
Level: integer; var LeafCount: integer; var ReducibleNodes: TReducibleNodes);
procedure DeleteTree(var Node: TOctreeNode);
procedure GetPaletteColors(const Node: TOctreeNode;
var RGBQuadArray: TRGBQuadArray; var Index: integer);
procedure ReduceTree(ColorBits: integer; var LeafCount: integer;
var ReducibleNodes: TReducibleNodes);
public
constructor Create(MaxColors: integer; ColorBits: integer);
destructor Destroy; override;
procedure GetColorTable(var RGBQuadArray: TRGBQuadArray);
function ProcessImage(const DIB: TDIBReader): boolean;
property ColorCount: integer read FLeafCount;
end;
constructor TOctreeNode.Create(Level: integer; ColorBits: integer;
var LeafCount: integer; var ReducibleNodes: TReducibleNodes);
var
i : integer;
begin
PixelCount := 0;
RedSum := 0;
GreenSum := 0;
BlueSum := 0;
for i := Low(Child) to High(Child) do
Child[i] := nil;
IsLeaf := (Level = ColorBits);
if (IsLeaf) then
begin
Next := nil;
inc(LeafCount);
end else
begin
Next := ReducibleNodes[Level];
ReducibleNodes[Level] := self;
end;
end;
destructor TOctreeNode.Destroy;
var
i : integer;
begin
for i := High(Child) downto Low(Child) do
Child[i].Free;
end;
constructor TColorQuantizer.Create(MaxColors: integer; ColorBits: integer);
var
i : integer;
begin
ASSERT(ColorBits <= 8, 'ColorBits must be 8 or less');
FTree := nil;
FLeafCount := 0;
// Initialize all nodes even though only ColorBits+1 of them are needed
for i := Low(FReducibleNodes) to High(FReducibleNodes) do
FReducibleNodes[i] := nil;
FMaxColors := MaxColors;
FColorBits := ColorBits;
end;
destructor TColorQuantizer.Destroy;
begin
if (FTree <> nil) then
DeleteTree(FTree);
end;
procedure TColorQuantizer.GetColorTable(var RGBQuadArray: TRGBQuadArray);
var
Index : integer;
begin
Index := 0;
GetPaletteColors(FTree, RGBQuadArray, Index);
end;
// Handles passed to ProcessImage should refer to DIB sections, not DDBs.
// In certain cases, specifically when it's called upon to process 1, 4, or
// 8-bit per pixel images on systems with palettized display adapters,
// ProcessImage can produce incorrect results if it's passed a handle to a
// DDB.
function TColorQuantizer.ProcessImage(const DIB: TDIBReader): boolean;
var
i ,
j : integer;
ScanLine : pointer;
Pixel : PRGBTriple;
begin
Result := True;
for j := 0 to DIB.Bitmap.Height-1 do
begin
Scanline := DIB.Scanline[j];
Pixel := ScanLine;
for i := 0 to DIB.Bitmap.Width-1 do
begin
with Pixel^ do
AddColor(FTree, rgbtRed, rgbtGreen, rgbtBlue,
FColorBits, 0, FLeafCount, FReducibleNodes);
while FLeafCount > FMaxColors do
ReduceTree(FColorbits, FLeafCount, FReducibleNodes);
inc(Pixel);
end;
end;
end;
procedure TColorQuantizer.AddColor(var Node: TOctreeNode; r,g,b: byte;
ColorBits: integer; Level: integer; var LeafCount: integer;
var ReducibleNodes: TReducibleNodes);
const
Mask: array[0..7] of BYTE = ($80, $40, $20, $10, $08, $04, $02, $01);
var
Index : integer;
Shift : integer;
begin
// If the node doesn't exist, create it.
if (Node = nil) then
Node := TOctreeNode.Create(Level, ColorBits, LeafCount, ReducibleNodes);
if (Node.IsLeaf) then
begin
inc(Node.PixelCount);
inc(Node.RedSum, r);
inc(Node.GreenSum, g);
inc(Node.BlueSum, b);
end else
begin
// Recurse a level deeper if the node is not a leaf.
Shift := 7 - Level;
Index := (((r and mask[Level]) SHR Shift) SHL 2) or
(((g and mask[Level]) SHR Shift) SHL 1) or
((b and mask[Level]) SHR Shift);
AddColor(Node.Child[Index], r, g, b, ColorBits, Level+1, LeafCount, ReducibleNodes);
end;
end;
procedure TColorQuantizer.DeleteTree(var Node: TOctreeNode);
var
i : integer;
begin
for i := High(TReducibleNodes) downto Low(TReducibleNodes) do
if (Node.Child[i] <> nil) then
DeleteTree(Node.Child[i]);
Node.Free;
Node := nil;
end;
procedure TColorQuantizer.GetPaletteColors(const Node: TOctreeNode;
var RGBQuadArray: TRGBQuadArray; var Index: integer);
var
i : integer;
begin
if (Node.IsLeaf) then
begin
with RGBQuadArray[Index] do
begin
if (Node.PixelCount <> 0) then
begin
rgbRed := BYTE(Node.RedSum DIV Node.PixelCount);
rgbGreen := BYTE(Node.GreenSum DIV Node.PixelCount);
rgbBlue := BYTE(Node.BlueSum DIV Node.PixelCount);
end else
begin
rgbRed := 0;
rgbGreen := 0;
rgbBlue := 0;
end;
rgbReserved := 0;
end;
inc(Index);
end else
begin
for i := Low(Node.Child) to High(Node.Child) do
if (Node.Child[i] <> nil) then
GetPaletteColors(Node.Child[i], RGBQuadArray, Index);
end;
end;
procedure TColorQuantizer.ReduceTree(ColorBits: integer; var LeafCount: integer;
var ReducibleNodes: TReducibleNodes);
var
RedSum ,
GreenSum ,
BlueSum : integer;
Children : integer;
i : integer;
Node : TOctreeNode;
begin
// Find the deepest level containing at least one reducible node
i := Colorbits - 1;
while (i > 0) and (ReducibleNodes[i] = nil) do
dec(i);
// Reduce the node most recently added to the list at level i.
Node := ReducibleNodes[i];
ReducibleNodes[i] := Node.Next;
RedSum := 0;
GreenSum := 0;
BlueSum := 0;
Children := 0;
for i := Low(ReducibleNodes) to High(ReducibleNodes) do
if (Node.Child[i] <> nil) then
begin
inc(RedSum, Node.Child[i].RedSum);
inc(GreenSum, Node.Child[i].GreenSum);
inc(BlueSum, Node.Child[i].BlueSum);
inc(Node.PixelCount, Node.Child[i].PixelCount);
Node.Child[i].Free;
Node.Child[i] := nil;
inc(Children);
end;
Node.IsLeaf := TRUE;
Node.RedSum := RedSum;
Node.GreenSum := GreenSum;
Node.BlueSum := BlueSum;
dec(LeafCount, Children-1);
end;
////////////////////////////////////////////////////////////////////////////////
//
// Octree Color Quantization Wrapper
//
////////////////////////////////////////////////////////////////////////////////
// Adapted from Earl F. Glynn's PaletteLibrary, March 1998
////////////////////////////////////////////////////////////////////////////////
// Wrapper for internal use - uses TDIBReader for bitmap access
function doCreateOptimizedPaletteForSingleBitmap(const DIB: TDIBReader;
Colors, ColorBits: integer; Windows: boolean): hPalette;
var
SystemPalette : HPalette;
ColorQuantizer : TColorQuantizer;
i : integer;
LogicalPalette : TMaxLogPalette;
RGBQuadArray : TRGBQuadArray;
Offset : integer;
begin
LogicalPalette.palVersion := $0300;
LogicalPalette.palNumEntries := Colors;
if (Windows) then
begin
// Get the windows 20 color system palette
SystemPalette := GetStockObject(DEFAULT_PALETTE);
GetPaletteEntries(SystemPalette, 0, 10, LogicalPalette.palPalEntry[0]);
GetPaletteEntries(SystemPalette, 10, 10, LogicalPalette.palPalEntry[245]);
Colors := 236;
Offset := 10;
LogicalPalette.palNumEntries := 256;
end else
Offset := 0;
// Normally for 24-bit images, use ColorBits of 5 or 6. For 8-bit images
// use ColorBits = 8.
ColorQuantizer := TColorQuantizer.Create(Colors, ColorBits);
try
ColorQuantizer.ProcessImage(DIB);
ColorQuantizer.GetColorTable(RGBQuadArray);
finally
ColorQuantizer.Free;
end;
for i := 0 to Colors-1 do
with LogicalPalette.palPalEntry[i+Offset] do
begin
peRed := RGBQuadArray[i].rgbRed;
peGreen := RGBQuadArray[i].rgbGreen;
peBlue := RGBQuadArray[i].rgbBlue;
peFlags := RGBQuadArray[i].rgbReserved;
end;
Result := CreatePalette(pLogPalette(@LogicalPalette)^);
end;
function CreateOptimizedPaletteForSingleBitmap(const Bitmap: TBitmap;
Colors, ColorBits: integer; Windows: boolean): hPalette;
var
DIB : TDIBReader;
begin
DIB := TDIBReader.Create(Bitmap, pf24bit);
try
Result := doCreateOptimizedPaletteForSingleBitmap(DIB, Colors, ColorBits, Windows);
finally
DIB.Free;
end;
end;
////////////////////////////////////////////////////////////////////////////////
//
// Color reduction
//
////////////////////////////////////////////////////////////////////////////////
{$IFOPT R+}
{$DEFINE R_PLUS}
{$RANGECHECKS OFF}
{$ENDIF}
function ReduceColors(Bitmap: TBitmap; ColorReduction: TColorReduction;
DitherMode: TDitherMode): TBitmap;
var
Palette : hPalette;
ColorLookup : TColorLookup;
Ditherer : TDitherEngine;
Row : Integer;
DIBResult : TDIBWriter;
DIBSource : TDIBReader;
SrcScanLine ,
Src : PRGBTriple;
DstScanLine ,
Dst : PChar;
BGR : TRGBTriple;
{$ifdef DEBUG_DITHERPERFORMANCE}
TimeStart ,
TimeStop : DWORD;
{$endif}
begin
{$ifdef DEBUG_DITHERPERFORMANCE}
timeBeginPeriod(5);
TimeStart := timeGetTime;
{$endif}
Result := TBitmap.Create;
try
if (ColorReduction = rmNone) then
begin
Result.Assign(Bitmap);
SetPixelFormat(Result, pf24bit);
exit;
end;
// Set bitmap width and height
Result.Width := Bitmap.Width;
Result.Height := Bitmap.Height;
// Set the bitmap pixel format
SafeSetPixelFormat(Result, pf8bit);
Result.Palette := 0;
ColorLookup := nil;
Ditherer := nil;
DIBResult := nil;
DIBSource := nil;
Palette := 0;
try // Protect above resources
// Dithering and color mapper only supports 24 bit bitmaps,
// so we have convert the source bitmap to the appropiate format.
DIBSource := TDIBReader.Create(Bitmap, pf24bit);
try
// Create a palette based on current options
case (ColorReduction) of
rmQuantizeWindows:
Palette := CreateOptimizedPaletteForSingleBitmap(Bitmap, 256, 8, True);
rmNetscape:
Palette := WebPalette;
rmMyPalette:
Palette := CopyPalette(ThePalette);
rmWindows20:
Palette := GetStockObject(DEFAULT_PALETTE);
else
exit;
end;
Result.Palette := Palette;
case (ColorReduction) of
// For some strange reason my fast and dirty color lookup
// is more precise that Windows GetNearestPaletteIndex...
rmNetscape:
ColorLookup := TNetscapeColorLookup.Create(Palette);
else
ColorLookup := TFastColorLookup.Create(Palette);
end;
// Nothing to do if palette doesn't contain any colors
if (ColorLookup.Colors = 0) then
exit;
// Create a ditherer based on current options
case (DitherMode) of
dmNearest:
Ditherer := TDitherEngine.Create(Bitmap.Width, ColorLookup);
dmFloydSteinberg:
Ditherer := TFloydSteinbergEngine.Create(Bitmap.Width, ColorLookup);
else
exit;
end;
// The processed bitmap is returned in pf8bit format
DIBResult := TDIBWriter.Create(Result, pf8bit);
// Process the image
Row := 0;
while (Row < Bitmap.Height) do
begin
SrcScanline := DIBSource.ScanLine[Row];
DstScanline := DIBResult.ScanLine[Row];
Src := pointer(longInt(SrcScanLine) + Ditherer.Column*sizeof(TRGBTriple));
Dst := pointer(longInt(DstScanLine) + Ditherer.Column);
while (Ditherer.Column < Ditherer.Width) and (Ditherer.Column >= 0) do
begin
BGR := Src^;
// Dither and map a single pixel
Dst^ := Ditherer.Dither(BGR.rgbtRed, BGR.rgbtGreen, BGR.rgbtBlue,
BGR.rgbtRed, BGR.rgbtGreen, BGR.rgbtBlue);
inc(Src, Ditherer.Direction);
inc(Dst, Ditherer.Direction);
end;
Inc(Row);
Ditherer.NextLine;
end;
except
Result.ReleasePalette;
if (Palette <> 0) then
DeleteObject(Palette);
raise;
end;
finally
if (ColorLookup <> nil) then
ColorLookup.Free;
if (Ditherer <> nil) then
Ditherer.Free;
if (DIBResult <> nil) then
DIBResult.Free;
if (DIBSource <> nil) then
DIBSource.Free;
end;
except
Result.Free;
raise;
end;
{$ifdef DEBUG_DITHERPERFORMANCE}
TimeStop := timeGetTime;
ShowMessage(format('Dithered %d pixels in %d mS, Rate %d pixels/mS (%d pixels/S)',
[Bitmap.Height*Bitmap.Width, TimeStop-TimeStart,
MulDiv(Bitmap.Height, Bitmap.Width, TimeStop-TimeStart+1),
MulDiv(Bitmap.Height, Bitmap.Width * 1000, TimeStop-TimeStart+1)]));
timeEndPeriod(5);
{$endif}
end;
{$IFDEF R_PLUS}
{$RANGECHECKS ON}
{$UNDEF R_PLUS}
{$ENDIF}
function GetBitmap(Source: TPersistent): TBitmap;
var
PixelFormat : TPixelFormat;
FBitmap: TBitmap;
ColorReduction: TColorReduction;
DitherMode: TDitherMode;
begin
Result := Nil;
if (Source is TBitmap) then {should always be}
begin
if (TBitmap(Source).Empty) then
exit;
PixelFormat := GetPixelFormat(TBitmap(Source));
if (PixelFormat > pfDevice) then
begin
if ColorBits >= 8 then
ColorReduction := rmMyPalette
else ColorReduction := rmWindows20;
DitherMode := dmFloydSteinberg;
// Convert image to 8 bits/pixel or less
FBitmap := ReduceColors(TBitmap(Source), ColorReduction, DitherMode);
end else
begin
// Create new bitmap and copy
FBitmap := TBitmap.Create;
FBitmap.Assign(TBitmap(Source));
end;
Result := FBitmap;
end;
end;
{$ENDIF not HL_LAZARUS}
end.
Reference in New Issue View Git Blame Copy Permalink