2025-05-12 10:07:51 +03:00

599 lines
15 KiB
ObjectPascal
Raw Blame History

unit imgFx;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls,Math;
procedure PicInvert(src: tbitmap; isTrans:Boolean);
procedure AddColorNoise(var clip: tbitmap; Amount: Integer;isTrans:Boolean);
procedure AntiAliasRect(clip: tbitmap; XOrigin, YOrigin,XFinal, YFinal: Integer;isTrans:Boolean);
procedure AntiAlias(clip: tbitmap;isTrans:Boolean);
procedure Contrast(var clip: tbitmap; Amount: Integer;isTrans:Boolean);
procedure Saturation(var clip: tbitmap; Amount: Integer;isTrans:Boolean);
procedure Lightness(var clip: tbitmap; Amount: Integer;isTrans:Boolean);
procedure Darkness(var src: tbitmap; Amount: integer;isTrans:Boolean);
procedure GrayScale(var clip: tbitmap;isTrans:Boolean);
procedure SmoothResize(var Src, Dst: TBitmap);
procedure SmoothRotate(var Src, Dst: TBitmap; cx, cy: Integer;Angle: Extended);
procedure SplitBlur(var clip: tbitmap; Amount: integer;isTrans:Boolean);
procedure GaussianBlur(var clip: tbitmap; Amount: integer;isTrans:Boolean);
procedure Mosaic(var Bm:TBitmap;size:Integer;isTrans:Boolean);
procedure Emboss(var Bmp:TBitmap;isTrans:Boolean);
procedure Solorize(src, dst: tbitmap; amount: integer;isTrans:Boolean);
procedure Posterize(src, dst: tbitmap; amount: integer;isTrans:Boolean);
implementation
type
pRGBArray = ^TRGBArray; // Use SysUtils.pByteArray for 8-bit color
TRGBArray = ARRAY[0..32767] OF TRGBTriple;
var
tC:trgbtriple;
pa:pRGBArray;
function eRgb(t:trgbtriple;p:pbytearray;index:Integer):Boolean;
begin
result := (t.rgbtBlue = p[index]) and (t.rgbtGreen = p[index+1]) and (t.rgbtRed = p[index+2]);
end;
procedure PicInvert(src: tbitmap;isTrans:Boolean);
var w,h,x,y:integer;
p:pbytearray;
begin
w:=src.width;
h:=src.height;
src.PixelFormat :=pf24bit;
pa := src.scanline[h-1];
tc := pa[0];
for y:=0 to h-1 do begin
p:=src.scanline[y];
for x:=0 to w-1 do begin
if (not isTrans) or (not eRGB(tc,p,x*3)) then
begin
p[x*3]:= not p[x*3];
p[x*3+1]:= not p[x*3+1];
p[x*3+2]:= not p[x*3+2];
end;
end;
end;
end;
function IntToByte(i:Integer):Byte;
begin
if i>255 then Result:=255
else if i<0 then Result:=0
else Result:=i;
end;
procedure AddColorNoise(var clip: tbitmap; Amount: Integer;isTrans:Boolean);
var
p0:pbytearray;
x,y,r,g,b: Integer;
begin
pa := clip.scanline[clip.Height-1];
tc := pa[0];
for y:=0 to clip.Height-1 do
begin
p0:=clip.ScanLine [y];
for x:=0 to clip.Width-1 do
begin
if (not isTrans) or (not eRGB(tc,p0,x*3)) then
begin
r:=p0[x*3]+(Random(Amount)-(Amount shr 1));
g:=p0[x*3+1]+(Random(Amount)-(Amount shr 1));
b:=p0[x*3+2]+(Random(Amount)-(Amount shr 1));
p0[x*3]:=IntToByte(r);
p0[x*3+1]:=IntToByte(g);
p0[x*3+2]:=IntToByte(b);
end;
end;
end;
end;
procedure AntiAliasRect(clip: tbitmap; XOrigin, YOrigin,
XFinal, YFinal: Integer;isTrans:Boolean);
var Memo,x,y: Integer; (* Composantes primaires des points environnants *)
p0,p1,p2:pbytearray;
begin
pa := clip.scanline[clip.Height-1];
tc := pa[0];
if XFinal<XOrigin then begin Memo:=XOrigin; XOrigin:=XFinal; XFinal:=Memo; end; (* Inversion des valeurs *)
if YFinal<YOrigin then begin Memo:=YOrigin; YOrigin:=YFinal; YFinal:=Memo; end; (* si diff<66>rence n<>gative*)
XOrigin:=max(1,XOrigin);
YOrigin:=max(1,YOrigin);
XFinal:=min(clip.width-2,XFinal);
YFinal:=min(clip.height-2,YFinal);
clip.PixelFormat :=pf24bit;
for y:=YOrigin to YFinal do begin
p0:=clip.ScanLine [y-1];
p1:=clip.scanline [y];
p2:=clip.ScanLine [y+1];
for x:=XOrigin to XFinal do begin
if (not isTrans) or (not eRGB(tc,p1,x*3)) then
begin
p1[x*3]:=(p0[x*3]+p2[x*3]+p1[(x-1)*3]+p1[(x+1)*3])div 4;
p1[x*3+1]:=(p0[x*3+1]+p2[x*3+1]+p1[(x-1)*3+1]+p1[(x+1)*3+1])div 4;
p1[x*3+2]:=(p0[x*3+2]+p2[x*3+2]+p1[(x-1)*3+2]+p1[(x+1)*3+2])div 4;
end;
end;
end;
end;
procedure AntiAlias(clip: tbitmap;isTrans:Boolean);
begin
AntiAliasRect(clip,0,0,clip.width,clip.height,isTrans);
end;
procedure Contrast(var clip: tbitmap; Amount: Integer;isTrans:Boolean);
var
p0:pbytearray;
rg,gg,bg,r,g,b,x,y: Integer;
begin
pa := clip.scanline[clip.Height-1];
tc := pa[0];
for y:=0 to clip.Height-1 do
begin
p0:=clip.scanline[y];
for x:=0 to clip.Width-1 do
begin
if (not isTrans) or (not eRGB(tc,p0,x*3)) then
begin
r:=p0[x*3];
g:=p0[x*3+1];
b:=p0[x*3+2];
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;
p0[x*3]:=IntToByte(r);
p0[x*3+1]:=IntToByte(g);
p0[x*3+2]:=IntToByte(b);
end;
end;
end;
end;
procedure GrayScale(var clip: tbitmap;isTrans:Boolean);
var
p0:pbytearray;
Gray,x,y: Integer;
begin
pa := clip.scanline[clip.Height-1];
tc := pa[0];
for y:=0 to clip.Height-1 do
begin
p0:=clip.scanline[y];
for x:=0 to clip.Width-1 do
begin
if (not isTrans) or (not eRGB(tc,p0,x*3)) then
begin
Gray:=Round(p0[x*3]*0.3+p0[x*3+1]*0.59+p0[x*3+2]*0.11);
p0[x*3]:=Gray;
p0[x*3+1]:=Gray;
p0[x*3+2]:=Gray;
end;
end;
end;
end;
procedure Lightness(var clip: tbitmap; Amount: Integer;isTrans:Boolean);
var
p0:pbytearray;
r,g,b,x,y: Integer;
begin
pa := clip.scanline[clip.Height-1];
tc := pa[0];
for y:=0 to clip.Height-1 do begin
p0:=clip.scanline[y];
for x:=0 to clip.Width-1 do
begin
if (not isTrans) or (not eRGB(tc,p0,x*3)) then
begin
r:=p0[x*3];
g:=p0[x*3+1];
b:=p0[x*3+2];
p0[x*3]:=IntToByte(r+((255-r)*Amount)div 255);
p0[x*3+1]:=IntToByte(g+((255-g)*Amount)div 255);
p0[x*3+2]:=IntToByte(b+((255-b)*Amount)div 255);
end;
end;
end;
end;
procedure Darkness(var src: tbitmap; Amount: integer;isTrans:Boolean);
var
p0:pbytearray;
r,g,b,x,y: Integer;
begin
src.pixelformat:=pf24bit;
pa := src.scanline[src.Height-1];
tc := pa[0];
for y:=0 to src.Height-1 do begin
p0:=src.scanline[y];
for x:=0 to src.Width-1 do
begin
if (not isTrans) or (not eRGB(tc,p0,x*3)) then
begin
r:=p0[x*3];
g:=p0[x*3+1];
b:=p0[x*3+2];
p0[x*3]:=IntToByte(r-((r)*Amount)div 255);
p0[x*3+1]:=IntToByte(g-((g)*Amount)div 255);
p0[x*3+2]:=IntToByte(b-((b)*Amount)div 255);
end;
end;
end;
end;
procedure Saturation(var clip: tbitmap; Amount: Integer;isTrans:Boolean);
var
p0:pbytearray;
Gray,r,g,b,x,y: Integer;
begin
pa := clip.scanline[clip.Height-1];
tc := pa[0];
for y:=0 to clip.Height-1 do begin
p0:=clip.scanline[y];
for x:=0 to clip.Width-1 do
begin
if (not isTrans) or (not eRGB(tc,p0,x*3)) then
begin
r:=p0[x*3];
g:=p0[x*3+1];
b:=p0[x*3+2];
Gray:=(r+g+b)div 3;
p0[x*3]:=IntToByte(Gray+(((r-Gray)*Amount)div 255));
p0[x*3+1]:=IntToByte(Gray+(((g-Gray)*Amount)div 255));
p0[x*3+2]:=IntToByte(Gray+(((b-Gray)*Amount)div 255));
end;
end;
end;
end;
procedure SmoothResize(var Src, Dst: TBitmap);
var
x,y,xP,yP,
yP2,xP2: Integer;
Read,Read2: PByteArray;
t,z,z2,iz2: Integer;
pc:PBytearray;
w1,w2,w3,w4: Integer;
Col1r,col1g,col1b,Col2r,col2g,col2b: byte;
begin
xP2:=((src.Width-1)shl 15)div Dst.Width;
yP2:=((src.Height-1)shl 15)div Dst.Height;
yP:=0;
for y:=0 to Dst.Height-1 do
begin
xP:=0;
Read:=src.ScanLine[yP shr 15];
if yP shr 16<src.Height-1 then
Read2:=src.ScanLine [yP shr 15+1]
else
Read2:=src.ScanLine [yP shr 15];
pc:=Dst.scanline[y];
z2:=yP and $7FFF;
iz2:=$8000-z2;
for x:=0 to Dst.Width-1 do
begin
t:=xP shr 15;
Col1r:=Read[t*3];
Col1g:=Read[t*3+1];
Col1b:=Read[t*3+2];
Col2r:=Read2[t*3];
Col2g:=Read2[t*3+1];
Col2b:=Read2[t*3+2];
z:=xP and $7FFF;
w2:=(z*iz2)shr 15;
w1:=iz2-w2;
w4:=(z*z2)shr 15;
w3:=z2-w4;
pc[x*3+2]:=
(Col1b*w1+Read[(t+1)*3+2]*w2+
Col2b*w3+Read2[(t+1)*3+2]*w4)shr 15;
pc[x*3+1]:=
(Col1g*w1+Read[(t+1)*3+1]*w2+
Col2g*w3+Read2[(t+1)*3+1]*w4)shr 15;
pc[x*3]:=
(Col1r*w1+Read2[(t+1)*3]*w2+
Col2r*w3+Read2[(t+1)*3]*w4)shr 15;
Inc(xP,xP2);
end;
Inc(yP,yP2);
end;
end;
function TrimInt(i, Min, Max: Integer): Integer;
begin
if i>Max then Result:=Max
else if i<Min then Result:=Min
else Result:=i;
end;
procedure SmoothRotate(var Src, Dst: TBitmap; cx, cy: Integer;
Angle: Extended);
type
TFColor = record b,g,r:Byte end;
var
Top,
Bottom,
Left,
Right,
eww,nsw,
fx,fy,
wx,wy: Extended;
cAngle,
sAngle: Double;
xDiff,
yDiff,
ifx,ify,
px,py,
ix,iy,
x,y: Integer;
nw,ne,
sw,se: TFColor;
P1,P2,P3:Pbytearray;
begin
Angle:=angle;
Angle:=-Angle*Pi/180;
sAngle:=Sin(Angle);
cAngle:=Cos(Angle);
xDiff:=(Dst.Width-Src.Width)div 2;
yDiff:=(Dst.Height-Src.Height)div 2;
for y:=0 to Dst.Height-1 do
begin
P3:=Dst.scanline[y];
py:=2*(y-cy)+1;
for x:=0 to Dst.Width-1 do
begin
px:=2*(x-cx)+1;
fx:=(((px*cAngle-py*sAngle)-1)/ 2+cx)-xDiff;
fy:=(((px*sAngle+py*cAngle)-1)/ 2+cy)-yDiff;
ifx:=Round(fx);
ify:=Round(fy);
if(ifx>-1)and(ifx<Src.Width)and(ify>-1)and(ify<Src.Height)then
begin
eww:=fx-ifx;
nsw:=fy-ify;
iy:=TrimInt(ify+1,0,Src.Height-1);
ix:=TrimInt(ifx+1,0,Src.Width-1);
P1:=Src.scanline[ify];
P2:=Src.scanline[iy];
nw.r:=P1[ifx*3];
nw.g:=P1[ifx*3+1];
nw.b:=P1[ifx*3+2];
ne.r:=P1[ix*3];
ne.g:=P1[ix*3+1];
ne.b:=P1[ix*3+2];
sw.r:=P2[ifx*3];
sw.g:=P2[ifx*3+1];
sw.b:=P2[ifx*3+2];
se.r:=P2[ix*3];
se.g:=P2[ix*3+1];
se.b:=P2[ix*3+2];
Top:=nw.b+eww*(ne.b-nw.b);
Bottom:=sw.b+eww*(se.b-sw.b);
P3[x*3+2]:=IntToByte(Round(Top+nsw*(Bottom-Top)));
Top:=nw.g+eww*(ne.g-nw.g);
Bottom:=sw.g+eww*(se.g-sw.g);
P3[x*3+1]:=IntToByte(Round(Top+nsw*(Bottom-Top)));
Top:=nw.r+eww*(ne.r-nw.r);
Bottom:=sw.r+eww*(se.r-sw.r);
P3[x*3]:=IntToByte(Round(Top+nsw*(Bottom-Top)));
end;
end;
end;
end;
procedure SplitBlur(var clip: tbitmap; Amount: integer;isTrans:Boolean);
var
p0,p1,p2:pbytearray;
cx,x,y: Integer;
Buf: array[0..3,0..2]of byte;
begin
if Amount=0 then Exit;
pa := clip.scanline[clip.Height-1];
tc := pa[0];
for y:=0 to clip.Height-1 do
begin
p0:=clip.scanline[y];
if y-Amount<0 then p1:=clip.scanline[y]
else {y-Amount>0} p1:=clip.ScanLine[y-Amount];
if y+Amount<clip.Height then p2:=clip.ScanLine[y+Amount]
else {y+Amount>=Height} p2:=clip.ScanLine[clip.Height-y];
for x:=0 to clip.Width-1 do
begin
if (not isTrans) or (not eRGB(tc,p0,x*3)) then
begin
if x-Amount<0 then cx:=x
else {x-Amount>0} cx:=x-Amount;
Buf[0,0]:=p1[cx*3];
Buf[0,1]:=p1[cx*3+1];
Buf[0,2]:=p1[cx*3+2];
Buf[1,0]:=p2[cx*3];
Buf[1,1]:=p2[cx*3+1];
Buf[1,2]:=p2[cx*3+2];
if x+Amount<clip.Width then cx:=x+Amount
else {x+Amount>=Width} cx:=clip.Width-x;
Buf[2,0]:=p1[cx*3];
Buf[2,1]:=p1[cx*3+1];
Buf[2,2]:=p1[cx*3+2];
Buf[3,0]:=p2[cx*3];
Buf[3,1]:=p2[cx*3+1];
Buf[3,2]:=p2[cx*3+2];
p0[x*3]:=(Buf[0,0]+Buf[1,0]+Buf[2,0]+Buf[3,0])shr 2;
p0[x*3+1]:=(Buf[0,1]+Buf[1,1]+Buf[2,1]+Buf[3,1])shr 2;
p0[x*3+2]:=(Buf[0,2]+Buf[1,2]+Buf[2,2]+Buf[3,2])shr 2;
end;
end;
end;
end;
procedure GaussianBlur(var clip: tbitmap; Amount: integer;isTrans:Boolean);
var
i: Integer;
clp: Tbitmap;
begin
clp := TBitmap.Create;
clp.Width := Clip.Width +1;
clp.Height := Clip.Height+1;
clp.PixelFormat := pf24bit;
clp.Canvas.StretchDraw(Rect(0,0,clp.Width,clp.Height),clip);
for i:=Amount downto 0 do
SplitBlur(clp,1,isTrans);
clip.Canvas.Draw(0,0,clp);
end;
procedure Mosaic(var Bm:TBitmap;size:Integer;isTrans:Boolean);
var
x,y,i,j:integer;
p1,p2:pbytearray;
r,g,b:byte;
begin
y:=0;
repeat
p1:=bm.scanline[y];
x:=0;
repeat
j:=1;
repeat
p2:=bm.scanline[y];
x:=0;
repeat
r:=p1[x*3];
g:=p1[x*3+1];
b:=p1[x*3+2];
i:=1;
repeat
p2[x*3]:=r;
p2[x*3+1]:=g;
p2[x*3+2]:=b;
inc(x);
inc(i);
until (x>=bm.width) or (i>size);
until x>=bm.width;
inc(j);
inc(y);
until (y>=bm.height) or (j>size);
until (y>=bm.height) or (x>=bm.width);
until y>=bm.height;
end;
procedure Emboss(var Bmp:TBitmap;isTrans:Boolean);
var
x,y: Integer;
p1,p2: Pbytearray;
begin
pa := Bmp.scanline[Bmp.Height-1];
tc := pa[0];
for y:=0 to Bmp.Height-2 do
begin
p1:=bmp.scanline[y];
p2:=bmp.scanline[y+1];
for x:=0 to Bmp.Width-4 do
begin
if (not isTrans) or (not eRGB(tc,p1,x*3)) then
begin
p1[x*3]:=(p1[x*3]+(p2[(x+3)*3] xor $FF))shr 1;
p1[x*3+1]:=(p1[x*3+1]+(p2[(x+3)*3+1] xor $FF))shr 1;
p1[x*3+2]:=(p1[x*3+2]+(p2[(x+3)*3+2] xor $FF))shr 1;
end;
end;
end;
end;
procedure Solorize(src, dst: tbitmap; amount: integer;isTrans:Boolean);
var w,h,x,y:integer;
ps,pd:pbytearray;
c:integer;
begin
pa := src.scanline[src.Height-1];
tc := pa[0];
w:=src.width;
h:=src.height;
src.PixelFormat :=pf24bit;
dst.PixelFormat :=pf24bit;
for y:=0 to h-1 do begin
ps:=src.scanline[y];
pd:=dst.scanline[y];
for x:=0 to w-1 do begin
c:=(ps[x*3]+ps[x*3+1]+ps[x*3+2]) div 3;
if ((not isTrans) or (not eRGB(tc,ps,x*3))) and (c>amount) then
begin
pd[x*3]:= 255-ps[x*3];
pd[x*3+1]:=255-ps[x*3+1];
pd[x*3+2]:=255-ps[x*3+2];
end
else begin
pd[x*3]:=ps[x*3];
pd[x*3+1]:=ps[x*3+1];
pd[x*3+2]:=ps[x*3+2];
end;
end;
end;
end;
procedure Posterize(src, dst: tbitmap; amount: integer;isTrans:Boolean);
var w,h,x,y:integer;
ps,pd:pbytearray;
c:integer;
begin
pa := src.scanline[src.Height-1];
tc := pa[0];
w:=src.width;
h:=src.height;
src.PixelFormat :=pf24bit;
dst.PixelFormat :=pf24bit;
for y:=0 to h-1 do begin
ps:=src.scanline[y];
pd:=dst.scanline[y];
for x:=0 to w-1 do begin
if ((not isTrans) or (not eRGB(tc,ps,x*3))) then
begin
pd[x*3]:= round(ps[x*3]/amount)*amount;
pd[x*3+1]:=round(ps[x*3+1]/amount)*amount;
pd[x*3+2]:=round(ps[x*3+2]/amount)*amount;
end else begin
pd[x*3]:= ps[x*3];
pd[x*3+1]:=ps[x*3+1];
pd[x*3+2]:=ps[x*3+1];
end;
end;
end;
end;
end.