Get average color of an image - delphi

I am trying to get the average color of an image. I tried various methods and now I use the following code, but I could not get the correct result.
Can anyone explain what is wrong with my code?
//load bitmap to curimg
img1.Picture.Bitmap := curimg ; //testing the previous line
//My image is always greater than 25x25 but I only need a 25x25 box
for I := 0 to 25 do
begin
for y := 0 to 25 do
begin
r := r + GetRValue(curimg.Canvas.Pixels[y, I]);
g := g + GetGValue(curimg.Canvas.Pixels[y, I]);
b := b + GetBValue(curimg.Canvas.Pixels[y, I]);
end;
end;
r := r div (25 * 25);
g := g div (25 * 25);
b := b div (25 * 25);
rgbk := RGB(r, g, b);
Result = rgbk;
end;
img1 and image1 of type TImageBox are on my form.

The local variables r,g,b: integer should be initialized to zero first.

One thing which seems wrong with this is that in comments you say that you have 25*25 image, but you loop over 26*26 pixels, so the loops should be:
for I := 0 to 24 do
begin
for y := 0 to 24 do

Related

Scan Line Out of Range Error for Bitmap. TJanDrawImage Component for a Paint-like Program

I am using the free JansDraw Components and when the executable runs, it throws AV error. I could locate the error to specifically the loop block of the code (not the initial block of assignment statements).
procedure TjanDrawImage.colorcircle(var bm:TBitmap;center:tpoint;radius,mode:integer);
var p,p0,p1:pbytearray;
dx,x,y,w,h,i,j,sum,c:integer;
cm,tm:tbitmap;
Rs,Rd:trect;
begin
x:=center.x;
y:=center.y;
w:=bm.width;
h:=bm.height;
cm:=tbitmap.create;
cm.width:=2*radius;
cm.height:=2*radius;
cm.PixelFormat :=FPixelFormat;
tm:=tbitmap.create;
tm.width:=2*radius;
tm.height:=2*radius;
tm.PixelFormat :=FPixelFormat;
tm.canvas.brush.color:=clblack;
tm.canvas.Ellipse (0,0,tm.width-1,tm.height-1);
tm.transparent:=true;
tm.TransparentColor :=clblack;
Rd:=rect(0,0,cm.width,cm.height);
Rs:=rect(x-radius,y-radius,x+radius,y+radius);
cm.canvas.CopyRect (Rd,bm.canvas,RS);
for j:=0 to cm.height-1 do begin
p:=cm.scanline[j];
if j>0 then p0:=cm.scanline[j-1];
if j<(h-1) then p1:=cm.scanline[j+1];
for i:=0 to cm.width-1 do begin
case mode of
0: //blue
begin
p[i*3+1]:=0;
p[i*3+2]:=0;
end;
1: //green
begin
p[i*3]:=0;
p[i*3+2]:=0;
end;
2: //red
begin
p[i*3]:=0;
p[i*3+1]:=0;
end;
3: //not blue
begin
p[i*3]:=0;
end;
4: //not green
begin
p[i*3+1]:=0;
end;
5: //not red
begin
p[i*3+2]:=0;
end;
6: //half blue
begin
p[i*3]:=p[i*3]*9 div 10;
end;
7: //half green
begin
p[i*3+1]:=p[i*3+1]*9 div 10;
end;
8: //half red
begin
p[i*3+2]:=p[i*3+2]*9 div 10;
end;
9:// darker
begin
p[i*3]:=round(p[i*3]*10 /11);
p[i*3+1]:=round(p[i*3+1]*10 / 11);
p[i*3+2]:=round(p[i*3+2]*10 /11);
end;
10:// lighter
begin
p[i*3]:=round(p[i*3]*11 / 10);
p[i*3+1]:=round(p[i*3+1]*11 / 10);
p[i*3+2]:=round(p[i*3+2]*11 / 10);
end;
11:// gray
begin
sum:=round((p[i*3]+p[i*3+1]+p[i*3+2])/ 3);
p[i*3]:=sum;
p[i*3+1]:=sum;
p[i*3+2]:=sum;
end;
12:// mix
begin
c:=p[i*3];
p[i*3]:=p[i*3+1];
p[i*3+1]:=p[i*3+2];
p[i*3+2]:=c;
end;
13://smooth
begin
if ((j>0) and (j<(h-1))and (i>0)and (i<(w-1))) then begin
p[i*3]:=round((p[(i-1)*3]+p[(i+1)*3]+p0[i*3]+p1[i*3]) /4);
p[i*3+1]:=round((p[(i-1)*3+1]+p[(i+1)*3+1]+p0[i*3+1]+p1[i*3+1]) /4);
p[i*3+2]:=round((p[(i-1)*3+2]+p[(i+1)*3+2]+p0[i*3+2]+p1[i*3+2]) / 4);
end;
end;
end;
end;
end;
cm.canvas.Draw (0,0,tm);
cm.transparent:=true;
cm.transparentcolor:=clwhite;
bm.Canvas.draw(x-radius,y-radius,cm);
cm.free;
tm.free;
end;
A linked question which is helpful is this - implementing scan line of bitmap corectly. It suggests to cast the pointers to NativeInt. The OP changed his code after answers, making it difficult to correlate old code with new code. I understand that my problem is due to some hard coded sequential access of pointers but I am really beginner to make sense of scan line or pointers. If you help me port this, these components will continue to be useful to everyone.
update after comment from #Renate Schaaf:
all the brush modes of the janDrawImage are working now, except for the below one. I was expecting a bigger problem but that didn't turn out to be the case. So modified the title of the question. #Renate Schaaf Can you please help fix the below one too. I tried but failed.
procedure TjanDrawImage.rimple(src,dst:tbitmap;amount:extended);
var ca,sa,a,dx,dy,r,rx,ry,sr,fr:extended;
w,h,x,y,cx,cy,i,j,c,ci:NativeInt;
p1,p2:pbytearray;
begin
w:=src.width;
h:=src.height;
cx:=w div 2;
cy:=h div 2;
if amount<1 then amount:=1;
fr:=cx/amount;
for y:=0 to h-1 do begin
p1:=src.ScanLine[y];
for x:=0 to w-1 do begin
dx:=x-cx;dy:=-(y-cx);
r:=sqrt(sqr(dx)+sqr(dy));
sr:=fr*sin(r/cx*amount*2*pi);
if (r+sr<cx) and (r+sr>0) then begin
a:=arctan2(dy,dx);
sincos(a,sa,ca);
i:=cx+round((r+sr)*ca);
j:=cy+round((r+sr)*sa);
p2:=dst.scanline[j];
c:=x*3;ci:=i*3;
p2[ci]:=p1[c];
p2[ci+1]:=p1[c+1];
p2[ci+2]:=p1[c+2];
end;
end;
end;
end;
When you do scanline operations, you always need to make sure that your pixel location is within the boundaries of your bitmap, particularly if you make geometric transformations.
So, in the last example you must clamp j to [0,h-1] and i to [0,w-1] using max(min(..)).
Also, you should set the size and pixelformat of src and dst to the same at the beginning.
I didn't really bother to find out what this ripple is supposed to do, but when I run an example it doesn't look like it's doing whatever it does right. For geometric transformations you need to work backwards, running through the pixels of the destination and figure out which pixel of the source needs to go there. Otherwise you end up with a destination that has holes, like here.
Edit:
Since I'm stuck with my project: I think this is the routine you really want to use. Note that I just switched the roles of src and dst and corrected some errors. It now adds a water ripple effect to the bitmap.
procedure rimple(src, dst: TBitmap; amount: extended);
var
ca, sa, a, dx, dy, r, sr, fr: extended;
w, h, x, y, cx, cy, i, j, c, ci: NativeInt;
p1, p2: pbytearray;
bits: integer;
begin
Assert(src.PixelFormat in [pf24bit, pf32bit],
'Device independent bitmap needed');
dst.PixelFormat := src.PixelFormat;
bits := 3;
if src.PixelFormat = pf32bit then
bits := 4;
w := src.width;
h := src.height;
dst.SetSize(w, h);
cx := w div 2;
cy := h div 2;
// in case somebody enters a negative amount
if abs(amount) < 1 then
amount := 1;
fr := cx / amount;
for y := 0 to h - 1 do
begin
// switched src and dst
p1 := dst.scanline[y]; // src.scanline[y];
for x := 0 to w - 1 do
begin
dx := x - cx;
// Corrected from dy:=-(y-cx)
dy := (y - cy);
r := sqrt(sqr(dx) + sqr(dy));
sr := fr * sin(r / cx * amount * 2 * pi);
// Omitted the following check
// if (r + sr < cx) and (r + sr > 0) then
begin
a := arctan2(dy, dx);
sincos(a, sa, ca);
i := max(min(cx + round((r + sr) * ca), w - 1), 0);
j := max(min(cy + round((r + sr) * sa), h - 1), 0);
// switched src and dst
p2 := src.scanline[j];
c := x * bits;
ci := i * bits;
p1[c] := p2[ci];
p1[c + 1] := p2[ci + 1];
p1[c + 2] := p2[ci + 2];
end;
end;
end;
end;

Getting the fraction from a double

I have written this function that converts a double to a fraction returning a string:
function getFraction(x: double):string;
var h1, h2, k1, k2, y, a, aux : double;
begin
//Setup the values
h1 := 1;
h2 := 0;
k1 := 0;
k2 := 1;
y := x;
//Generates the fraction
repeat
begin
a := floor(y);
aux := h1;
h1 := a*h1+h2;
h2 := aux;
aux := k1;
k1 := a*k1+k2;
k2 := aux;
y := 1/(y-a) ;
end;
until ( abs(x-h1/k1) > x*0.000001);
//Output
Result := FloatToStr(h1) + '/' + FloatToStr(k1);
end;
And then I call it in this way: Edit7.Text := getFraction(x); where the x is a double. I am using lazarus and I always have this error:
I am sure that the code above has not logic hassles because it becomes from a Java class that I have implemented last week in a project (code).
What am I missing? The full code of my Delphi project can be found here.
The error will surely occur here:
y := 1/(y-a);
When y-a evaluates to 0 then this will result in a divide by zero error. That happens when you pass 0 to the function.
Or perhaps when you evaluate h1/k1 the value of k1 is zero. Again, that's a floating point exception.
Even when you trap those conditions, I cannot make the function return anything that seems remotely sensible to me. So, once you fix the exception condition then you'll have further work.
I'm sure that you could have worked this out in the debugger, even if you could not do so by reading the code. The debugger will tell you which line produced the error and then it is merely a matter of inspecting the value of the operands in the expression.
For what it's worth, your repeat loop is the wrong way around. You're replacing a java do/while with repeat/until - the condition has to invert for this to work.
To avoid divide by zero, just check and break out of the loop. That will save the crash, but I haven't verified that it will always produce the right answer, although it does for previously deadly inputs like 0.25 or 0.5.
repeat
begin
a := floor(y);
aux := h1;
h1 := a * h1 + h2;
h2 := aux;
aux := k1;
k1 := a * k1 + k2;
k2 := aux;
if (y - a = 0) or (k1 = 0) then break; //!!
y := 1 / (y - a) ;
end;
until (Abs(x - h1 / k1) <= x * 0.000001); // Here <= instead of >

Connect 4: Check for winner

In Delphi, I have a Connect 4 board representation (7 columns x 6 lines) in form of an array:
TBoard = Array[1..7, 1..6] of SmallInt;
Board: TBoard; // instance ob TBoard
Each element can have three different states:
1 = player 1's pieces
0 = empty
-1 = player 2's pieces
Now I need a function which checks if there's a winner or a draw:
function CheckForWinner(): SmallInt;
... where 1 is player 1's win, 0 is a draw, -1 is player 2's win and "nil" is for a game which has not ended yet.
My draft is as follows - split into two single functions:
function CheckForWinner(): SmallInt;
var playerToCheck: ShortInt;
s, z: Byte;
draw: Boolean;
begin
draw := TRUE;
for s := 1 to 7 do begin
for z := 1 to 6 do begin
if Board[s, z] = 0 then draw := FALSE; // if there are empty fields then it is no draw
end;
end;
if draw then begin
result := 0;
end
else begin
playerToCheck := Board[lastPieceX, lastPieceY]; // only for last-moving player
if searchRow(playerToCheck, +1, 0, lastPieceX, lastPieceY) then // search right/left
result := playerToCheck
else if searchRow(playerToCheck, 0, +1, lastPieceX, lastPieceY) then // search up/down
result := playerToCheck
else if searchRow(playerToCheck, +1, +1, lastPieceX, lastPieceY) then // search right-down/left-up
result := playerToCheck
else if searchRow(playerToCheck, +1, -1, lastPieceX, lastPieceY) then // search right-up/left-down
result := playerToCheck;
else
result := nil;
end;
end;
end;
function searchRow(player: SmallInt; sChange, zChange: ShortInt; startS, startZ: Byte): Boolean;
var inRow, s, z: SmallInt;
begin
inRow := 0;
s := startS;
z := startZ;
while (Board[s, z] = player) AND (inRow < 4) AND (s >= 1) AND (s <= 7) AND (z >= 1) AND (z <= 6) do begin
s := s+sChange;
z := z+zChange;
inRow := inRow+1;
end;
s := startS-sChange;
z := startZ-zChange;
while (Board[s, z] = player) AND (inRow < 4) AND (s >= 1) AND (s <= 7) AND (z >= 1) AND (z <= 6) do begin
s := s-sChange;
z := z-zChange;
inRow := inRow+1;
end;
if inRow = 4 then
result := TRUE
else
result := FALSE;
end;
What do you think of this approach? Do you have a better (faster / shorter) solution?
Thank you very much!
I didn't read your code. I just elected to write some myself with a blank slate.
Here's my version:
const
RowCount = 6;
ColCount = 7;
type
TState = (stNone, stA, stB);
TBoard = array [1..RowCount] of array [1..ColCount] of TState;
function ValidLocation(Row, Col: Integer): Boolean;
begin
Result := InRange(Row, 1, RowCount) and InRange(Col, 1, ColCount);
end;
procedure Check(
const Board: TBoard;
const StartRow, StartCol: Integer;
const RowDelta, ColDelta: Integer;
out Winner: TState
);
var
Row, Col, Count: Integer;
State: TState;
begin
Winner := stNone;
Row := StartRow;
Col := StartCol;
State := Board[Row, Col];
if State=stNone then
exit;
Count := 0;
while ValidLocation(Row, Col) and (Board[Row, Col]=State) do begin
inc(Count);
if Count=4 then begin
Winner := State;
exit;
end;
inc(Row, RowDelta);
inc(Col, ColDelta);
end;
end;
function Winner(const Board: TBoard): TState;
var
Row, Col: Integer;
begin
for Row := 1 to RowCount do begin
for Col := 1 to ColCount do begin
Check(Board, Row, Col, 0, 1, Result);//check row
if Result<>stNone then
exit;
Check(Board, Row, Col, 1, 0, Result);//check column
if Result<>stNone then
exit;
Check(Board, Row, Col, 1, 1, Result);//check diagonal
if Result<>stNone then
exit;
Check(Board, Row, Col, 1, -1, Result);//check other diagonal
if Result<>stNone then
exit;
end;
end;
Result := stNone;
end;
Big long pile of code. Uses brute force approach, not that performance matters for Connect 4. Don't like the four identical if Result<>stNone then exit; lines, but you can surely think of a cleaner way. Code has not been run. It might not even work!! Just the way my brain attempted to solve the problem.
Checking for a winner in very much the same way as you do, only with a little less code.
I think you wouldn't need to check all fields to determine if the game is done. Just increase a counter when you drop a piece in the game. The game is a draw if the counter reaches 42 and there is no winner yet.
function CheckRow(x, y, xd, yd: Integer): Boolean;
var
c: Integer;
function RowLength(x, y, xd, yd: Integer): Integer;
begin
Result := 0;
repeat
Inc(Result);
Inc(x, xd);
Inc(y, yd);
until not ((x in [1..7]) and (y in [1..6]) and (Board[x, y] = c));
end;
begin
c := Board[x, y];
Result := 4 <= RowLength(x, y, xd, yd) + RowLength(x, y, xd*-1, yd*-1) - 1;
end;
function CheckForWinner(x, y: Integer): Integer;
begin
Result := 0;
if CheckRow(x, y, 0, 1) or CheckRow(x, y, 1, 1) or
CheckRow(x, y, 1, 0) or CheckRow(x, y, 1, -1) then
Result := Board[x,y];
end;
Disclaimer: I haven't studied the algorithm in detail. The comments below are merely my first reactions after staring at the code for less than ten seconds.
I have some very quick remarks. First, I think
TCellState = (csUnoccupied, csPlayerA, csPlayerB)
TBoard = Array[1..7, 1..6] of TCellState;
is nicer. Of course, you can save compatibility with your old code by doing
TCellState = (csUnoccupied = 0, csPlayerA = 1, csPlayerB = -1)
Second,
draw := true;
for s := 1 to 7 do begin
for z := 1 to 6 do begin
if Board[s, z] = 0 then draw := false;
end;
end;
You don't need the begin and end parts:
draw := TRUE;
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
draw := false;
More importantly, as a gain in performance, you should break the loops as soon as you have set drawn to false:
draw := true;
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
begin
draw := false;
break;
end;
This will, however, only break the z loop. To break both loops, the nicest way is to put the entire block above in a local function. Let's call it CheckDraw:
function CheckDraw: boolean;
begin
result := true;
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
Exit(false);
end;
Alternatively, you can use label and goto to break out of both loops at once.
Update
I see now that you can just do
for s := 1 to 7 do
for z := 1 to 6 do
if Board[s, z] = 0 then
Exit(0);
and you don't even need to introduce the draw local variable!
End update
Furthermore,
if inRow = 4 then
result := TRUE
else
result := FALSE;
is bad. You should do just
result := inRow = 4;
Finally, In my taste
s := s+sChange;
should be written
inc(s, sChange);
and
inRow := inRow+1
should be
inc(inRow);
Oh, and nil is a pointer, not an integer.
The source code from the Fhourstones Benchmark from John Tromp uses a fascinating algorithm for testing a connect four game for a win. The algorithm uses following bitboard representation of the game:
. . . . . . . TOP
5 12 19 26 33 40 47
4 11 18 25 32 39 46
3 10 17 24 31 38 45
2 9 16 23 30 37 44
1 8 15 22 29 36 43
0 7 14 21 28 35 42 BOTTOM
There is one bitboard for the red player and one for the yellow player. 0 represents a empty cell, 1 represents a filled cell. The bitboard is stored in an unsigned 64 bit integer variable. The bits 6, 13, 20, 27, 34, 41, >= 48 have to be 0.
The algorithm is:
// return whether 'board' includes a win
bool haswon(unsigned __int64 board)
{
unsigned __int64 y = board & (board >> 6);
if (y & (y >> 2 * 6)) // check \ diagonal
return true;
y = board & (board >> 7);
if (y & (y >> 2 * 7)) // check horizontal
return true;
y = board & (board >> 8);
if (y & (y >> 2 * 8)) // check / diagonal
return true;
y = board & (board >> 1);
if (y & (y >> 2)) // check vertical
return true;
return false;
}
You have to call the function for the bitboard of the player who did the last move

fast finding of small image in a bigger image

I need to get the coordinates of a small image location residing in a big image (let say I need to search for a specific tree inside a forest photograph. If the sub-image is found then the result would be something like: x=120 y=354 by example).
Is there a fast algorithm that I could use ?
I'm using Delphi (can also use Java if needed)
Edit: A few things about the theory:
In a nutshell, there are two "spaces" to apply filters on an image: in color spare or in frequency space. If you decided the space(freq here, there are two sorts of filters: applied as convolution and correlation(here). To keep it simple, we assume that appling correlation simple means "we multiplicate two things". With using the correlation in frequency space of an image you can measure how similar images are. Two images are similar, if the grayscale gradients are. This is measured by the covariance. (Maybe someone can help me with inserting formulars here.) The crosscorrelationcoefficent is the normalised covariance (insert formular here:( )
If you put this into a algorithm for searching affinities between a "model" and a "reference image" (model is a small section that you search within the ref. img.), you get the matlab code, which I commented too. The formular that the code uses is this one:
FT([f°g] (m,n))=F(u,v)*G°(u,v). Where F is the fft and G° is the complex conjugated of G (G is the fft of the model)
Please define fast. :)
The solution I have in mind will need the fft, which is fast, but maybe not as fast as you want. It searches for the small "I_ausschnitt" image inside the I image and gives the position with the highes "possibility".
In matlab, this one will work. I hope you can put it into delphi. :)
I = im2double(imread('Textiltextur.tif')); // This is our reference image
I_model = imcrop( I, [49 36 42 28] ); // Our model - what we want so search in I
[X Y] = size( I ); // Get the size of the reference image.
f = fft2(I); // Perform the fast fourier transform->put the image into frequency space.
f_model = fft2(I_model ,X,Y); // Perform the fft of the model but do this in the size of the original image. matlab will center I_model and set other pixel to zero
w = conj(model ); // Complex conjugated
g = real( ifft2(w.*f)); // .* will perform a komponent wise multiplicaion e.g. [0][0]*[0][0], [0][1]*[0][1] and not a matrix mul.
gs =im2uint8(mat2gray(g)); // Convert the resulting correlation into an grayscale image with larger values->higher correlation
// Rest of the code is for displaying only
figure(1);
imshow(gs);
colormap hsv
figure;
[ XX YY] = meshgrid(1:Y,1:X );
colormap hsv
surfc(XX,YY,double(gs)), title('3D Korrelation')
min_corr = min(min(gs))
max_corr = max(max(gs))
%axis([1 X 1 Y min_corr max_corr])
colorbar
Edit: This will only work for grayscale images.
One possibility is a Boyer-Moore string search: http://en.wikipedia.org/wiki/Boyer%E2%80%93Moore_string_search_algorithm
You'll have to adapt it to your image search problem, of course.
Supposing the large image has N pixels and the small one M pixels, you'd be looking at an average case performance of N/M, which is rather good.
There are a number of different techniques to find a sub image in an image.
The most straightforward is to use 2D correlation of your small image on the larger image. This will be quite slow but easy to implement. It also only works well if the sub image is aligned with the original (no rotation) and of the same scale.
If that is not the case (you have rotation and/or scale variations) then you need something more advanced. My choice would be to use a feature detection algorithm such as SIFT or SURF.
And just to reiterate what I have put in most of the previous answers: Using algorithms that are designed for 1D strings (Boyer-Moore) for image processing is just wrong. If you do you will most likely end up spending hours implementing and adapting something that does not work in the current context while there are other better algorithms that you could use.
It is pretty fast (fails to find in 160ms, finds in 90ms on 1600x900) and the only one you will find out there.
Any speedups are welcome. Checked to work with 24-bit bitmaps under Win7/Win10 x64, XE2, XE5.
uses
System.Generics.Collections;
type
TSubImageInfo = record
X: integer;
Y: integer;
Color: integer;
end;
function ImageSearch(const ASubimageFile: string): TRect;
var
X, Y, K, _Color: integer;
_SubImageInfo: TSubImageInfo;
_SubImageInfoList: TList<TSubImageInfo>;
_SmallWidth, _SmallHeight, _BigWidth, _BigHeight: integer;
_MatchingPixels: integer;
_LTColor, _RTColor, _LBColor, _RBColor: integer;
_FirstPixels: TList<TSubImageInfo>;
_Offset: TPoint;
_Desktop: HDC;
_ScreenBitmap: TBitmap;
_SubimageBitmap: TPNGImage;
_Pos: TPoint;
begin
Result.Left := -1;
Result.Top := Result.Left;
Result.Height := Result.Left;
Result.Width := Result.Left;
if not FileExists(ASubimageFile) then
Exit;
_SubImageInfoList := TList<TSubImageInfo>.Create;
_ScreenBitmap := TBitmap.Create;
_SubimageBitmap := TPNGImage.Create;
_FirstPixels := TList<TSubImageInfo>.Create;
try
_SubimageBitmap.LoadFromFile(ASubimageFile);
if (_SubimageBitmap.Height < 3) or (_SubimageBitmap.Width < 3) then
Exit; // Image is too small
X := 0;
Y := _SubimageBitmap.Height div 2;
while X < _SubimageBitmap.Width - 1 do
begin
_SubImageInfo.X := X;
_SubImageInfo.Y := Y;
_Color := _SubimageBitmap.Canvas.Pixels[X, Y];
_SubImageInfo.Color := _Color;
_SubImageInfoList.Add(_SubImageInfo);
X := X + 3;
end;
Y := 0;
X := _SubimageBitmap.Width div 2;
while Y < _SubimageBitmap.Height - 1 do
begin
_SubImageInfo.X := X;
_SubImageInfo.Y := Y;
_Color := _SubimageBitmap.Canvas.Pixels[X, Y];
_SubImageInfo.Color := _Color;
_SubImageInfoList.Add(_SubImageInfo);
Y := Y + 3;
end;
X := 0;
Y := _SubimageBitmap.Height div 4;
while X < _SubimageBitmap.Width - 1 do
begin
_SubImageInfo.X := X;
_SubImageInfo.Y := Y;
_Color := _SubimageBitmap.Canvas.Pixels[X, Y];
_SubImageInfo.Color := _Color;
_SubImageInfoList.Add(_SubImageInfo);
X := X + 3;
end;
Y := 0;
X := _SubimageBitmap.Width div 4;
while Y < _SubimageBitmap.Height - 1 do
begin
_SubImageInfo.X := X;
_SubImageInfo.Y := Y;
_Color := _SubimageBitmap.Canvas.Pixels[X, Y];
_SubImageInfo.Color := _Color;
_SubImageInfoList.Add(_SubImageInfo);
Y := Y + 3;
end;
X := 0;
Y := (_SubimageBitmap.Height div 4) + (_SubimageBitmap.Height div 2);
while X < _SubimageBitmap.Width - 1 do
begin
_SubImageInfo.X := X;
_SubImageInfo.Y := Y;
_Color := _SubimageBitmap.Canvas.Pixels[X, Y];
_SubImageInfo.Color := _Color;
_SubImageInfoList.Add(_SubImageInfo);
X := X + 3;
end;
Y := 0;
X := (_SubimageBitmap.Width div 4) + (_SubimageBitmap.Width div 2);
while Y < _SubimageBitmap.Height - 1 do
begin
_SubImageInfo.X := X;
_SubImageInfo.Y := Y;
_Color := _SubimageBitmap.Canvas.Pixels[X, Y];
_SubImageInfo.Color := _Color;
_SubImageInfoList.Add(_SubImageInfo);
Y := Y + 3;
end;
_Desktop := GetDC(0);
_ScreenBitmap.PixelFormat := pf32bit;
_ScreenBitmap.Width := Screen.Width;
_ScreenBitmap.Height := Screen.Height;
BitBlt(_ScreenBitmap.Canvas.Handle, 0, 0, _ScreenBitmap.Width,
_ScreenBitmap.Height, _Desktop, 0, 0, SRCCOPY);
_MatchingPixels := 0;
_SmallWidth := _SubimageBitmap.Width - 1;
_SmallHeight := _SubimageBitmap.Height - 1;
_BigWidth := _ScreenBitmap.Width;
_BigHeight := _ScreenBitmap.Height;
_LTColor := _SubimageBitmap.Canvas.Pixels[0, 0];
_RTColor := _SubimageBitmap.Canvas.Pixels[_SmallWidth, 0];
_LBColor := _SubimageBitmap.Canvas.Pixels[0, _SmallHeight];
_RBColor := _SubimageBitmap.Canvas.Pixels[_SmallWidth, _SmallHeight];
for X := 1 to 3 do
begin
for Y := 1 to 3 do
begin
_SubImageInfo.X := X;
_SubImageInfo.Y := Y;
_SubImageInfo.Color := _SubimageBitmap.Canvas.Pixels[X, Y];
_FirstPixels.Add(_SubImageInfo);
end;
end;
X := 0;
while X < _BigWidth - _SmallWidth do
begin
Y := 0;
while Y < _BigHeight - _SmallHeight do
begin
_Color := _ScreenBitmap.Canvas.Pixels[X, Y];
_Offset.X := 0;
_Offset.Y := 0;
for K := 0 to _FirstPixels.Count - 1 do
begin
if (_Color = _FirstPixels[K].Color) then
begin
_Offset.X := _FirstPixels[K].X;
_Offset.Y := _FirstPixels[K].Y;
Break;
end;
end;
// Check if all corners matches of smaller image
if ((_Offset.X <> 0) or (_Color = _LTColor)) and
(_ScreenBitmap.Canvas.Pixels[X + _SmallWidth, Y] = _RTColor) and
(_ScreenBitmap.Canvas.Pixels[X, Y + _SmallHeight] = _LBColor) and
(_ScreenBitmap.Canvas.Pixels[X + _SmallWidth, Y + _SmallHeight]
= _RBColor) then
begin
// Checking if content matches
for K := 0 to _SubImageInfoList.Count - 1 do
begin
_Pos.X := X - _Offset.X + _SubImageInfoList[K].X;
_Pos.Y := Y - _Offset.Y + _SubImageInfoList[K].Y;
if (_ScreenBitmap.Canvas.Pixels[_Pos.X, _Pos.Y] = _SubImageInfoList
[K].Color) then
_MatchingPixels := _MatchingPixels + 1
else
begin
_Pos.X := X - _Offset.X - 1 + _SubImageInfoList[K].X;
_Pos.Y := Y - _Offset.Y + 1 + _SubImageInfoList[K].Y;
if (_ScreenBitmap.Canvas.Pixels[_Pos.X, _Pos.Y]
= _SubImageInfoList[K].Color) then
_MatchingPixels := _MatchingPixels + 1
else
begin
_MatchingPixels := 0;
Break;
end;
end;
end;
if (_MatchingPixels - 1 = _SubImageInfoList.Count - 1) then
begin
Result.Left := X - _Offset.X;
Result.Top := Y - _Offset.Y;
Result.Width := _SubimageBitmap.Width;
Result.Height := _SubimageBitmap.Height;
Exit;
end;
end;
Y := Y + 3;
end;
X := X + 3;
end;
finally
FreeAndNil(_FirstPixels);
FreeAndNil(_ScreenBitmap);
FreeAndNil(_SubimageBitmap);
FreeAndNil(_SubImageInfoList);
end;
end;
What it does is it loads sub-image from file and searches it on the screen (it identifies image by corner colors then if those matches it searches as in attached image), but you can easily adapt it.
Result would be a screen coordinates next to PDF file icon letter E.
If you're searching for an exact match (i.e. not a single pixel is different between the pattern you're looking for and the area in the image you want to find), you can actually use the Boyer Moore algorithm. It should be quite straight-forward to adapt it for looking for a 2D pattern.
Let's say the pattern you look for is 20x20 pixels big. You build a table mapping greyvalues (or colors) to positions in the pattern image. Now can go through the search image in large strides, starting at pixel 19/19: If this pixel contains a greyvalue that's not contained in the pattern, you can skip this position and all the positions in a 20x20 area around it. So the next pixel you would check would be at 39/19 in the search image. If it contains a pixel that appeard e.g. in 3 positions in the pattern image, you can test these three positions relative to your current position in the search image (39/19).
Note that this algorithm makes two assumptions:
you can only find exact matches. This is practically impossible for real-world images, unless the pattern image was extracted directly from the search image. It's even unlikely to work if source and pattern images are e.g. scanned from the same photograph with the same scanner. It won't work if the pattern or source image were compressed using a lossy compression (like jpeg) after the pattern was extracted.
The speedup depends on the number of greyvalues used. If you're looking for a binary pattern in a binary image, this algorithm won't run in O(n/m) time.
I would take a practical approach to this problem for 2D position matching:
They are probably going to be bitmaps...
Scan each line in the larger bitmap from 0 to Larger.height - Smaller.Height and from 0 to Larger.Width - Smaller.Width to find Smaller.TopLeft matching Pixels. When found:
IF Smaller.TopRight and smaller.bottomLeft and smaller.bottomRight are all equal to the corresponding pixels in the Larger bitmap (all the corners match) then initiate a full compare of that section.
Make sure that all comparisons fail early (do not continue comparing after any mismatch).
On average you will only need to scan less that 50% of the larger bitmap and will not start many full comparisons that fail.

How to speed up algorithm (Binarization, integral image)

I wrote this procedure based on integral image algorithm described at this url
http://people.scs.carleton.ca/~roth/iit-publications-iti/docs/gerh-50002.pdf
Is there any way to do this code faster?
Pointers are much faster as dynamic arrays?
procedure TForm1.bBinarizationClick(Sender: TObject);
var
iX1, iY1,
iX2, iY2,
ii, jj,
s, s2,
iSum, iCount, index,
iHeight, iWidth : Integer;
iSize: Integer;
row : ^TRGBTriple;
black : TRGBTriple;
aIntegralIm: array of Integer;
aGrays : array of Byte;
startTime : Cardinal;
begin
iWidth := bBitmap.Width;
iHeight := bBitmap.Height;
iSize := iWidth * iHeight;
SetLength(aGrays, iSize);
SetLength(aIntegralIm, iSize);
black.rgbtRed := (clBlack and $0000FF);
black.rgbtGreen := (clBlack and $00FF00) shr 8;
black.rgbtBlue := (clBlack and $FF0000) shr 16;
bBitmap2.Canvas.Brush.Color := clWhite;
bBitmap2.Canvas.FillRect(Rect(0, 0, bBitmap2.Width, bBitmap2.Height));
s := Round(iWidth / TrackBar2.Position);
s2 := Round(s / 2);
startTime := GetTickCount();
index := 0;
for ii := 0 to iHeight - 1 do begin
row := bBitmap.ScanLine[ii];
for jj := 0 to iWidth - 1 do begin
aGrays[index] := ((row.rgbtRed * 77 + row.rgbtGreen * 150 + row.rgbtBlue * 29) shr 8);
inc(index);
inc(row);
end;
end;
for ii := 0 to iWidth - 1 do begin
iSum := 0;
for jj := 0 to iHeight - 1 do begin
index := jj*iWidth+ii;
iSum := iSum + aGrays[index];
if ii = 0 then aIntegralIm[index] := iSum
else aIntegralIm[index] := aIntegralIm[index - 1] + iSum;
end;
end;
for jj := 0 to iHeight - 1 do begin
row := bBitmap2.ScanLine[jj];
for ii := 0 to iWidth - 1 do begin
index := jj*iWidth+ii;
iX1 := ii-s2;
iX2 := ii+s2;
iY1 := jj-s2;
iY2 := jj+s2;
if (iX1 < 0) then iX1 := 0;
if (iX2 >= iWidth) then iX2 := iWidth-1;
if (iY1 < 0) then iY1 := 0;
if (iY2 >= iHeight) then iY2 := iHeight-1;
iCount := (iX2 - iX1) * (iY2 - iY1);
iSum := aIntegralIm[iY2*iWidth+iX2]
- aIntegralIm[iY1*iWidth+iX2]
- aIntegralIm[iY2*iWidth+iX1]
+ aIntegralIm[iY1*iWidth+iX1];
if (aGrays[index] * iCount) < (iSum * (100 - TrackBar1.Position) / 100) then row^ := black;
inc(row);
end;
end;
ePath.Text := 'Time: ' + inttostr(GetTickCount() - startTime) + ' ms';
imgOryginal.Picture.Bitmap.Assign(bBitmap2);
end;
You can at least do a few simple things:
precalculate (100 - TrackBar1.Position) into a variable
Instead of division: / 100 use * 100 on the other side. You might not need any floating point values.
Use lookup tables for the following (care to explain the identation btw?):
Code:
if (iX1 < 0) then iX1 := 0;
if (iX2 >= iWidth) then iX2 := iWidth-1;
if (iY1 < 0) then iY1 := 0;
if (iY2 >= iHeight) then iY2 := iHeight-1;
Try to keep the index and icremnet, decrement istead of multiplication: index := jj*iWidth+ii;
My guess is that the second loop is the slow bit.
The trick would be to avoid to recalculate everything in the second loop all the time
If S is constant (relative to the loop I mean, not absolute)
iy1,iy2 only change with the main(jj) loop and so do iy1*width (and iy2*width).
Precalculate them, or optimize them away in the same way you do with row. (precalculate once per line, increment inbetween)
change the ii loop into three loops:
the first bit where ix1=0
the second where ix1=ii-s ix2=ii+s;
the third where ix1=ii-s and ix2=iwidth-1
this removes a lot of checks out of the loops, to be done only once.
make a dedicated loop for the condition if (aGrays[index] * iCount) < (iSum * (100 - TrackBar1.Position) / 100) then row^ := black; so that it isn't evaluated for each pixel, since you can precalculate the area's where this happens ?
introduce pointers into the gray calculating loop so that you don't have to recalculate the index each pixel (but e.g. only for the row loop, incrementing a ptr per pixel)
If you are hardy, you can also precalculate the jump between lines. Keep in mind that abs(scanline[j]-scanline[i])-width is a metric for the number of alignment bytes per row.
Even more advanced is optimizing for cache effects on the level of your algorithm. See
rotating bitmaps. In code
to get an idea how this works. Some pointer tricks are demonstrated there too (but only for 8-bit elements)
I would first use a profiler to find out the CPU usage repartition, to figure out the smallest part(s) of code that would benefit the most from optimisation.
Then I would adapt the effort according to the results. If some code represents 90% of the CPU load and is executed zillions of times, even extreme measures (recoding a few sequences using inline assembly language) might make sense.
Use the excellent and free SamplingProfiler to find out the bottleneck in your code. Then optimize and run the profiler again to find the next bottleneck. This approach is much better than guessing what's need to be optimized because even experts are often wrong about that.

Resources