func.pas

识别动网asp论坛的验证码 程序语言：delphi 7.0 作者：netdust 2007-12-4

        end;
        if n1 < unitH-1 then
        begin
          Inc(n3,unitAry[(n1+1)*unitW+n2]);
          if n2 > 0 then Inc(n3,unitAry[(n1+1)*unitW+n2-1]);
          if n2 < unitW-1 then Inc(n3,unitAry[(n1+1)*unitW+n2+1]);
        end;
        if n2 > 0 then Inc(n3,unitAry[n1*unitW+n2-1]);
        if n2 < unitW-1 then Inc(n3,unitAry[n1*unitW+n2+1]);
        if n3 = 1 then
        begin
          n3 := Length(ary);
          SetLength(ary,n3+1);
          ary[n3] := n1*unitW+n2;
        end;
      end else begin
        //添补4个正方向被堵死的点
        n3 := 0;
        if n1 > 0 then Inc(n3,unitAry[(n1-1)*unitW+n2]);
        if n1 < unitH-1 then Inc(n3,unitAry[(n1+1)*unitW+n2]);
        if n2 > 0 then Inc(n3,unitAry[n1*unitW+n2-1]);
        if n2 < unitW-1 then Inc(n3,unitAry[n1*unitW+n2+1]);
        if n3 = 4 then unitAry[n1*unitW+n2] := 1;
      end;
    end;
  end;
  for n1:=0 to Length(ary)-1 do unitAry[ary[n1]] := 0;

	//去除周围有2个邻居，且相连的点
	//去除周围有3个邻居，且在同一方向的点
  SetLength(ary,0);
  for n1:=0 to unitH-1 do
  begin
    for n2:=0 to unitW-1 do
    begin
      if unitAry[n1*unitW+n2] = 1 then
      begin
        n3 := 0;
        if n1 > 0 then
        begin
          if n2 > 0 then Inc(n3,unitAry[(n1-1)*unitW+n2-1]);
          Inc(n3,unitAry[(n1-1)*unitW+n2] shl 1);
          if n2 < unitW-1 then Inc(n3,unitAry[(n1-1)*unitW+n2+1] shl 2);
        end;
        if n2 > 0 then Inc(n3,unitAry[n1*unitW+n2-1] shl 3);
        if n2 < unitW-1 then Inc(n3,unitAry[n1*unitW+n2+1] shl 4);
        if n1 < unitH-1 then
        begin
          if n2 > 0 then Inc(n3,unitAry[(n1+1)*unitW+n2-1] shl 5);
          Inc(n3,unitAry[(n1+1)*unitW+n2] shl 6);
          if n2 < unitW-1 then Inc(n3,unitAry[(n1+1)*unitW+n2+1] shl 7);
        end;
        if (n3=3) or (n3=6) or (n3=20) or (n3=144) or (n3=192) or (n3=96) or (n3=40) or (n3=9)
          or (n3=7) or (n3=148) or (n3=41) or (n3=224) then
        begin
          n3 := Length(ary);
          SetLength(ary,n3+1);
          ary[n3] := n1*unitW+n2;
        end;
      end;
    end;
  end;
  for n1:=0 to Length(ary)-1 do unitAry[ary[n1]] := 0;
end;

//旋转图片，使旋转干扰失效
procedure roundUnit(var unitW,unitH:Integer;var unitAry:TBArray);
begin
	//未实现
end;

//根据骨线模板对点进行标记
procedure boneDeal(tn,w,h,i,n,unitW,unitH:Integer;var unitAry:TBArray;var dotF:Boolean);
var
  i1,i2,v: Integer;
begin
  for i1:=1 to w do
  begin
    for i2:=1 to h do
    begin
      v := boneTp[tn][(i2-1)*w+i1-1];
      if (v<>-1) and (unitAry[(i+i2-2)*unitW+(n+i1-2)]<>v) then exit;
    end;
  end;
  dotF := true;
end;

//图片抽骨 (实际效果不好，基本未使用)
procedure boneUnit(unitW,unitH:Integer;var unitAry:TBArray);
var
  i,n: Integer;
  flag,dotF: Boolean;
begin
  flag := true;
  while flag do
  begin
    flag := false;
    for i:=1 to unitH-2 do
    begin
      for n:=1 to unitW-2 do
      begin
        if unitAry[i*unitW+n] = 1 then
        begin
          dotF := false;
          if n < unitW-2 then
          begin
            if not dotF then boneDeal(0,4,3,i,n,unitW,unitH,unitAry,dotF);
            if not dotF then boneDeal(1,4,3,i,n,unitW,unitH,unitAry,dotF);
            if not dotF then boneDeal(2,4,3,i,n,unitW,unitH,unitAry,dotF);
          end;
          if not dotF then boneDeal(3,3,3,i,n,unitW,unitH,unitAry,dotF);
          if not dotF then boneDeal(4,3,3,i,n,unitW,unitH,unitAry,dotF);
          if not dotF then boneDeal(5,3,3,i,n,unitW,unitH,unitAry,dotF);
          if not dotF then boneDeal(6,3,3,i,n,unitW,unitH,unitAry,dotF);
          if (i<unitH-2) and (not dotF) then boneDeal(7,3,4,i,n,unitW,unitH,unitAry,dotF);
          if dotF then
          begin
            unitAry[i*unitW+n] := 0;
            if not flag then flag := true;
          end;
        end;
      end;
    end;
  end;
  //使用2个紧缩模板再进行一轮细化
  for i:=1 to unitH-2 do
  begin
    for n:=1 to unitW-2 do
    begin
      if unitAry[i*unitW+n] = 1 then
      begin
        dotF := false;
        if not dotF then boneDeal(8,3,3,i,n,unitW,unitH,unitAry,dotF);
        if not dotF then boneDeal(9,3,3,i,n,unitW,unitH,unitAry,dotF);
        if dotF then unitAry[i*unitW+n] := 0;
      end;
    end;
  end;
end;

//标准化连线
procedure unifyDrawLine(toX,toY,x,y,x1,y1,w,unitW:Integer;xp,yp:Double;var ary,unitAry:TBArray);
var
  dx,dy,dt,n: Integer;
begin
  if unitAry[(toY+y1)*unitW+toX+x1] = 0 then exit;
  toX := Round(toX*xp);
  toY := Round(toY*yp);
  dx := toX - x;
  dy := toY - y;
  if Abs(dx) > Abs(dy) then dt := Abs(dx) else dt := Abs(dy);
  for n:=1 to dt-1 do ary[(y+Round(n*dy/dt))*w+x+Round(n*dx/dt)] := 1;
end;

//标准化填区域
procedure unifyDrawArea(toX,toY,x,y,x1,y1,w,unitW:Integer;xp,yp:Double;var ary,unitAry:TBArray);
var
  dx,dy,n1,n2: Integer;
begin
  if unitAry[(toY+y1)*unitW+toX+x1] = 0 then exit;
  toX := Round(toX*xp);
  toY := Round(toY*yp);
  dx := toX - x;
  dy := toY - y;
  for n1:=1 to Abs(dy)-1 do
    for n2:=1 to Abs(dx)-1 do
      ary[(y+n1*Sign(dy))*w+x+n2*Sign(dx)] := 1;
end;

//统一到40*40大小，返回为false时表示没有任何点
function unifyUnit(var unitW,unitH:Integer;var unitAry:TBArray):Boolean;
var
  ary: TBArray;
  n1,n2,x,y,x1,x2,y1,y2,w,h: Integer;
  xp,yp: Double;
  flag: Boolean;
begin
  //舍弃周围空白
  x1 := -1;
  for n1:=0 to unitW-1 do
  begin
    for n2:=0 to unitH-1 do
    begin
      if unitAry[n2*unitW+n1] = 1 then
       begin
        x1 := n1;
        break;
      end;
    end;
    if x1 > -1 then break;
  end;
  if x1 = -1 then
  begin
    result := false;
    exit;
  end;
  x2 := -1;
  for n1:=unitW-1 downto 0 do
  begin
    for n2:=0 to unitH-1 do
    begin
      if unitAry[n2*unitW+n1] = 1 then
      begin
        x2 := n1;
        break;
      end;
    end;
    if x2 > -1 then break;
  end;
  y1 := -1;
  for n1:=0 to unitH-1 do
  begin
    for n2:=0 to unitW-1 do
    begin
      if unitAry[n1*unitW+n2] = 1 then
      begin
        y1 := n1;
        break;
      end;
    end;
    if y1 > -1 then break;
  end;
  y2 := -1;
  for n1:=unitH-1 downto 0 do
  begin
    for n2:=0 to unitW-1 do
    begin
      if unitAry[n1*unitW+n2] = 1 then
      begin
        y2 := n1;
        break;
      end;
    end;
    if y2 > -1 then break;
  end;
  Dec(x2,x1-1);
  Dec(y2,y1-1);
  //统一大小
  w := 40;
  h := 40;
  SetLength(ary,w*h);
  for n1:=0 to w*h-1 do ary[n1] := 0;
  if x2 > 1 then xp := (w-1)/(x2-1) else xp := w-1;
  if y2 > 1 then yp := (h-1)/(y2-1) else yp := h-1;
  flag := (xp>1) or (yp>1);
  for n1:=0 to y2-1 do
  begin
    for n2:=0 to x2-1 do
    begin
      if unitAry[(n1+y1)*unitW+n2+x1] = 1 then
      begin
        x := Round(n2*xp);
        y := Round(n1*yp);
        ary[y*w+x] := 1;
        if flag then
        begin
          if n2<x2-1 then unifyDrawLine(n2+1,n1,x,y,x1,y1,w,unitW,xp,yp,ary,unitAry);
          if n1<y2-1 then
          begin
            unifyDrawLine(n2,n1+1,x,y,x1,y1,w,unitW,xp,yp,ary,unitAry);
            if unitAry[(n1+y1+1)*unitW+n2+x1] = 0 then
            begin
              if (n2<x2-1) and (unitAry[(n1+y1)*unitW+n2+x1+1]=0) then
                unifyDrawLine(n2+1,n1+1,x,y,x1,y1,w,unitW,xp,yp,ary,unitAry);
              if (n2>0) and (unitAry[(n1+y1)*unitW+n2+x1-1]=0) then
                unifyDrawLine(n2-1,n1+1,x,y,x1,y1,w,unitW,xp,yp,ary,unitAry);
            end else begin
              if (n2<x2-1) and (unitAry[(n1+y1)*unitW+n2+x1+1]=1) then
                unifyDrawArea(n2+1,n1+1,x,y,x1,y1,w,unitW,xp,yp,ary,unitAry);
              if (n2>0) and (unitAry[(n1+y1)*unitW+n2+x1-1]=1) then
                unifyDrawArea(n2-1,n1+1,x,y,x1,y1,w,unitW,xp,yp,ary,unitAry);
            end;
          end;
        end;
      end;
    end;
  end;
  unitW := w;
  unitH := h;
  unitAry := ary;
  result := true;
end;

//数组的欧氏距离
function osLen(var ary1,ary2:TI25Array):Integer;
var
  i,v: Integer;
begin
  v := 0;
  for i:=0 to 24 do Inc(v,(ary1[i]-ary2[i])*(ary1[i]-ary2[i]));
  result := v;
end;

//按照指定区域进行分隔
//spn: 0 自动分隔，否则按指定区域分隔; -1 最大可分隔数; >0 限制在最大分隔数内
//spx0,spy0:从0开始的
function splitArea(spn,spx0,spy0,spuw,spuh,sppw,imgW:Integer;var imgAry:TBArray):TAAIArray;
var
  ary: TAAIArray;
  n1,n2,n3,l: Integer;
begin
  SetLength(ary,spn);
  for n1:=0 to spn-1 do
  begin
    for n2:=0 to spuw-1 do
    begin
      for n3:=0 to spuh-1 do
      begin
        if imgAry[(n3+spy0)*imgW+n2+n1*(spuw+sppw)+spx0] = 1 then
        begin
          l := Length(ary[n1]);
          SetLength(ary[n1],l+1);
          ary[n1][l][0] := n2 + n1*spuw + spx0;
          ary[n1][l][1] := n3 + spy0;
        end;
      end;
    end;
  end;
  //去掉空集
  n2 := 0;
  for n1:=0 to spn-1 do
  begin
    if Length(ary[n1]) = 0 then
      Inc(n2)
    else if n2 > 0 then
      ary[n1-n2] := ary[n1];
  end;
  if n2 > 0 then SetLength(ary,Length(ary)-n2);
  result := ary;
end;

//剪裁目标区域
procedure cutArea(var imgW,imgH:Integer;spx0,spy0,spw2,sph2:Integer;var imgAry:TBArray);
var
  ary2: TBArray;
  i,n: Integer;
begin
  if spw2 <= 0 then spw2 := imgW + spw2;
  if sph2 <= 0 then sph2 := imgH + sph2;
  if spw2 > imgW then spw2 := imgW;
  if sph2 > imgH then sph2 := imgH;
  SetLength(ary2,spw2*sph2);
  for i:=0 to sph2-1 do
  begin
    for n:=0 to spw2-1 do
    begin
      ary2[i*spw2+n] := imgAry[(i+spy0)*imgW+n+spx0];
    end;
  end;
  imgAry := ary2;
  imgW := spw2;
  imgH := sph2;
end;

function loadLib_Str(var buf:TBArray;n,l:Integer):string;
var
  i: Integer;
  s: string;
begin
  s := '';
  for i:=0 to l-1 do s := s + char(buf[n+i]);
  result := s;
end;

function loadLib_Int(var buf:Array of byte;var i:Integer):Integer;
begin
  result := buf[i] + buf[i+1] shl 8 + buf[i+2] shl 16 + buf[i+3] shl 24;
  Inc(i,4);
end;

function loadLibFile(kind,fn:pchar):Boolean;
var
  buf: TBArray;
  n,i,j,k: Integer;
  sLibName: string;
begin
  result := false;
  n := FileOpen(fn, fmOpenRead);
  if n = -1 then exit;
  i := FileSeek(n,0,2);
  FileSeek(n,0,0);
  SetLength(buf,i);
  FileRead(n, buf[0], i);
  FileClose(n);
  if loadLib_Str(buf,0,8) <> ('NdOcrLib') then exit;  //文件类型
  if buf[8] <> 1 then exit;   //版本
  sLibName := loadLib_Str(buf,71,20);
  j := Length(libAry);
  for n:=0 to j-1 do   //重复加载库
    if StrComp(pchar(libAry[n].LibName),pchar(sLibName)) = 0 then exit;

  SetLength(libAry,j+1);
  with libAry[j] do
  begin
    mRound := buf[9];
    bone := buf[10];
    k := 11;
    lightKind := loadLib_Int(buf,k);
    light1 := loadLib_Int(buf,k);
    light2 := loadLib_Int(buf,k);
    dots := loadLib_Int(buf,k);
    maxNoise := loadLib_Int(buf,k) / 1000;
    limit := loadLib_Int(buf,k);
    spn := loadLib_Int(buf,k);
    spx0 := loadLib_Int(buf,k);
    spy0 := loadLib_Int(buf,k);
    spuw := loadLib_Int(buf,k);
    spuh := loadLib_Int(buf,k);
    sppw := loadLib_Int(buf,k);
    rlL := loadLib_Int(buf,k);
    rlH := loadLib_Int(buf,k);
    ruW := loadLib_Int(buf,k);
  end;
  libAry[j].LibName := sLibName;
  libAry[j].Ary := copy(buf,291,i-291);
  result := true;
end;

end.