📄 fastbmp.pas
字号:
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;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -