ditherunit.pas

查看html文件的控件

// 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 <[e-mail]>
    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;
    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			,