dib.pas

传奇源代码的delphi版本

unit DIB;

interface

{$INCLUDE DelphiXcfg.inc}
{$DEFINE USE_SCANLINE}

uses
  Windows, SysUtils, Classes, Graphics, Controls, Math;

type
  TColorLineStyle = (csSolid, csGradient, csRainbow);
  TColorLinePixelGeometry = (pgPoint, pgCircular, pgRectangular);

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

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

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

  {   Added this type for New SPecial Effect   }
  TFilter = array[0..2, 0..2] of SmallInt;
  TLines = array[0..0] of TBGR;
  PLines = ^TLines;
  TBytes = array[0..0] of Byte;
  PBytes = ^TBytes;
  TPBytes = array[0..0] of PBytes;
  PPBytes = ^TPBytes;
  {   End of type's   }

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

  TFilterTypeResample = (ftrBox, ftrTriangle, ftrHermite, ftrBell, ftrBSpline,
    ftrLanczos3, ftrMitchell);

  TDistortType = (dtFast, dtSlow);
  {DXFusion effect type}
  TFilterMode = (fmNormal, fmMix50, fmMix25, fmMix75);

  TLightSource = record
    X, Y: Integer;
    Size1, Size2: Integer;
    Color: TColor;
  end;

  TLightArray = array{$IFDEF DelphiX_Delphi3} [0..0]{$ENDIF} of TLightsource;

  TMatrixSetting = array[0..9] of Integer;
  {--}
  TDIB = class(TGraphic)
  private
    FCanvas: TCanvas;
    FImage: TDIBSharedImage;

    FProgressName: string;
    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;
    FLUTDist: array[0..255, 0..255] of Integer;
    LG_COUNT: Integer;
    LG_DETAIL: 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: string);
    procedure EndProgress;
    procedure UpdateProgress(PercentY: Integer);

    {   Added these 3 functions for New Specials Effects   }
    function Interval(iMin, iMax, iValue: Integer; iMark: boolean): Integer;
    function IntToByte(i: Integer): Byte;
    function TrimInt(i, Min, Max: Integer): Integer;
    {   End of 3 functions for New Special Effect   }
    procedure DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
    procedure Darkness(Amount: integer);
    function GetAlphaChannel: TDIB;
    procedure SetAlphaChannel(const Value: TDIB);
  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;
    function HasAlphaChannel: Boolean;
    function AssignAlphaChannel(DIB: TDIB): Boolean;
    procedure RetAlphaChannel(out DIB: TDIB);
    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);
    procedure UpdatePalette;
    {  Special effect  }
    procedure Blur(ABitCount: Integer; Radius: Integer);
    procedure Greyscale(ABitCount: Integer);
    procedure Mirror(MirrorX, MirrorY: Boolean);
    procedure Negative;

    {   Added New Special Effect   }
    procedure Spray(Amount: integer);
    procedure Emboss;
    procedure AddMonoNoise(Amount: integer);
    procedure AddGradiantNoise(Amount: byte);
    function Twist(bmp: TDIB; Amount: byte): boolean;
    function FishEye(bmp: TDIB): boolean;
    function SmoothRotateWrap(Bmp: TDIB; cx, cy: Integer; Degree: Extended): boolean;
    procedure Lightness(Amount: integer);
    procedure Saturation(Amount: integer);
    procedure Contrast(Amount: integer);
    procedure AddRGB(ra, ga, ba: byte);
    function Filter(Dest: TDIB; Filter: TFilter): boolean;
    procedure Sharpen(Amount: Integer);
    function IntToColor(i: Integer): TBGR;
    function Rotate(Dst: TDIB; cx, cy: Integer; Angle: Double): boolean;
    procedure SplitBlur(Amount: Integer);
    procedure GaussianBlur(Bmp: TDIB; Amount: Integer);
    {   End of New Special Effect   }
    {
    New effect for TDIB
    with Some Effects like AntiAlias, Contrast,
    Lightness, Saturation, GaussianBlur, Mosaic,
    Twist, Splitlight, Trace, Emboss, etc.
    Works with 24bit color DIBs.

    This component is based on TProEffectImage component version 1.0 by
    Written By Babak Sateli ([e-mail], http://raveland.netfirms.com)

    and modified by (c) 2004 Jaro Benes
    for DelphiX use.

    Demo was modifies into DXForm with function like  original

    DISCLAIMER
    This component is provided AS-IS without any warranty of any kind, either express or
    implied. This component is freeware and can be used in any software product.
    }
    procedure DoInvert;
    procedure DoAddColorNoise(Amount: Integer);
    procedure DoAddMonoNoise(Amount: Integer);
    procedure DoAntiAlias;
    procedure DoContrast(Amount: Integer);
    procedure DoFishEye(Amount: Integer);
    procedure DoGrayScale;
    procedure DoLightness(Amount: Integer);
    procedure DoDarkness(Amount: Integer);
    procedure DoSaturation(Amount: Integer);
    procedure DoSplitBlur(Amount: Integer);
    procedure DoGaussianBlur(Amount: Integer);
    procedure DoMosaic(Size: Integer);
    procedure DoTwist(Amount: Integer);
    procedure DoSplitlight(Amount: integer);
    procedure DoTile(Amount: integer);
    procedure DoSpotLight(Amount: integer; Spot: TRect);
    procedure DoTrace(Amount: integer);
    procedure DoEmboss;
    procedure DoSolorize(Amount: integer);
    procedure DoPosterize(Amount: integer);
    procedure DoBrightness(Amount: integer);
    procedure DoResample(AmountX, AmountY: integer; TypeResample: TFilterTypeResample);
    procedure DoColorize(ForeColor, BackColor: TColor);

    { Standalone DXFusion }
    {--- c o n F u s i o n ---}
    {By Joakim Back, www.back.mine.nu}
    {Huge thanks to Ilkka Tuomioja for helping out with the project.}

    procedure CreateDIBFromBitmap(const Bitmap: TBitmap);
    {Drawing Methods.}
    procedure DrawOn(SrcCanvas: TCanvas; Dest: TRect; DestCanvas: TCanvas;
      Xsrc, Ysrc: Integer);
    procedure DrawTo(SrcDIB: TDIB; X, Y, Width, Height, SourceX,
      SourceY: Integer);
    procedure DrawTransparent(SrcDIB: TDIB; const X, Y, Width, Height,
      SourceX, SourceY: Integer; const Color: TColor);
    procedure DrawShadow(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
      FilterMode: TFilterMode);
    procedure DrawDarken(SrcDIB: TDIB; X, Y, Width, Height,
      Frame: Integer);
    procedure DrawAdditive(SrcDIB: TDIB; X, Y, Width, Height, Alpha,
      Frame: Integer);
    procedure DrawQuickAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
      SourceX, SourceY: Integer; const Color: TColor;
      FilterMode: TFilterMode);
    procedure DrawTranslucent(SrcDIB: TDIB; const X, Y, Width, Height,
      SourceX, SourceY: Integer; const Color: TColor);
    procedure DrawMorphed(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
      SourceY: Integer; const Color: TColor);
    procedure DrawAlpha(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
      SourceY, Alpha: Integer; const Color: TColor);
    procedure DrawAlphaMask(SrcDIB, MaskDIB: TDIB; const X, Y, Width,
      Height, SourceX, SourceY: Integer);
    procedure DrawAntialias(SrcDIB: TDIB);
    procedure Draw3x3Matrix(SrcDIB: TDIB; Setting: TMatrixSetting);
    procedure DrawMono(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
      SourceY: integer; const TransColor, ForeColor, BackColor: TColor);
    {One-color Filters.}
    procedure FilterLine(X1, Y1, X2, Y2: Integer; Color: TColor;
      FilterMode: TFilterMode);
    procedure FilterRect(X, Y, Width, Height: Integer; Color: TColor;
      FilterMode: TFilterMode);
    { Lightsource. }
    procedure InitLight(Count, Detail: Integer);
    procedure DrawLights(FLight: TLightArray; AmbientLight: TColor);
    //
    // effect for special purpose
    //
    procedure FadeOut(DIB2: TDIB; Step: Byte);
    procedure DoZoom(DIB2: TDIB; ZoomRatio: Real);
    procedure DoBlur(DIB2: TDIB);
    procedure FadeIn(DIB2: TDIB; Step: Byte);
    procedure FillDIB8(Color: Byte);
    procedure DoRotate(DIB1: TDIB; xc, yc, a: Integer);
    procedure Distort(DIB1: TDIB; dt: TDistortType; xc, yc, b: Integer; factor: Real);
    function Ink(DIB: TDIB; const SprayInit: Boolean; const AmountSpray: Integer): Boolean;
    // lines
    procedure AntialiasedLine(x1, y1, x2, y2: integer; color: TColor);
    function GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
      FromPoint, ToPoint: Extended): TColor;
    procedure ColoredLine(const iStart, iEnd: TPoint; iColorStyle: TColorLineStyle;
      iGradientFrom, iGradientTo: TColor; iPixelGeometry: TColorLinePixelGeometry;
      iRadius: WORD);
    // standard property
    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;
    property AlphaChannel: TDIB read GetAlphaChannel write SetAlphaChannel;
  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;
{$IFDEF DelphiX_Spt9}property OnMouseWheel; {$ENDIF}
{$IFDEF DelphiX_Spt9}property OnResize; {$ENDIF}
{$IFDEF DelphiX_Spt9}property OnCanResize; {$ENDIF}
{$IFDEF DelphiX_Spt9}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));