{Copyright Francesco Savastano 2001 : This source is free , but you
 cannot distribute it , if you want others have it , let them know
 to come to my web site : http://digilander.iol.it/gensavas/francosava/
If you put this algorithm in your free or commercial software i'd like my name in your thanx list .
 also check out my photoretouch program at : http://web.tiscalinet.it/new_world_software/ }

 {Description :unit to implement the famous magic wand algorithm : an other secret is revealed !
 the use of this unit is shown in the attached delphi sample program }
 unit magwand;



interface


uses
  Windows,SysUtils, Classes, Graphics,math;

type
tbool2darray=array of array of boolean;
TPointArray= array of TPoint;
procedure magicwand(var bitmap1:tbitmap;a,b:integer;oldcolor:tcolor;tolerance:real;var mask:tbool2darray);
procedure exec(var bitmap1:tbitmap;xf,yf:integer;var nf:integer;oldcolor:tcolor;tolerance:real;var mask:tbool2darray);
procedure showmagicwand(var bitmap1:tbitmap;var mask:tbool2darray);
Procedure MakePath(var mask:tbool2darray;var Points:TPointArray;var closed:Boolean);
Procedure BoundMask(var mask:tbool2darray;var maskX:tbool2darray);


implementation
type
  trgbtriplerow=array[0..30000]of trgbtriple;
  prgbtriplerow=^trgbtriplerow;

var
  fillx:array[0..80000]of integer;
  filly:array[0..80000]of integer;


  {magic wand algorithm same as seed fill algorithm}
procedure magicwand;
var
  nf:integer;
  i,ir:integer;
  xf,yf:integer;
begin
nf := 1;
ir := 1;
fillx[nf]:= a;
filly[nf]:= b;
exec(bitmap1,a,b,nf,oldcolor,tolerance,mask);
while nf>ir do
begin
ir := ir+1;
xf := fillx[ir];
yf := filly[ir];
exec(bitmap1,xf,yf,nf,oldcolor,tolerance,mask);
if (nf>75000)  then
begin
for i := 1 to nf-ir do
begin
fillx[i] := fillx[ir+i];
filly[i] := filly[ir+i];
end;
nf := nf-ir ;
ir := 0;
end;
end;
end;


procedure exec;
var
hh,ll,ss,h1,l1,s1,aa,bb,cc:real;
c1,c2,c3,pixr,pixg,pixb,oldr,oldg,oldb,newr,newg,newb:byte;
pix:tcolorref;
jj:byte;
xr,yr:longint;
gray:real;
pp:prgbtriplerow;
begin
oldr:=getrvalue(oldcolor);
oldg:=getgvalue(oldcolor);
oldb:=getbvalue(oldcolor);

for jj:=1 to 4 do
begin
if jj=1 then
begin
xr:=xf+1;
yr:=yf;
end;
if jj=2 then
begin
xr:=xf-1;
yr:=yf;
end;
if jj=3 then
begin
xr:=xf;
yr:=yf+1;
end;
if jj=4 then
begin
xr:=xf;
yr:=yf-1;
end;
if ((xr< bitmap1.width)and(jj=1))or((xr>=0)and(jj=2))
or ((yr< bitmap1.height)and(jj=3))or((yr>=0)and(jj=4)) then
begin
pp:=bitmap1.scanline[yr];
pix:=rgb(pp[xr].rgbtred,pp[xr].rgbtgreen,pp[xr].rgbtblue);
pixr:=getrvalue(pix);
pixg:=getgvalue(pix);
pixb:=getbvalue(pix);
if (not mask[xr,yr])and(abs(pixr-oldr)<=tolerance*150)and(abs(pixg-oldg)<=tolerance*150)and(abs(pixb-oldb)<=tolerance*150)then
begin
mask[xr,yr]:=true;
nf := nf+1;
fillx[nf]:= xr;
filly[nf]:= yr;
end;
end;
end;
end;

{This is only one of possible ways to show the result of the magic wand selection (stored in the array "mask" ) onto a bitmap ,
sorry but the selection will not be animated like you see in some photoretouch softwares ,
but i don't think this is very difficult to do !}

procedure showmagicwand;
var
i,j:integer;
test:boolean;
pp:prgbtriplerow;
begin
  for j:=1 to bitmap1.height-2 do
  begin
    pp:=bitmap1.scanline[j];
    for i:=1 to bitmap1.width-2 do
    begin
      if mask[i,j]then
      begin
        test:= mask[i-1,j] and mask[i+1,j] and mask[i,j-1] and mask[i,j+1] ;
        if not test then
        begin
          {simply invert the colors of the boundary pixels }
          with pp[i] do
          begin
            rgbtred:=255-rgbtred;
            rgbtgreen:=255-rgbtgreen;
            rgbtblue:=255-rgbtblue;
          end;
        end;
      end;
    end;
  end;
end;

Procedure BoundMask(var mask:tbool2darray;var maskX:tbool2darray);
var
i,j:integer;
lenH,lenW: Integer;
test: Boolean;
Si,sJ,ci,cj: Integer;
first:Boolean;
done: Boolean;
pCnt:Integer;
begin
  lenW := Length(mask);
  lenH := Length(mask[0]);
  SetLength(maskX,LenW);
  for i := 0 to LenW-1 do SetLength(maskX[i],LenH);
  for j := 0 to Lenh-1 do
    for i := 0 to LenW-1 do
      maskX[i,j] := false;
  first := True;
  for j:=1 to lenH-2 do
  begin
    //pp:=bitmap1.scanline[j];
    for i:=1 to lenW-2 do
    begin
      if mask[i,j]then
      begin
        test:= mask[i-1,j] and mask[i+1,j] and mask[i,j-1] and mask[i,j+1] ;
        if not test then
        begin
          {simply invert the colors of the boundary pixels }
          maskX[i,j] := True;
          if first then begin
            si := i;
            sj := j;
            first := false;
          end;
        end;
      end;
    end;
  end;
end;

Procedure MakePath(var mask:tbool2darray;var Points:TPointArray; var closed: Boolean);
var
i,j:integer;
lenH,lenW: Integer;
MaskX:tbool2darray;
test: Boolean;
Si,sJ,ci,cj: Integer;
first:Boolean;
done: Boolean;
pCnt:Integer;
begin
  Closed := false;
  si := -1;
  sj := -1;

  lenW := Length(mask);
  lenH := Length(mask[0]);
  SetLength(maskX,LenW);
  SetLength(Points,0);
  for i := 0 to LenW-1 do SetLength(maskX[i],LenH);
  for j := 0 to Lenh-1 do
    for i := 0 to LenW-1 do
      maskX[i,j] := false;
  first := True;
  for j:=1 to lenH-2 do
  begin
    //pp:=bitmap1.scanline[j];
    for i:=1 to lenW-2 do
    begin
      if mask[i,j]then
      begin
        test:= mask[i-1,j] and mask[i+1,j] and mask[i,j-1] and mask[i,j+1] ;
        if not test then
        begin
          {simply invert the colors of the boundary pixels }
          maskX[i,j] := True;
          if first then begin
            si := i;
            sj := j;
            first := false;
          end;
        end;
      end;
    end;
  end;
  if (si = -1) or (sj = -1) then exit;
  ci := si;
  cj := sj;
  SetLength(Points,1);
  Points[0] := Point(si,sj);
  pCnt := 1;
  done := false;
  repeat
    if (ci < LenW-1) and maskX[ci+1,cj] then begin
      ci := ci+1;
    end else if (cj > 0) and maskX[ci,cj-1] then begin
      cj := cj-1;
    end else if (cj < LenH-1) and maskX[ci,cj+1] then begin
      cj := cj+1;
    end else if (ci > 0) and maskX[ci-1,cj] then begin
      ci := ci-1;
    end else if (ci > 0) and (cj < LenH-1) and maskX[ci-1,cj+1] then begin
      ci := ci-1;
      cj := cj+1;
    end else if (cj < LenH-1) and (ci < LenW-1) and maskX[ci+1,cj+1] then begin
      ci := ci+1;
      cj := cj+1;
    end else if (ci > 0) and (cj > 0) and maskX[ci-1,cj-1] then begin
      ci := ci-1;
      cj := cj-1;
    end else if (ci < LenW-1) and (cj >0) and maskX[ci+1,cj-1] then begin
      ci := ci+1;
      cj := cj-1;
    end else begin
      done := True;
    end;
    if not done then begin
      pCnt := pCnt+1;
      SetLength(Points,pCnt);
      Points[pCnt-1] := Point(ci,cj);
      maskx[ci,cj] := false;
    end;
    if done then begin
      if (abs(ci-si) < 2) and (abs(cj-sj) < 2) then closed := True;
    end;
  until done;

end;



end.