SRL Archive - Development

type
  PRGBQuadArray = ^TRGBQuadArray;
  TRGBQuadArray = array [0..0] of TRGBQuad;

function FindColorTolerance(Client: HDC; Color: Integer; var dx, dy: Integer; x1, y1, x2, y2, Tolerance: Integer): Boolean;
const
  Offset: array [0..0] of Integer = (1);
var
  Color_rgbRed, Color_rgbGreen, Color_rgbBlue: Integer;
  bmpW, bmpH: Integer;
  bmi: TBitmapInfo;
  DIBHandle: HBitmap;
  CompDC: HDC;
  PrevObj: HGDIOBJ;
  Pixels: PRGBQuadArray;
  I, H, L, HW: Integer;
  J: Integer;
begin
  Result := False;
  
  Color_rgbRed := Color; //(Color and $ff);
  Color_rgbGreen := Color shr 8; //(Color and $ff00) shr 8;
  Color_rgbBlue := Color shr 16; //(Color and $ff0000) shr 16;

  bmpW := x2 - x1 + 1;
  bmpH := y2 - y1 + 1;

  FillMemory(@bmi, SizeOf(TBitmapInfo), 0);
  with bmi.bmiHeader do
  begin
    biSize        := SizeOf(TBitmapInfoHeader);
    biWidth       := bmpW;
    biHeight      := -bmpH;
    biPlanes      := 1;
    biBitCount    := 32;
    biCompression := BI_RGB;
  end;

  try
    DIBHandle := CreateDIBSection(0, bmi, DIB_RGB_COLORS, Pointer(Pixels), 0, 0);

    CompDC := CreateCompatibleDC(Client);
    PrevObj := SelectObject(CompDC, DIBHandle);

    BitBlt(CompDC, 0, 0, bmpW, bmpH, Client, x1, y1, SRCCOPY);

    H := High(Offset);
    L := Length(OffSet);
    HW := (bmpH - 1) * (bmpW - 1);
    Tolerance := Sqr(Tolerance);

    for J := 0 to H do
    begin
      if Result then
        Break;

      I := 0 - OffSet[J];
      while ( i < HW - OffSet[J] ) do
      begin
        Inc(I, L);
        if Tolerance >= (Sqr(Color_rgbRed - Pixels^[I].rgbRed)
           +Sqr(Color_rgbGreen - Pixels^[I].rgbGreen)
           +Sqr(Color_rgbBlue - Pixels^[I].rgbBlue)) then
        begin
          dx := x1 + (I mod bmpW);
          dy := y1 + (I div bmpW);
          Result := True;
          Break;
        end;
      end;
    end;

  finally
    PrevObj := SelectObject(CompDC, PrevObj);
    DeleteDC(CompDC);
    DeleteObject(DIBHandle);
  end;

end;

this would be for the windows end of the findcolor functions

tell me what you guys think, I have been trying to match scars findcolor speed for some time

any benchmarks/input is welcome

i see that the current findcolor functions use just bitblt and bmbits, but i think this may be faster?

Why not use

function SimilarColors(Color1, Color2, Tolerance: Integer): Boolean; //By: Freddy1990
begin
  Result := ((Abs((Color1 and $ff) - (Color2 and $ff)) <= Tolerance) and
    (Abs(((Color1 and $ff00) shr 8) - ((Color2 and $ff00) shr 8)) <= Tolerance) and
    (Abs(((Color1 and $ff0000) shr 16) - ((Color2 and $ff0000) shr 16)) <= Tolerance));
end;

??

Or is your tolerance system exactly the same?
I don't think you should change the tolerance calculations..

Because Freddy's system is crappy, and slow.

Implementing that directly, as well as removing the constant calculations is one option.

I can't really speak to the functions inside Simba, but I think they are more suited to the Cross Platform application, as well they do not use the HDC, they use the TIO_Manager set of classes.

Anyways, nice work.. I don't think it will be implemented directly.

(Not my final say either though.)

@marpis, i believe they are pretty much the same, i was told that the sqr were a little more accurate/faster, but im not sure

@Nava2, i just posted this for development of improved speed

simba has if Linux then Blah; if Windows then Blah, so this could be used on the windows end atleast, and if not no big deal, im just trying to make the most badass findcolor :D

I'm not sure what's faster -> Creating a bitmap every colorfind or just bitblt'ing to an existing bitmap?

Also I'm not sure what is faster -> 1-for loop "for w*h do" or 2 nested for loops "for x do for y do".

dont know masta, need to runs some tests :D

I think the way we implement FindColorsTolerance is runs quite well. The main issue is all the different tolerance comparisons.
Making them all inline makes a huge difference, but it is damn ugly.

Anyway, if you want to speed up your function a bit, remove the (and not result) part, and add Exit; after result := true;.

@wizzup, yeah i changed some things in main function…but i was trying to compare simbas bmbits vs createdibsection

i dont know what to tell u about the inline uglyness :p

function FindColorToleranceSimba(Client: HDC; Color: TRGBQuad; var dx, dy: Integer; x1, y1, x2, y2, Tolerance: Integer): Boolean;
var
  bmp: TBitmap;
  BmpInfo: Windows.TBitmap;
  Ptr: PRGB32;
  PtrInc: Integer;
  Width, Height: Integer;
  x, y: Integer;
begin
  try

    Bmp := TBitmap.Create;
    Bmp.PixelFormat := pf32bit;
    Bmp.Width := x2 - y1;
    Bmp.Height := y2 - y1;

    Width := Bmp.Width + 1;
    Height := Bmp.Height + 1;

    BitBlt(Bmp.Canvas.Handle, 0, 0, Width, Height, Client, x1, y1, SRCCOPY);

    GetObject(bmp.Handle, SizeOf(BmpInfo), @BmpInfo);
    Ptr := bmpInfo.bmBits;
    PtrInc := Bmp.Width - w;
    Tolerance := Sqr(Tolerance);

    for y := y1 to y2 do
    begin
      for x := x1 to x2 do
      begin
        if Tolerance >= (Sqr(Color.rgbRed - Ptr^.R)
                  +Sqr(Color.rgbGreen - Ptr^.G)
                  +Sqr(Color.rgbBlue  - Ptr^.B)) then
        begin
          Result := True;
          dx := x;
          dy := y;
          bmp.Free;
          Exit;
        end;
       Inc(Ptr);
      end;
      Inc(Ptr, PtrInc);
    end;

  finally
  end;
end;

this one returns the wrong coord though :redface:, prob did something stupid