DIB.pas

unit DIB;

interface

{$INCLUDE DelphiXcfg.inc}
{$IFDEF CPUX64}{$DEFINE PP}{$ENDIF}
{$IFNDEF CPUX64}{$IFNDEF CPUX86}{$DEFINE INLINEASM}{$ENDIF}{$ENDIF}
uses
  Windows, SysUtils, Classes, Graphics, Controls;

type
  TRGBQuads = array[0..255] of TRGBQuad;

  TPaletteEntries = array[0..255] of TPaletteEntry;

  PBGR = ^TBGR;
  TBGR = packed record
    B, G, R: Byte;
  end;

  PArrayBGR = ^TArrayBGR;
  TArrayBGR = array[0..10000] of TBGR;

  PArrayByte = ^TArrayByte;
  TArrayByte = array[0..10000] of Byte;

  PArrayWord = ^TArrayWord;
  TArrayWord = array[0..10000] of Word;

  PArrayDWord = ^TArrayDWord;
  TArrayDWord = array[0..10000] of DWord;

  {  TDIB  }

  TDIBPixelFormat = record
    RBitMask, GBitMask, BBitMask: DWORD;
    RBitCount, GBitCount, BBitCount: DWORD;
    RShift, GShift, BShift: DWORD;
    RBitCount2, GBitCount2, BBitCount2: DWORD;
  end;

  TDIBSharedImage = class(TSharedImage)
  private       
    FBitCount: Integer;
    FBitmapInfo: PBitmapInfo;
    FBitmapInfoSize: Integer;
    FChangePalette: Boolean;
    FColorTable: TRGBQuads;
    FColorTablePos: Integer;
    FCompressed: Boolean;
    FDC: THandle;
    FHandle: THandle;
    FHeight: Integer;
    FMemoryImage: Boolean;
    FNextLine: Integer;
    FOldHandle: THandle;
    FPalette: HPalette;
    FPaletteCount: Integer;
    FPBits: Pointer;
    FPixelFormat: TDIBPixelFormat;
    FSize: Integer;
    FTopPBits: Pointer;
    FWidth: Integer;
    FWidthBytes: Integer;
    constructor Create;
    procedure Init;virtual;
    procedure NewImage(AWidth, AHeight, ABitCount: Integer;
      const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
    procedure Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
    procedure Compress(Source: TDIBSharedImage);
    procedure Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);
    procedure ReadData(Stream: TStream; MemoryImage: Boolean);
    function GetPalette: THandle;
    procedure SetColorTable(const Value: TRGBQuads);
  protected
    procedure FreeHandle; override;
  public
    destructor Destroy; override;
  end;

  TDIB = class(TGraphic)
  private
    FCanvas: TCanvas;
    FImage: TDIBSharedImage;    

    FProgressName: ansistring;
    FProgressOldY: DWORD;
    FProgressOldTime: DWORD;
    FProgressOld: DWORD;
    FProgressY: DWORD;
    {  For speed-up  }
    FBitCount: Integer;
    FHeight: Integer;
    FNextLine: Integer;
    FNowPixelFormat: TDIBPixelFormat;
    FPBits: Pointer;
    FSize: Integer;
    FTopPBits: Pointer;
    FWidth: Integer;
    FWidthBytes: Integer;
    procedure AllocHandle;
    procedure CanvasChanging(Sender: TObject);
    procedure Changing(MemoryImage: Boolean);
    procedure ConvertBitCount(ABitCount: Integer);
    function GetBitmapInfo: PBitmapInfo;
    function GetBitmapInfoSize: Integer;
    function GetCanvas: TCanvas;
    function GetHandle: THandle;
    function GetPaletteCount: Integer;
    function GetPixel(X, Y: Integer): DWORD;
    function GetPBits: Pointer;
    function GetPBitsReadOnly: Pointer;
    function GetScanLine(Y: Integer): Pointer;
    function GetScanLineReadOnly(Y: Integer): Pointer;
    function GetTopPBits: Pointer;
    function GetTopPBitsReadOnly: Pointer;
    procedure SetBitCount(Value: Integer);
    procedure SetImage(Value: TDIBSharedImage);
    procedure SetNowPixelFormat(const Value: TDIBPixelFormat);
    procedure SetPixel(X, Y: Integer; Value: DWORD);
    procedure StartProgress(const Name: ansistring);
    procedure EndProgress;
    procedure UpdateProgress(PercentY: Integer);
    procedure NegativeASM(Size: NativeInt; P: Pointer);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetPalette: HPalette; override;
    function GetWidth: Integer; override;
    procedure ReadData(Stream: TStream); override;
    procedure SetHeight(Value: Integer); override;
    procedure SetPalette(Value: HPalette); override;
    procedure SetWidth(Value: Integer); override;
    procedure WriteData(Stream: TStream); override;
  public
    ColorTable: TRGBQuads;
    PixelFormat: TDIBPixelFormat;
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear;
    procedure Compress;
    procedure Decompress;
    procedure FreeHandle;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure SetSize(AWidth, AHeight, ABitCount: Integer);reintroduce;virtual;
    procedure UpdatePalette;
    {  Special effect  }
    procedure Blur(ABitCount: Integer; Radius: Integer);
    procedure Greyscale(ABitCount: Integer);
    procedure Mirror(MirrorX, MirrorY: Boolean);
    procedure Negative;

    property BitCount: Integer read FBitCount write SetBitCount;
    property BitmapInfo: PBitmapInfo read GetBitmapInfo;
    property BitmapInfoSize: Integer read GetBitmapInfoSize;
    property Canvas: TCanvas read GetCanvas;
    property Handle: THandle read GetHandle;
    property Height: Integer read FHeight write SetHeight;
    property NextLine: Integer read FNextLine;
    property NowPixelFormat: TDIBPixelFormat read FNowPixelFormat write SetNowPixelFormat;
    property PaletteCount: Integer read GetPaletteCount;
    property PBits: Pointer read GetPBits;
    property PBitsReadOnly: Pointer read GetPBitsReadOnly;
    property Pixels[X, Y: Integer]: DWORD read GetPixel write SetPixel;
    property ScanLine[Y: Integer]: Pointer read GetScanLine;
    property ScanLineReadOnly[Y: Integer]: Pointer read GetScanLineReadOnly;
    property Size: Integer read FSize;
    property TopPBits: Pointer read GetTopPBits;
    property TopPBitsReadOnly: Pointer read GetTopPBitsReadOnly;
    property Width: Integer read FWidth write SetWidth;
    property WidthBytes: Integer read FWidthBytes;
  end;

  TDIBitmap = class(TDIB) end;

  {  TCustomDXDIB  }

  TCustomDXDIB = class(TComponent)
  private
    FDIB: TDIB;
    procedure SetDIB(Value: TDIB);
  public
    constructor Create(AOnwer: TComponent); override;
    destructor Destroy; override;
    property DIB: TDIB read FDIB write SetDIB;
  end;

  {  TDXDIB  }

  TDXDIB = class(TCustomDXDIB)
  published
    property DIB;
  end;

  {  TCustomDXPaintBox  }

  TCustomDXPaintBox = class(TGraphicControl)
  private
    FAutoStretch: Boolean;
    FCenter: Boolean;
    FDIB: TDIB;
    FKeepAspect: Boolean;
    FStretch: Boolean;
    FViewWidth: Integer;
    FViewHeight: Integer;
    procedure SetAutoStretch(Value: Boolean);
    procedure SetCenter(Value: Boolean);
    procedure SetDIB(Value: TDIB);
    procedure SetKeepAspect(Value: Boolean);
    procedure SetStretch(Value: Boolean);
    procedure SetViewWidth(Value: Integer);
    procedure SetViewHeight(Value: Integer);
  protected
    function GetPalette: HPALETTE; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    property AutoStretch: Boolean read FAutoStretch write SetAutoStretch;
    property Canvas;
    property Center: Boolean read FCenter write SetCenter;
    property DIB: TDIB read FDIB write SetDIB;
    property KeepAspect: Boolean read FKeepAspect write SetKeepAspect;
    property Stretch: Boolean read FStretch write SetStretch;
    property ViewWidth: Integer read FViewWidth write SetViewWidth;
    property ViewHeight: Integer read FViewHeight write SetViewHeight;
  end;

  {  TDXPaintBox  }

  TDXPaintBox = class(TCustomDXPaintBox)
  published
    {$IFDEF DelphiX_Spt4}property Anchors;{$ENDIF}
    property AutoStretch;
    property Center;
    {$IFDEF DelphiX_Spt4}property Constraints;{$ENDIF}
    property DIB;
    property KeepAspect;
    property Stretch;
    property ViewWidth;
    property ViewHeight;

    property Align;
    property DragCursor;
    property DragMode;
    property Enabled;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD;
procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte);
function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;

function GreyscaleColorTable: TRGBQuads;

function RGBQuad(R, G, B: Byte): TRGBQuad;
function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad;
function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads;
function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry;
function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries;

implementation

uses DXConsts;

function Max(B1, B2: Integer): Integer;
begin
  if B1>=B2 then Result := B1 else Result := B2;
end;

function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
begin
  Result.RBitMask := ((1 shl RBitCount)-1) shl (GBitCount+BBitCount);
  Result.GBitMask := ((1 shl GBitCount)-1) shl (BBitCount);
  Result.BBitMask := (1 shl BBitCount)-1;
  Result.RBitCount := RBitCount;
  Result.GBitCount := GBitCount;
  Result.BBitCount := BBitCount;
  Result.RBitCount2 := 8-RBitCount;
  Result.GBitCount2 := 8-GBitCount;
  Result.BBitCount2 := 8-BBitCount;
  Result.RShift := (GBitCount+BBitCount)-(8-RBitCount);
  Result.GShift := BBitCount-(8-GBitCount);
  Result.BShift := 8-BBitCount;
end;

function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;

  function GetBitCount(b: Integer): Integer;
  var
    i: Integer;
  begin
    i := 0;
    while (i<31) and (((1 shl i) and b)=0) do Inc(i);

    Result := 0;
    while ((1 shl i) and b)<>0 do
    begin
      Inc(i);
      Inc(Result);
    end;
  end;

begin
  Result := MakeDIBPixelFormat(GetBitCount(RBitMask), GetBitCount(GBitMask),
    GetBitCount(BBitMask));
end;

function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD;
begin
  with PixelFormat do
    Result := ((R shl RShift) and RBitMask) or ((G shl GShift) and GBitMask) or
      ((B shr BShift) and BBitMask);
end;

procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte);
begin
  with PixelFormat do
  begin
    R := (Color and RBitMask) shr RShift;
    R := R or (R shr RBitCount2);
    G := (Color and GBitMask) shr GShift;
    G := G or (G shr GBitCount2);
    B := (Color and BBitMask) shl BShift;
    B := B or (B shr BBitCount2);
  end;
end;

function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
begin
  with PixelFormat do
  begin
    Result := (Color and RBitMask) shr RShift;
    Result := Result or (Result shr RBitCount);
  end;
end;

function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
begin
  with PixelFormat do
  begin
    Result := (Color and GBitMask) shr GShift;
    Result := Result or (Result shr GBitCount);
  end;
end;

function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
begin
  with PixelFormat do
  begin
    Result := (Color and BBitMask) shl BShift;
    Result := Result or (Result shr BBitCount);
  end;
end;

function GreyscaleColorTable: TRGBQuads;
var
  i: Integer;
begin
  for i:=0 to 255 do
    with Result[i] do
    begin
      rgbRed := i;
      rgbGreen := i;
      rgbBlue := i;
      rgbReserved := 0;
    end;
end;

function RGBQuad(R, G, B: Byte): TRGBQuad;
begin
  with Result do
  begin
    rgbRed := R;
    rgbGreen := G;
    rgbBlue := B;
    rgbReserved := 0;
  end;
end;

function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad;
begin
  with Result do
    with Entry do
    begin
      rgbRed := peRed;
      rgbGreen := peGreen;
      rgbBlue := peBlue;
      rgbReserved := 0;
    end;
end;

function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads;
var
  i: Integer;
begin
  for i:=0 to 255 do
    Result[i] := PaletteEntryToRGBQuad(Entries[i]);
end;

function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry;
begin
  with Result do
    with RGBQuad do
    begin
      peRed := rgbRed;
      peGreen := rgbGreen;
      peBlue := rgbBlue;
      peFlags := 0;
    end;
end;

function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries;
var
  i: Integer;
begin
  for i:=0 to 255 do
    Result[i] := RGBQuadToPaletteEntry(RGBQuads[i]);
end;

{  TDIBSharedImage  }

type
  PLocalDIBPixelFormat = ^TLocalDIBPixelFormat;
  TLocalDIBPixelFormat = packed record
    RBitMask, GBitMask, BBitMask: DWORD;
  end;

  TPaletteItem = class(TCollectionItem)
  private
    ID: Integer;
    Palette: HPalette;
    RefCount: Integer;
    ColorTable: TRGBQuads;
    ColorTableCount: Integer;
    destructor Destroy; override;
    procedure AddRef;
    procedure Release;
  end;

  TPaletteManager = class
  private
    FList: TCollection;
    constructor Create;
    destructor Destroy; override;
    function CreatePalette(const ColorTable: TRGBQuads; ColorTableCount: Integer): HPalette;
    procedure DeletePalette(var Palette: HPalette);
  end;

destructor TPaletteItem.Destroy;
begin
  DeleteObject(Palette);
  inherited Destroy;
end;

procedure TPaletteItem.AddRef;
begin
  Inc(RefCount);
end;

procedure TPaletteItem.Release;
begin
  Dec(RefCount);
  if RefCount<=0 then Free;
end;

constructor TPaletteManager.Create;
begin
  inherited Create;
  FList := TCollection.Create(TPaletteItem);
end;

destructor TPaletteManager.Destroy;
begin
  FList.Free;
  inherited Destroy;
end;

function TPaletteManager.CreatePalette(const ColorTable: TRGBQuads; ColorTableCount: Integer): HPalette;
type
  TMyLogPalette = record
    palVersion: Word;
    palNumEntries: Word;
    palPalEntry: TPaletteEntries;
  end;
var
  i, ID: Integer;
  Item: TPaletteItem;
  LogPalette: TMyLogPalette;
begin
  {  Hash key making  }
  ID := ColorTableCount;
  for i:=0 to ColorTableCount-1 do
    with ColorTable[i] do
    begin
      Inc(ID, rgbRed);
      Inc(ID, rgbGreen);
      Inc(ID, rgbBlue);
    end;

  {  Does the same palette already exist?  }
  for i:=0 to FList.Count-1 do
  begin
    Item := TPaletteItem(FList.Items[i]);
    if (Item.ID=ID) and (Item.ColorTableCount=ColorTableCount) and
      CompareMem(@Item.ColorTable, @ColorTable, ColorTableCount*SizeOf(TRGBQuad)) then
    begin
      Item.AddRef; Result := Item.Palette;
      Exit;
    end;
  end;

  {  New palette making  }
  Item := TPaletteItem.Create(FList);
  Item.ID := ID;
  Move(ColorTable, Item.ColorTable, ColorTableCount*SizeOf(TRGBQuad));
  Item.ColorTableCount := ColorTableCount;

  with LogPalette do
  begin
    palVersion := $300;
    palNumEntries := ColorTableCount;
    palPalEntry := RGBQuadsToPaletteEntries(ColorTable);
  end;

  Item.Palette := Windows.CreatePalette(PLogPalette(@LogPalette)^);
  Item.AddRef; Result := Item.Palette;
end;

procedure TPaletteManager.DeletePalette(var Palette: HPalette);
var
  i: Integer;
  Item: TPaletteItem;
begin
  if Palette=0 then Exit;

  for i:=0 to FList.Count-1 do
  begin
    Item := TPaletteItem(FList.Items[i]);
    if (Item.Palette=Palette) then
    begin
      Palette := 0;
      Item.Release;
      Exit;
    end;
  end;
end;

var
  FPaletteManager: TPaletteManager;

function PaletteManager: TPaletteManager;
begin
  if FPaletteManager=nil then
    FPaletteManager := TPaletteManager.Create;
  Result := FPaletteManager;
end;

constructor TDIBSharedImage.Create;
begin
  inherited Create;
  Init;
end;

procedure TDIBSharedImage.NewImage(AWidth, AHeight, ABitCount: Integer;
  const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
var
  InfoOfs: Integer;
  UsePixelFormat: Boolean;
begin
  Init;

  {  Pixel format check  }
  case ABitCount of
    1 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
    4 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
    8 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
    16: begin
          if not (((PixelFormat.RBitMask=$7C00) and (PixelFormat.GBitMask=$03E0) and (PixelFormat.BBitMask=$001F)) or
            ((PixelFormat.RBitMask=$F800) and (PixelFormat.GBitMask=$07E0) and (PixelFormat.BBitMask=$001F))) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
        end;
    24: begin
          if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
        end;
    32: begin
          if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
            raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
        end;
  else
    raise EInvalidGraphicOperation.CreateFmt(SInvalidDIBBitCount, [ABitCount]);
  end;

  FBitCount := ABitCount;
  FHeight := AHeight;
  FWidth := AWidth;
  FWidthBytes := (((AWidth*ABitCount)+31) shr 5) * 4;
  FNextLine := -FWidthBytes;
  FSize := FWidthBytes*FHeight;
  UsePixelFormat := ABitCount in [16, 32];

  FPixelFormat := PixelFormat;

  FPaletteCount := 0;
  if FBitCount<=8 then
    FPaletteCount := 1 shl FBitCount;

  FBitmapInfoSize := SizeOf(TBitmapInfoHeader);
  if UsePixelFormat then
    Inc(FBitmapInfoSize, SizeOf(TLocalDIBPixelFormat));
  Inc(FBitmapInfoSize, SizeOf(TRGBQuad)*FPaletteCount);

  GetMem(FBitmapInfo, FBitmapInfoSize);
  FillChar(FBitmapInfo^, FBitmapInfoSize, 0);

  {  BitmapInfo setting.  }
  with FBitmapInfo^.bmiHeader do
  begin
    biSize := SizeOf(TBitmapInfoHeader);
    biWidth := FWidth;
    biHeight := FHeight;
    biPlanes := 1;
    biBitCount := FBitCount;
    if UsePixelFormat then
      biCompression := BI_BITFIELDS
    else
    begin
      if (FBitCount=4) and (Compressed) then
        biCompression := BI_RLE4
      else if (FBitCount=8) and (Compressed) then
        biCompression := BI_RLE8
      else
        biCompression := BI_RGB;
    end;
    biSizeImage := FSize;
    biXPelsPerMeter := 0;
    biYPelsPerMeter := 0;
    biClrUsed := 0;
    biClrImportant := 0;
  end;
  InfoOfs := SizeOf(TBitmapInfoHeader);

  if UsePixelFormat then
  begin
    with PLocalDIBPixelFormat(Integer(FBitmapInfo)+InfoOfs)^ do
    begin
      RBitMask := PixelFormat.RBitMask;
      GBitMask := PixelFormat.GBitMask;
      BBitMask := PixelFormat.BBitMask;
    end;

    Inc(InfoOfs, SizeOf(TLocalDIBPixelFormat));
  end;

  FColorTablePos := InfoOfs;

  FColorTable := ColorTable;
  Move(FColorTable, Pointer(Integer(FBitmapInfo)+FColorTablePos)^, SizeOf(TRGBQuad)*FPaletteCount);

  FCompressed := FBitmapInfo^.bmiHeader.biCompression in [BI_RLE4, BI_RLE8];
  FMemoryImage := MemoryImage or FCompressed;

  {  DIB making.  }
  if not Compressed then
  begin
    if MemoryImage then
    begin
      FPBits := Pointer(GlobalAlloc(GMEM_FIXED, FSize));
      if FPBits=nil then
        OutOfMemoryError;
    end else
    begin
      FDC := CreateCompatibleDC(0);

      FHandle := CreateDIBSection(FDC, FBitmapInfo^, DIB_RGB_COLORS, FPBits, 0, 0);
      if FHandle=0 then
        raise EOutOfResources.CreateFmt(SCannotMade, ['DIB']);

      FOldHandle := SelectObject(FDC, FHandle);
    end;
  end;

  FTopPBits := Pointer(Integer(FPBits)+(FHeight-1)*FWidthBytes);
end;

procedure TDIBSharedImage.Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
begin
  if Source.FSize=0 then
  begin
    Init;
    FMemoryImage := MemoryImage;
  end else
  begin
    NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
      Source.FPixelFormat, Source.FColorTable, MemoryImage, Source.FCompressed);
    if FCompressed then
    begin
      FBitmapInfo.bmiHeader.biSizeImage := Source.FBitmapInfo.bmiHeader.biSizeImage;
      GetMem(FPBits, FBitmapInfo.bmiHeader.biSizeImage);
      Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
    end else
    begin
      Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
    end;
  end;
end;

procedure TDIBSharedImage.Compress(Source: TDIBSharedImage);

  procedure EncodeRLE4;
  var
    Size: Integer;

    function AllocByte: PByte;
    begin
      if Size mod 4096=0 then
        ReAllocMem(FPBits, Size+4095);
      Result := Pointer(Integer(FPBits)+Size);
      Inc(Size);
    end;

  var
    B1, B2, C: Byte;
    PB1, PB2: Integer;
    Src: PByte;
    X, Y: Integer;

    function GetPixel(x: Integer): Integer;
    begin
      if X and 1=0 then
        Result := PArrayByte(Src)[X shr 1] shr 4
      else
        Result := PArrayByte(Src)[X shr 1] and $0F;
    end;

  begin
    Size := 0;

    for y:=0 to Source.FHeight-1 do
    begin
      x := 0;
      Src := Pointer(Integer(Source.FPBits)+y*FWidthBytes);
      while x<Source.FWidth do
      begin
        if (Source.FWidth-x>3) and (GetPixel(x)=GetPixel(x+2)) then
        begin
          {  Encoding mode  }
          B1 := 2;
          B2 := (GetPixel(x) shl 4) or GetPixel(x+1);

          Inc(x, 2);

          C := B2;

          while (x<Source.FWidth) and (C and $F=GetPixel(x)) and (B1<255) do
          begin
            Inc(B1);
            Inc(x);
            C := (C shr 4) or (C shl 4);
          end;

          AllocByte^ := B1;
          AllocByte^ := B2;
        end else
        if (Source.FWidth-x>5) and ((GetPixel(x)<>GetPixel(x+2)) or (GetPixel(x+1)<>GetPixel(x+3))) and
          ((GetPixel(x+2)=GetPixel(x+4)) and (GetPixel(x+3)=GetPixel(x+5))) then
        begin
          {  Encoding mode }
          AllocByte^ := 2;
          AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
          Inc(x, 2);
        end else
        begin
          if (Source.FWidth-x<4) then
          begin
            {  Encoding mode }
            while Source.FWidth-x>=2 do
            begin
              AllocByte^ := 2;
              AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
              Inc(x, 2);
            end;

            if Source.FWidth-x=1 then
            begin
              AllocByte^ := 1;
              AllocByte^ := GetPixel(x) shl 4;
              Inc(x);
            end;
          end else
          begin
            {  Absolute mode  }
            PB1 := Size; AllocByte;
            PB2 := Size; AllocByte;

            B1 := 0;
            B2 := 4;

            AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
            AllocByte^ := (GetPixel(x+2) shl 4) or GetPixel(x+3);

            Inc(x, 4);

            while (x+1<Source.FWidth) and (B2<254) do
            begin
              if (Source.FWidth-x>3) and (GetPixel(x)=GetPixel(x+2)) and (GetPixel(x+1)=GetPixel(x+3)) then
                Break;

              AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
              Inc(B2, 2);
              Inc(x, 2);
            end;

            PByte(Integer(FPBits)+PB1)^ := B1;
            PByte(Integer(FPBits)+PB2)^ := B2;
          end;
        end;

        if Size and 1=1 then AllocByte;
      end;

      {  End of line  }
      AllocByte^ := 0;
      AllocByte^ := 0;
    end;

    {  End of bitmap  }
    AllocByte^ := 0;
    AllocByte^ := 1;

    FBitmapInfo.bmiHeader.biSizeImage := Size;
    FSize := Size;
  end;

  procedure EncodeRLE8;
  var
    Size: Integer;

    function AllocByte: PByte;
    begin
      if Size mod 4096=0 then
        ReAllocMem(FPBits, Size+4095);
      Result := Pointer(Integer(FPBits)+Size);
      Inc(Size);
    end;

  var
    B1, B2: Byte;
    PB1, PB2: Integer;
    Src: PByte;
    X, Y: Integer;
  begin
    Size := 0;

    for y:=0 to Source.FHeight-1 do
    begin
      x := 0;
      Src := Pointer(Integer(Source.FPBits)+y*FWidthBytes);
      while x<Source.FWidth do
      begin
        if (Source.FWidth-x>2) and (Src^=PByte(Integer(Src)+1)^) then
        begin
          {  Encoding mode  }
          B1 := 2;
          B2 := Src^;

          Inc(x, 2);
          Inc(Src, 2);

          while (x<Source.FWidth) and (Src^=B2) and (B1<255) do
          begin
            Inc(B1);
            Inc(x);
            Inc(Src);
          end;

          AllocByte^ := B1;
          AllocByte^ := B2;
        end else
        if (Source.FWidth-x>2) and (Src^<>PByte(Integer(Src)+1)^) and (PByte(Integer(Src)+1)^=PByte(Integer(Src)+2)^) then
        begin
          {  Encoding mode }
          AllocByte^ := 1;
          AllocByte^ := Src^; Inc(Src);
          Inc(x);
        end else
        begin
          if (Source.FWidth-x<4) then
          begin
            {  Encoding mode }
            if Source.FWidth-x=2 then
            begin
              AllocByte^ := 1;
              AllocByte^ := Src^; Inc(Src);

              AllocByte^ := 1;
              AllocByte^ := Src^; Inc(Src);
              Inc(x, 2);
            end else
            begin
              AllocByte^ := 1;
              AllocByte^ := Src^; Inc(Src);
              Inc(x);
            end;
          end else
          begin
            {  Absolute mode  }
            PB1 := Size; AllocByte;
            PB2 := Size; AllocByte;

            B1 := 0;
            B2 := 3;

            Inc(x, 3);

            AllocByte^ := Src^; Inc(Src);
            AllocByte^ := Src^; Inc(Src);
            AllocByte^ := Src^; Inc(Src);

            while (x<Source.FWidth) and (B2<255) do
            begin
              if (Source.FWidth-x>3) and (Src^=PByte(Integer(Src)+1)^) and (Src^=PByte(Integer(Src)+2)^) and (Src^=PByte(Integer(Src)+3)^) then
                Break;

              AllocByte^ := Src^; Inc(Src);
              Inc(B2);
              Inc(x);
            end;

            PByte(Integer(FPBits)+PB1)^ := B1;
            PByte(Integer(FPBits)+PB2)^ := B2;
          end;
        end;

        if Size and 1=1 then AllocByte;
      end;

      {  End of line  }
      AllocByte^ := 0;
      AllocByte^ := 0;
    end;

    {  End of bitmap  }
    AllocByte^ := 0;
    AllocByte^ := 1;

    FBitmapInfo.bmiHeader.biSizeImage := Size;
    FSize := Size;
  end;

begin
  if Source.FCompressed then
    Duplicate(Source, Source.FMemoryImage)
  else begin
    NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
      Source.FPixelFormat, Source.FColorTable, True, True);
    case FBitmapInfo.bmiHeader.biCompression of
      BI_RLE4: EncodeRLE4;
      BI_RLE8: EncodeRLE8;
    else
      Duplicate(Source, Source.FMemoryImage);
    end;
  end;
end;

procedure TDIBSharedImage.Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);

  procedure DecodeRLE4;
  var
    B1, B2, C: Byte;
    Dest, Src, P: PByte;
    X, Y, i: Integer;
  begin
    Src := Source.FPBits;
    X := 0;
    Y := 0;

    while True do
    begin
      B1 := Src^; Inc(Src);
      B2 := Src^; Inc(Src);

      if B1=0 then
      begin
        case B2 of
          0: begin  {  End of line  }
               X := 0;
               Inc(Y);
             end;
          1: Break; {  End of bitmap  }
          2: begin  {  Difference of coordinates  }
               Inc(X, B1);
               Inc(Y, B2); Inc(Src, 2);
             end;
        else
          {  Absolute mode  }
          Dest := Pointer(Longint(FPBits)+Y*FWidthBytes);

          C := 0;
          for i:=0 to B2-1 do
          begin
            if i and 1=0 then
            begin
              C := Src^; Inc(Src);
            end else
            begin
              C := C shl 4;
            end;

            P := Pointer(Integer(Dest)+X shr 1);
            if X and 1=0 then
              P^ := (P^ and $0F) or (C and $F0)
            else
              P^ := (P^ and $F0) or ((C and $F0) shr 4);

            Inc(X);
          end;
        end;
      end else
      begin
        {  Encoding mode  }
        Dest := Pointer(Longint(FPBits)+Y*FWidthBytes);

        for i:=0 to B1-1 do
        begin
          P := Pointer(Integer(Dest)+X shr 1);
          if X and 1=0 then
            P^ := (P^ and $0F) or (B2 and $F0)
          else
            P^ := (P^ and $F0) or ((B2 and $F0) shr 4);

          Inc(X);

          // Swap nibble
          B2 := (B2 shr 4) or (B2 shl 4);
        end;
      end;

      {  Word arrangement  }
      Inc(Src, Longint(Src) and 1);
    end;
  end;

  procedure DecodeRLE8;
  var
    B1, B2: Byte;
    Dest, Src: PByte;
    X, Y: Integer;
  begin
    Dest := FPBits;
    Src := Source.FPBits;
    X := 0;
    Y := 0;

    while True do
    begin
      B1 := Src^; Inc(Src);
      B2 := Src^; Inc(Src);

      if B1=0 then
      begin
        case B2 of
          0: begin  {  End of line  }
               X := 0; Inc(Y);
               Dest := Pointer(Longint(FPBits)+Y*FWidthBytes+X);
             end;
          1: Break; {  End of bitmap  }
          2: begin  {  Difference of coordinates  }
               Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
               Dest := Pointer(Longint(FPBits)+Y*FWidthBytes+X);
             end;
        else
          {  Absolute mode  }
          Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
        end;
      end else
      begin
        {  Encoding mode  }
        FillChar(Dest^, B1, B2); Inc(Dest, B1);
      end;

      {  Word arrangement  }
      Inc(Src, Longint(Src) and 1);
    end;
  end;

begin
  if not Source.FCompressed then
    Duplicate(Source, MemoryImage)
  else begin
    NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
      Source.FPixelFormat, Source.FColorTable, MemoryImage, False);
    case Source.FBitmapInfo.bmiHeader.biCompression of
      BI_RLE4: DecodeRLE4;
      BI_RLE8: DecodeRLE8;
    else
      Duplicate(Source, MemoryImage);
    end;                                               
  end;
end;

procedure TDIBSharedImage.ReadData(Stream: TStream; MemoryImage: Boolean);
var
  BI: TBitmapInfoHeader;
  BC: TBitmapCoreHeader;
  BCRGB: array[0..255] of TRGBTriple;

  procedure LoadRLE4;
  begin
    FSize := BI.biSizeImage;
    FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
    FBitmapInfo.bmiHeader.biSizeImage := FSize;
    Stream.ReadBuffer(FPBits^, FSize);
  end;

  procedure LoadRLE8;
  begin
    FSize := BI.biSizeImage;
    FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
    FBitmapInfo.bmiHeader.biSizeImage := FSize;
    Stream.ReadBuffer(FPBits^, FSize);
  end;

  procedure LoadRGB;
  var
    y: Integer;
  begin
    if BI.biHeight<0 then
    begin
      for y:=0 to Abs(BI.biHeight)-1 do
        Stream.ReadBuffer(Pointer(Integer(FTopPBits)+y*FNextLine)^, FWidthBytes);
    end else
    begin
      Stream.ReadBuffer(FPBits^, FSize);
    end;
  end;

var
  i, PalCount: Integer;
  OS2: Boolean;
  Localpf: TLocalDIBPixelFormat;
  AColorTable: TRGBQuads;
  APixelFormat: TDIBPixelFormat;
begin
  {  Header size reading  }
  i := Stream.Read(BI.biSize, 4);

  if i=0 then
  begin
    Init;
    Exit;
  end;
  if i<>4 then
    raise EInvalidGraphic.Create(SInvalidDIB);

  {  Kind check of DIB  }
  OS2 := False;

  case BI.biSize of
    SizeOf(TBitmapCoreHeader):
      begin
        {  OS/2 type  }
        Stream.ReadBuffer(Pointer(Integer(@BC)+4)^, SizeOf(TBitmapCoreHeader)-4);

        with BI do
        begin
          biClrUsed := 0;
          biCompression := BI_RGB;
          biBitCount := BC.bcBitCount;
          biHeight := BC.bcHeight;
          biWidth := BC.bcWidth;
        end;

        OS2 := True;
      end;
    SizeOf(TBitmapInfoHeader):
      begin
        {  Windows type  }
        Stream.ReadBuffer(Pointer(Integer(@BI)+4)^, SizeOf(TBitmapInfoHeader)-4);
      end;
  else
    raise EInvalidGraphic.Create(SInvalidDIB);
  end;

  {  Bit mask reading.  }
  if BI.biCompression = BI_BITFIELDS then
  begin
    Stream.ReadBuffer(Localpf, SizeOf(Localpf));
    with Localpf do
      APixelFormat := MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask);
  end else
  begin
    if BI.biBitCount=16 then
      APixelFormat := MakeDIBPixelFormat(5, 5, 5)
    else if BI.biBitCount=32 then
      APixelFormat := MakeDIBPixelFormat(8, 8, 8)
    else
      APixelFormat := MakeDIBPixelFormat(8, 8, 8);
  end;

    {  Palette reading  }
  PalCount := BI.biClrUsed;
  if (PalCount=0) and (BI.biBitCount<=8) then
    PalCount := 1 shl BI.biBitCount;
  if PalCount>256 then PalCount := 256;

  FillChar(AColorTable, SizeOf(AColorTable), 0);

  if OS2 then
  begin
    {  OS/2 type  }
    Stream.ReadBuffer(BCRGB, SizeOf(TRGBTriple)*PalCount);
    for i:=0 to PalCount-1 do
    begin
      with BCRGB[i] do
        AColorTable[i] := RGBQuad(rgbtRed, rgbtGreen, rgbtBlue);
    end;
  end else
  begin
    {  Windows type  }
    Stream.ReadBuffer(AColorTable, SizeOf(TRGBQuad)*PalCount);
  end;

  {  DIB ì¬  }
  NewImage(BI.biWidth, Abs(BI.biHeight), BI.biBitCount, APixelFormat, AColorTable,
    MemoryImage, BI.biCompression in [BI_RLE4, BI_RLE8]);

  {  Pixel data reading  }
  case BI.biCompression of
    BI_RGB      : LoadRGB;
    BI_RLE4     : LoadRLE4;
    BI_RLE8     : LoadRLE8;
    BI_BITFIELDS: LoadRGB;
  else
    raise EInvalidGraphic.Create(SInvalidDIB);
  end;
end;

destructor TDIBSharedImage.Destroy;
begin
  if FHandle<>0 then
  begin
    if FOldHandle<>0 then SelectObject(FDC, FOldHandle);
    DeleteObject(FHandle);
  end else
  begin
    if FPBits<>nil then
      GlobalFreePtr(FPBits);
  end;

  PaletteManager.DeletePalette(FPalette);
  if FDC<>0 then DeleteDC(FDC);

  FreeMem(FBitmapInfo);
  inherited Destroy;
end;

procedure TDIBSharedImage.FreeHandle;
begin
  raise Exception.create('unimplemented');
//TODO -cunimplemented: unimplemented block
end;

function TDIBSharedImage.GetPalette: THandle;
begin
  if FPaletteCount>0 then
  begin
    if FChangePalette then
    begin
      FChangePalette := False;
      PaletteManager.DeletePalette(FPalette);
      FPalette := PaletteManager.CreatePalette(FColorTable, FPaletteCount);
    end;
    Result := FPalette;
  end else
    Result := 0;
end;

procedure TDIBSharedImage.Init;
begin
  FMemoryImage := True;
  SetColorTable(GreyscaleColorTable);
  FColorTable := GreyscaleColorTable;
  FPixelFormat := MakeDIBPixelFormat(8, 8, 8);
end;

procedure TDIBSharedImage.SetColorTable(const Value: TRGBQuads);
begin
  FColorTable := Value;
  FChangePalette := True;

  if (FSize>0) and (FPaletteCount>0) then
  begin
    SetDIBColorTable(FDC, 0, 256, FColorTable);
    Move(FColorTable, Pointer(Integer(FBitmapInfo)+FColorTablePos)^, SizeOf(TRGBQuad)*FPaletteCount);
  end;
end;

{ TDIB }

var
  FEmptyDIBImage: TDIBSharedImage;

function EmptyDIBImage: TDIBSharedImage;
begin
  if FEmptyDIBImage=nil then
  begin
    FEmptyDIBImage := TDIBSharedImage.Create;
    FEmptyDIBImage.Reference;
  end;
  Result := FEmptyDIBImage;
end;

constructor TDIB.Create;
begin
  inherited Create;
  SetImage(EmptyDIBImage);
end;

destructor TDIB.Destroy;
begin
  SetImage(EmptyDIBImage);
  FCanvas.Free;
  inherited Destroy;
end;

procedure TDIB.Assign(Source: TPersistent);

  procedure AssignBitmap(Source: TBitmap);
  var
    Data: array[0..1023] of Byte;
    BitmapRec: Windows.PBitmap;
    DIBSectionRec: PDIBSection;
    PaletteEntries: TPaletteEntries;
  begin
    GetPaletteEntries(Source.Palette, 0, 256, PaletteEntries);
    ColorTable := PaletteEntriesToRGBQuads(PaletteEntries);
    UpdatePalette;

    case GetObject(Source.Handle, SizeOf(Data), @Data) of
      SizeOf(Windows.TBitmap):
          begin
            BitmapRec := @Data;
            case BitmapRec^.bmBitsPixel of
              16: PixelFormat := MakeDIBPixelFormat(5, 5, 5);
            else
              PixelFormat := MakeDIBPixelFormat(8, 8, 8);
            end;
            SetSize(BitmapRec^.bmWidth, BitmapRec^.bmHeight, BitmapRec^.bmBitsPixel);
          end;
      SizeOf(TDIBSection):
          begin
            DIBSectionRec := @Data;
            if DIBSectionRec^.dsBm.bmBitsPixel>=24 then
            begin
              PixelFormat := MakeDIBPixelFormat(8, 8, 8);
            end else
            if DIBSectionRec^.dsBm.bmBitsPixel>8 then
            begin
              PixelFormat := MakeDIBPixelFormat(DIBSectionRec^.dsBitfields[0],
                DIBSectionRec^.dsBitfields[1], DIBSectionRec^.dsBitfields[2]);
            end else
            begin
              PixelFormat := MakeDIBPixelFormat(8, 8, 8);
            end;
            SetSize(DIBSectionRec^.dsBm.bmWidth, DIBSectionRec^.dsBm.bmHeight,
              DIBSectionRec^.dsBm.bmBitsPixel);
          end;
    else
      Exit;
    end;

    FillChar(PBits^, Size, 0);
    Canvas.Draw(0, 0, Source);
  end;

  procedure AssignGraphic(Source: TGraphic);
  var
    x,y: integer;
  begin
    if Source is TBitmap then
      AssignBitmap(TBitmap(Source))
    else
    begin
      SetSize(Source.Width, Source.Height, 32);
      FillChar(PBits^, Size, 0);
      Canvas.Draw(0, 0, Source);
      for y := 0 to height-1 do begin
        for x := 0 to width -1 do begin
          self.pixels[x,y] := (self.pixels[x,y] and dword(clWhite)) or (dword(random(255)) shl 24);
        end;
      end;
    end;
  end;

begin
  if Source=nil then
  begin
    Clear;
  end else if Source is TDIB then
  begin
    if Source<>Self then
      SetImage(TDIB(Source).FImage);
  end else if Source is TGraphic then
  begin
    AssignGraphic(TGraphic(Source));
  end else if Source is TPicture then
  begin
    if TPicture(Source).Graphic<>nil then
      AssignGraphic(TPicture(Source).Graphic)
    else
      Clear;
  end else 
    inherited Assign(Source);
end;

procedure TDIB.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  OldPalette: HPalette;
  OldMode: Integer;
begin
  if Size>0 then
  begin
    if PaletteCount>0 then
    begin
      OldPalette := SelectPalette(ACanvas.Handle, Palette, False);
      RealizePalette(ACanvas.Handle);
    end else
      OldPalette := 0;
    try
      OldMode := SetStretchBltMode(ACanvas.Handle, COLORONCOLOR);
      try
        GdiFlush;
        if FImage.FMemoryImage then
        begin
          with Rect do
            StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
              0, 0, Width, Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS , ACanvas.CopyMode);
        end else
        begin
          with Rect do
            StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
              FImage.FDC, 0, 0, Width, Height, ACanvas.CopyMode);
        end;
      finally
        SetStretchBltMode(ACanvas.Handle, OldMode);
      end;
    finally
      SelectPalette(ACanvas.Handle, OldPalette, False);
    end;
  end;
end;

procedure TDIB.Clear;
begin
  SetImage(EmptyDIBImage);
end;

procedure TDIB.CanvasChanging(Sender: TObject);
begin
  Changing(False);
end;

procedure TDIB.Changing(MemoryImage: Boolean);
var
  TempImage: TDIBSharedImage;
begin
  if (FImage.RefCount>1) or (FImage.FCompressed) or ((not MemoryImage) and (FImage.FMemoryImage)) then
  begin
    TempImage := TDIBSharedImage.Create;
    try
      TempImage.Decompress(FImage, FImage.FMemoryImage and MemoryImage);
    except
      TempImage.Free;
      raise;
    end;
    SetImage(TempImage);
  end;
end;

procedure TDIB.AllocHandle;
var
  TempImage: TDIBSharedImage;
begin
  if FImage.FMemoryImage then
  begin
    TempImage := TDIBSharedImage.Create;
    try
      TempImage.Decompress(FImage, False);
    except
      TempImage.Free;
      raise;
    end;
    SetImage(TempImage);
  end;
end;

procedure TDIB.Compress;
var
  TempImage: TDIBSharedImage;
begin
  if (not FImage.FCompressed) and (BitCount in [4, 8]) then
  begin
    TempImage := TDIBSharedImage.Create;
    try
      TempImage.Compress(FImage);
    except
      TempImage.Free;
      raise;
    end;
    SetImage(TempImage);
  end;
end;

procedure TDIB.Decompress;
var
  TempImage: TDIBSharedImage;
begin
  if FImage.FCompressed then
  begin
    TempImage := TDIBSharedImage.Create;
    try
      TempImage.Decompress(FImage, FImage.FMemoryImage);
    except
      TempImage.Free;
      raise;
    end;
    SetImage(TempImage);
  end;
end;

procedure TDIB.FreeHandle;
var
  TempImage: TDIBSharedImage;
begin
  if not FImage.FMemoryImage then
  begin
    TempImage := TDIBSharedImage.Create;
    try
      TempImage.Duplicate(FImage, True);
    except
      TempImage.Free;
      raise;
    end;
    SetImage(TempImage);
  end;
end;

function TDIB.GetBitmapInfo: PBitmapInfo;
begin
  Result := FImage.FBitmapInfo;
end;

function TDIB.GetBitmapInfoSize: Integer;
begin
  Result := FImage.FBitmapInfoSize;
end;

function TDIB.GetCanvas: TCanvas;
begin
  if (FCanvas=nil) or (FCanvas.Handle=0) then
  begin
    AllocHandle;

    FCanvas := TCanvas.Create;
    FCanvas.Handle := FImage.FDC;
    FCanvas.OnChanging := CanvasChanging;
  end;
  Result := FCanvas;
end;

function TDIB.GetEmpty: Boolean;
begin
  Result := Size=0;
end;

function TDIB.GetHandle: THandle;
begin
  Changing(True);
  Result := FImage.FHandle;
end;

function TDIB.GetHeight: Integer;
begin
  Result := FHeight;
end;

function TDIB.GetPalette: HPalette;
begin
  Result := FImage.GetPalette;
end;

function TDIB.GetPaletteCount: Integer;
begin
  Result := FImage.FPaletteCount;
end;

function TDIB.GetPBits: Pointer;
begin
  Changing(True);

  if not FImage.FMemoryImage then
    GDIFlush;
  Result := FPBits;
end;

function TDIB.GetPBitsReadOnly: Pointer;
begin
  if not FImage.FMemoryImage then
    GDIFlush;
  Result := FPBits;
end;

function TDIB.GetScanLine(Y: Integer): Pointer;
begin
  Changing(True);
  if (Y<0) or (Y>=FHeight) then
    raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);

  if not FImage.FMemoryImage then
    GDIFlush;
  Result := Pointer(Integer(FTopPBits)+Y*FNextLine);
end;

function TDIB.GetScanLineReadOnly(Y: Integer): Pointer;
begin
  if (Y<0) or (Y>=FHeight) then
    raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);

  if not FImage.FMemoryImage then
    GDIFlush;
  Result := Pointer(Integer(FTopPBits)+Y*FNextLine);
end;

function TDIB.GetTopPBits: Pointer;
begin
  Changing(True);

  if not FImage.FMemoryImage then
    GDIFlush;
  Result := FTopPBits;
end;

function TDIB.GetTopPBitsReadOnly: Pointer;
begin
  if not FImage.FMemoryImage then
    GDIFlush;
  Result := FTopPBits;
end;           

function TDIB.GetWidth: Integer;
begin
  Result := FWidth;
end;

const
  Mask1: array[0..7] of DWORD = ($80, $40, $20, $10, $08, $04, $02, $01);
  Mask1n: array[0..7] of DWORD = ($FFFFFF7F, $FFFFFFBF, $FFFFFFDF, $FFFFFFEF,
    $FFFFFFF7, $FFFFFFFB, $FFFFFFFD, $FFFFFFFE);
  Mask4: array[0..1] of DWORD = ($F0, $0F);
  Mask4n: array[0..1] of DWORD = ($FFFFFF0F, $FFFFFFF0);

  Shift1: array[0..7] of DWORD = (7, 6, 5, 4, 3, 2, 1, 0);
  Shift4: array[0..1] of DWORD = (4, 0);

function TDIB.GetPixel(X, Y: Integer): DWORD;
begin
  Decompress;

  Result := 0;
  if (X>=0) and (X<FWidth) and (Y>=0) and (Y<FHeight) then
  begin
    case FBitCount of
      1 : Result := (PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
      4 : Result := (PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1];
      8 : Result := PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X];
      16: Result := PArrayWord(Integer(FTopPBits)+Y*FNextLine)[X];
      24: with PArrayBGR(Integer(FTopPBits)+Y*FNextLine)[X] do
            Result := R or (G shl 8) or (B shl 16);
      32: Result := PArrayDWord(Integer(FTopPBits)+Y*FNextLine)[X];
    end;
  end;
end;

procedure TDIB.SetPixel(X, Y: Integer; Value: DWORD);
var
  P: PByte;
begin
  Changing(True);

  if (X>=0) and (X<FWidth) and (Y>=0) and (Y<FHeight) then
  begin
    case FBitCount of
      1 : begin
            P := @PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3];
            P^ := (P^ and Mask1n[X and 7]) or ((Value and 1) shl Shift1[X and 7]);
          end;
      4 : begin
            P := @PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3];
            P^ := (P^ and Mask4n[X and 1]) or ((Value and 15) shl Shift4[X and 1]);
          end;
      8 : PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
      16: PArrayWord(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
      24: with PArrayBGR(Integer(FTopPBits)+Y*FNextLine)[X] do
          begin
            B := Byte(Value shr 16);
            G := Byte(Value shr 8);
            R := Byte(Value);
          end;
      32: PArrayDWord(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
    end;
  end;
end;
                            
procedure TDIB.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  {  For interchangeability with an old version.  }
  Filer.DefineBinaryProperty('DIB', LoadFromStream, nil, False);
end;

type
  TGlobalMemoryStream = class(TMemoryStream)
  private
    FHandle: THandle;
  public
    constructor Create(AHandle: THandle);
    destructor Destroy; override;
  end;

constructor TGlobalMemoryStream.Create(AHandle: THandle);
begin
  inherited Create;
  FHandle := AHandle;
  SetPointer(GlobalLock(AHandle), GlobalSize(AHandle));
end;

destructor TGlobalMemoryStream.Destroy;
begin
  GlobalUnLock(FHandle);
  SetPointer(nil, 0);
  inherited Destroy;
end;

procedure TDIB.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
var
  Stream: TGlobalMemoryStream;
begin
  Stream := TGlobalMemoryStream.Create(AData);
  try
    ReadData(Stream);
  finally
    Stream.Free;
  end;
end;

const
  BitmapFileType = Ord('B') + Ord('M')*$100;

procedure TDIB.LoadFromStream(Stream: TStream);
var
  BF: TBitmapFileHeader;
  i: Integer;
begin
  {  File header reading  }
  i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
  if i=0 then Exit;
  if i<>SizeOf(TBitmapFileHeader) then
    raise EInvalidGraphic.Create(SInvalidDIB);

  {  Is the head 'BM'?  }
  if BF.bfType<>BitmapFileType then
    raise EInvalidGraphic.Create(SInvalidDIB);

  ReadData(Stream);
end;

procedure TDIB.ReadData(Stream: TStream);
var
  TempImage: TDIBSharedImage;
begin
  TempImage := TDIBSharedImage.Create;
  try
    TempImage.ReadData(Stream, FImage.FMemoryImage);
  except
    TempImage.Free;
    raise;
  end;
  SetImage(TempImage);
end;

procedure TDIB.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  var APalette: HPALETTE);
var
  P: Pointer;
  Stream: TMemoryStream;
begin
  AFormat := CF_DIB;
  APalette := 0;

  Stream := TMemoryStream.Create;
  try
    WriteData(Stream);

    AData := GlobalAlloc(GHND, Stream.Size);
    if AData=0 then OutOfMemoryError;

    P := GlobalLock(AData);
    Move(Stream.Memory^, P^, Stream.Size);
    GlobalUnLock(AData);
  finally
    Stream.Free;
  end;
end;

procedure TDIB.SaveToStream(Stream: TStream);
var
  BF: TBitmapFileHeader;
begin
  if Empty then Exit;

  with BF do
  begin
    bfType    := BitmapFileType;
    bfOffBits := SizeOf(TBitmapFileHeader)+BitmapInfoSize;
    bfSize    := bfOffBits+FImage.FBitmapInfo^.bmiHeader.biSizeImage;
    bfReserved1 := 0;
    bfReserved2 := 0;
  end;
  Stream.WriteBuffer(BF, SizeOf(TBitmapFileHeader));

  WriteData(Stream);
end;

procedure TDIB.WriteData(Stream: TStream);
begin
  if Empty then Exit;

  if not FImage.FMemoryImage then
    GDIFlush;

  Stream.WriteBuffer(FImage.FBitmapInfo^, FImage.FBitmapInfoSize);
  Stream.WriteBuffer(FImage.FPBits^, FImage.FBitmapInfo.bmiHeader.biSizeImage);
end;

procedure TDIB.SetBitCount(Value: Integer);
begin
  if Value<=0 then
    Clear
  else
  begin
    if Empty then
    begin
      SetSize(Max(Width, 1), Max(Height, 1), Value)
    end else
    begin
      ConvertBitCount(Value);
    end;
  end;
end;

procedure TDIB.SetHeight(Value: Integer);
begin
  if Value<=0 then
    Clear
  else
  begin
    if Empty then
      SetSize(Max(Width, 1), Value, 8)
    else
      SetSize(Width, Value, BitCount);
  end;
end;

procedure TDIB.SetWidth(Value: Integer);
begin
  if Value<=0 then
    Clear
  else
  begin
    if Empty then
      SetSize(Value, Max(Height, 1), 8)
    else
      SetSize(Value, Height, BitCount);
  end;
end;

procedure TDIB.SetImage(Value: TDIBSharedImage);
begin
  if FImage<>Value then
  begin
    if FCanvas<>nil then
      FCanvas.Handle := 0;
    
    FImage.Release;
    FImage := Value;
    FImage.Reference;

    if FCanvas<>nil then
      FCanvas.Handle := FImage.FDC;

    ColorTable := FImage.FColorTable;
    PixelFormat := FImage.FPixelFormat;

    FBitCount := FImage.FBitCount;
    FHeight := FImage.FHeight;
    FNextLine := FImage.FNextLine;
    FNowPixelFormat := FImage.FPixelFormat;
    FPBits := FImage.FPBits;
    FSize := FImage.FSize;
    FTopPBits := FImage.FTopPBits;
    FWidth := FImage.FWidth;
    FWidthBytes := FImage.FWidthBytes;
  end;
end;

procedure TDIB.SetNowPixelFormat(const Value: TDIBPixelFormat);
var
  Temp: TDIB;
begin
  if CompareMem(@Value, @FImage.FPixelFormat, SizeOf(TDIBPixelFormat)) then exit;

  PixelFormat := Value;

  Temp := TDIB.Create;
  try
    Temp.Assign(Self);
    SetSize(Width, Height, BitCount);
    Canvas.Draw(0, 0, Temp);
  finally
    Temp.Free;
  end;
end;

procedure TDIB.SetPalette(Value: HPalette);
var
  PaletteEntries: TPaletteEntries;
begin
  GetPaletteEntries(Value, 0, 256, PaletteEntries);
  DeleteObject(Value);

  ColorTable := PaletteEntriesToRGBQuads(PaletteEntries);
  UpdatePalette;
end;

procedure TDIB.SetSize(AWidth, AHeight, ABitCount: Integer);
var
  TempImage: TDIBSharedImage;
begin
  if (AWidth=Width) and (AHeight=Height) and (ABitCount=BitCount) and
    (NowPixelFormat.RBitMask=PixelFormat.RBitMask) and
    (NowPixelFormat.GBitMask=PixelFormat.GBitMask) and
    (NowPixelFormat.BBitMask=PixelFormat.BBitMask) then Exit;

  if (AWidth<=0) or (AHeight<=0) then
  begin
    Clear;
    Exit;
  end;

  TempImage := TDIBSharedImage.Create;
  try
    TempImage.NewImage(AWidth, AHeight, ABitCount,
      PixelFormat, ColorTable, FImage.FMemoryImage, False);
  except
    TempImage.Free;
    raise;
  end;
  SetImage(TempImage);

  PaletteModified := True;
end;

procedure TDIB.UpdatePalette;
var
  Col: TRGBQuads;
begin
  if CompareMem(@ColorTable, @FImage.FColorTable, SizeOf(ColorTable)) then Exit;

  Col := ColorTable;
  Changing(True);
  ColorTable := Col;
  FImage.SetColorTable(ColorTable);

  PaletteModified := True;
end;

procedure TDIB.ConvertBitCount(ABitCount: Integer);
var
  Temp: TDIB;

  procedure CreateHalftonePalette(R, G, B: Integer);
  var
    i: Integer;
  begin
    for i:=0 to 255 do
      with ColorTable[i] do
      begin
        rgbRed   := ((i shr (G+B-1)) and (1 shl R-1)) * 255 div (1 shl R-1);
        rgbGreen := ((i shr (B-1)) and (1 shl G-1)) * 255 div (1 shl G-1);
        rgbBlue  := ((i shr 0) and (1 shl B-1)) * 255 div (1 shl B-1);
      end;
  end;

  procedure PaletteToPalette_Inc;
  var
    x, y: Integer;
    i: DWORD;
    SrcP, DestP: Pointer;
    P: PByte;
  begin
    i := 0;

    for y:=0 to Height-1 do
    begin
      SrcP := Temp.ScanLine[y];
      DestP := ScanLine[y];

      for x:=0 to Width-1 do
      begin
        case Temp.BitCount of
          1 : begin
                i := (PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
              end;
          4 : begin
                i := (PArrayByte(SrcP)[X and 1] and Mask4[X and 1]) shr Shift4[X and 1];
              end;
          8 : begin
                i := PByte(SrcP)^;
                Inc(PByte(SrcP));
              end;
        end;

        case BitCount of
          1 : begin
                P := @PArrayByte(DestP)[X shr 3];
                P^ := (P^ and Mask1n[X and 7]) or (i shl Shift1[X shr 3]);
              end;
          4 : begin
                P := @PArrayByte(DestP)[X shr 1];
                P^ := (P^ and Mask4n[X and 1]) or (i shl Shift4[X and 1]);
              end;
          8 : begin
                PByte(DestP)^ := i;
                Inc(PByte(DestP));
              end;
        end;
      end;
    end;
  end;

  procedure PaletteToRGB_or_RGBToRGB;
  var
    x, y: Integer;
    SrcP, DestP: Pointer;
    cR, cG, cB: Byte;
  begin
    cR := 0;
    cG := 0;
    cB := 0;

    for y:=0 to Height-1 do
    begin
      SrcP := Temp.ScanLine[y];
      DestP := ScanLine[y];

      for x:=0 to Width-1 do
      begin
        case Temp.BitCount of
          1 : begin
                with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
                begin
                  cR := rgbRed;
                  cG := rgbGreen;
                  cB := rgbBlue;
                end;
              end;
          4 : begin
                with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
                begin
                  cR := rgbRed;
                  cG := rgbGreen;
                  cB := rgbBlue;
                end;
              end;
          8 : begin
                with Temp.ColorTable[PByte(SrcP)^] do
                begin
                  cR := rgbRed;
                  cG := rgbGreen;
                  cB := rgbBlue;
                end;
                Inc(PByte(SrcP));
              end;
          16: begin
                pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, cR, cG, cB);
                Inc(PWord(SrcP));
              end;
          24: begin
                with PBGR(SrcP)^ do
                begin
                  cR := R;
                  cG := G;
                  cB := B;
                end;

                Inc(PBGR(SrcP));
              end;
          32: begin
                pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, cR, cG, cB);
                Inc(PDWORD(SrcP));
              end;
        end;

        case BitCount of
          16: begin
                PWord(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
                Inc(PWord(DestP));
              end;
          24: begin
                with PBGR(DestP)^ do
                begin
                  R := cR;
                  G := cG;
                  B := cB;
                end;
                Inc(PBGR(DestP));
              end;
          32: begin
                PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
                Inc(PDWORD(DestP));
              end;
        end;
      end;
    end;
  end;

begin
  if Size=0 then exit;

  Temp := TDIB.Create;
  try
    Temp.Assign(Self);
    SetSize(Temp.Width, Temp.Height, ABitCount);

    if FImage=Temp.FImage then Exit;

    if (Temp.BitCount<=8) and (BitCount<=8) then
    begin
      {  The image is converted from the palette color image into the palette color image.  }
      if Temp.BitCount<=BitCount then
      begin
        PaletteToPalette_Inc;
      end else
      begin
        case BitCount of
          1: begin
               ColorTable[0] := RGBQuad(0, 0, 0);
               ColorTable[1] := RGBQuad(255, 255, 255);
             end;
          4: CreateHalftonePalette(1, 2, 1);
          8: CreateHalftonePalette(3, 3, 2);
        end;
        UpdatePalette;

        Canvas.Draw(0, 0, Temp);
      end;
    end else
    if (Temp.BitCount<=8) and (BitCount>8) then
    begin
      {  The image is converted from the palette color image into the rgb color image.  }
      PaletteToRGB_or_RGBToRGB;
    end else
    if (Temp.BitCount>8) and (BitCount<=8) then
    begin
      {  The image is converted from the rgb color image into the palette color image.  }
      case BitCount of
        1: begin
             ColorTable[0] := RGBQuad(0, 0, 0);
             ColorTable[1] := RGBQuad(255, 255, 255);
           end;
        4: CreateHalftonePalette(1, 2, 1);
        8: CreateHalftonePalette(3, 3, 2);
      end;
      UpdatePalette;

      Canvas.Draw(0, 0, Temp);
    end else
    if (Temp.BitCount>8) and (BitCount>8) then
    begin
      {  The image is converted from the rgb color image into the rgb color image.  }
      PaletteToRGB_or_RGBToRGB;
    end;
  finally
    Temp.Free;
  end;
end;

{  Special effect  }

procedure TDIB.StartProgress(const Name: ansistring);
begin
  FProgressName := Name;
  FProgressOld := 0;
  FProgressOldTime := GetTickCount;
  FProgressY := 0;
  FProgressOldY := 0;
  Progress(Self, psStarting, 0, False, Rect(0, 0, Width, Height), FProgressName);
end;

procedure TDIB.EndProgress;
begin
  Progress(Self, psEnding, 100, True, Rect(0, FProgressOldY, Width, Height), FProgressName);
end;

procedure TDIB.UpdateProgress(PercentY: Integer);
var
  Redraw: Boolean;
  Percent: DWORD;
begin
  Redraw := (GetTickCount-FProgressOldTime>200) and (FProgressY-FProgressOldY>32) and
    (((Height div 3>Integer(FProgressY)) and (FProgressOldY=0)) or (FProgressOldY<>0));

  Percent := PercentY*100 div Height;

  if (Percent<>FProgressOld) or (Redraw) then
  begin
    Progress(Self, psRunning, Percent, Redraw,
      Rect(0, FProgressOldY, Width, FProgressY), FProgressName);
    if Redraw then
    begin
      FProgressOldY := FProgressY;
      FProgressOldTime := GetTickCount;
    end;

    FProgressOld := Percent;
  end;

  Inc(FProgressY);
end;

procedure TDIB.Blur(ABitCount: Integer; Radius: Integer);
type
  TAve = record
    cR, cG, cB: DWORD;
    c: DWORD;
  end;
  TArrayAve = array[0..0] of TAve;

var
  Temp: TDIB;

  procedure AddAverage(Y, XCount: Integer; var Ave: TArrayAve);
  var
    X: Integer;
    SrcP: Pointer;
    AveP: ^TAve;
    R, G, B: Byte;
  begin
    case Temp.BitCount of
      1 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
              begin
                Inc(cR, rgbRed);
                Inc(cG, rgbGreen);
                Inc(cB, rgbBlue);
                Inc(c);
              end;
              Inc(AveP);
            end;
          end;
      4 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
              begin
                Inc(cR, rgbRed);
                Inc(cG, rgbGreen);
                Inc(cB, rgbBlue);
                Inc(c);
              end;
              Inc(AveP);
            end;
          end;
      8 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[PByte(SrcP)^], AveP^ do
              begin
                Inc(cR, rgbRed);
                Inc(cG, rgbGreen);
                Inc(cB, rgbBlue);
                Inc(c);
              end;
              Inc(PByte(SrcP));
              Inc(AveP);
            end;
          end;
      16: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
              with AveP^ do
              begin
                Inc(cR, R);
                Inc(cG, G);
                Inc(cB, B);
                Inc(c);
              end;
              Inc(PWord(SrcP));
              Inc(AveP);
            end;
          end;
      24: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with PBGR(SrcP)^, AveP^ do
              begin
                Inc(cR, R);
                Inc(cG, G);
                Inc(cB, B);
                Inc(c);
              end;
              Inc(PBGR(SrcP));
              Inc(AveP);
            end;
          end;
      32: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
              with AveP^ do
              begin
                Inc(cR, R);
                Inc(cG, G);
                Inc(cB, B);
                Inc(c);
              end;
              Inc(PDWORD(SrcP));
              Inc(AveP);
            end;
          end;
    end;
  end;

  procedure DeleteAverage(Y, XCount: Integer; var Ave: TArrayAve);
  var
    X: Integer;
    SrcP: Pointer;
    AveP: ^TAve;
    R, G, B: Byte;
  begin
    case Temp.BitCount of
      1 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
              begin
                Dec(cR, rgbRed);
                Dec(cG, rgbGreen);
                Dec(cB, rgbBlue);
                Dec(c);
              end;
              Inc(AveP);
            end;
          end;
      4 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
              begin
                Dec(cR, rgbRed);
                Dec(cG, rgbGreen);
                Dec(cB, rgbBlue);
                Dec(c);
              end;
              Inc(AveP);
            end;
          end;
      8 : begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with Temp.ColorTable[PByte(SrcP)^], AveP^ do
              begin
                Dec(cR, rgbRed);
                Dec(cG, rgbGreen);
                Dec(cB, rgbBlue);
                Dec(c);
              end;
              Inc(PByte(SrcP));
              Inc(AveP);
            end;
          end;
      16: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
              with AveP^ do
              begin
                Dec(cR, R);
                Dec(cG, G);
                Dec(cB, B);
                Dec(c);
              end;
              Inc(PWord(SrcP));
              Inc(AveP);
            end;
          end;
      24: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              with PBGR(SrcP)^, AveP^ do
              begin
                Dec(cR, R);
                Dec(cG, G);
                Dec(cB, B);
                Dec(c);
              end;
              Inc(PBGR(SrcP));
              Inc(AveP);
            end;
          end;
      32: begin
            SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
            AveP := @Ave;
            for x:=0 to XCount-1 do
            begin
              pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
              with AveP^ do
              begin
                Dec(cR, R);
                Dec(cG, G);
                Dec(cB, B);
                Dec(c);
              end;
              Inc(PDWORD(SrcP));
              Inc(AveP);
            end;
          end;
    end;
  end;

  procedure Blur_Radius_Other;
  var
    FirstX, LastX, FirstX2, LastX2, FirstY, LastY: Integer;
    x, y, x2, y2, jx, jy: Integer;
    Ave: TAve;
    AveX: ^TArrayAve;
    DestP: Pointer;
    P: PByte;
  begin
    GetMem(AveX, Width*SizeOf(TAve));
    try
      FillChar(AveX^, Width*SizeOf(TAve), 0);

      FirstX2 := -1;
      LastX2 := -1;
      FirstY := -1;
      LastY := -1;

      x := 0;
      for x2:=-Radius to Radius do
      begin
        jx := x+x2;
        if (jx>=0) and (jx<Width) then
        begin
          if FirstX2=-1 then FirstX2 := jx;
          if LastX2<jx then LastX2 := jx;
        end;
      end;

      y := 0;
      for y2:=-Radius to Radius do
      begin
        jy := y+y2;
        if (jy>=0) and (jy<Height) then
        begin
          if FirstY=-1 then FirstY := jy;
          if LastY<jy then LastY := jy;
        end;
      end;

      for y:=FirstY to LastY do
        AddAverage(y, Temp.Width, AveX^);

      for y:=0 to Height-1 do
      begin
        DestP := ScanLine[y];

        {  The average is updated.  }
        if y-FirstY=Radius+1 then
        begin
          DeleteAverage(FirstY, Temp.Width, AveX^);
          Inc(FirstY);
        end;

        if LastY-y=Radius-1 then
        begin
          Inc(LastY); if LastY>=Height then LastY := Height-1;
          AddAverage(LastY, Temp.Width, AveX^);
        end;

        {  The average is calculated again.  }
        FirstX := FirstX2;
        LastX := LastX2;

        FillChar(Ave, SizeOf(Ave), 0);
        for x:=FirstX to LastX do
          with AveX[x] do
          begin
            Inc(Ave.cR, cR);
            Inc(Ave.cG, cG);
            Inc(Ave.cB, cB);
            Inc(Ave.c, c);
          end;

        for x:=0 to Width-1 do
        begin
          {  The average is updated.  }
          if x-FirstX=Radius+1 then
          begin
            with AveX[FirstX] do
            begin
              Dec(Ave.cR, cR);
              Dec(Ave.cG, cG);
              Dec(Ave.cB, cB);
              Dec(Ave.c, c);
            end;
            Inc(FirstX);
          end;

          if LastX-x=Radius-1 then
          begin
            Inc(LastX); if LastX>=Width then LastX := Width-1;
            with AveX[LastX] do
            begin
              Inc(Ave.cR, cR);
              Inc(Ave.cG, cG);
              Inc(Ave.cB, cB);
              Inc(Ave.c, c);
            end;
          end;

          {  The average is written.  }
          case BitCount of
            1 : begin
                  P := @PArrayByte(DestP)[X shr 3];
                  with Ave do
                    P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(((cR+cG+cB) div c) div 3>127)) shl Shift1[X and 7]);
                end;
            4 : begin
                  P := @PArrayByte(DestP)[X shr 1];
                  with Ave do
                    P^ := (P^ and Mask4n[X and 1]) or (((((cR+cG+cB) div c) div 3) shr 4) shl Shift4[X and 1]);
                end;
            8 : begin
                  with Ave do
                    PByte(DestP)^ := ((cR+cG+cB) div c) div 3;
                  Inc(PByte(DestP));
                end;
            16: begin
                  with Ave do
                    PWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
                  Inc(PWORD(DestP));
                end;
            24: begin
                  with PBGR(DestP)^, Ave do
                  begin
                    R := cR div c;
                    G := cG div c;
                    B := cB div c;
                  end;
                  Inc(PBGR(DestP));
                end;
            32: begin
                  with Ave do
                    PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
                  Inc(PDWORD(DestP));
                end;
          end;
        end;

        UpdateProgress(y);
      end;
    finally
      FreeMem(AveX);
    end;
  end;

var
  i, j: Integer;
begin
  if Empty or (Radius=0) then Exit;

  Radius := Abs(Radius);

  StartProgress('Blur');
  try
    Temp := TDIB.Create;
    try
      Temp.Assign(Self);
      SetSize(Width, Height, ABitCount);

      if ABitCount<=8 then
      begin
        FillChar(ColorTable, SizeOf(ColorTable), 0);
        for i:=0 to (1 shl ABitCount)-1 do
        begin
          j := i * (1 shl (8-ABitCount));
          j := j or (j shr ABitCount);
          ColorTable[i] := RGBQuad(j, j, j);
        end;
        UpdatePalette;
      end;

      Blur_Radius_Other;
    finally
      Temp.Free;
    end;
  finally
    EndProgress;
  end;
end;

procedure TDIB.Greyscale(ABitCount: Integer);
var
  YTblR, YTblG, YTblB: array[0..255] of Byte;
  i, j, x, y: Integer;
  c: DWORD;
  R, G, B: Byte;
  Temp: TDIB;
  DestP, SrcP: Pointer;
  P: PByte;
begin
  if Empty then exit;

  Temp := TDIB.Create;
  try
    Temp.Assign(Self);
    SetSize(Width, Height, ABitCount);

    if ABitCount<=8 then
    begin
      FillChar(ColorTable, SizeOf(ColorTable), 0);
      for i:=0 to (1 shl ABitCount)-1 do
      begin
        j := i * (1 shl (8-ABitCount));
        j := j or (j shr ABitCount);
        ColorTable[i] := RGBQuad(j, j, j);
      end;
      UpdatePalette;
    end;

    for i:=0 to 255 do
    begin
      YTblR[i] := Trunc(0.3588*i);
      YTblG[i] := Trunc(0.4020*i);
      YTblB[i] := Trunc(0.2392*i);
    end;

    c := 0;

    StartProgress('Greyscale');
    try
      for y:=0 to Height-1 do
      begin
        DestP := ScanLine[y];
        SrcP := Temp.ScanLine[y];

        for x:=0 to Width-1 do
        begin
          case Temp.BitCount of
            1 : begin
                  with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
                    c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
                end;
            4 : begin
                  with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
                    c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
                end;
            8 : begin
                  with Temp.ColorTable[PByte(SrcP)^] do
                    c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
                  Inc(PByte(SrcP));
                end;
            16: begin
                  pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
                  c := YTblR[R]+YTblR[G]+YTblR[B];
                  Inc(PWord(SrcP));
                end;
            24: begin
                  with PBGR(SrcP)^ do
                    c := YTblR[R]+YTblG[G]+YTblB[B];
                  Inc(PBGR(SrcP));
                end;
            32: begin
                  pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
                  c := YTblR[R]+YTblR[G]+YTblR[B];
                  Inc(PDWORD(SrcP));
                end;
          end;

          case BitCount of
            1 : begin
                  P := @PArrayByte(DestP)[X shr 3];
                  P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(c>127)) shl Shift1[X and 7]);
                end;
            4 : begin
                  P := @PArrayByte(DestP)[X shr 1];
                  P^ := (P^ and Mask4n[X and 1]) or ((c shr 4) shl Shift4[X and 1]);
                end;
            8 : begin
                  PByte(DestP)^ := c;
                  Inc(PByte(DestP));
                end;
            16: begin
                  PWord(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
                  Inc(PWord(DestP));
                end;
            24: begin
                  with PBGR(DestP)^ do
                  begin
                    R := c;
                    G := c;
                    B := c;
                  end;
                  Inc(PBGR(DestP));
                end;
            32: begin
                  PDWORD(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
                  Inc(PDWORD(DestP));
                end;
          end;
        end;

        UpdateProgress(y);
      end;
    finally
      EndProgress;
    end;
  finally
    Temp.Free;
  end;
end;

procedure TDIB.Mirror(MirrorX, MirrorY: Boolean);
var
  x, y, Width2, c: Integer;
  P1, P2, TempBuf: Pointer;
begin
  if Empty then exit;
  if (not MirrorX) and (not MirrorY) then Exit;

  if (not MirrorX) and (MirrorY) then
  begin
    GetMem(TempBuf, WidthBytes);
    try
      StartProgress('Mirror');
      try
        for y:=0 to Height shr 1-1 do
        begin
          P1 := ScanLine[y];
          P2 := ScanLine[Height-y-1];

          Move(P1^, TempBuf^, WidthBytes);
          Move(P2^, P1^, WidthBytes);
          Move(TempBuf^, P2^, WidthBytes);

          UpdateProgress(y*2);
        end;
      finally
        EndProgress;
      end;
    finally
      FreeMem(TempBuf, WidthBytes);
    end;
  end else if (MirrorX) and (not MirrorY) then
  begin
    Width2 := Width shr 1;

    StartProgress('Mirror');
    try
      for y:=0 to Height-1 do
      begin
        P1 := ScanLine[y];

        case BitCount of
          1 : begin
                for x:=0 to Width2-1 do
                begin
                  c := Pixels[x, y];
                  Pixels[x, y] := Pixels[Width-x-1, y];
                  Pixels[Width-x-1, y] := c;
                end;
              end;
          4 : begin
                for x:=0 to Width2-1 do
                begin
                  c := Pixels[x, y];
                  Pixels[x, y] := Pixels[Width-x-1, y];
                  Pixels[Width-x-1, y] := c;
                end;
              end;
          8 : begin
                P2 := Pointer(Integer(P1)+Width-1);
                for x:=0 to Width2-1 do
                begin
                  PByte(@c)^ := PByte(P1)^;
                  PByte(P1)^ := PByte(P2)^;
                  PByte(P2)^ := PByte(@c)^;
                  Inc(PByte(P1));
                  Dec(PByte(P2));
                end;
              end;
          16: begin
                P2 := Pointer(Integer(P1)+(Width-1)*2);
                for x:=0 to Width2-1 do
                begin
                  PWord(@c)^ := PWord(P1)^;
                  PWord(P1)^ := PWord(P2)^;
                  PWord(P2)^ := PWord(@c)^;
                  Inc(PWord(P1));
                  Dec(PWord(P2));
                end;       
              end;
          24: begin
                P2 := Pointer(Integer(P1)+(Width-1)*3);
                for x:=0 to Width2-1 do              
                begin
                  PBGR(@c)^ := PBGR(P1)^;
                  PBGR(P1)^ := PBGR(P2)^;
                  PBGR(P2)^ := PBGR(@c)^;
                  Inc(PBGR(P1));
                  Dec(PBGR(P2));
                end;
              end;
          32: begin
                P2 := Pointer(Integer(P1)+(Width-1)*4);
                for x:=0 to Width2-1 do
                begin
                  PDWORD(@c)^ := PDWORD(P1)^;
                  PDWORD(P1)^ := PDWORD(P2)^;
                  PDWORD(P2)^ := PDWORD(@c)^;
                  Inc(PDWORD(P1));
                  Dec(PDWORD(P2));
                end;
              end;
        end;

        UpdateProgress(y);
      end;
    finally
      EndProgress;
    end;
  end else if (MirrorX) and (MirrorY) then
  begin
    StartProgress('Mirror');
    try
      for y:=0 to Height shr 1-1 do
      begin
        P1 := ScanLine[y];
        P2 := ScanLine[Height-y-1];

        case BitCount of
          1 : begin
                for x:=0 to Width-1 do
                begin
                  c := Pixels[x, y];
                  Pixels[x, y] := Pixels[Width-x-1, Height-y-1];
                  Pixels[Width-x-1, Height-y-1] := c;
                end;
              end;
          4 : begin
                for x:=0 to Width-1 do
                begin
                  c := Pixels[x, y];
                  Pixels[x, y] := Pixels[Width-x-1, Height-y-1];
                  Pixels[Width-x-1, Height-y-1] := c;
                end;
              end;
          8 : begin
                P2 := Pointer(Integer(P2)+Width-1);
                for x:=0 to Width-1 do
                begin
                  PByte(@c)^ := PByte(P1)^;
                  PByte(P1)^ := PByte(P2)^;
                  PByte(P2)^ := PByte(@c)^;
                  Inc(PByte(P1));
                  Dec(PByte(P2));
                end;
              end;
          16: begin
                P2 := Pointer(Integer(P2)+(Width-1)*2);
                for x:=0 to Width-1 do
                begin
                  PWord(@c)^ := PWord(P1)^;
                  PWord(P1)^ := PWord(P2)^;
                  PWord(P2)^ := PWord(@c)^;
                  Inc(PWord(P1));
                  Dec(PWord(P2));
                end;
              end;
          24: begin
                P2 := Pointer(Integer(P2)+(Width-1)*3);
                for x:=0 to Width-1 do
                begin
                  PBGR(@c)^ := PBGR(P1)^;
                  PBGR(P1)^ := PBGR(P2)^;
                  PBGR(P2)^ := PBGR(@c)^;
                  Inc(PBGR(P1));
                  Dec(PBGR(P2));
                end;
              end;
          32: begin
                P2 := Pointer(Integer(P2)+(Width-1)*4);
                for x:=0 to Width-1 do
                begin
                  PDWORD(@c)^ := PDWORD(P1)^;
                  PDWORD(P1)^ := PDWORD(P2)^;
                  PDWORD(P2)^ := PDWORD(@c)^;
                  Inc(PDWORD(P1));
                  Dec(PDWORD(P2));
                end;
              end;
        end;

        UpdateProgress(y*2);
      end;
    finally
      EndProgress;
    end;
  end;
end;

procedure TDIB.NegativeASM(Size: NativeInt; P:Pointer);assembler;
{$IFDEF CPUX64}
asm
  mov rdx,rcx
  mov rax,rbx

{  Unit of QWORD.  }
@@xword_skip:
  shr rcx,2
  jz @@qword_skip

  dec rcx
@@qword_loop:
  not qword ptr [rax+rcx*4]
  dec rcx
  jnl @@qword_loop

  mov rcx,rdx
  shr rcx,2
  add rax,rcx*4

{  Unit of Byte.  }
@@qword_skip:
  mov rcx,rdx
  and rcx,3
  jz @@byte_skip

  dec rcx
@@loop_byte:
  not byte ptr [rax+rcx]
  dec rcx
  jnl @@loop_byte

@@byte_skip:
end;

{$ELSE}
asm
  mov edx,eax
  mov eax,ebx

{  Unit of DWORD.  }
@@qword_skip:
  shr ecx,2
  jz @@dword_skip

  dec ecx
@@dword_loop:
  not dword ptr [eax+ecx*4]
  dec ecx
  jnl @@dword_loop

  mov ecx,edx
  shr ecx,2
  add eax,ecx*4

{  Unit of Byte.  }
@@dword_skip:
  mov ecx,edx
  and ecx,3
  jz @@byte_skip

  dec ecx
@@loop_byte:
  not byte ptr [eax+ecx]
  dec ecx
  jnl @@loop_byte

@@byte_skip:
end;
{$ENDIF}


procedure TDIB.Negative;
var
  i, i2: Integer;
  P: Pointer;
begin
  p := nil;
  if Empty then exit;

  if BitCount<=8 then
  begin
    for i:=0 to 255 do
      with ColorTable[i] do
      begin
        rgbRed := 255-rgbRed;
        rgbGreen := 255-rgbGreen;
        rgbBlue := 255-rgbBlue;
      end;
    UpdatePalette;
  end else
  begin
{$IFNDEF INLINEASM}
  self.NegativeASM(Size, P);
{$ELSE}
    P := PBits;
    i2 := Size;
    asm
      mov ecx,i2
      mov eax,P
      mov edx,ecx

    {  Unit of DWORD.  }
    @@qword_skip:
      shr ecx,2
      jz @@dword_skip

      dec ecx
    @@dword_loop:
      not dword ptr [eax+ecx*4]
      dec ecx
      jnl @@dword_loop

      mov ecx,edx
      shr ecx,2
      add eax,ecx*4

    {  Unit of Byte.  }
    @@dword_skip:
      mov ecx,edx
      and ecx,3
      jz @@byte_skip

      dec ecx
    @@loop_byte:
      not byte ptr [eax+ecx]
      dec ecx
      jnl @@loop_byte

    @@byte_skip:
    end;
{$ENDIF}
  end;

end;

{  TCustomDXDIB  }

constructor TCustomDXDIB.Create(AOnwer: TComponent);
begin
  inherited Create(AOnwer);
  FDIB := TDIB.Create;
end;

destructor TCustomDXDIB.Destroy;
begin
  FDIB.Free;
  inherited Destroy;
end;

procedure TCustomDXDIB.SetDIB(Value: TDIB);
begin
  FDIB.Assign(Value);
end;

{  TCustomDXPaintBox  }

constructor TCustomDXPaintBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDIB := TDIB.Create;

  ControlStyle := ControlStyle + [csReplicatable];
  Height := 105;
  Width := 105;
end;

destructor TCustomDXPaintBox.Destroy;
begin
  FDIB.Free;
  inherited Destroy;
end;

function TCustomDXPaintBox.GetPalette: HPALETTE;
begin
  Result := FDIB.Palette;
end;

procedure TCustomDXPaintBox.Paint;

  procedure Draw2(Width, Height: Integer);
  begin
    if (Width<>FDIB.Width) or (Height<>FDIB.Height) then
    begin
      if FCenter then
      begin
        inherited Canvas.StretchDraw(Bounds(-(Width-ClientWidth) div 2,
          -(Height-ClientHeight) div 2, Width, Height), FDIB);
      end else
      begin
        inherited Canvas.StretchDraw(Bounds(0, 0, Width, Height), FDIB);
      end;
    end else
    begin
      if FCenter then
      begin
        inherited Canvas.Draw(-(Width-ClientWidth) div 2, -(Height-ClientHeight) div 2,
          FDIB);
      end else
      begin
        inherited Canvas.Draw(0, 0, FDIB);
      end;
    end;
  end;

var
  r, r2: Single;
  ViewWidth2, ViewHeight2: Integer;
begin
  inherited Paint;

  with inherited Canvas do
  begin
    if (csDesigning in ComponentState) then
    begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;

    if FDIB.Empty then Exit;

    if (FViewWidth>0) or (FViewHeight>0) then
    begin
      ViewWidth2 := FViewWidth;
      if ViewWidth2=0 then ViewWidth2 := FDIB.Width;
      ViewHeight2 := FViewHeight;
      if ViewHeight2=0 then ViewHeight2 := FDIB.Height;

      if FAutoStretch then
      begin
        if (ClientWidth<ViewWidth2) or (ClientHeight<ViewHeight2) then
        begin
          r := ViewWidth2/ClientWidth;
          r2 := ViewHeight2/ClientHeight;
          if r>r2 then
            r := r2;
          Draw2(Round(r*ClientWidth), Round(r*ClientHeight));
        end else
          Draw2(ViewWidth2, ViewHeight2);
      end else
        Draw2(ViewWidth2, ViewHeight2);
    end else
    begin
      if FAutoStretch then
      begin
        if (FDIB.Width>ClientWidth) or (FDIB.Height>ClientHeight) then
        begin
          r := ClientWidth/FDIB.Width;
          r2 := ClientHeight/FDIB.Height;
          if r>r2 then
            r := r2;
          Draw2(Round(r*FDIB.Width), Round(r*FDIB.Height));
        end else
          Draw2(FDIB.Width, FDIB.Height);
      end else
      if FStretch then
      begin
        if FKeepAspect then
        begin
          r := ClientWidth/FDIB.Width;
          r2 := ClientHeight/FDIB.Height;
          if r>r2 then
            r := r2;
          Draw2(Round(r*FDIB.Width), Round(r*FDIB.Height));
        end else
          Draw2(ClientWidth, ClientHeight);
      end else
        Draw2(FDIB.Width, FDIB.Height);
    end;
  end;
end;

procedure TCustomDXPaintBox.SetAutoStretch(Value: Boolean);
begin
  if FAutoStretch<>Value then
  begin
    FAutoStretch := Value;
    Invalidate;
  end;
end;

procedure TCustomDXPaintBox.SetCenter(Value: Boolean);
begin
  if FCenter<>Value then
  begin
    FCenter := Value;
    Invalidate;
  end;
end;

procedure TCustomDXPaintBox.SetDIB(Value: TDIB);
begin
  if FDIB<>Value then
  begin
    FDIB.Assign(Value);
    Invalidate;
  end;
end;

procedure TCustomDXPaintBox.SetKeepAspect(Value: Boolean);
begin
  if Value<>FKeepAspect then
  begin
    FKeepAspect := Value;
    Invalidate;
  end;
end;

procedure TCustomDXPaintBox.SetStretch(Value: Boolean);
begin
  if Value<>FStretch then
  begin
    FStretch := Value;
    Invalidate;
  end;
end;

procedure TCustomDXPaintBox.SetViewWidth(Value: Integer);
begin
  if Value<0 then Value := 0;
  if Value<>FViewWidth then
  begin
    FViewWidth := Value;
    Invalidate;
  end;
end;

procedure TCustomDXPaintBox.SetViewHeight(Value: Integer);
begin
  if Value<0 then Value := 0;
  if Value<>FViewHeight then
  begin
    FViewHeight := Value;
    Invalidate;
  end;
end;

initialization
  TPicture.RegisterClipBoardFormat(CF_DIB, TDIB);
  TPicture.RegisterFileFormat('dib', 'Device Independent Bitmap', TDIB);
finalization
  TPicture.UnRegisterGraphicClass(TDIB);

  FEmptyDIBImage.Free;
  FPaletteManager.Free;
end.