FastBMP.pas

Top  Previous  Next

unit FastBmp;

 

//  FastBmp v0.06

//  Gordon Alex Cowie III (aka "GoRDy") <gfody@jps.net>

//  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 <armindo.da-silva@wanadoo.fr>

//   -Blur, Wave, Spray, Rotate

//   -TFastImage component based on FastBmp

//

//  Andreas Goransson <andreas.goransson@epk.ericsson.se>

//   -Texture filter

//   -Added some optimizations here an there

//

//  Earl F. Glynn <earlglynn@att.net>

//   -Rotation optimizations

//   -Computer lab: www.infomaster.net/external/efg/

//

//  Vit Kovalcik <vkovalcik@iname.com>

//   -Optimized Resize method

//   -Check out UniDib for 4,8,16,24,32 bit dibs!

//   -www.geocities.com/SiliconValley/Hills/1335/

//

//  Anders Melander <anders@melander.dk>

//  David Ullrich <ullrich@hardy.math.okstate.edu>

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

procedure TFastBmp.SmoothResize (Dst:TFastBmp);

var

x,y,xP,yP,

yP2,xP2:Integer;

Read,Read2:PLine;

t,z,iz,z2,iz2:Integer;

pc:PFColor;

begin

If Width=1 then

begin

   Resize (Dst);

   Exit;

end;

if (Dst.Width=Width) and (Dst.Height=Height) then

begin

   CopyMemory(Dst.Bits,Bits,Size);

   Exit;

end;

xP2:=((Width-1) shl 16) div Dst.Width;

yP2:=((Height-1) shl 16) div Dst.Height;

yP:=0;

for y:=0 to Dst.Height-1 do

begin

   xP:=0;

   Read:=ScanLines[yP shr 16];

   If yP shr 16<Height-1 then

     Read2:=ScanLines[yP shr 16+1]

   else

     Read2:=ScanLines[yP shr 16];

   pc:=Dst.ScanLines[y];

   z2:=yP AND $FFFF;

   iz2:=$10000-z2;

   for x:=0 to Dst.Width-1 do

   begin

     t:=xP shr 16;

     z:=xP AND $FFFF;

     iz:=$10000-z;

     pc^.b:=

       (((Read^[t].b*iz+Read^[t+1].b*z) shr 16)*iz2+

       ((Read2^[t].b*iz+Read2^[t+1].b*z) shr 16)*z2) shr 16;

     pc^.r:=

       (((Read^[t].r*iz+Read^[t+1].r*z) shr 16)*iz2+

       ((Read2^[t].r*iz+Read2^[t+1].r*z) shr 16)*z2) shr 16;

     pc^.g:=

       (((Read^[t].g*iz+Read^[t+1].g*z) shr 16)*iz2+

       ((Read2^[t].g*iz+Read2^[t+1].g*z) shr 16)*z2) shr 16;

     Inc (pc);

     Inc (xP,xP2);

   end;

   Inc (yP,yP2);

end;

end;

 

// more optimizations by Vit

procedure TFastBmp.Flip;

var

Line:  PLine;

w,x,y: Integer;

c:     TFColor;

begin

w:=Width-1;

for y:=0 to Height-1 do

begin

   Line:=ScanLines[y];

   for x:=0 to w div 2 do

   begin

     c:=Line^[x];

     Line^[x]:=Line^[w-x];

     Line^[w-x]:=c;

   end;

end;

end;

 

procedure TFastBmp.Flop;

var

y,cy,h: Integer;

Line:   PLine;

begin

GetMem(Line,Width*3);

cy:=Height div 2-1;

h:=Height-1;

for y:=0 to cy do

begin

   GetScanLine(y,Line);

   ScanLines[y]:=ScanLines[h-y];

   ScanLines[h-y]:=Line;

end;

FreeMem(Line,Width*3);

end;

 

procedure TFastBmp.TurnCW;

var

x,y: Integer;

Tmp: TFastBmp;

begin

Tmp:=TFastBmp.Create(Height,Width);

for x:=0 to Width-1 do

for y:=0 to Height-1 do

Tmp.Pixels[Height-y-1,x]:=Pixels[x,y];

DeleteObject(Handle);

Handle:=Tmp.Handle;

Width:=Tmp.Width;

Height:=Tmp.Height;

Size:=Tmp.Size;

Bits:=Tmp.Bits;

BmpHeader:=Tmp.BmpHeader;

BmpInfo:=Tmp.BmpInfo;

CalcLines;

end;

 

procedure TFastBmp.TurnCCW;

var

x,y: Integer;

Tmp: TFastBmp;

begin

Tmp:=TFastBmp.Create(Height,Width);

for x:=0 to Width-1 do

for y:=0 to Height-1 do

Tmp.Pixels[y,Width-x-1]:=Pixels[x,y];

DeleteObject(Handle);

Handle:=Tmp.Handle;

Width:=Tmp.Width;

Height:=Tmp.Height;

Size:=Tmp.Size;

Bits:=Tmp.Bits;

BmpHeader:=Tmp.BmpHeader;

BmpInfo:=Tmp.BmpInfo;

CalcLines;

end;

 

procedure TFastBmp.AddColorNoise(Amount:Integer);

var

x,y,p,

r,g,b: Integer;

Tmp:   PFColor;

begin

p:=Integer(Bits);

for y:=0 to Height-1 do

begin

   Tmp:=Pointer(p);

   for x:=0 to Width-1 do

   begin

     r:=Tmp.r+(Random(Amount)-(Amount shr 1));

     g:=Tmp.g+(Random(Amount)-(Amount shr 1));

     b:=Tmp.b+(Random(Amount)-(Amount shr 1));

     Tmp.r:=IntToByte(r);

     Tmp.g:=IntToByte(g);

     Tmp.b:=IntToByte(b);

     Inc(Tmp);

   end;

   Inc(p,RowInc);

end;

end;

 

procedure TFastBmp.AddMonoNoise(Amount:Integer);

var

x,y,a,p,

r,g,b: Integer;

Tmp:   PFColor;

begin

p:=Integer(Bits);

for y:=0 to Height-1 do

begin

   Tmp:=Pointer(p);

   for x:=0 to Width-1 do

   begin

     a:=Random(Amount)-(Amount shr 1);

     r:=Tmp.r+a;

     g:=Tmp.g+a;

     b:=Tmp.b+a;

     Tmp.r:=IntToByte(r);

     Tmp.g:=IntToByte(g);

     Tmp.b:=IntToByte(b);

     Inc(Tmp)

   end;

   Inc(p,RowInc);

end;

end;

 

procedure TFastBmp.RGB(ra,ga,ba:Integer);

var

p,x,y: Integer;

Tmp:   PFColor;

begin

p:=Integer(Bits);

for y:=0 to Height-1 do

begin

   Tmp:=Pointer(p);

   for x:=0 to Width-1 do

   begin

     Tmp.r:=IntToByte(Tmp.r+ra);

     Tmp.g:=IntToByte(Tmp.g+ga);

     Tmp.b:=IntToByte(Tmp.b+ba);

     Inc(Tmp);

   end;

   Inc(p,RowInc);

end;

end;

 

// Amount: inverted < -255 < low contrast < 0 < high contrast

procedure TFastBmp.Contrast(Amount:Integer);

var

rg,gg,bg,

r,g,b,p,

x,y:  Integer;

Tmp:  PFColor;

begin

p:=Integer(Bits);

for y:=0 to Height-1 do

begin

   Tmp:=Pointer(p);

   for x:=0 to Width-1 do

   begin

     r:=Tmp.r; g:=Tmp.g; b:=Tmp.b;

 

     rg:=(Abs(127-r)*Amount)div 255;

     gg:=(Abs(127-g)*Amount)div 255;

     bg:=(Abs(127-b)*Amount)div 255;

 

     if r>127 then r:=r+rg else r:=r-rg;

     if g>127 then g:=g+gg else g:=g-gg;

     if b>127 then b:=b+bg else b:=b-bg;

 

     Tmp.r:=IntToByte(r);

     Tmp.g:=IntToByte(g);

     Tmp.b:=IntToByte(b);

     Inc(Tmp);

   end;

   Inc(p,RowInc);

end;

end;

 

// Amount: 0 = Grayscale, 255 = Normal

procedure TFastBmp.Saturation(Amount:Integer);

var

Gray,

r,g,b,

p,x,y: Integer;

Tmp:   PFColor;

begin

p:=Integer(Bits);

for y:=0 to Height-1 do

begin

   Tmp:=Pointer(p);

   for x:=0 to Width-1 do

   begin

     r:=Tmp.r; g:=Tmp.g; b:=Tmp.b;

     Gray:=(r+g+b)div 3;

 

     Tmp.r:=IntToByte(Gray+(((r-Gray)*Amount)div 255));

     Tmp.g:=IntToByte(Gray+(((g-Gray)*Amount)div 255));

     Tmp.b:=IntToByte(Gray+(((b-Gray)*Amount)div 255));

     Inc(Tmp);

   end;

   Inc(p,RowInc);

end;

end;

 

procedure TFastBmp.Lightness(Amount:Integer);

var

r,g,b,

p,x,y: Integer;

Tmp:   PFColor;

begin

p:=Integer(Bits);

for y:=0 to Height-1 do

begin

   Tmp:=Pointer(p);

   for x:=0 to Width-1 do

   begin

     r:=Tmp.r; g:=Tmp.g; b:=Tmp.b;

 

     Tmp.r:=IntToByte(r+((255-r)*Amount)div 255);

     Tmp.g:=IntToByte(g+((255-g)*Amount)div 255);

     Tmp.b:=IntToByte(b+((255-b)*Amount)div 255);

     Inc(Tmp);

   end;

   Inc(p,RowInc);

end;

end;

 

procedure TFastBmp.SplitBlur(Amount:Integer);

var

Lin,

Lin1,

Lin2:  PLine;

cx,

i,x,y: Integer;

Buf:   array[0..3]of TFColor;

Tmp:   TFColor;

begin

if Amount=0 then Exit;

 

for y:=0 to Height-1 do

begin

   Lin:=ScanLines[y];

 

   if y-Amount<0         then Lin1:=ScanLines[y]

   else {y-Amount>0}          Lin1:=ScanLines[y-Amount];

   if y+Amount<Height    then Lin2:=ScanLines[y+Amount]

   else {y+Amount>=Height}    Lin2:=ScanLines[Height-y];

 

   for x:=0 to Width-1 do

   begin

     if x-Amount<0     then cx:=x

     else {x-Amount>0}      cx:=x-Amount;

     Buf[0]:=Lin1^[cx];

     Buf[1]:=Lin2^[cx];

     if x+Amount<Width     then cx:=x+Amount

     else {x+Amount>=Width}     cx:=Width-x;

     Buf[2]:=Lin1^[cx];

     Buf[3]:=Lin2^[cx];

     Tmp.r:=(Buf[0].r+Buf[1].r+Buf[2].r+Buf[3].r)shr 2;

     Tmp.g:=(Buf[0].g+Buf[1].g+Buf[2].g+Buf[3].g)shr 2;

     Tmp.b:=(Buf[0].b+Buf[1].b+Buf[2].b+Buf[3].b)shr 2;

     Lin^[x]:=Tmp;

   end;

end;

end;

 

// cheap gaussian blur 1=little blur 10=blurry as hell

procedure TFastBmp.GaussianBlur(Amount:Integer);

var

i: Integer;

begin

for i:=Amount downto 0 do

SplitBlur(i);

end;

 

//  smooth edges, weight is weight of edge.

//  higher the weight, sharper the edges.

procedure TFastBmp.Smooth(Weight:Integer);

var

Lin1,

Lin2,

Line: PLine;

w4,i,j,

x,y,

c,w:  Integer;

Tmp:  TFColor;

begin

GetMem(Line,Width*3);

w4:=Weight+4;

for y:=0 to Height-1 do

begin

   if y=0 then i:=y+1 else i:=y-1;

   if y=Height-1 then j:=y-1 else j:=y+1;

   Lin1:=Scanlines[i];

   Lin2:=Scanlines[j];

   GetScanLine(y,Line);

   for x:=0 to Width-1 do

   begin

     if x=0 then c:=x+1 else c:=x-1;

     if x=Width-1 then w:=x-1 else w:=x+1;

     Tmp.r:=(Line^[c].r+Line^[w].r+

             Lin1^[x].r+Lin2^[x].r+

            (Line^[x].r*Weight))div w4;

     Tmp.g:=(Line^[c].g+Line^[w].g+

             Lin1^[x].g+Lin2^[x].g+

            (Line^[x].g*Weight))div w4;

     Tmp.b:=(Line^[c].b+Line^[w].b+

             Lin1^[x].b+Lin2^[x].b+

            (Line^[x].b*Weight))div w4;

     Line^[x]:=Tmp;

   end;

   Scanlines[y]:=Line;

end;

FreeMem(Line,Width*3);

end;

 

procedure TFastBmp.VertRoll(Amount:Integer);

var

Line: PLine;

p,y:  Integer;

begin

if Amount>Width then Amount:=Amount mod Width;

if Amount=0 then Exit;

GetMem(Line,Amount*3);

for y:=0 to Height-1 do

begin

   p:=Integer(Scanlines[y]);

   CopyMemory(Line,Pointer(p+((Width-Amount)*3)),Amount*3);

   MoveMemory(Pointer(p+(Amount*3)),Pointer(p),(Width-Amount)*3);

   CopyMemory(Pointer(p),Line,Amount*3);

end;

FreeMem(Line,Amount*3);

end;

 

procedure TFastBmp.HorzRoll(Amount:Integer);

var

Buff: Pointer;

p,y:  Integer;

begin

if Amount>Height then Amount:=Amount mod Height;

if Amount=0 then Exit;

p:=Integer(Bits)+(Height*(Width mod 4))+((Height*Width)*3);

p:=p-Integer(Scanlines[Amount]);

y:=Integer(Scanlines[Amount])-Integer(Scanlines[0]);

GetMem(Buff,y);

CopyMemory(Buff,Scanlines[Height-Amount],y);

MoveMemory(Scanlines[Amount],Scanlines[0],p);

CopyMemory(Scanlines[0],Buff,y);

FreeMem(Buff,y);

end;

 

//  Optimizations Welcome!

procedure TFastBmp.WaveWrap(Dst:TFastBmp;XDIV,YDIV,RatioVal:Integer);

type PArray=^TArray;

    TArray=Array [0..0] of Integer;

var

i,j,x,y,

Val,XSrc,YSrc: Integer;

st:PArray;

begin

if(YDiv=0)or(XDiv=0)then Exit;

GetMem (st,4*Dst.Height);

For j:=0 to Dst.Height-1 do

   st^[j]:=Round(RatioVal*Sin(j/YDiv));

for i:=0 to Dst.Width-1 do

begin

   YSrc:=Round(RatioVal*sin(i/XDiv));

   if YSrc<0 then

     YSrc:=Height-1-(-YSrc mod Height)

   else

     if YSrc>=Height then

       YSrc:=YSrc mod(Height-1);

   for j:=0 to Dst.Height-1 do

   begin

     XSrc:=i+st[j];

     if XSrc<0 then

       XSrc:=Width-1-(-XSrc mod Width)

     else

       if XSrc>=Width then

         XSrc:=XSrc mod Width;

 

     Dst.Pixels[i,j]:=Pixels[XSrc,YSrc];

     Inc (YSrc);

     If YSrc=Height then

       YSrc:=0;

   end;

end;

FreeMem (st);

end;

 

//  Optimizations Welcome!

procedure TFastBmp.Wave(Dst:TFastBmp;XDIV,YDIV,RatioVal:Integer);

type PArray=^TArray;

    TArray=Array [0..0] of Integer;

var

i,j,x,y,

Val,XSrc,YSrc: Integer;

st:PArray;

begin

if(YDiv=0)or(XDiv=0)then Exit;

GetMem (st,4*Dst.Height);

For j:=0 to Dst.Height-1 do

   st^[j]:=Round(RatioVal*Sin(j/YDiv));

for i:=0 to Dst.Width-1 do

begin

   YSrc:=Round(RatioVal*Sin(i/XDiv));

   for j:=0 to Dst.Height-1 do

   begin

     XSrc:=i+st^[j];

 

     if(XSrc>-1)and(XSrc<Width)and(YSrc>-1)and(YSrc<Height)then

     Dst.Pixels[i,j]:=Pixels[XSrc,YSrc];

 

     Inc(YSrc);

   end;

end;

FreeMem(st);

end;

 

procedure TFastBmp.Spray(Dst:TFastBmp;Amount:Integer);

var

i,j,x,y,

Val:     Integer;

begin

for i:=0 to Dst.Width-1 do

for j:=0 to Dst.Height-1 do

begin

   Val:=Random(Amount);

   x:=i+Val-Random(Val*2);

   y:=j+Val-Random(Val*2);

   if(x>-1)and(x<Width)and(y>-1)and(y<Height)then

   Dst.Pixels[i,j]:=Pixels[x,y];

end;

end;

 

// Vit Kovalcik.. this codes fast!

procedure TFastBmp.InterpolateRect

(x1,y1,x2,y2:Integer;c00,c10,c01,c11:TFColor);

{Draws rectangle, which will have different color in each corner and

will blend from one color to another

 

c00 - color in upper left corner

c10 - upper right

c01 - lower left

c11 - lower right

 

(c[0,0]    c[1,0]

c[0,1]    c[1,1])

}

var

xCount,yCount:Integer;

t,t2,z,iz:Integer;

rp,rp2,gp,gp2,bp,bp2:Integer;

xx:Integer;

pb:PByte;

dx:Integer;

begin

If x2<x1 then

begin

   t:=x2;

   x2:=x1;

   x1:=t;

end;

If y2<y1 then

begin

   t:=y2;

   y2:=y1;

   y1:=t;

end;

If (x1<0) OR (y1<0) OR (x2>Width-1) OR (y2>Width-1) then

   Exit;

z:=0;

iz:=$100000;

If x2<>x1 then

   t:=$100000 div (x2-x1);

If y2<>y1 then

   t2:=$100000 div (y2-y1);

dx:=x2-x1;

For yCount:=y1 to y2 do

begin

   xx:=((c00.r*iz+c01.r*z) shr 20);

   rp:=xx shl 20;

   rp2:=(((c10.r*iz+c11.r*z) shr 20)-xx)*t;

   xx:=((c00.g*iz+c01.g*z) shr 20);

   gp:=xx shl 20;

   gp2:=(((c10.g*iz+c11.g*z) shr 20)-xx)*t;

   xx:=((c00.b*iz+c01.b*z) shr 20);

   bp:=xx shl 20;

   bp2:=(((c10.b*iz+c11.b*z) shr 20)-xx)*t;

   pb:=@PLine(ScanLines[yCount])^[x1];

   For xCount:=0 to dx do

   begin

     pb^:=bp shr 20;

     Inc (bp,bp2);

     PByte(Integer(pb)+1)^:=gp shr 20;

     Inc (gp,gp2);

     PByte(Integer(pb)+2)^:=rp shr 20;

     Inc (rp,rp2);

     Inc (pb,3);

   end;

   Inc (z,t2);

   Dec (iz,t2);

end;

end;

 

// EFG's computer lab - Rotate Scanline

procedure TFastBmp.RotateWrap(Dst:TFastBmp;Degree:Extended;iRotationAxis,jRotationAxis:Integer);

var

Theta,

cosTheta,

sinTheta:      Double;

i,j,Delta,

iOriginal,

iPrime,

iPrimeRotated,

jOriginal,

jPrime,

jPrimeRotated: Integer;

RowOriginal,

RowRotated:    PLine;

begin

GetMem(RowRotated,Dst.Width*3);

Theta:=-Degree*Pi/180;

sinTheta:=Sin(Theta);

cosTheta:=Cos(Theta);

 

for j:=0 to Dst.Height-1 do

begin

   Dst.GetScanline(j,RowRotated);

   jPrime:=2*(j-jRotationAxis)+1;

   for i:=0 to Dst.Width-1 do

   begin

     iPrime:=2*(i-iRotationAxis)+1;

     iPrimeRotated:=Round(iPrime*cosTheta-jPrime*sinTheta);

     jPrimeRotated:=Round(iPrime*sinTheta+jPrime*cosTheta);

     iOriginal:=(iPrimeRotated-1)div 2+iRotationAxis;

     jOriginal:=(jPrimeRotated-1)div 2+jRotationAxis;

 

     if      iOriginal<0       then iOriginal:=Width-1-(-iOriginal mod Width)

     else if iOriginal>=Width  then iOriginal:=iOriginal mod Width;

     if      jOriginal<0       then jOriginal:=Height-1-(-jOriginal mod Height)

     else if jOriginal>=Height then jOriginal:=jOriginal mod Height;

 

     RowOriginal:=Scanlines[jOriginal];

     RowRotated^[i]:=RowOriginal[iOriginal];

   end;

   Dst.Scanlines[j]:=RowRotated;

end;

FreeMem(RowRotated,Dst.Width*3);

end;

 

procedure TFastBmp.GrayScale;

var

Tmp:   PFColor;

Gray,

p,x,y: Integer;

begin

p:=Integer(Bits);

for y:=0 to Height-1 do

begin

   Tmp:=Pointer(p);

   for x:=0 to Width-1 do

   begin

     Gray:=Round(Tmp.r*0.3+Tmp.g*0.59+Tmp.b*0.11);

     Tmp.b:=Gray;

     Tmp.g:=Gray;

     Tmp.r:=Gray;

     Inc(Tmp);

   end;

   Inc(p,RowInc);

end;

end;

 

procedure TFastBmp.DiscardColor;

var

Tmp:   PFColor;

Gray,

p,x,y: Integer;

begin

p:=Integer(Bits);

for y:=0 to Height-1 do

begin

   Tmp:=Pointer(p);

   for x:=0 to Width-1 do

   begin

     Gray:=(Tmp.b*2+Tmp.g+Tmp.r)shr 2;

     Tmp.b:=Gray;

     Tmp.g:=Gray;

     Tmp.r:=Gray;

     Inc(Tmp);

   end;

   Inc(p,RowInc);

end;

end;

 

procedure TFastBmp.Sharpen;

begin

 

end;

 

//  Interpolated Resampling Based on 'Bitmap Resampler'

//

//  By Anders Melander <anders@melander.dk>

//  -Interpolated Bitmap Resampling using filters.

//

//  v0.04 Optimized w/PLines

//

//  Contributors:

//  Dale Schumacher - "General Filtered Image Rescaling"

//  David Ullrich <ullrich@hardy.math.okstate.edu>

 

// Hermite filter

function HermiteFilter(Value:Single):Single;

begin

// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1

if(Value<0)then Value:=-Value;

if(Value<1)then Result:=(2*Value-3)*Sqr(Value)+1

else Result:=0;

end;

 

// Box filter

// a.k.a. "Nearest Nieghbor" filter

// anme: I have not been able to get acceptable

//       results with this filter for subsampling.

function BoxFilter(Value:Single):Single;

begin

if(Value>-0.5)and(Value<=0.5)then Result:=1

else {Value > .5 | < -.5}         Result:=0;

end;

 

// Triangle filter

// a.k.a. "Linear" or "Bilinear" filter

function TriangleFilter(Value:Single):Single;

begin

if(Value<0)then Value:=-Value;

if(Value<1)then Result:=1-Value

else            Result:=0;

end;

 

// Bell filter

function BellFilter(Value:Single):Single;

begin

if(Value<0)then Value:=-Value;

if(Value<0.5)then Result:=0.75-Sqr(Value)

else if(Value<1.5)then Result:=0.5*Sqr(Value-1.5)

else Result:=0;

end;

 

// B-spline filter

function SplineFilter(Value:Single):Single;

var

tt: Single;

begin

if(Value<0)then Value:=-Value;

if(Value<1)then

begin

   tt:=Sqr(Value);

   Result:=0.5*tt*Value-tt+2/3;

end else if(Value<2)then

begin

   Value:=2-Value;

   Result:=1/6*Sqr(Value)*Value;

end else

   Result:=0;

end;

 

// Lanczos3 filter

function Lanczos3Filter(Value:Single):Single;

function SinC(Value:Single):Single;

begin

   if(Value<>0)then

   begin

     Value:=Value*Pi;

     Result:=Sin(Value)/Value

   end

   else Result:=1;

end;

begin

if(Value<0)then Value:=-Value;

if(Value<3)then Result:=SinC(Value)*SinC(Value/3)

else Result:=0;

end;

 

// Mitchell Filter

function MitchellFilter(Value:Single):Single;

const

C=0.333333333333333333333333333333333;

var

tt:Single;

begin

if(Value<0)then Value:=-Value;

tt:=Sqr(Value);

if(Value<1)then

begin

   Value:=(((12-9*C-6*C)*(Value*tt))+

          ((-18+12*C+6*C)*tt)+

          (6-2*C));

   Result:=Value/6;

end else

if(Value<2)then

begin

   Value:=(((-1*C-6*C)*(Value*tt))+

          ((6*C+30*C)*tt)+

          ((-12*C-48*C)*Value)+

          (8*C+24*C));

   Result:=Value/6;

end else

   Result:=0;

end;

 

procedure TFastBmp.Resample(Dst:TFastBmp;Filter:TFilterProc;FWidth:Single);

type

// Contributor for a pixel

TContributor=record

Pixel:  Integer;  // Source pixel

Weight: Single;  // Pixel weight

end;

 

TContributorList=array[0..0] of TContributor;

PContributorList=^TContributorList;

 

// List of source pixels contributing to a destination pixel

TCList=record

n: Integer;

p: PContributorList;

end;

 

TCListList=array[0..0] of TCList;

PCListList=^TCListList;

 

TRGB=record

r,g,b: Single;

end;

 

var

Delta,

DestDelta,

SrcWidth,

SrcHeight,

DstWidth,

DstHeight,

i,j,k,

Left,Right,n:   Integer;

 

xScale,yScale,

Center,Wdth,

fScale,Weight:  Single;

 

Work:           TFastBmp;

Contrib:        PCListList;

rgb:            TRGB;

Color:          TFColor;

SourceLine,

DestLine:       PLine;

SourcePixel,

DestPixel:      PFColor;

 

begin

DstWidth:=Dst.Width;

DstHeight:=Dst.Height;

SrcWidth:=Width;

SrcHeight:=Height;

 

Work:=TFastBmp.Create(DstWidth,SrcHeight);

 

if(SrcWidth=1)then xScale:=DstWidth/SrcWidth

else xScale:=(DstWidth-1)/(SrcWidth-1);

if(SrcHeight=1)then yScale:=DstHeight/SrcHeight

else yScale:=(DstHeight-1)/(SrcHeight-1);

 

GetMem(contrib, DstWidth*SizeOf(TCList));

// Horizontal sub-sampling

if(xScale<1)then

begin

   Wdth:=fWidth/xScale;

   fScale:=1/xScale;

   for i:=0 to DstWidth-1 do

   begin

     Contrib^[i].n:=0;

     GetMem(Contrib^[i].p,Trunc(Wdth*2+1)*SizeOf(TContributor));

     Center:=i/xScale;

     Left:=Trunc(Center-Wdth);

     Right:=Trunc(Center+Wdth);

     for j:=Left to Right do

     begin

       Weight:=Filter((Center-j)/fScale)/fScale;

       if(Weight=0)then Continue;

       if(j<0)then n:=-j

       else if(j>=SrcWidth)then n:=SrcWidth-j+SrcWidth-1

       else n:=j;

       k:=Contrib^[i].n;

       Contrib^[i].n :=Contrib^[i].n+1;

       Contrib^[i].p^[k].Pixel:=n;

       Contrib^[i].p^[k].Weight:=Weight;

     end;

   end;

end else

// Horizontal super-sampling

begin

   for i:=0 to DstWidth-1 do

   begin

     Contrib^[i].n:=0;

     GetMem(Contrib^[i].p,Trunc(fWidth*2+1)*SizeOf(TContributor));

     Center:=i/xScale;

     Left:=Trunc(Center-fWidth);

     Right:=Trunc(Center+fWidth);

     for j:=Left to Right do

     begin

       Weight:=Filter(Center-j);

       if(Weight=0)then Continue;

       if(j<0)then n:=-j

       else if(j>=SrcWidth)then n:=SrcWidth-j+SrcWidth-1

       else n:=j;

       k:=Contrib^[i].n;

       Contrib^[i].n:=Contrib^[i].n+1;

       Contrib^[i].p^[k].Pixel:=n;

       Contrib^[i].p^[k].Weight:=Weight;

     end;

   end;

end;

 

for k:=0 to SrcHeight-1 do

begin

   SourceLine:=ScanLines[k];

   DestPixel:=Work.ScanLines[k];

   for i:=0 to DstWidth-1 do

   begin

     rgb.r:=0;

     rgb.g:=0;

     rgb.b:=0;

     for j:=0 to Contrib^[i].n-1 do

     begin

       Color:=SourceLine^[Contrib^[i].p^[j].Pixel];

       Weight:=Contrib^[i].p^[j].Weight;

       if(Weight=0)then Continue;

       rgb.b:=rgb.b+Color.b*Weight;

       rgb.g:=rgb.g+Color.g*Weight;

       rgb.r:=rgb.r+Color.r*Weight;

     end;

     if(rgb.r>255)then Color.r:=255

     else if(rgb.r<0)then Color.r:=0

     else Color.r:=Round(rgb.r);

     if(rgb.g>255)then Color.g:=255

     else if(rgb.g<0)then Color.g:=0

     else Color.g:=Round(rgb.g);

     if(rgb.b>255)then Color.b:=255

     else if(rgb.b<0)then Color.b:=0

     else Color.b:=Round(rgb.b);

     DestPixel^:=Color;

     Inc(DestPixel);

   end;

end;

 

for i:=0 to DstWidth-1 do

FreeMem(Contrib^[i].p);

FreeMem(Contrib);

 

GetMem(contrib, DstHeight* sizeof(TCList));

 

// Vertical sub-sampling

if(yScale<1)then

begin

   Wdth:=fWidth/yScale;

   fScale:=1/yScale;

   for i:=0 to DstHeight-1 do

   begin

     Contrib^[i].n:=0;

     GetMem(Contrib^[i].p,Trunc(Wdth*2+1)*SizeOf(TContributor));

     Center:=i/yScale;

     Left:=Trunc(Center-Wdth);

     Right:=Trunc(Center+Wdth);

     for j:=Left to Right do

     begin

       Weight:=Filter((Center-j)/fScale)/fScale;

       if(Weight=0)then Continue;

       if(j<0)then n:=-j

       else if(j>=SrcHeight)then n:=SrcHeight-j+SrcHeight-1

       else n:=j;

       k:=Contrib^[i].n;

       Contrib^[i].n:=Contrib^[i].n+1;

       Contrib^[i].p^[k].Pixel:=n;

       Contrib^[i].p^[k].Weight:=Weight;

     end;

   end

end else

// Vertical super-sampling

begin

   for i:=0 to DstHeight-1 do

   begin

     Contrib^[i].n:=0;

     GetMem(Contrib^[i].p,Trunc(fWidth*2+1)*SizeOf(TContributor));

     Center:=i/yScale;

     Left:=Trunc(Center-fWidth);

     Right:=Trunc(Center+fWidth);

     for j:=Left to Right do

     begin

       Weight:=Filter(Center-j);

       if(Weight=0)then Continue;

       if(j<0)then n:=-j

       else if(j>=SrcHeight)then n:=SrcHeight-j+SrcHeight-1

       else n:=j;

       k:=Contrib^[i].n;

       Contrib^[i].n:=Contrib^[i].n+1;

       Contrib^[i].p^[k].Pixel:=n;

       Contrib^[i].p^[k].Weight:=Weight;

     end;

   end;

end;

 

SourceLine:=Work.ScanLines[0];

Delta:=Integer(Work.ScanLines[1])-Integer(SourceLine);

DestLine:=Dst.ScanLines[0];

DestDelta:=Integer(Dst.ScanLines[1])-Integer(DestLine);

for k:=0 to DstWidth-1 do

begin

   DestPixel:=Pointer(DestLine);

   for i:=0 to DstHeight-1 do

   begin

     rgb.r:=0;

     rgb.g:=0;

     rgb.b:=0;

     for j:=0 to Contrib^[i].n-1 do

     begin

       Color:=PFColor(Integer(SourceLine)+Contrib^[i].p^[j].Pixel*Delta)^;

       Weight:=Contrib^[i].p^[j].Weight;

       if(Weight=0)then Continue;

       rgb.r:=rgb.r+Color.r*Weight;

       rgb.g:=rgb.g+Color.g*Weight;

       rgb.b:=rgb.b+Color.b*Weight;

     end;

     if(rgb.r>255)then Color.r:=255

     else if(rgb.r<0)then Color.r:=0

     else Color.r:=Round(rgb.r);

     if(rgb.g>255)then Color.g:=255

     else if(rgb.g<0)then Color.g:=0

     else Color.g:=Round(rgb.g);

     if(rgb.b>255)then Color.b:=255

     else if(rgb.b<0)then Color.b:=0

     else Color.b:=Round(rgb.b);

     DestPixel^:=Color;

     Inc(Integer(DestPixel),DestDelta);

   end;

   Inc(SourceLine);

   Inc(DestLine);

end;

 

for i:=0 to DstHeight-1 do

FreeMem(Contrib^[i].p);

FreeMem(Contrib);

Work.Free;

end;

 

 

destructor TFastBmp.Destroy;

begin

FreeMem(Calcs,Height*SizeOf(Integer));

DeleteObject(Handle);

inherited;

end;

 

end.