Поиск одного изображения в другом

[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;

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

[czuryk]

Есть другой вариант, с которым мне помогли, там очень быстро ищется под-изображение по 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;

[alexBlack]

По-моему простой перебор работает достаточно быстро (<200мс)

function SearchBitmap(bmMain, bmSub:TBitMap; var R:TRect):boolean;
type TIntArray = array [word] of integer;
     PIntArray = ^TIntArray;
var p0, p1, p2:PIntArray;
    x, y:integer;
    x1, y1, w, w0, w1, k : integer;
    b : boolean;
begin
   result := true;
   FillChar(R, sizeOf(R), 0);

   bmMain.PixelFormat:=pf32bit;
   bmSub.PixelFormat:=pf32bit;

   w  := bmMain.width;
   w0 := bmMain.Width*sizeOf(integer);
   w1 := bmSub.Width*sizeOf(integer);

   p0 := bmMain.ScanLine[0];
   p1 := bmSub.ScanLine[0];
   for y := 0 to bmMain.Height - bmSub.Height do begin
      for x := 0 to bmMain.Width - bmSub.Width do begin

         b := true;

         p2 := p1; k := 0;
         for y1 := 0 to bmSub.Height-1 do begin
            for x1 := 0 to bmSub.Width - 1 do begin
                if p0[k+x+x1] <> p2[x1] then begin
                   b := false;
                   break;
                end;
            end;
            if not b then break;
            integer(p2) := integer(p2) - w1;
            k := k - w;
         end;

         if b then begin
            R := Rect(x, y, x+bmSub.Width, y+bmSub.Height);
            exit;
         end;
      end;
      integer(p0) := integer(p0) - w0;
   end;
   result := false;
end;

Для теста

procedure TestSearch;
var bmMain, bmSub: TBitmap;
    C:TCanvas;
    T:integer;
    B:boolean;
    R:TRect;
    S:String;
begin
  bmMain := TBitmap.Create();
  bmSub  := TBitmap.Create();
  C := TCanvas.Create;
  C.Handle := getDC(0);
  try
    // 1280x1024
    bmMain := CaptureScreenRect(Rect(0,0,Screen.Width,Screen.Height));

    // Худший вариант
    bmSub  := CaptureScreenRect(Rect(Screen.Width-150,Screen.Height-150,Screen.Width,Screen.Height));

    T := GetTickCount();
    B := SearchBitmap(bmMain, bmSub, R);
    if B
    then S := 'found '
    else S := 'not found ';

    // !!!
    Form8.Label1.Caption := S + IntToStr(GetTickCount()-T);

    if B then begin
       C.Brush.Color := clBlack;
       C.FrameRect(R);
    end;

  finally
    C.Free;
    bmMain.Free;
    bmSub.Free;
  end;
end;

[Роман Радер]

учитывая то, что в изображениях бывают нечеткости - другой цвет, качество, то возможность такого поиска стремится к нулю... если BMP то ладно, а JPG - проблема

[mutabor]

Сообщение от Роман Радер

учитывая то, что в изображениях бывают нечеткости - другой цвет, качество, то возможность такого поиска стремится к нулю... если BMP то ладно, а JPG - проблема

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

[czuryk]

Нет, баннер мне не нужо, это пиктограмка из другой программы и она не изменна, это растровое изображение BMP 24bit формата, просто важна именно скорость.

[Роман Радер]

Если BMP то проблем не будет. Ускорить это сложно... Полный перебор - решение.
Ну можно как-то сравнивать не всю картинку а куском - вырезать маленький кусок и если нашли такой-же то тогда уже в ту-же позицию сравнивать всю картинку.

[czuryk]

Спасибо alexBlack!
Работает и действительно достаточно быстро,но я пока не могу сообразить почему?
Мне комрад x128, помог, прислал такой код:

function TForm1.CompareIMG: FRes;
var
  y, x, yy, xx: integer;
  p1, p2: pByteArray;
  adr1, adr2: integer;
begin
  Screen.Cursor:=crHourGlass;
  y:=0;
  repeat
    x:=0;
    repeat
      Result.found:=true;
      yy:=0;
      repeat
        p1:=Image1.Picture.Bitmap.ScanLine[y+yy];
        p2:=Image2.Picture.Bitmap.ScanLine[yy];
        xx:=0;
        repeat
          adr1:=x shl 1 + x; adr2:= xx shl 1 + xx;
          if p1[adr1+adr2+0]<>p2[adr2+0] then Result.found:=false; //b
          if p1[adr1+adr2+1]<>p2[adr2+1] then Result.found:=false; //g
          if p1[adr1+adr2+2]<>p2[adr2+2] then Result.found:=false; //r
          inc(xx);
        until (xx>=Image2.Width) or (Not Result.found);
        inc(yy);
      until (yy>=Image2.Height) or (Not Result.found);
      inc(x);
    until (x>=Image1.Width-Image2.Width) or (Result.found);
    inc(y);
  until (y>=Image1.Height-Image2.Height) or (Result.found);
  Screen.Cursor:=crDefault;
  if Result.found then begin
    Result.x:=x-1;
    Result.y:=y-1;
  end;
end;

но он работает достаточно медленно,порядка 2 секунд. И я не вижу особых различий...
Можешь прокоментировать.... хочется понять

[alexBlack]

Могу предположить:
В приведенном коде ScanLine вызывается внутри 3-го цикла. Итого
~Image1.Height*Image1.Width*Image2. Height = ~1024*1280*100 раз

в моем - один раз. дальше только сложение/вычитание

[NikroBass]

Извините что влезаю, но не подскажете как делать тоже самое только из компонента webbrouser1
Суть проблеммы нужно совершить клик по флеш приложению