{************************************************************}
{                   Delphi VCL Extensions                    }
{                                                            }
{                   Bitmap files TGrapic class               }
{                                                            }
{      Copyright (c) 2002-2013 SoftGold software company     }
{                                                            }
{************************************************************}
unit sgBitmap;

interface

{$INCLUDE SGDXF.INC}

uses Windows, SysUtils, Classes, Graphics, MVFont, sgConsts, Math
  {$IFDEF SGFPC}
    , LCLType
  {$ENDIF}
  ;

type

  TsgBitmapImage = class;

  { TsgBitmap }

  TsgBitmap = class(TGraphic)
  private
    FHeight: Word;
    FImg: TsgBitmapImage;
    FOnRotate: TNotifyEvent;
    FPixelFormat: TPixelFormat;
    FWidth: Word;
    procedure AssignBM(ABitmap: TBitmap);
    function GetROP: Byte;
    function GetScanLine(ARow: Integer): Pointer;
    function GetInfoSize: Integer;
    function InfoSize: Integer;
    procedure NewImage;
    procedure SetPixelFormat(AValue: TPixelFormat);
    procedure SetROP(AValue: Byte);
    procedure Update;
    function GetRowData: Pointer;
  protected
    FROP: Integer;
    procedure AssignTo(ADest: TPersistent); override;
    procedure CopyBitmapImage;
    procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
    procedure DoExceptionNotImplemented;
    procedure NewBitmapImage;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure SetHeight(AValue: Integer); override;
    procedure SetWidth(AValue: Integer); override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(ASource: TPersistent); override;
    procedure Flip;
    function GetColors(AColors: Pointer): Integer;
    procedure LoadFromClipboardFormat(AFmt: Word; AData: THandle; APal: HPALETTE); {$IFNDEF SGFPC} override;{$ENDIF}
    procedure LoadFromStream(AStream: TStream); override;
    procedure Rotate(const AAngle: Integer);
    function RowSize: Integer;
    procedure SaveToClipboardFormat(var AFmt: Word; var AData: THandle; var APal: HPALETTE); {$IFNDEF SGFPC} override;{$ENDIF}
    procedure SaveToFile(const FileName: String); override;
    procedure SaveToStream(AStream: TStream); override;
    procedure SetColors(AColors: Pointer);
    property ImageData: TsgBitmapImage read FImg;
    property OnRotate: TNotifyEvent read FOnRotate write FOnRotate;
    property PixelFormat: TPixelFormat read FPixelFormat write SetPixelFormat;
    property ROP: Byte read GetROP write SetROP;
    property ScanLine[Row: Integer]: Pointer read GetScanLine;
    property RowData: Pointer read GetRowData;
  end;

  TsgBitmapImage = class(TSharedImage)
  protected
    FData: Pointer;
    FInfo: Windows.PBitmapInfo;
    procedure FreeHandle; override;
  public
    procedure Assign(ASource: TsgBitmapImage);
    property Data: Pointer read FData;
    property Info: Windows.PBitmapInfo read FInfo;
  end;

  { TsgBMAdapter }

  TsgBMAdapter = class(TGraphic)
  private
    FOwned: TGraphic;
    FSource: TGraphic;
    FBitmap: TBitmap;
    function BM: TBitmap;
    procedure ForceBM;
    procedure ForceSG;
    function GetCanvas: TCanvas;
    function GetHandleType: TBitmapHandleType;
    function GetPixelFormat: TPixelFormat;
    function GetROP: Integer;
    function GetScanLine(ARow: Integer): Pointer;
    function GetSource: TGraphic;
    function GetBitmap: TBitmap;
    function IsBM: Boolean;
    function IsSG: Boolean;
    procedure SetHandleType(AValue: TBitmapHandleType);
    procedure SetOwned(AValue: TGraphic);
    procedure SetPixelFormat(AValue: TPixelFormat);
    procedure SetROP(AValue: Integer);
    procedure SetSource(AValue: TGraphic);
    function SG: TsgBitmap;
  protected
    procedure AssignTo(ADest: TPersistent); override;
    procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    {$IFDEF SGFPC}
    function GetTransparent: Boolean; override;
    {$ENDIF}
    procedure SetHeight(AValue: Integer); override;
    procedure SetWidth(AValue: Integer); override;
    {$IFDEF SGFPC}
    procedure SetTransparent(Value: Boolean); override;
    {$ENDIF}
    property Owned: TGraphic read FOwned write SetOwned;
    property Source: TGraphic read GetSource write SetSource;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(ASrc: TPersistent); override;
    function GetColorTable(APoint: Pointer): Integer;
    procedure LoadFromClipboardFormat(AFmt:{$IFDEF SGFPC}TClipboardFormat{$ELSE}Word;
       AData: THandle; APal: HPALETTE{$ENDIF}); override;
    procedure LoadFromStream(AStream: TStream); override;
    procedure Rotate(AAngle: Integer);
    procedure SaveToClipboardFormat({$IFNDEF SGFPC}var {$ENDIF} AFmt:{$IFDEF SGFPC}TClipboardFormat{$ELSE}Word;
      var AData: THandle; var APal: HPALETTE{$ENDIF}); override;
    procedure SaveToStream(AStream: TStream); override;
    property Bitmap: TBitmap read GetBitmap;
    property Canvas: TCanvas read GetCanvas;
    property HandleType: TBitmapHandleType read GetHandleType write SetHandleType;
    property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
    property ROP: Integer read GetROP write SetROP;
    property ScanLine[Row: Integer]: Pointer read GetScanLine;
  end;

{$IFDEF SGFPC}
function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
{$ENDIF}

implementation

uses
  sgFunction;

const

  ROPs: array[Byte] of Word =
  ($0042, $0289, $0C89, $00AA, $0C88, $00A9, $0865, $02C5,
   $0F08, $0245, $0329, $0B2A, $0324, $0B25, $08A5, $0001,
   $0C85, $00A6, $0868, $02C8, $0869, $02C9, $5CCA, $1D54,
   $0D59, $1CC8, $06C5, $0768, $06CA, $0766, $01A5, $0385,
   $0F09, $0248, $0326, $0B24, $0D55, $1CC5, $06C8, $1868,
   $0369, $16CA, $0CC9, $1D58, $0784, $060A, $064A, $0E2A,
   $032A, $0B28, $0688, $0008, $06C4, $1864, $01A8, $0388,
   $078A, $0604, $0644, $0E24, $004A, $18A4, $1B24, $00EA,
   $0F0A, $0249, $0D5D, $1CC4, $0328, $0B29, $06C6, $076A,
   $0368, $16C5, $0789, $0605, $0CC8, $1954, $0645, $0E25,
   $0325, $0B26, $06C9, $0764, $08A9, $0009, $01A9, $0389,
   $0785, $0609, $0049, $18A9, $0649, $0E29, $1B29, $00E9,
   $0365, $16C6, $0786, $0608, $0788, $0606, $0046, $18A8,
   $58A6, $0145, $01E9, $178A, $01E8, $1785, $1E28, $0C65,
   $0CC5, $1D5C, $0648, $0E28, $0646, $0E26, $1B28, $00E6,
   $01E5, $1786, $1E29, $0C68, $1E24, $0C69, $0955, $03C9,
   $03E9, $0975, $0C49, $1E04, $0C48, $1E05, $17A6, $01C5,
   $00C6, $1B08, $0E06, $0666, $0E08, $0668, $1D7C, $0CE5,
   $0C45, $1E08, $17A9, $01C4, $17AA, $01C9, $0169, $588A,
   $1888, $0066, $0709, $07A8, $0704, $07A6, $16E6, $0345,
   $00C9, $1B05, $0E09, $0669, $1885, $0065, $0706, $07A5,
   $03A9, $0189, $0029, $0889, $0744, $06E9, $0B06, $0229,
   $0E05, $0665, $1974, $0CE8, $070A, $07A9, $16E9, $0348,
   $074A, $06E6, $0B09, $0226, $1CE4, $0D7D, $0269, $08C9,
   $00CA, $1B04, $1884, $006A, $0E04, $0664, $0708, $07AA,
   $03A8, $0184, $0749, $06E4, $0020, $0888, $0B08, $0224,
   $0E0A, $066A, $0705, $07A4, $1D78, $0CE9, $16EA, $0349,
   $0745, $06E8, $1CE9, $0D75, $0B04, $0228, $0268, $08C8,
   $03A5, $0185, $0746, $06EA, $0748, $06E5, $1CE8, $0D79,
   $1D74, $5CE6, $02E9, $0849, $02E8, $0848, $0086, $0A08,
   $0021, $0885, $0B05, $022A, $0B0A, $0225, $0265, $08C5,
   $02E5, $0845, $0089, $0A09, $008A, $0A0A, $02A9, $0062);

  cnstBPPs: array[TPixelFormat] of Byte = (0,1,4,8,16,16,24,32,0);

type

  TRotateData = record
    Dst: PByte;
    Src: PByte;
    ISrc: Integer;
    DSrc: Integer;
    Count: Integer;
  end;

  TRowProc = procedure(var Data: TRotateData; PrepProc: Pointer);

{assembler inserts}

procedure PrepareRow;
{$IFDEF SG_CPUX64}
asm
  MOV RAX, RCX
	MOVSX	RCX,[RAX].TRotateData.Count;
	MOVSX RDX,[RAX].TRotateData.DSrc;
	MOVSX	RSI,[RAX].TRotateData.ISrc;
	MOV	RDI,[RAX].TRotateData.Dst;
	MOV	RAX,[RAX].TRotateData.Src;
end;
{$ELSE}
asm
	MOV	ECX,[EAX].TRotateData.Count;
	MOV	EDX,[EAX].TRotateData.DSrc;
	MOV	ESI,[EAX].TRotateData.ISrc;
	MOV	EDI,[EAX].TRotateData.Dst;
	MOV	EAX,[EAX].TRotateData.Src;
end;
{$ENDIF}

procedure Row01(var Data: TRotateData; PrepProc: Pointer);
asm
{$IFDEF SG_CPUX64}
	PUSH	RBX
	PUSH	RSI
	PUSH	RDI
	CALL	RDX
	MOV	RBX,$8080
	PUSH	RCX
	MOV	RCX,RSI
	AND	CL,7
	SHR	BL,CL
	POP	RCX
	SHR	RSI,3
	ADD	RSI,RAX
@@1:	TEST	[RSI],BL
	JZ	@@2
	OR	[RDI],BH
@@2:	ROR	BH,1
	ADC	RDI,0
	ADD	RSI,RDX
	DEC	RCX
	JNZ	@@1
	POP	RDI
	POP	RSI
	POP	RBX
{$ELSE}
	PUSH	EBX
	PUSH	ESI
	PUSH	EDI
	CALL	EDX
	MOV	EBX,$8080
	PUSH	ECX
	MOV	ECX,ESI
	AND	CL,7
	SHR	BL,CL
	POP	ECX
	SHR	ESI,3
	ADD	ESI,EAX
@@1:	TEST	[ESI],BL
	JZ	@@2
	OR	[EDI],BH
@@2:	ROR	BH,1
	ADC	EDI,0
	ADD	ESI,EDX
	DEC	ECX
	JNZ	@@1
	POP	EDI
	POP	ESI
	POP	EBX
{$ENDIF}
end;

procedure Row01H(var Data: TRotateData; PrepProc: Pointer);
asm
{$IFDEF SG_CPUX64}
	PUSH	RBX
	PUSH	RSI
	PUSH	RDI
	CALL	RDX
	MOV	RBX,$8080
	PUSH	RCX
	MOV	RCX,RSI
	AND	CL,7
	SHR	BL,CL
	POP	RCX
	SHR	RSI,3
	ADD	RSI,RAX
@@1:	TEST	[RSI],BL
	JZ	@@2
	OR	[RDI],BH
@@2:	ROR	BH,1
	ADC	RDI,0
	ROL	BL,1
	SBB	RSI,0
	DEC	RCX
	JNZ	@@1
	POP	RDI
	POP	RSI
	POP	RBX
{$ELSE}
	PUSH	EBX
	PUSH	ESI
	PUSH	EDI
	CALL	EDX
	MOV	EBX,$8080
	PUSH	ECX
	MOV	ECX,ESI
	AND	CL,7
	SHR	BL,CL
	POP	ECX
	SHR	ESI,3
	ADD	ESI,EAX
@@1:	TEST	[ESI],BL
	JZ	@@2
	OR	[EDI],BH
@@2:	ROR	BH,1
	ADC	EDI,0
	ROL	BL,1
	SBB	ESI,0
	DEC	ECX
	JNZ	@@1
	POP	EDI
	POP	ESI
	POP	EBX
{$ENDIF}
end;

procedure Row04(var Data: TRotateData; PrepProc: Pointer);
asm
{$IFDEF SG_CPUX64}
	PUSH	RBX
	PUSH	RSI
	PUSH	RDI
	CALL	RDX
	MOV	RBX,$F0F0
	SHR	RSI,1
	JNC	@@1
	NOT	BL
@@1:	ADD	RSI,RAX
@@2:	MOV	AL,[RSI]
	AND	AL,BL
	MOV	AH,AL
	ROR	AH,4
	OR	AL,AH
	AND	AL,BH
	OR	[RDI],AL
	ROR	BH,4
	ADC	RDI,0
	ADD	RSI,RDX
	DEC	RCX
	JNZ	@@2
	POP	RDI
	POP	RSI
	POP	RBX
{$ELSE}
	PUSH	EBX
	PUSH	ESI
	PUSH	EDI
	CALL	EDX
	MOV	EBX,$F0F0
	SHR	ESI,1
	JNC	@@1
	NOT	BL
@@1:	ADD	ESI,EAX
@@2:	MOV	AL,[ESI]
	AND	AL,BL
	MOV	AH,AL
	ROR	AH,4
	OR	AL,AH
	AND	AL,BH
	OR	[EDI],AL
	ROR	BH,4
	ADC	EDI,0
	ADD	ESI,EDX
	DEC	ECX
	JNZ	@@2
	POP	EDI
	POP	ESI
	POP	EBX
{$ENDIF}
end;

procedure Row04H(var Data: TRotateData; PrepProc: Pointer);
asm
{$IFDEF SG_CPUX64}
	PUSH	RBX
	PUSH	RSI
	PUSH	RDI
	CALL	RDX
	MOV	RBX,$F0F0
	SHR	RSI,1
	JNC	@@1
	NOT	BL
@@1:	ADD	RSI,RAX
@@2:	MOV	AL,[RSI]
	AND	AL,BL
	MOV	AH,AL
	ROR	AH,4
	OR	AL,AH
	AND	AL,BH
	OR	[RDI],AL
	ROR	BH,4
	ADC	RDI,0
	ROL	BL,4
	SBB	RSI,0
	DEC	RCX
	JNZ	@@2
	POP	RDI
	POP	RSI
	POP	RBX
{$ELSE}
	PUSH	EBX
	PUSH	ESI
	PUSH	EDI
	CALL	EDX
	MOV	EBX,$F0F0
	SHR	ESI,1
	JNC	@@1
	NOT	BL
@@1:	ADD	ESI,EAX
@@2:	MOV	AL,[ESI]
	AND	AL,BL
	MOV	AH,AL
	ROR	AH,4
	OR	AL,AH
	AND	AL,BH
	OR	[EDI],AL
	ROR	BH,4
	ADC	EDI,0
	ROL	BL,4
	SBB	ESI,0
	DEC	ECX
	JNZ	@@2
	POP	EDI
	POP	ESI
	POP	EBX
{$ENDIF}
end;

procedure Row08(var Data: TRotateData; PrepProc: Pointer);
asm
{$IFDEF SG_CPUX64}
	PUSH	RSI
	PUSH	RDI
	CALL	RDX
	ADD	RSI,RAX
@@1:	MOV	AL,[RSI]
	MOV	[RDI],AL
	INC	RDI
	ADD	RSI,RDX
	DEC	RCX
	JNZ	@@1
	POP	RDI
	POP	RSI
{$ELSE}
	PUSH	ESI
	PUSH	EDI
	CALL	EDX
	ADD	ESI,EAX
@@1:	MOV	AL,[ESI]
	MOV	[EDI],AL
	INC	EDI
	ADD	ESI,EDX
	DEC	ECX
	JNZ	@@1
	POP	EDI
	POP	ESI
{$ENDIF}
end;

procedure Row16(var Data: TRotateData; PrepProc: Pointer);
asm
{$IFDEF SG_CPUX64}
	PUSH	RSI
	PUSH	RDI
	CALL	RDX
	LEA	ESI,[RAX][RSI*2]
@@1:	MOV	AX,[RSI]
	MOV	[RDI],AX
	ADD	RDI,2
	ADD	RSI,RDX
	DEC	RCX
	JNZ	@@1
	POP	RDI
	POP	RSI
{$ELSE}
	PUSH	ESI
	PUSH	EDI
	CALL	EDX
	LEA	ESI,[EAX][ESI*2]
@@1:	MOV	AX,[ESI]
	MOV	[EDI],AX
	ADD	EDI,2
	ADD	ESI,EDX
	DEC	ECX
	JNZ	@@1
	POP	EDI
	POP	ESI
{$ENDIF}
end;

procedure Row24(var Data: TRotateData; PrepProc: Pointer);
asm
{$IFDEF SG_CPUX64}
	PUSH	RSI
	PUSH	RDI
	CALL	RDX
	LEA	RSI,[ESI][ESI*2]
  ADD RSI,RAX
@@1:	MOV	AX,[RSI]
	MOV	[RDI],AX
	MOV	AL,2[RSI]
	MOV	2[RDI],AL
	ADD	RDI,3
	ADD	RSI,RDX
	DEC	RCX
	JNZ	@@1
	POP	RDI
	POP	RSI
{$ELSE}
	PUSH	ESI
	PUSH	EDI
	CALL	EDX
	LEA	ESI,[ESI][ESI * 2]
	ADD	ESI,EAX
@@1:	MOV	AX,[ESI]
	MOV	[EDI],AX
        MOV	AL,[ESI + 2]
	MOV	[EDI + 2],AL
	ADD	EDI,3
	ADD	ESI,EDX
	DEC	ECX
	JNZ	@@1
	POP	EDI
	POP	ESI
{$ENDIF}
end;

procedure Row32(var Data: TRotateData; PrepProc: Pointer);
asm
{$IFDEF SG_CPUX64}
	PUSH	RSI
	PUSH	RDI
	CALL	RDX
	LEA	ESI,[RAX][RSI*4]
@@1:	MOV	RAX,[RSI]
	MOV	[RDI],RAX
	ADD	RDI,4
	ADD	RSI,RDX
	DEC	RCX
	JNZ	@@1
	POP	RDI
	POP	RSI
{$ELSE}
	PUSH	ESI
	PUSH	EDI
	CALL	EDX
	LEA	ESI,[EAX][ESI*4]
@@1:	MOV	EAX,[ESI]
	MOV	[EDI],EAX
	ADD	EDI,4
	ADD	ESI,EDX
	DEC	ECX
	JNZ	@@1
	POP	EDI
	POP	ESI
{$ENDIF}
end;

{$IFDEF SGFPC}
procedure InvalidBitmap;
begin
  Exception.Create('Invalid Bitmap')
end;

procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
  Colors: Integer);
var
  DS: TDIBSection;
  Bytes: Integer;
begin
  DS.dsbmih.biSize := 0;
  Bytes := GetObject(Bitmap, SizeOf(DS), @DS);
  if Bytes = 0 then InvalidBitmap
  else if (Bytes >= (SizeOf(DS.dsbm) + SizeOf(DS.dsbmih))) and
    (DS.dsbmih.biSize >= DWORD(SizeOf(DS.dsbmih))) then
    BI := DS.dsbmih
  else
  begin
    FillChar(BI, SizeOf(BI), 0);
    with BI, DS.dsbm do
    begin
      biSize := SizeOf(BI);
      biWidth := bmWidth;
      biHeight := bmHeight;
    end;
  end;
  case Colors of
    2: BI.biBitCount := 1;
    3..16:
      begin
        BI.biBitCount := 4;
        BI.biClrUsed := Colors;
      end;
    17..256:
      begin
        BI.biBitCount := 8;
        BI.biClrUsed := Colors;
      end;
  else
    BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
  end;
  BI.biPlanes := 1;
  if BI.biClrImportant > BI.biClrUsed then
    BI.biClrImportant := BI.biClrUsed;
  if BI.biSizeImage = 0 then
    BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
end;

function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
var
  OldPal: HPALETTE;
  DC: HDC;
begin
  InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), 0);
  OldPal := 0;
  DC := CreateCompatibleDC(0);
  try
    if Palette <> 0 then
    begin
      OldPal := SelectPalette(DC, Palette, False);
      RealizePalette(DC);
    end;
    Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
      Windows.TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
  finally
    if OldPal <> 0 then SelectPalette(DC, OldPal, False);
    DeleteDC(DC);
  end;
end;

function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
begin
  Dec(Alignment);
  Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
  Result := Result div 8;
end;
{$ENDIF}


{procedure ReadBytes(var PBit: TsgInt64; var Dest; Count: Integer); register;
var
  Src: PByte;
  Next: WordRec;
  Shift: Byte;
  P: PByte;
begin
  Integer(Src) := PBit.Lo shr 3 or PBit.Hi shl 29;
  Shift := PBit.Lo and 7;
  Inc2(PBit, Count shl 3);
  P := @Dest;
  while Count > 0 do
  begin
    Next.Hi := Src^;
    Inc(Src);
    Next.Lo := Src^;
    Word(Next) := Word(Next) shl Shift;
    P^ := Next.Hi;
    Inc(P);
    Dec(Count);
  end;
end;}
//procedure ReadBytes(var PBit: TsgInt64; var Dest; Count: Integer); register;
//asm
//{$IFDEF SG_CPUX64}
//{$ELSE}
//    PUSH    EBX
//    PUSH    ESI
//    PUSH    EDI
//    MOV     EBX,ECX
//    MOV     EDI,EDX
//    MOV     EDX,EAX
//    MOV     EAX,[EDX]
//    MOV	    ECX,4[EDX]
//    MOV     ESI,EAX
//    SHRD    ESI,ECX,3
//    AND     AL,7
//    MOV     CL,AL
//    MOV     EAX,EBX
//    SHL     EAX,3
//    ADD     [EDX],EAX
//    ADC	    DWORD PTR 4[EDX],0
//@@1:        MOV     AX,[ESI]
//    XCHG    AL,AH
//    SHL     AX,CL
//    MOV     [EDI],AH
//    INC     ESI
//    INC     EDI
//    DEC     EBX
//    JNZ     @@1
//    POP     EDI
//    POP     ESI
//    POP     EBX
//{$ENDIF}
//end;
//
//procedure Inc2(var PBit: TsgInt64; Value: Integer);
//asm
//	ADD	[EAX],EDX
//	ADC	DWORD PTR 4[EAX],0
//end;

{ TsgBitmap }

{private}

procedure TsgBitmap.AssignBM(ABitmap: TBitmap);
var
//  I: Integer;
  vHandleGdiObject: HGDIOBJ;
  vDC: HDC;
  vPByte: PByte;
begin
  ABitmap.HandleType := bmDIB;
  FWidth := ABitmap.Width;
  FHeight := ABitmap.Height;
  FPixelFormat := ABitmap.PixelFormat;
  FROP := SRCCOPY;
  Update;
  if PixelFormat <= pf8bit then
  begin
    vPByte := PByte(FImg.FInfo);
    Inc(vPByte, SizeOf(TBitmapInfoHeader));
    vDC := CreateCompatibleDC(0);
    vHandleGdiObject := SelectObject(vDC, ABitmap.Handle);
    GetDIBColorTable(vDC, 0, 256, vPByte^);
    SelectObject(vDC,vHandleGdiObject);
    DeleteDC(vDC);
  end;
  GetDIB(ABitmap.Handle, ABitmap.Palette, FImg.FInfo^, PPointer(FImg.FData)^);
//  vHandleGdiObject := RowSize;
//  for I := 0 to Height - 1 do
//    Move(ABitmap.ScanLine[I]^, ScanLine[I]^, vHandleGdiObject);
end;

function TsgBitmap.GetROP: Byte;
begin
  Result := LongRec(FROP).Hi;
end;

function TsgBitmap.GetRowData: Pointer;
begin
  Result := FImg.FData;
end;

function TsgBitmap.GetScanLine(ARow: Integer): Pointer;
begin
  Result := FImg.FData;
  if Result <> nil then
  begin
    ARow := (FHeight - 1) - ARow;
    Inc(PByte(Result), RowSize * ARow);
  end;
end;

function TsgBitmap.InfoSize: Integer;
begin
  if PixelFormat <= pf8bit then
    Result := 1 shl (FImg.FInfo.bmiHeader.biBitCount + 2)
  else
  begin
    if FImg.FInfo.bmiHeader.biCompression = BI_BITFIELDS then
      Result := 12
    else
      Result := 0;
  end;
  Inc(Result, SizeOf(TBitmapInfoHeader));
end;

procedure TsgBitmap.CopyBitmapImage;
var
  vImgOrg: TsgBitmapImage;
begin
  vImgOrg := FImg;
  try
    NewImage;
    NewBitmapImage;
    CopyMemory(FImg.Info, vImgOrg.FInfo, GetInfoSize);
    CopyMemory(FImg.FData, vImgOrg.FData, FHeight * RowSize);
  finally
    vImgOrg.Release;
  end;
end;

procedure TsgBitmap.NewBitmapImage;
begin
  FImg.FInfo := AllocMem(GetInfoSize);
  with FImg.FInfo.bmiHeader do
  begin
    biSize := SizeOf(TBitmapInfoHeader);
    biWidth := FWidth;
    biHeight := FHeight;
    biPlanes := 1;
    biBitCount := cnstBPPs[FPixelFormat];
  end;
  GetMem(FImg.FData, FHeight*RowSize);
end;

procedure TsgBitmap.NewImage;
begin
  FImg := TsgBitmapImage.Create;
  FImg.Reference;
end;

procedure TsgBitmap.SetPixelFormat(AValue: TPixelFormat);
begin
  if AValue <> FPixelFormat then
  begin
    FPixelFormat := AValue;
    Update;
  end;
end;

procedure TsgBitmap.SetROP(AValue: Byte);
begin
  FROP := AValue shl 16 + ROPs[AValue];
end;

procedure TsgBitmap.Update;
begin
  if FImg.RefCount > 1 then
  begin
    FImg.Release;
    NewImage;
  end;
  FImg.FreeHandle;
  if not Empty then
    NewBitmapImage;
  Changed(Self);
end;

{protected}

procedure TsgBitmap.AssignTo(ADest: TPersistent);
begin
  if ADest is TBitmap then
  begin
    TBitmap(ADest).PixelFormat := PixelFormat;
    AssignToBitmap(Self, TBitmap(ADest))
  end
  else
    inherited AssignTo(ADest);
end;

procedure TsgBitmap.Draw(ACanvas: TCanvas; const ARect: TRect);
var
  vOldGdiObject: HGDIOBJ;
  vRect: TRect;
  vX1, vY1, vX2, vY2, vWidth, vHeigth, vROP: Integer;
//  vStretchBltMode: Integer;
  vDC: HDC;
begin
  if not Empty then
  begin
    vDC := ACanvas.Handle;
    if {$IFNDEF SGFPC} (ACanvas is TMetaFileCanvas) or {$ENDIF} (GetObjectType(vDC) in [OBJ_METADC, OBJ_ENHMETADC]) then
      vRect := ARect
    else
      if GetClipBox(vDC, vRect) <> NULLREGION then
        IntersectRect(vRect, vRect, ARect);
    if not IsRectEmpty(vRect) then
    begin
      vROP := FROP;
      if Transparent then
        FROP := SRCAND;
      try
        vWidth := ARect.Right - ARect.Left;
        vHeigth := ARect.Bottom - ARect.Top;
        vX1 := MulDiv(vRect.Left - ARect.Left, FWidth, vWidth);
        vY1 := MulDiv(vRect.Top - ARect.Top, FHeight, vHeigth);
        vX2 := MulDiv(vRect.Right - ARect.Left, FWidth, vWidth);
        vY2 := MulDiv(vRect.Bottom - ARect.Top, FHeight, vHeigth);
        if vX1 > 0 then
          Dec(vX1);
        if vY1 > 0 then
          Dec(vY1);
        if vX2 < FWidth then
          Inc(vX2);
        if vY2 < FHeight then
          Inc(vY2);
        vRect.Left := ARect.Left + MulDiv(vX1, vWidth, FWidth);
        vRect.Top := ARect.Top + MulDiv(vY1, vHeigth, FHeight);
        vRect.Right := ARect.Left + MulDiv(vX2, vWidth, FWidth);
        vRect.Bottom := ARect.Top + MulDiv(vY2, vHeigth, FHeight);

        if vRect.Left < -$3000 then
          vRect.Left := -$3000;
        if vRect.Top < -$3000 then
          vRect.Top := -$3000;
        if vRect.Right - vRect.Left > $7FFF then
          vRect.Right := vRect.Left + $6000;
        if vRect.Bottom - vRect.Top > $7FFF then
          vRect.Bottom := vRect.Top + $6000;

        vOldGdiObject := 0;
        if FROP <> SRCCOPY then
          vOldGdiObject := SelectObject(vDC, GetStockObject(BLACK_BRUSH)); // !!!!!?????
        try
//          vStretchBltMode := GetStretchBltMode(vDC);
//          try
//            if FPixelFormat <> pf1bit then
//              SetStretchBltMode(vDC, COLORONCOLOR);
            StretchDIBits(vDC, vRect.Left, vRect.Top, vRect.Right - vRect.Left,
              vRect.Bottom - vRect.Top, vX1, FHeight - vY2, vX2 - vX1, vY2 - vY1,
              FImg.FData, FImg.FInfo^, DIB_RGB_COLORS, FROP);
//          finally
//            SetStretchBltMode(vDC, vStretchBltMode);
//          end;
        finally
          if vOldGdiObject <> 0 then
            SelectObject(vDC, vOldGdiObject);
        end;
      finally
        FROP := vROP;
      end;
    end;
  end;
end;

procedure TsgBitmap.DoExceptionNotImplemented;
begin
  Exception.Create('Not implemented');
end;

function TsgBitmap.GetEmpty: Boolean;
begin
  Result := (FWidth = 0) or (FHeight = 0) or (FPixelFormat = pfDevice);
end;

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

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

procedure TsgBitmap.SetHeight(AValue: Integer);
begin
  if AValue <> FHeight then
  begin
    FHeight := AValue;
    Update;
  end;
end;

procedure TsgBitmap.SetWidth(AValue: Integer);
begin
  if AValue <> FWidth then
  begin
    FWidth := AValue;
    Update;
  end;
end;

{public}

constructor TsgBitmap.Create;
begin
  inherited Create;
  NewImage;
  FROP := SRCCOPY;
end;

destructor TsgBitmap.Destroy;
begin
  FImg.Release;
  inherited Destroy;
end;

procedure TsgBitmap.Assign(ASource: TPersistent);
var
  vsgBitmap: TsgBitmap absolute ASource;
  vGraphic: TGraphic;
begin
  if ASource is TsgBitmap then
  begin
    Self.Transparent := vsgBitmap.Transparent;
    Self.FWidth := vsgBitmap.FWidth;
    Self.FHeight := vsgBitmap.FHeight;
    Self.FROP := vsgBitmap.FROP;
    Self.FPixelFormat := vsgBitmap.FPixelFormat;
    vsgBitmap.FImg.Reference;
    Self.FImg.Release;
    Self.FImg := vsgBitmap.FImg;
    Self.Changed(Self);
  end
  else
    if ASource is TBitmap then
      AssignBM(TBitmap(ASource))
    else
    begin
      if ASource is TGraphic then
      begin
        vGraphic := CreateCopyGraphicAsBitmap(TGraphic(ASource));
        try
          if vGraphic <> nil then
            AssignBM(TBitmap(vGraphic))
          else
            inherited Assign(ASource);
        finally
          vGraphic.Free;
        end;
      end
      else
        inherited Assign(ASource);
    end;
end;

procedure TsgBitmap.Flip;
var
  vPByte0,vPByte1,vPByte2: PAnsiChar;
  vRowSize: Integer;
begin
  vRowSize := RowSize;
  GetMem(vPByte2,vRowSize);
  try
    vPByte0 := ScanLine[0];
    vPByte1 := ScanLine[Height-1];
    while vPByte0 < vPByte1 do
    begin
      Move(vPByte0^, vPByte2^, vRowSize);
      Move(vPByte1^, vPByte0^, vRowSize);
      Move(vPByte2^, vPByte1^, vRowSize);
      Inc(vPByte0,vRowSize);
      Dec(vPByte1,vRowSize);
    end;
  finally
    FreeMem(vPByte2);
  end;
end;

function TsgBitmap.GetColors(AColors: Pointer): Integer;
var
  vPByte: PByte;
begin
  Result := 0;
  if (FImg.FInfo = nil) or not (FPixelFormat in [pf1bit..pf8bit]) then
    Exit;
  Result := 1 shl FImg.FInfo.bmiHeader.biBitCount;
  vPByte := PByte(FImg.FInfo);
  Inc(vPByte, SizeOf(TBitmapInfoHeader));
  Move(vPByte^, AColors^, Result shl 2);
end;

function TsgBitmap.GetInfoSize: Integer;
begin
  Result := SizeOf(TBitmapInfoHeader);
  if FPixelFormat in [pf1bit..pf8bit] then
    Inc(Result, 1 shl (cnstBPPs[FPixelFormat] + 2));
end;

procedure TsgBitmap.LoadFromClipboardFormat(AFmt: Word; AData: THandle; APal: HPALETTE);
begin
  DoExceptionNotImplemented;
end;

procedure TsgBitmap.LoadFromStream(AStream: TStream);
var
  vBitmap: TBitmap;
begin
  vBitmap := TBitmap.Create;
  try
    vBitmap.LoadFromStream(AStream);
    AssignBM(vBitmap);
  finally
    vBitmap.Free;
  end;
end;

procedure TsgBitmap.Rotate(const AAngle: Integer);
const
  cnstProcs: array[TPixelFormat] of TRowProc =
    (nil, Row01, Row04, Row08, Row16, Row16, Row24, Row32, nil);
var
  I,vRowSrc,vRowDst: Integer;
  vRowProc: TRowProc;
  vNewData: PByte;
  vPoint: TPoint;
  vRotateData: TRotateData;
  vOctant: Integer;
begin
  vOctant := AAngle div 90 and 3;
  if Empty or (vOctant = 0) then
    Exit;
  if FImg.RefCount > 1 then
    CopyBitmapImage;
  if vOctant=2 then
  begin
    vPoint.X := FWidth;
    vPoint.Y := FHeight;
  end
  else
  begin
    vPoint.X := FHeight;
    vPoint.Y := FWidth;
  end;
  vRowSrc := (FWidth * FImg.FInfo.bmiHeader.biBitCount + 31) and -32 shr 3;
  vRowDst := (vPoint.X * FImg.FInfo.bmiHeader.biBitCount + 31) and -32 shr 3;
  I := vRowDst * vPoint.Y;
  GetMem(vNewData, I);
  if PixelFormat < pf8bit then
    FillChar(vNewData^, I, 0);
  vRotateData.Dst := vNewData;
  vRotateData.Src := FImg.FData;
  vRotateData.Count := vPoint.X;
  if vOctant=3 then
    vRotateData.ISrc := 0
  else
    vRotateData.ISrc := FWidth-1;
  if vOctant > 1 then
    Inc(vRotateData.Src, vRowSrc*(FHeight-1));
  if vOctant = 1 then
    vRotateData.DSrc := vRowSrc
  else
    vRotateData.DSrc := -vRowSrc;
  case vOctant of
    1: vRowSrc := -1;
    3: vRowSrc := 1;
  end;
  vRowProc := cnstProcs[PixelFormat];
  if vOctant=2 then
  case PixelFormat of
    pf1bit:	vRowProc := Row01H;
    pf4bit: 	vRowProc := Row04H;
    else	vRotateData.DSrc := -(FImg.FInfo.bmiHeader.biBitCount shr 3);
  end;
  for I:=0 to vPoint.Y -1 do
  begin
    if Assigned(OnRotate) then
      OnRotate(Self);
    vRowProc(vRotateData, @PrepareRow);
    Inc(vRotateData.Dst, vRowDst);
    if vOctant=2 then
      Dec(vRotateData.Src, vRowSrc)
    else
      Inc(vRotateData.ISrc, vRowSrc);
  end;
  FreeMem(FImg.FData);
  FImg.FData := vNewData;
  FWidth := vPoint.X;
  FHeight := vPoint.Y;
  FImg.FInfo.bmiHeader.biWidth := FWidth;
  FImg.FInfo.bmiHeader.biHeight := FHeight;
  Changed(Self);
end;

function TsgBitmap.RowSize: Integer;
begin
  Result := (FWidth * FImg.FInfo.bmiHeader.biBitCount + 31) and -32 shr 3;
end;

procedure TsgBitmap.SaveToClipboardFormat(var AFmt: Word; var AData: THandle;
  var APal: HPALETTE);
begin
  DoExceptionNotImplemented;
end;

procedure TsgBitmap.SaveToFile(const FileName: String);
var S: TFileStream;
begin
  S := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(S);
  finally
    S.Free;
  end;
end;

procedure TsgBitmap.SaveToStream(AStream: TStream);
var
  vBitmapFileHeader: TBitmapFileHeader;
begin
  vBitmapFileHeader.bfType := $4D42;
  vBitmapFileHeader.bfOffBits := SizeOf(vBitmapFileHeader);
  if not Empty then
    Inc(vBitmapFileHeader.bfOffBits, InfoSize);
  vBitmapFileHeader.bfSize := vBitmapFileHeader.bfOffBits + FHeight*Cardinal(RowSize);
  vBitmapFileHeader.bfReserved1 := 0;
  vBitmapFileHeader.bfReserved2 := 0;
  AStream.WriteBuffer(vBitmapFileHeader, SizeOf(vBitmapFileHeader));
  AStream.WriteBuffer(FImg.FInfo^, InfoSize);
  AStream.WriteBuffer(FImg.FData^, FHeight*RowSize);
end;

procedure TsgBitmap.SetColors(AColors: Pointer);
var
  vPByte: PByte;
begin
  if (FImg.FInfo = nil) or not (FPixelFormat in [pf1bit..pf8bit]) then
    Exit;
  vPByte := PByte(FImg.FInfo);
  Inc(vPByte, SizeOf(TBitmapInfoHeader));
  Move(AColors^, vPByte^, 1 shl (FImg.FInfo.bmiHeader.biBitCount + 2));
end;

{TsgBitmapImage}

procedure TsgBitmapImage.Assign(ASource: TsgBitmapImage);
begin
  if ASource.Info <> nil then
  begin
    if FInfo = nil then
      New(FInfo);
    FInfo^ := ASource.Info^;
  end
  else
    DisposeAndNil(FInfo);
  if ASource.FData <> nil then
  begin

  end
  else
  begin
    if FData <> nil then
    begin
      FreeMem(FData);
      FData := nil;
    end;
  end;
end;

procedure TsgBitmapImage.FreeHandle;
begin
  ReallocMem(FInfo,0);
  if FData <> nil then
  begin
    FreeMem(FData);
    FData := nil;
  end;
end;

{ TsgBMAdapter }

{private}

function TsgBMAdapter.BM: TBitmap;
begin
  Result := TBitmap(Source);
end;

procedure TsgBMAdapter.ForceBM;
var
  vBitmap: TBitmap;
begin
  if IsBM then
    Exit;
  vBitmap := TBitmap.Create;
  try
    if FSource <> nil then
      vBitmap.Assign(FSource);
    if IsSG then
      vBitmap.PixelFormat := SG.PixelFormat;
    Owned := vBitmap;
  except
    vBitmap.Free;
    raise;
  end;
end;

procedure TsgBMAdapter.ForceSG;
var
  vsgBitmap: TsgBitmap;
begin
  if IsSG then
    Exit;
  vsgBitmap := TsgBitmap.Create;
  try
    if FSource <> nil then
      vsgBitmap.Assign(FSource);
    Owned := vsgBitmap;
  except
    vsgBitmap.Free;
    raise;
  end;
end;

function TsgBMAdapter.GetBitmap: TBitmap;
begin
  if BM.ClassName = TsgBitmap.ClassName then
    TsgBitmap(BM).AssignTo(FBitmap)
  else
    if BM is TBitmap then
      FBitmap.Assign(BM);
   Result := FBitmap;
end;

function TsgBMAdapter.GetCanvas: TCanvas;
begin
  ForceBM;
  Result := BM.Canvas;
end;

function TsgBMAdapter.GetHandleType: TBitmapHandleType;
begin
  if not IsBM then
    Result := bmDIB
  else
    Result := BM.HandleType;
end;

function TsgBMAdapter.GetPixelFormat: TPixelFormat;
var
  vDIBSection: TDIBSection;
begin
  if IsBM then
    Result := BM.PixelFormat
  else Result := SG.PixelFormat;
  if (Result=pfCustom) and IsBM then
  begin
    GetObject(BM.Handle, SizeOf(vDIBSection), @vDIBSection);
    if (vDIBSection.dsBmih.biBitCount = 16) and
       (vDIBSection.dsBmih.biCompression = BI_BITFIELDS) then
      Result := pf15bit;
  end;
end;

function TsgBMAdapter.GetROP: Integer;
begin
  if IsSG then
    Result := SG.FROP
  else
    Result := SRCCOPY;
end;

function TsgBMAdapter.GetScanLine(ARow: Integer): Pointer;
begin
  if IsBM then
    Result := BM.ScanLine[ARow]
  else
    Result := SG.ScanLine[ARow];
end;

function TsgBMAdapter.GetSource: TGraphic;
begin
  if FSource=nil then
    ForceSG;
  Result := FSource;
end;

function TsgBMAdapter.IsBM: Boolean;
begin
  Result := FSource is TBitmap;
end;

function TsgBMAdapter.IsSG: Boolean;
begin
  Result := FSource is TsgBitmap;
end;

procedure TsgBMAdapter.SetHandleType(AValue: TBitmapHandleType);
begin
  if IsBM then
    BM.HandleType := AValue;
end;

procedure TsgBMAdapter.SetOwned(AValue: TGraphic);
begin
  if AValue <> FOwned then
  begin
    FOwned.Free;
    FOwned := AValue;
    FSource := AValue;
  end;
end;

procedure TsgBMAdapter.SetPixelFormat(AValue: TPixelFormat);
begin
  if AValue = PixelFormat then
    Exit;
  if IsSG and Empty then
    SG.PixelFormat := AValue
  else
  begin
    ForceBM;
    BM.PixelFormat := AValue;
  end;
end;

procedure TsgBMAdapter.SetROP(AValue: Integer);
begin
  if AValue = GetROP then
    Exit;
  if AValue = SRCCOPY then
    ForceBM
  else
  begin
    ForceSG;
    SG.FROP := AValue;
  end;
end;

procedure TsgBMAdapter.SetSource(AValue: TGraphic);
begin
  if AValue <> FSource then
  begin
    FOwned.Free;
    FOwned := nil;
    FSource := AValue;
  end;
end;

function TsgBMAdapter.SG: TsgBitmap;
begin
  Result := TsgBitmap(Source);
end;

{protected}

procedure TsgBMAdapter.AssignTo(ADest: TPersistent);
begin
  ADest.Assign(Source);
end;

procedure TsgBMAdapter.Draw(ACanvas: TCanvas; const ARect: TRect);
begin
  ACanvas.StretchDraw(ARect,Source);
end;

function TsgBMAdapter.GetEmpty: Boolean;
begin
  Result := Source.Empty;
end;

function TsgBMAdapter.GetHeight: Integer;
begin
  Result := Source.Height;
end;

function TsgBMAdapter.GetWidth: Integer;
begin
  Result := Source.Width;
end;
{$IFDEF SGFPC}
function TsgBMAdapter.GetTransparent: Boolean;
begin
  Result := False;
end;
{$ENDIF}

procedure TsgBMAdapter.SetHeight(AValue: Integer);
begin
  Source.Height := AValue;
end;

procedure TsgBMAdapter.SetWidth(AValue: Integer);
begin
  Source.Width := AValue;
end;

{$IFDEF SGFPC}
procedure TsgBMAdapter.SetTransparent(Value: Boolean);
begin
  //
end;
{$ENDIF}

{public}

constructor TsgBMAdapter.Create;
begin
  FBitmap := TBitmap.Create;
  inherited Create;
end;

destructor TsgBMAdapter.Destroy;
begin
  FBitmap.Free;
  FOwned.Free;
  inherited Destroy;
end;

procedure TsgBMAdapter.Assign(ASrc: TPersistent);
  function TryAssign: Boolean;
  begin
    Result := True;
    try
      BM.Assign(ASrc)
    except
      Result := False
    end;
  end;
begin
  if ASrc is TsgBitmap then
    Source := TsgBitmap(ASrc)
  else
    if ASrc is TBitmap then
      Source := TBitmap(ASrc)
    else
      {$IFNDEF SGFPC}
      if ASrc is TMetafile then
      begin
        ForceBM;
        AssignToBitmap(TGraphic(ASrc), BM);
      end
      else
      {$ENDIF}
        if ASrc is TGraphic then
        begin
          ForceBM;
          if not TryAssign then
            AssignToBitmap(TGraphic(ASrc), BM);
        end
        else
          inherited Assign(ASrc);
end;

function TsgBMAdapter.GetColorTable(APoint: Pointer): Integer;
begin
  if IsSG then
    Result := SG.GetColors(APoint)
  else
    Result := GetDIBColorTable(BM.Canvas.Handle, 0, 256, APoint^);
end;

procedure TsgBMAdapter.LoadFromClipboardFormat(AFmt:{$IFDEF SGFPC}TClipboardFormat{$ELSE}Word;
 AData: THandle; APal: HPALETTE{$ENDIF});
begin
  ForceBM;
  BM.LoadFromClipboardFormat(AFmt{$IFNDEF SGFPC}, AData, APal{$ENDIF});
end;

procedure TsgBMAdapter.LoadFromStream(AStream: TStream);
begin
  Source.LoadFromStream(AStream);
end;

procedure TsgBMAdapter.Rotate(AAngle: Integer);
begin
  ForceSG;
  SG.Rotate(AAngle);
end;

procedure TsgBMAdapter.SaveToClipboardFormat({$IFNDEF SGFPC}var {$ENDIF} AFmt:{$IFDEF SGFPC}TClipboardFormat{$ELSE}Word;
 var AData: THandle; var APal: HPALETTE{$ENDIF});
begin
  ForceBM;
  BM.SaveToClipboardFormat(AFmt{$IFNDEF SGFPC}, AData, APal{$ENDIF});
end;

procedure TsgBMAdapter.SaveToStream(AStream: TStream);
begin
  Source.SaveToStream(AStream);
end;

(*// For future versions
initialization
  TPicture.RegisterFileFormat('bmp', 'Bitmap image', TsgBitmap);

finalization
  TPicture.UnRegisterGraphicClass(TsgBitmap);
*)
end.
