ndocr3.dpr

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

library NdOcr3;

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;



{$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:Integer;
begin
  l := Length(ary) - 1;
  for n1:=0 to l-1 do
  begin
    if (lightKind = 2) or (lightKind = 4) then begin
      n3 := ary[n1][1];
      n4 := n1;
      for n2:=n1+1 to l do
      begin
        if n3 < ary[n2][1] then
        begin
          n3 := ary[n2][1];
          n4 := n2;
        end;
      end;
    end else begin
      n3 := ary[n1][0];
      n4 := n1;
      for n2:=n1+1 to l do
      begin
        if n3 < ary[n2][0] then
        begin
          n3 := ary[n2][0];
          n4 := n2;
        end;
      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;
	while i <= l do
	begin
	  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 light1 := otsuIndex(ary);
  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);
  l := imgW*imgH-1;
  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,top,borderT,borderX,borderB: 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;
        top := n1;
        borderT := 0;
        borderX := 0;
        borderB := 0;
        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];
            if y < top then top := y;
            if (x=0) or (x=48) then Inc(borderX);
            if (y=0) then Inc(borderT);
            if (y=19) then Inc(borderB);
            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) and (top<10) and (borderX<8) and (borderT<5) and (borderB<5) 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 unifyDrawLine(toX,toY,x,y,x1,y1,w,unitW:Integer;xp,yp:Double;var ary,unitAry:TBArray);stdcall;
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);stdcall;
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;

function unifyUnit(var unitW,unitH:Integer;var unitAry:TBArray):Boolean;stdcall;
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;