ndocr1.dpr

一个不错的QQ2009验证码自动识别程序源代码

library NdOcr1;

uses
  SysUtils,Windows,Classes,Math;

type
  TBArray  = Array of byte;
  TABArray = Array of TBArray;
  TAIArray = Array of Array[0..1] of Integer;
  TAAIArray = Array of TAIArray;
  TI25Array = Array[0..24] of byte;
  TLib = record
    LibName: string;
    mRound,bone,lightKind,light1,light2,dots,limit,spn,spx0,spy0,spuw,spuh,sppw: Integer;
    maxNoise: Double;
    Ary: TBArray;
  end;

var
  libAry: Array of TLib;
  boneTp: Array[0..9] of Array[0..11] of Integer =
    (
      (0,-1,1,-1,0,1,1,1,0,-1,1,-1),
      (0,0,-1,-1,0,1,1,1,-1,1,1,-1),
      (-1,1,1,-1,0,1,1,1,0,0,-1,-1),
      (1,1,1,-1,1,-1,0,0,0,99,99,99),
      (1,-1,0,1,1,0,1,-1,0,99,99,99),
      (-1,0,0,1,1,0,-1,1,-1,99,99,99),
      (-1,1,-1,1,1,0,-1,0,0,99,99,99),
      (0,0,0,-1,1,-1,1,1,1,-1,1,-1),
      (0,0,0,0,1,0,1,1,1,99,99,99),
      (0,0,1,0,1,1,0,0,1,99,99,99)
    );


{$R *.res}

procedure setLightAry(i:Integer;var ary:TAIArray;var imgAry:TBArray);stdcall;
var
  n1: Integer;
begin
  for n1:=0 to Length(ary)-1 do
  begin
    if ary[n1][0] = imgAry[i] then
    begin
      Inc(ary[n1][1]);
      exit;
    end;
  end;
  n1 := Length(ary);
  SetLength(ary,n1+1);
  ary[n1][0] := imgAry[i];
  ary[n1][1] := 1;
end;

procedure sortLightAry(var ary:TAIArray;lightKind:byte);stdcall;
var
  n1,n2,n3,n4,l,kind:Integer;
begin
  l := Length(ary) - 1;
  if (lightKind = 2) or (lightKind = 4) then
    kind := 1
  else
    kind := 0;
  for n1:=0 to l-1 do
  begin
    n3 := ary[n1][kind];
    n4 := n1;
    for n2:=n1+1 to l do
    begin
      if n3 < ary[n2][kind] then
      begin
        n3 := ary[n2][kind];
        n4 := n2;
      end;
    end;
    if n4 <> n1 then
    begin
      n2 := ary[n1][0];
      n3 := ary[n1][1];
      ary[n1][0] := ary[n4][0];
      ary[n1][1] := ary[n4][1];
      ary[n4][0] := n2;
      ary[n4][1] := n3;
    end;
  end;
end;

function indexOfLightAry(c:Integer;var ary:TAIArray):Integer;stdcall;
var
  n:Integer;
begin
  for n:=0 to Length(ary)-1 do
  begin
    if ary[n][0] = c then
    begin
      result := n;
      exit;
    end;
  end;
  result := -1;
end;

function otsuIndex(var ary:TAIArray):Integer;stdcall;
var
  sum,csum,fmax,m1,m2,sb: Double;
  n,k,n1,n2: Integer;
begin
  result := 1;
  if Length(ary) < 3 then exit;
  sum := 0;
  csum := 0;
  n := 0;
  for k:=0 to Length(ary)-1 do
  begin
    sum := sum + ary[k][0]*ary[k][1];
    n := n + ary[k][1];
  end;
  fmax := -1;
  n1 := 0;
  for k:=0 to Length(ary)-1 do
  begin
    n1 := n1 + ary[k][1];
    n2 := n - n1;
    if n2 = 0 then break;
    csum := csum + ary[k][0]*ary[k][1];
    m1 := csum / n1;
    m2 := (sum-csum) / n2;
    sb := n1*n2*(m1-m2)*(m1-m2);
    if sb > fmax then
    begin
      fmax := sb;
      result := k + 1;
    end;
  end;
end;

function picTo01(lightKind:byte;light1,light2,dots,imgW,imgH:Integer;var imgAry:TBArray):Integer;stdcall;
var
  ary:TAIArray;
  ary2:TBArray;
  i,l,n1,count:Integer;
begin

	Randomize();
	i := 0;
	l := imgW*imgH - 1;
  count := 0;
	while i <= l do
	begin
    Inc(count);
	  setLightAry(i,ary,imgAry);
	  if dots > 2 then
	  begin
	    Inc(i,dots+Random(5)-2);
	  end else begin
	    Inc(i,dots);
	  end;
	end;

	sortLightAry(ary,lightKind);

  if lightKind = 0 then begin
    light1 := otsuIndex(ary);
    if light2 = -1 then begin
      n1 := 0;
      for i:=0 to light1-1 do Inc(n1,ary[i][1]);
      if n1*2 >= count then
        light2 := Length(ary)
      else begin
        light2 := light1;
        light1 := 0;
      end;
    end;
  end else if lightKind < 3 then begin
    if light1 = -1 then light1 := Length(ary);
    if light2 = -1 then light2 := Length(ary);
  end else begin
    if light1 = -1 then light1 := imgW * imgH;
    if light2 = -1 then light2 := imgW * imgH;
  end;

  count := 0;
  SetLength(ary2,imgW*imgH);
  for i:=0 to l do
  begin
    n1 := imgAry[i];
    if lightKind < 3 then n1 := indexOfLightAry(n1,ary);
    if (n1>=light1) and (n1<=light2) then
    begin
      ary2[i] := 1;
      Inc(count);
    end else begin
      ary2[i] := 0;
    end;
  end;

  imgAry:=ary2;
  result := count;
end;

procedure to8(x,y,imgW,imgH:Integer;var ary:TAIArray;var imgAry:TBArray);stdcall;
var l:Integer;
begin
  if (x>=0) and (x<imgW) and (y>=0) and (y<imgH) and (imgAry[y*imgW+x]=1) then
  begin
    imgAry[y*imgW+x] := 2;
    l := Length(ary);
    SetLength(ary,l+1);
    ary[l][0] := x;
    ary[l][1] := y;
  end;
end;

function clearNoise(maxNoise,imgW,imgH:Integer;rtnFlag:Boolean;var imgAry:TBArray):TAAIArray;stdcall;
var
  n1,n2,n3,n4,x,y: Integer;
  ary,ary2: TAIArray;
  rtnAry: TAAIArray;
begin
  if rtnFlag then SetLength(rtnAry,0);
  for n2:=0 to imgW-1 do
  begin
    for n1:=0 to imgH-1 do
    begin
      if imgAry[n1*imgW+n2] = 1 then
      begin
        SetLength(ary,1);
        ary[0][0] := n2;
        ary[0][1] := n1;
        imgAry[n1*imgW+n2] := 2;
        n3 := 0;
        SetLength(ary2,1);
        While Length(ary2) > 0 do
        begin
          SetLength(ary2,0);
          for n4:=n3 to Length(ary)-1 do
          begin
            x := ary[n4][0];
            y := ary[n4][1];
            to8(x-1,y-1,imgW,imgH,ary2,imgAry);
            to8(x,y-1,imgW,imgH,ary2,imgAry);
            to8(x+1,y-1,imgW,imgH,ary2,imgAry);
            to8(x-1,y,imgW,imgH,ary2,imgAry);
            to8(x+1,y,imgW,imgH,ary2,imgAry);
            to8(x-1,y+1,imgW,imgH,ary2,imgAry);
            to8(x,y+1,imgW,imgH,ary2,imgAry);
            to8(x+1,y+1,imgW,imgH,ary2,imgAry);
          end;
          n3 := Length(ary);
          SetLength(ary,n3+Length(ary2));
          for n4:=0 to Length(ary2)-1 do
          begin
            ary[n3+n4] := ary2[n4];
          end;
        end;
        if Length(ary) > maxNoise then
        begin
          n4 := 3;
          if rtnFlag then
          begin
            n3 := Length(rtnAry);
            SetLength(rtnAry,n3+1);
            rtnAry[n3] := ary;
          end;
        end else
          n4 := 0;
        for n3:=0 to Length(ary)-1 do
          imgAry[ary[n3][0]+ary[n3][1]*imgW] := n4;
      end;
    end;
  end;
  n2 := imgW*imgH-1;
  for n1:=0 to n2 do
    if imgAry[n1] = 3 then imgAry[n1] := 1;
  result := rtnAry;
end;

procedure fixUnit(unitW,unitH:Integer;var unitAry:TBArray);stdcall;
var
  ary: Array of Integer;
  n1,n2,n3: Integer;
begin
  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
          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 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
        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;

	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);stdcall;
var
  x0,y0,l,ml: Double;
  i,n,n2,x1,x2,y1,y2,us2: Integer;
  lAry: Array of Integer;
  ua2: TBArray;
  flag: Boolean;
s:string;
begin
  x0 := 0;
  y0 := 0;
  n2 := 0;
  SetLength(lAry,unitH);
  for i:=0 to unitH-1 do
  begin
    lAry[i] := unitW;
    for n:=0 to unitW-1 do
    begin
      if unitAry[i*unitW+n] = 1 then
      begin
        if lAry[i] = unitW then lAry[i] := n;
        Inc(n2);
        x0 := x0 + n;
        y0 := y0 + i;
      end;
    end;
  end;
  if n2 = 0 then exit;
  x0 := x0 / n2;
  y0 := y0 / n2;
  ml := Sqrt(Sqr(unitW)+Sqr(unitH));
  y1 := -1;
  y2 := -1;
  for i:=0 to Round(y0) do
  begin
    if lAry[i] <> unitW then
    begin
      for n:=Round(y0)+1 to unitH-1 do
      begin
        if lAry[n] <> unitW then
        begin
          flag := true;
          for n2:=0 to unitH-1 do
          begin
            if ((lAry[i]-lAry[n])*n2-lAry[i]*n+lAry[n]*i)/(i-n) > lAry[n2] then
            begin
              flag := false;
              break;
            end;
          end;
          if flag then
          begin
            l := Abs((i-n)*x0+(lAry[n]-lAry[i])*y0+lAry[i]*n-lAry[n]*i)/Sqrt(Sqr(i-n)+Sqr(lAry[n]-lAry[i]));
            if l < ml then
            begin
              ml := l;
              y1 := i;
              y2 := n;
            end;
            break;
          end;
        end;
      end;
    end;
  end;
  if y1 = -1 then exit;

  x1 := lAry[y1];
  x2 := lAry[y2];

  if x1 = x2 then exit;

  y0 := Sqrt(Sqr(x1-x2) + Sqr(y1-y2));
  x0 := Abs(x2-x1)/y0;
  y0 := Abs(y2-y1)/y0;
  if x2 > x1 then
  begin
    ml := x2+(unitH-1-y2)*(x2-x1)/(y2-y1);
    x2 := Round(ml+x0*x0*(unitW-1-ml));
    y2 := Round(y1+(unitH-1-y1)/(ml-x1)*(x2-x1));
  end else begin
    ml := y2+x2*(y2-y1)/(x1-x2);
    y2 := Round(ml+y0*y0*(unitH-1-ml));
    x2 := Round(x1-(y2-y1)*x1/(ml-y1));
  end;
  us2 := Round(Sqrt(Sqr(unitW)+Sqr(unitH)));
  SetLength(ua2,Sqr(us2));
  for i:=0 to Sqr(us2)-1 do ua2[i] := 0;
  for i:=0 to unitH-1 do
  begin
    for n:=0 to unitW-1 do
    begin
      if unitAry[n+i*unitW] = 1 then
      begin
        ml := Sqrt(Sqr(n-x2)+Sqr(i-y2));
        ua2[Round(ml*y0+(ml*x0-1)*us2)] := 1;
      end;
    end;
  end;
  unitW := us2;
  unitH := us2;
  unitAry := ua2;
s:='';
  for i:=0 to unitH-1 do
  begin
    for n:=0 to unitW-1 do s:=s+inttostr(unitary[n+i*unitw]);
    s:=s+';'+#13;
  end;
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);stdcall;
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);