[czuryk]

Добрый день коллеги! Очень прошу помочь!

Давно уже бьюсь, но никак не могу расколоть сабжевую проблему, гугл выдает некую информацию, но мне никак не удается ее адаптировать для своих нужд. Учтите, речь идет не о сравнении одного изображения с другим.
Мне нужно организовать поиск одного изображения (маленького, порядка 100х50 пикселей) в другом - большом, порядка 1280х1024 пикселей, причем поиск должен осуществлятся максимально быстро < 1 сек. Результатом работы функкции должны быть координаты X,Y маленьгоко изображения в большом (исходном).
Причем поиск долже выполнятся по полному схождению части большого изображения и маленького. Так как если искать по нескольки ключевых точек, то такие функции в моем случае дают сбой.

Код:

procedure TForm1.Button4Click(Sender: TObject);
Type
  TRGBTripleArray =  ARRAY[WORD] OF TRGBTriple;
  pRGBTripleArray =  ^TRGBTripleArray;
  
var
  b1, b2: TBitmap;
//  c1, c2: PByteArray;
  c1, c2: pRGBTripleArray;
  x, y, i,: Integer;
  eq: boolean;
  resX, resY: integer;

begin

b1 := Image1.Picture.Bitmap;
b2 := Image2.Picture.Bitmap;
Assert(b1.PixelFormat = b2.PixelFormat); // they have to be equal

for y := 0 to b1.Height - 1 do // Внешний цикл по строкам оригинала
   begin
   c1 := b1.Scanline[y];
   c2 := b2.Scanline[0]; // Ищу на соответствие только по 1-й строке

   for x := 0 to b1.Width - 1 do
      begin
      eq := true;
      for i := 0 to b2.Width - 1 do // Цикл по строке искомой строки
         begin
         if (c1[x+i].RGBtRed <> c2[i].RGBtRed) or (c1[x+i].RGBtGreen <> c2[i].RGBtGreen) or (c1[x+i].RGBtBlue <> c2[i].RGBtBlue) then
            begin eq := false; break; end
         end;
      if ( eq ) then begin resX:=x; resY:=y; break; end;
      end;
   if ( eq ) then break;
   end;

if ( eq ) then
   begin
   Memo1.Lines.Add('FOUND');
   b1.canvas.Brush.Color := clRed;
   b1.canvas.Ellipse(resX-3, resY-3, resX+3, resY+3);
   end
   else Memo1.Lines.Add('NOT FOUND');
end;

Этот код работает, но не быстро (в силу его примитивности и неоптимизированности) и ищет только по первой строке второго изображения. Как оптимально сделать чтобы он искал быстро по всем строкам под-изображения я еще не придумал.

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

Код:

...
...
 PInt = ^integer;
var
  Form1: TForm1;

implementation

{$R *.dfm}

function SearchBitmap(const bmMain,bmSub:TBitmap; var Res:TPoint):boolean;
var iMainHeight, iMainWidth,
    iSubHeight,  iSubWidth,
    iMainPXWidth, iSubPXWidth, iDiffPXWidth,
    iDiffHeight: integer;
    i,j:integer;
    eq: boolean;
    pRowMain, pRowSub : PByteArray;
    ltPt,rtPt,lbPt,rbPt : PInt;
    cPoints:array[0..3] of integer;
begin
  Res.X := -1;
  Res.Y := -1;
  SearchBitmap := false;
  bmMain.PixelFormat:=pf24bit;
  bmSub.PixelFormat:=pf24bit;
  iMainHeight := bmMain.Height;
  iMainWidth := bmMain.Width;
  iMainPXWidth := iMainWidth * 3;
  iSubHeight := bmSub.Height;
  iSubWidth := bmSub.Width ;
  iSubPXWidth := iSubWidth *3 ;
  iDiffPXWidth := iMainPXWidth - iSubPXWidth;

  iDiffHeight:= iMainHeight - iSubHeight;
  pRowSub := bmSub.ScanLine[0];
  cPoints[0]:= PInt(@(pRowSub^[0]))^ and $FFFFFF;
  cPoints[1]:= PInt(@(pRowSub^[iSubPXWidth-3]))^ and $FFFFFF;
  pRowSub := bmSub.ScanLine[iSubHeight-1];
  cPoints[2]:= PInt(@(pRowSub^[0]))^ and $FFFFFF;
  cPoints[3]:= PInt(@(pRowSub^[iSubPXWidth-3]))^ and $FFFFFF;
  eq:=false;
  for i:=0 to iDiffHeight - 1 do
  begin
    pRowMain := bmMain.ScanLine[i];
    pRowSub := bmMain.ScanLine[i+iSubHeight-1];
    j:=0;
    ltPt := PInt(@pRowMain^[j]);
    lbPt := PInt(@pRowSub^[j]);
    //rtPt := PInt(pRowMain + iSubPXWidth - 3);
    //rbPt := PInt(pRowSub + iSubPXWidth - 3);
    asm
      mov   eax,iSubPXWidth
      sub   eax,3
      mov   ecx,eax
      add   ecx,ltPt
      mov   rtPt,ecx
      mov   ecx,eax
      add   ecx,lbPt
      mov   rbPt,ecx
    end;

    while j<iDiffPXWidth do
    begin
      {
      eq := ((PInt(@(pRowMain^[j]))^ and $FFFFFF) = cPoints[0])
        and ((PInt(@(pRowMain^[j+iSubPXWidth-3]))^ and $FFFFFF) = cPoints[1])
        and ((PInt(@(pRowSub^[j]))^ and $FFFFFF ) = cPoints[2])
        and ((PInt(@(pRowSub^[j+iSubPXWidth-3]))^ and $FFFFFF) = cPoints[3]);
      }
      eq := ((ltPt^ and $FFFFFF) = cPoints[0])
        and ((rtPt^ and $FFFFFF) = cPoints[1])
        and ((lbPt^ and $FFFFFF) = cPoints[2])
        and ((rbPt^ and $FFFFFF) = cPoints[3]);
      if ( eq ) then
      begin
        Res.X := j div 3;
        Res.Y := i;
        SearchBitmap := true;
        break;
      end;
      asm
        add ltPt,3
        add rtPt,3
        add lbPt,3
        add rbPt,3
      end;
      inc(j,3);
    end;
    if eq then break;
  end;

end;



function CaptureScreenRect(ARect : TRect) : TBitmap; 
var
  ScreenDC: HDC;
begin
Result:=TBitmap.Create;
with result, ARect do
   begin
   Width:=Right-Left;
   Height:=Bottom-Top;
   ScreenDC:=GetDC(0);
   try
      BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY );
   finally
   ReleaseDC(0, ScreenDC);
   end;
   end;
end; 



procedure Search(pattern: string; p_color: TColor);
var
  bmMain, bmSub: TBitmap;
  startPoint: TPoint;
  c: TCanvas;

begin
c := TCanvas.Create;
c.Handle := GetDC(0);

  bmMain := TBitmap.Create();
  bmSub  := TBitmap.Create();
  try
//  image1.Picture.Bitmap := CaptureScreenRect(Rect(0,0,Screen.Width,Screen.Height));
  bmMain := CaptureScreenRect(Rect(0,0,Screen.Width,Screen.Height));
//       bmMain.LoadFromFile('screen_main.bmp');
    bmSub.LoadFromFile(pattern);
    if (SearchBitmap(bmMain, bmSub, startPoint)) then
        begin
        c.Brush.Color := p_color;
        c.Ellipse(startPoint.x-3, startPoint.y-3, startPoint.x+3, startPoint.y+3);
        end;
  finally
    bmMain.Free;
    bmSub.Free;
    c.Free;
  end;
end;