dib.pas.svn-base

Asphyre的传奇WIL,可以用Asphyre来写传奇了

    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
{$IFDEF VER9UP}property OnMouseWheel; {$ENDIF}
{$IFDEF VER9UP}property OnResize; {$ENDIF}
{$IFDEF VER9UP}property OnCanResize; {$ENDIF}
{$IFDEF VER9UP}property OnContextPopup; {$ENDIF}
    property OnStartDrag;
  end;

const
  DefaultFilterRadius: array[TFilterTypeResample] of Single = (0.5, 1, 1, 1.5, 2, 3, 2);

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;

function PosValue(Value: Integer): Integer;

type
  TOC = 0..511;
function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}

{   Added Constants for TFilter Type   }
const
  EdgeFilter: TFilter = ((-1, -1, -1), (-1, 8, -1), (-1, -1, -1));
  StrongOutlineFilter: TFilter = ((-100, 0, 0), (0, 0, 0), (0, 0, 100));
  Enhance3DFilter: TFilter = ((-100, 5, 5), (5, 5, 5), (5, 5, 100));
  LinearFilter: TFilter = ((-40, -40, -40), (-40, 255, -40), (-40, -40, -40));
  GranularFilter: TFilter = ((-20, 5, 20), (5, -10, 5), (100, 5, -100));
  SharpFilter: TFilter = ((-2, -2, -2), (-2, 20, -2), (-2, -2, -2));
{   End of constants   }

{   Added Constants for DXFusion Type   }
const
  { 3x3 Matrix Presets. }
  msEmboss: TMatrixSetting = (-1, -1, 0, -1, 6, 1, 0, 1, 1, 6);
  msHardEmboss: TMatrixSetting = (-4, -2, -1, -2, 10, 2, -1, 2, 4, 8);
  msBlur: TMatrixSetting = (1, 2, 1, 2, 4, 2, 1, 2, 1, 16);
  msSharpen: TMatrixSetting = (-1, -1, -1, -1, 15, -1, -1, -1, -1, 7);
  msEdgeDetect: TMatrixSetting = (-1, -1, -1, -1, 8, -1, -1, -1, -1, 1);

{Proportionaly scale of size, for recountin image sizes}
function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single;

procedure MakeDib(out DIB: TDIB; const iWidth, iHeight, iBitCount: Integer; iFillColor: TColor{$IFDEF VER4UP} = clBlack{$ENDIF}); {$IFDEF VER4UP}overload; {$ENDIF}
procedure{$IFDEF VER4UP}MakeDib{$ELSE}MakeDIB2{$ENDIF}(out DIB: TDIB; iBitmap: TBitmap); {$IFDEF VER4UP}overload; {$ENDIF}

implementation

uses
  DXConsts, jpeg;

function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single;
var
  XScale, YScale: Single;
begin
  XScale := 1;
  YScale := 1;
  if TargetWidth < SourceWidth then
    XScale := TargetWidth / SourceWidth;
  if TargetHeight < SourceHeight then
    YScale := TargetHeight / SourceHeight;
  Result := XScale;
  if YScale < Result then
    Result := YScale;
end;

{$IFDEF DelphiX_Delphi3}

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

function Min(B1, B2: Integer): Integer;
begin
  if B1 <= B2 then Result := B1 else Result := B2;
end;
{$ENDIF}

function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
begin
  Result := sin(((c * 360) / 511) * Pi / 180);
end;

function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
begin
  Result := cos(((c * 360) / 511) * Pi / 180);
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 RBitCount2);
  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 GBitCount2);
  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 BBitCount2);
  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;
  FMemoryImage := True;
  SetColorTable(GreyscaleColorTable);
  FColorTable := GreyscaleColorTable;
  FPixelFormat := MakeDIBPixelFormat(8, 8, 8);
end;

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

  {  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);