fastbmp.pas

一个基于不需引擎的文件管理系统,使用了许多界面比较好的控件

unit FastBmp;

//  FastBmp v0.06
//  Gordon Alex Cowie III (aka "GoRDy") <[e-mail]>
//  www.jps.net/gfody (currently down (jps sucks fat cock))
//
//  This unit is freeware.
//  Improvements, Ideas, Filters, Methods,
//  and Optimizations are welcome.
//  see Readme.txt for documentation.
//
//  Contributors:
//
//  Armindo Da Silva <[e-mail]>
//   -Blur, Wave, Spray, Rotate
//   -TFastImage component based on FastBmp
//
//  Andreas Goransson <[e-mail]>
//   -Texture filter
//   -Added some optimizations here an there
//
//  Earl F. Glynn <[e-mail]>
//   -Rotation optimizations
//   -Computer lab: www.infomaster.net/external/efg/
//
//  Vit Kovalcik <[e-mail]>
//   -Optimized Resize method
//   -Check out UniDib for 4,8,16,24,32 bit dibs!
//   -www.geocities.com/SiliconValley/Hills/1335/
//
//  Anders Melander <[e-mail]>
//  David Ullrich <[e-mail]>
//  Dale Schumacher
//   -Bitmap Resampler
//
//  P.S. if I don't respond to your email within a few days
//  send it again (jps sucks some horse dick)

interface

uses Windows;

type

TFColor=record
  b,g,r: Byte;
end;
PFColor=^TFColor;

TLine=array[0..0]of TFColor;
PLine=^TLine;
TCalcs=array[0..0]of Integer;
PCalcs=^TCalcs;
TFilterProc=function(Value:Single):Single;

TFastBmp=class
private
  procedure   CalcLines;
  procedure   SetPixel(x,y:Integer;Clr:TFColor);
  function    GetPixel(x,y:Integer):TFColor;
  procedure   SetLine(y:Integer;Line:Pointer);
  function    GetLine(y:Integer):Pointer;
public
  Calcs:      PCalcs;
  RowInc,
  Handle,
  Width,
  Height,
  Size:       Integer;
  Bits:       Pointer;
  BmpHeader:  TBITMAPINFOHEADER;
  BmpInfo:    TBITMAPINFO;
  // constructors
  constructor Create(cx,cy:Integer);
  constructor CreateFromFile(lpFile:string);
  constructor CreateFromhWnd(hBmp:Integer);
  constructor CreateCopy(hBmp:TFastBmp);
  destructor  Destroy; override;
  // properties
  property    Pixels[x,y:Integer]:TFColor read GetPixel write SetPixel;
  property    ScanLines[y:Integer]:Pointer read GetLine write SetLine;
  procedure   GetScanLine(y:Integer;Line:Pointer);
  // conversions
  procedure   Resize(Dst:TFastBmp);
  procedure   SmoothResize(Dst:TFastBmp);
  procedure   Resample(Dst:TFastBmp;Filter:TFilterProc;FWidth:Single);
  procedure   Tile(Dst:TFastBmp);
  procedure   CopyRect(Dst:TFastBmp;DstX,DstY,SrcX,SrcY,W,H:Integer);
  // screen drawing methods
  procedure   Draw(hDC,x,y:Integer);
  procedure   Stretch(hDC,x,y,cx,cy:Integer);
  procedure   DrawRect(hDC,hx,hy,x,y,cx,cy:Integer);
  procedure   TileDraw(hDC,x,y,cx,cy:Integer);
  // filters
  // v.6 - any filter that made a temporary dib has
  //       been changed to operate on a destination dib.
  procedure   Flip;     //Horizontal
  procedure   Flop;     //Vertical
  procedure   TurnCW;   //ClockWise
  procedure   TurnCCW;  //Counter-ClockWise
  procedure   Spray(Dst:TFastBmp;Amount:Integer);
  procedure   Sharpen;
  procedure   Contrast(Amount:Integer);
  procedure   Saturation(Amount:Integer);
  procedure   Lightness(Amount:Integer);
  procedure   Smooth(Weight:Integer);
  procedure   SplitBlur(Amount:Integer);
  procedure   GaussianBlur(Amount:Integer);
  procedure   Wave(Dst:TFastBmp;XDIV,YDIV,RatioVal:Integer);
  procedure   WaveWrap(Dst:TFastBmp;XDIV,YDIV,RatioVal:Integer);
  procedure   AddColorNoise(Amount:Integer);
  procedure   AddMonoNoise(Amount:Integer);
  procedure   RGB(ra,ga,ba:Integer);
  procedure   RotateWrap(Dst:TFastBmp;Degree:Extended;iRotationAxis,jRotationAxis:Integer);
  procedure   GrayScale;
  procedure   DiscardColor;
  procedure   InterpolateRect(x1,y1,x2,y2:Integer;c00,c10,c01,c11:TFColor);
  procedure   VertRoll(Amount:Integer);
  procedure   HorzRoll(Amount:Integer);
end;
PFastBmp=^TFastBmp;

// filter procs to use with TFastBmp.Resample   // suggested Radius
function SplineFilter(Value:Single):Single;     // 2.0
function BellFilter(Value:Single):Single;       // 1.5
function TriangleFilter(Value:Single):Single;   // 1.0
function BoxFilter(Value:Single):Single;        // 0.5
function HermiteFilter(Value:Single):Single;    // 1.0
function Lanczos3Filter(Value:Single):Single;   // 3.0
function MitchellFilter(Value:Single):Single;   // 2.0

// returns a TFColor given rgb values
function FRGB(r,g,b:Byte):TFColor;
function IntToByte(i:Integer):Byte;

implementation

function FRGB(r,g,b:Byte):TFColor;
begin
  Result.r:=r;
  Result.g:=g;
  Result.b:=b;
end;

function IntToByte(i:Integer):Byte;
begin
  if      i>255 then Result:=255
  else if i<0   then Result:=0
  else               Result:=i;
end;

// Precalculated scanline offsets!
procedure TFastBmp.CalcLines;
var
i: Integer;
begin
  GetMem(Calcs,Height*SizeOf(Integer));
  for i:=0 to Height-1 do
  Calcs^[i]:=Integer(Bits)+(i*(Width mod 4))+((i*Width)*3);
  i:=1;
  RowInc:=Calcs^[i]-Integer(Bits);
end;

procedure TFastBmp.SetPixel(x,y:Integer;Clr:TFColor);
begin
  //(y*(Width mod 4))+(((y*Width)+x)*3)
  //if(x>-1)and(x<Width)and(y>-1)and(y<Height)then
  PFColor(Calcs^[y]+(x*3))^:=Clr;
end;

function TFastBmp.GetPixel(x,y:Integer):TFColor;
begin
  //if(x>-1)and(x<Width)and(y>-1)and(y<Height)then
  Result:=PFColor(Calcs^[y]+(x*3))^;
end;

procedure TFastBmp.SetLine(y:Integer;Line:Pointer);
begin
  //Pointer(Integer(Bits)+(y*(Width mod 4))+((y*Width)*3)))
  CopyMemory(
    Pointer(Calcs^[y]),
    Line,
    Width*3);
end;

function TFastBmp.GetLine(y:Integer):Pointer;
begin
  Result:=Pointer(Calcs^[y]);
end;

procedure TFastBmp.GetScanLine(y:Integer;Line:Pointer);
begin
  CopyMemory(
    Line,
    Pointer(Calcs^[y]),
    Width*3);
end;

constructor TFastBmp.Create(cx,cy:Integer);
begin
  Width:=cx;
  Height:=cy;
  Size:=((Width*3)+(Width mod 4))*Height;
  with BmpHeader do
  begin
    biSize:=SizeOf(BmpHeader);
    biWidth:=Width;
    biHeight:=-Height;
    biPlanes:=1;
    biBitCount:=24;
    biCompression:=BI_RGB;
  end;
  BmpInfo.bmiHeader:=BmpHeader;
  Handle:=CreateDIBSection(0,
                   BmpInfo,
                   DIB_RGB_COLORS,
                   Bits,
                   0,
                   0);
  CalcLines;
end;

constructor TFastBmp.CreateFromFile(lpFile:string);
var
  Bmp:  TBITMAP;
  hDC,
  hBmp: Integer;
begin
  hBmp:=LoadImage(0,PChar(lpFile),IMAGE_BITMAP,0,0,LR_LOADFROMFILE or LR_COPYRETURNORG);
  GetObject(hBmp,SizeOf(Bmp),@Bmp);
  hDC:=CreateDC('DISPLAY',nil,nil,nil);
  SelectObject(hDC,hBmp);

  Width:=Bmp.bmWidth;
  Height:=Bmp.bmHeight;
  Size:=((Width*3)+(Width mod 4))*Height;
  //  bmp files are usually saved upside-down.
  //  I make this conversion to make sure that TFastBmp
  //  contains a rightside-up DIB (notice the -Height).
  //  Who the hell wants upside-down data anyways?
  with BmpHeader do
  begin
    biSize:=SizeOf(BmpHeader);
    biWidth:=Width;
    biHeight:=-Height;
    biPlanes:=1;
    biBitCount:=24;
    biCompression:=BI_RGB;
  end;
  BmpInfo.bmiHeader:=BmpHeader;
  Handle:=CreateDIBSection(0,
                 BmpInfo,
                 DIB_RGB_COLORS,
                 Bits,
                 0,
                 0);
  GetDIBits(hDC,hBmp,0,Height,Bits,BmpInfo,DIB_RGB_COLORS);
  DeleteDC(hDC);
  DeleteObject(hBmp);
  CalcLines;
end;

constructor TFastBmp.CreateFromhWnd(hBmp:Integer);
var
Bmp:  TBITMAP;
hDC:  Integer;
begin
  hDC:=CreateDC('DISPLAY',nil,nil,nil);
  SelectObject(hDC,hBmp);
  GetObject(hBmp,SizeOf(Bmp),@Bmp);
  Width:=Bmp.bmWidth;
  Height:=Bmp.bmHeight;
  Size:=((Width*3)+(Width mod 4))*Height;

  with BmpHeader do
  begin
    biSize:=SizeOf(BmpHeader);
    biWidth:=Width;
    biHeight:=-Height;
    biPlanes:=1;
    biBitCount:=24;
    biCompression:=BI_RGB;
  end;
  BmpInfo.bmiHeader:=BmpHeader;
  Handle:=CreateDIBSection(0,
                 BmpInfo,
                 DIB_RGB_COLORS,
                 Bits,
                 0,
                 0);
  GetDIBits(hDC,hBmp,0,Height,Bits,BmpInfo,DIB_RGB_COLORS);
  DeleteDC(hDC);
  CalcLines;
end;

constructor TFastBmp.CreateCopy(hBmp:TFastBmp);
begin
  BmpHeader:=hBmp.BmpHeader;
  BmpInfo:=hBmp.BmpInfo;
  Width:=hBmp.Width;
  Height:=hBmp.Height;
  Size:=hBmp.Size;
  Handle:=CreateDIBSection(0,
                 BmpInfo,
                 DIB_RGB_COLORS,
                 Bits,
                 0,
                 0);
  CopyMemory(Bits,hBmp.Bits,Size);
  CalcLines;
end;

//  Some drivers do not implement stretching of dibs very well.
//  i.e. most drivers will fail when stretching by a factor greater than
//  255, so a very small bitmap couldn't be stretched to full screen.
//  Use the native resize method for bug-free stretching.
procedure TFastBmp.Stretch(hDC,x,y,cx,cy:Integer);
begin
  SetStretchBltMode(hDC,STRETCH_DELETESCANS);
  // until I can implement DrawDib functions...
  StretchDIBits(hDC,
                x,y,cx,cy,
                0,0,Width,Height,
                Bits,
                BmpInfo,
                DIB_RGB_COLORS,
                SRCCOPY);
end;

procedure TFastBmp.Draw(hDC,x,y:Integer);
begin
  // SetDIBitsToDevice(hDC,x,y,Width,Height,0,0,0,
  //                   Height,Bits,BmpInfo,DIB_RGB_COLORS);
  // SetDIBitsToDevice is poorly implemented in a lot of
  // drivers, so I changed this function to use StretchDIBits
  StretchDIBits(hDC,
                x,y,Width,Height,
                0,0,Width,Height,
                Bits,
                BmpInfo,
                DIB_RGB_COLORS,
                SRCCOPY);
end;

procedure TFastBmp.DrawRect(hDC,hx,hy,x,y,cx,cy:Integer);
begin
  StretchDIBits(hDC,
                hx,hy+cy-1,cx,-cy+1,
                x,Height-y,cx,-cy+1,
                Bits,
                BmpInfo,
                DIB_RGB_COLORS,
                SRCCOPY);
end;

procedure TFastBmp.CopyRect(Dst:TFastBmp;DstX,DstY,SrcX,SrcY,W,H:Integer);
var
lw,lh,
x,y:   Integer;
begin




  for y:=0 to H-1 do
  begin
    for x:=0 to W-1 do
    begin

      Dst.Pixels[DstX+x,DstY+y]:=Pixels[SrcX+x,SrcY+y];

    end;
  end;

end;


//  I call this method of tiling.. 'Progressive Tiling'
procedure TFastBmp.TileDraw(hDC,x,y,cx,cy:Integer);
var
w,h,
hBmp,
MemDC: Integer;
begin
  MemDC:=CreateCompatibleDC(hDC);
  hBmp:=CreateCompatibleBitmap(hDC,cx,cy);
  SelectObject(MemDC,hBmp);
  Draw(MemDC,0,0);
  w:=Width;
  h:=Height;
  while h<cy do
  begin
    BitBlt(MemDC,0,h,w,h*2,MemDC,0,0,SRCCOPY);
    Inc(h,h);
  end;
  while w<cx do
  begin
    BitBlt(MemDC,w,0,w*2,cy,MemDC,0,0,SRCCOPY);
    Inc(w,w);
  end;
  BitBlt(hDC,x,y,cx,cy,MemDC,0,0,SRCCOPY);
  DeleteDC(MemDC);
  DeleteObject(hBmp);
end;

//  Trying to make this faster then TileDraw
//  Via copyrect (note to self: make copyrect)
procedure TFastBmp.Tile(Dst:TFastBmp);
var
LineOut,
LineIn:  PLine;
x,y,a,b: Integer;
begin
  a:=0;
  b:=0;
  GetMem(LineIn,Width*3);
  GetMem(LineOut,Dst.Width*3);

  for y:=0 to Dst.Height-1 do
  begin
    GetScanLine(b,LineIn);
    for x:=0 to Dst.Width-1 do
    begin
      LineOut^[x]:=LineIn^[a];
      Inc(a);
      if a=Width then a:=0;
    end;
    Dst.ScanLines[y]:=LineOut;
    a:=0;
    Inc(b);
    if b=Height then b:=0;
  end;
  FreeMem(LineOut,Dst.Width*3);
  FreeMem(LineIn,Width*3);
end;

//  Thanks to Vit Kovalcik for his optimizations!
//  Anybody wanna apply these optimizations to the resampler?
procedure TFastBmp.Resize(Dst:TFastBmp);
var
xCount,
yCount,
x,y,xP,yP,
xD,yD,
yiScale,
xiScale: Integer;
xScale,
yScale:  Single;
Read,
Line:    PLine;
Tmp:     TFColor;
pc:      PFColor;
begin
  if(Width=0)or(Height=0)or(Dst.Width=0)or(Dst.Height=0)then Exit;
  xScale:=Dst.Width/Width;
  yScale:=Dst.Height/Height;
  if(xScale=1)and(yScale=1)then
    CopyMemory(Dst.Bits,Bits,Size)
  else if(xScale<1)or(yScale<1)then
  begin
    xiScale:=(Width shl 16) div Dst.Width;
    yiScale:=(Height shl 16) div Dst.Height;
    yP:=0;
    for y:=0 to Dst.Height-1 do
    begin
      xP:=0;
      read:=ScanLines[yP shr 16];
      pc:=Dst.ScanLines[y];
      for x:=0 to Dst.Width-1 do
      begin
        pc^:=Read^[xP shr 16];
        Inc(pc);
        Inc(xP,xiScale);
      end;
      Inc(yP,yiScale);
    end;
  end
  else
  begin
    yiScale:=Round(yScale+0.5);
    xiScale:=Round(xScale+0.5);
    GetMem(Line,Dst.Width*3);
    for y:=0 to Height-1 do
    begin
      yP:=Trunc(yScale*y);
      Read:=Scanlines[y];
      for x:=0 to Width-1 do
      begin
        xP:=Trunc(xScale*x);
        Tmp:=Read^[x];
        for xCount:=0 to xiScale-1 do
        begin
          xD:=xCount+xP;
          if xD>=Dst.Width then Break;
          Line^[xD]:=Tmp;
        end;
      end;
      for yCount:=0 to yiScale-1 do
      begin
        yD:=yCount+yP;
        if yD>=Dst.Height then Break;
        Dst.Scanlines[yD]:=Line;
      end;
    end;
    FreeMem(Line,Dst.Width*3);
  end;
end;

//  Awesome!.. Vit Kovalcik