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‚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.