Распознавание изображения

[ClMlD]

Добрый час! Помогите разобраться в исходнике
Довольно давно один добрый человек с форума помог мне с написание программы для распознавания цифр , сейчас мне опять потребовался данный софт но он запилин под определенный шрифт , я сам пытался разобраться и к тому человеку обращался, вообщем я не смог понять , а он сказал забыл как пиксели подбирал (Может просто занят был)

Буду рад если вы просветите , просто объяснили бы как там идет определение что мне нужно отрегулировать что бы я смог применить другой шрифт ?

В архиве сам исходник , оригинал старых цифр, и цифры собранные в ряд для теста .
С начало нужно жмякнуть фильтр, потом поиск

Спасибо за внимание

[ClMlD]

UP

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    Memo1: TMemo;
    Button3: TButton;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    function scrin(x, y, h, w: integer): integer;
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  bmp: tbitmap;

CONST
  PixelCountMax = 32768;

TYPE
  pRGBArray = ^TRGBArray;
  TRGBArray = ARRAY [0 .. PixelCountMax - 1] OF TRGBTriple;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  x, y: integer;
  cif, cl: boolean;
  b, e: integer;
  t: integer;
  sum: string;
const
  s = '27953806';
begin
  Memo1.Clear;
  Memo1.Lines.BeginUpdate;
  sum := '';
  cif := false;
  b := 0;
  for x := 0 to bmp.Width - 1 do
  begin
    cl := true;
    for y := 0 to bmp.Height - 1 do
      if bmp.Canvas.Pixels[x, y] = clblack then
      begin
        if not cif then
        begin
          b := x;
          cif := true;
        end;
        cl := false;
        break;
      end;
    if cif and cl then
    begin
      e := x - 1;
      case e - b + 1 of
        6:
          sum := sum + '1';
        14:
          sum := sum + '4';
      else
        begin
          t := 4 * ord(bmp.Canvas.Pixels[b + 11, 14] = clblack) + 2 * ord
            (bmp.Canvas.Pixels[b, 9] = clblack) + ord
            (bmp.Canvas.Pixels[b + 4, 7] = clblack) + ord
            (bmp.Canvas.Pixels[b + 10, 0] = clblack) + 1;
          sum := sum + s[t];
        end;
      end;
      Memo1.Lines.Add(inttostr(b) + ' ' + inttostr(e) + ' = ' + inttostr
          (e - b + 1));
      cif := false;
    end;
  end;
  if cif then
  begin
    e := bmp.Width - 1;
    case e - b + 1 of
      6:
        sum := sum + '1';
      14:
        sum := sum + '4';
    else
      begin
        t := 4 * ord(bmp.Canvas.Pixels[b + 11, 14] = clblack) + 2 * ord
          (bmp.Canvas.Pixels[b, 9] = clblack) + ord
          (bmp.Canvas.Pixels[b + 4, 7] = clblack) + ord
          (bmp.Canvas.Pixels[b + 10, 0] = clblack) + 1;
        sum := sum + s[t];
      end;
    end;
    Memo1.Lines.Add(inttostr(b) + ' ' + inttostr(e));
  end;
  Label1.Caption := sum;
  Memo1.Lines.EndUpdate;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  x, y: integer;
  Row: pRGBArray;
begin
  for y := bmp.Height - 1 downto 0 do
  begin
    Row := pRGBArray(bmp.Scanline[y]);
    for x := 0 to bmp.Width - 1 do
    begin
      if (Row[x].rgbtGreen = 0) and (Row[x].rgbtblue < 10) then
      begin
        Row[x].rgbtRed := 0;
        Row[x].rgbtBlue := 0;
        Row[x].rgbtRed := 0;
      end
      else
      begin
        Row[x].rgbtBlue := 255;
        Row[x].rgbtGreen := 255;
        Row[x].rgbtRed := 255;
      end;
    end;
  end;
  Image1.Picture.Assign(bmp); // показать, как сработало преобразование в черно белое
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Image1.Picture.LoadFromFile('000.bmp');
  // только для показа на форме
  bmp := tbitmap.Create;
  bmp.LoadFromFile('000.bmp');
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  bmp.Free;
end;

function TForm1.scrin(x, y, h, w: integer): integer;
var
DeskHw,DeskHdC : Longint;
begin
deskHw:=getdesktopwindow;
DeskHdc:=getdc(deskHw);
Image2.Height:=(h);
Image2.Width:=(w);
BitBlt(Image2.Canvas.Handle,0,0,(w),(h),DeskHdc,(x),(y),SRCCOPY);
Image2.Picture.SaveToFile('f.bmp');
Image2.Picture:=nil;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
scrin(335,665,18,60);
end;

end.

[ClMlD]

UP UP UP UP

[BDA]

Похоже никто не хочет разбираться в таком коде
Дайте картинку со всеми цифрами (разместите на одной картинке, как в 000.bmp; крайне желательно по порядку) нового шрифта посмотреть.

[ClMlD]

скринеть функцией или сторонней программой можно , а то я помню у нас проблемы с этим были

[ClMlD]

Готово . . .. .

[ClMlD]

UP UP UP UP UP

[raxp]

...а зачем написали готово? Используйте Free GOCR, используйте MODI, используйте много чего, а вы зациклились на задаче, а время идет.

[ClMlD]

Сообщение от raxp

...а зачем написали готово? Используйте Free GOCR, используйте MODI, используйте много чего, а вы зациклились на задаче, а время идет.

Написал готово по поводу изображения , мне время особо роли не играет ибо пишу программу для себя, а распознания текста просто увеличит эффективность программы но она и без этого работает поэтому не спешу , а надеюсь что ув. BDA снова меня выручит так как данный код работал идеально

[BDA]

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    Memo1: TMemo;
    Button3: TButton;
    Image2: TImage;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    function scrin(x, y, h, w: integer): integer;
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  bmp: tbitmap;

CONST
  PixelCountMax = 32768;

TYPE
  pRGBArray = ^TRGBArray;
  TRGBArray = ARRAY [0 .. PixelCountMax - 1] OF TRGBTriple;

implementation

{$R *.dfm}

procedure solver(var sum: string; b, e: integer);
begin
  if e - b + 1 = 3 then
    sum := sum + '1'
  else if bmp.Canvas.Pixels[b + 1, 5] = clblack then
    sum := sum + '2'
  else if bmp.Canvas.Pixels[b + 2, 5] = clblack then
    sum := sum + '7'
  else if bmp.Canvas.Pixels[b + 3, 5] = clblack then
    sum := sum + '4'
  else if bmp.Canvas.Pixels[b, 0] = clblack then
    sum := sum + '5'
  else if bmp.Canvas.Pixels[b + 1, 1] = clblack then
    sum := sum + '6'
  else if (bmp.Canvas.Pixels[b + 4, 3] = clblack) and
    (bmp.Canvas.Pixels[b + 1, 4] = clblack) then
    sum := sum + '9'
  else if (bmp.Canvas.Pixels[b + 2, 3] = clblack) and
    (bmp.Canvas.Pixels[b + 1, 3] <> clblack) then
    sum := sum + '3'
  else if bmp.Canvas.Pixels[b, 3] = clblack then
    sum := sum + '0'
  else
    sum := sum + '8';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  x, y: integer;
  cif, cl: boolean;
  b, e: integer;
  sum: string;
begin
  Memo1.Clear;
  Memo1.Lines.BeginUpdate;
  sum := '';
  cif := false;
  b := 0;
  for x := 0 to bmp.Width - 1 do
  begin
    cl := true;
    for y := 0 to bmp.Height - 1 do
      if bmp.Canvas.Pixels[x, y] = clblack then
      begin
        if not cif then
        begin
          b := x;
          cif := true;
        end;
        cl := false;
        break;
      end;
    if cif and cl then
    begin
      e := x - 1;
      solver(sum, b, e);
      Memo1.Lines.Add(inttostr(b) + ' ' + inttostr(e) + ' = ' + inttostr
          (e - b + 1));
      cif := false;
    end;
  end;
  if cif then
  begin
    e := bmp.Width - 1;
    solver(sum, b, e);
    Memo1.Lines.Add(inttostr(b) + ' ' + inttostr(e));
  end;
  Label1.Caption := sum;
  Memo1.Lines.EndUpdate;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  x, y: integer;
  Row: pRGBArray;
begin
  for y := bmp.Height - 1 downto 0 do
  begin
    Row := pRGBArray(bmp.Scanline[y]);
    for x := 0 to bmp.Width - 1 do
    begin
      if (Row[x].rgbtred < 30) and (Row[x].rgbtgreen < 30) and
        (Row[x].rgbtblue < 30) then
      begin
        Row[x].rgbtblue := 255;
        Row[x].rgbtgreen := 255;
        Row[x].rgbtred := 255;
      end
      else
      begin
        Row[x].rgbtblue := 0;
        Row[x].rgbtgreen := 0;
        Row[x].rgbtred := 0;
      end;
    end;
  end;
  Image1.Picture.Assign(bmp); // показать, как сработало преобразование в черно белое
  Image1.Picture.SaveToFile('filter.bmp');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Image1.Picture.LoadFromFile('000.bmp');
  // только для показа на форме
  bmp := tbitmap.Create;
  bmp.LoadFromFile('000.bmp');
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  bmp.Free;
end;

function TForm1.scrin(x, y, h, w: integer): integer;
var
  DeskHw, DeskHdC: Longint;
begin
  DeskHw := getdesktopwindow;
  DeskHdC := getdc(DeskHw);
  Image2.Height := (h);
  Image2.Width := (w);
  BitBlt(Image2.Canvas.Handle, 0, 0, (w), (h), DeskHdC, (x), (y), SRCCOPY);
  Image2.Picture.SaveToFile('f.bmp');
  Image2.Picture := nil;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  scrin(335, 665, 18, 60);
end;

end.

1) Не смог разделить также красиво, как в прошлый раз
2) Нашел пару ошибок в предыдущей реализации
3) Изменен фильтр, а определение числа вынесено в отдельную функцию (вообще говоря, можно подумать над рефакторингом кода)