dib.pas.svn-base

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

unit DIB;

interface

{$DEFINE USE_SCANLINE}

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

type
  TColorLineStyle = (csSolid, csGradient, csRainbow);
  TColorLinePixelGeometry = (pgPoint, pgCircular, pgRectangular);
  PRGBQuads = ^TRGBQuads;
  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{$IFNDEF VER4UP} [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;
    FFreeList: TList;
    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 Darkness(Amount: Integer);
    function GetAlphaChannel: TDIB;
    procedure SetAlphaChannel(const Value: TDIB);
    function GetClientRect: TRect;
  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(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): 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); {$IFDEF VER9UP} overload;{$ENDIF}
    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(aR, aG, aB: 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 modified 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);
    {rotate}
    procedure DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
    procedure DoColorize(ForeColor, BackColor: TColor);
    {Simple explosion spoke effect}
    procedure DoNovaEffect(sr, sg, sb, cx, cy, radius,
      nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);

    {Simple Mandelbrot-set drawing}
    procedure DrawMandelbrot(ao, au: Integer; bo, bu: Double);

    {Sephia effect}
    procedure SephiaEffect(Depth: Integer{$IFDEF VER4UP} = 20{$ENDIF});

    {Simple bledn pixel}
    procedure BlendPixel(const X, Y: Integer; aColor: Cardinal; Alpha: Byte);
    {Line in polar system}
    procedure LinePolar(x, y: Integer; AngleInDegree, Length: extended;
      Color: cardinal);

    {special version Dark/Light procedure in percent}
    procedure Darker(Percent: Integer);
    procedure Lighter(Percent: Integer);

    {Simple graphical crypt}
    procedure EncryptDecrypt(const Key: Integer);

    { 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.}

    {
    modified by (c) 2005 Jaro Benes for DelphiX use.
    }

    procedure CreateDIBFromBitmap(const Bitmap: TBitmap);
    {Drawing Methods.}
    procedure DrawOn(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); {$IFDEF VER9UP} overload;{$ENDIF}
    procedure DrawShadow(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
      FilterMode: TFilterMode);
    procedure DrawShadows(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
      Alpha: Byte);
    procedure DrawDarken(SrcDIB: TDIB; X, Y, Width, Height,
      Frame: Integer);
    procedure DrawAdditive(SrcDIB: TDIB; X, Y, Width, Height: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF};
      Frame: Integer{$IFDEF VER4UP} = 0{$ENDIF});
    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; cX, cY, Angle: Integer);
    procedure Distort(DIB1: TDIB; dt: TDistortType; cX, cY, Angle: 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;
    function CreateBitmapFromDIB: TBitmap;
    procedure Fill(aColor: TColor);
    property ClientRect: TRect read GetClientRect;
  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 VER4UP}property Anchors; {$ENDIF}
    property AutoStretch;
    property Center;
{$IFDEF VER4UP}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;