1 Настоящая "адаптивная бинаризация" изрядно сложнее но и полезнее (не уверен что у меня лучшее решение но результат заметно отличается от более простой реализации )
Код: Выделить всё
// Binarization неизвестного происхождения ...
// Min,Max радиусы адаптации видимо можно сделать вычисления оптимального значения автоматическим.
// умолчание например Min=5, Max=15 )
procedure bBinarization(var bBitmap,OutB:TBitmap;Min,Max:Integer);
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;
bBitmap2:TBitmap;
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:=TBitmap.Create;
// bBitmap.PixelFormat:=pf24bit;;
bBitmap2.Canvas.Brush.Color := clWhite;
bBitmap2.SetSize(bBitmap.Width,bBitmap.Height);
bBitmap2.Canvas.FillRect(Rect(0, 0, bBitmap2.Width, bBitmap2.Height));
if max<1 Then Max:=1;
s := Round(iWidth /Max);
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;
//bBitmap2.endUpdate;
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
bBitmap2.BeginUpdate(False);
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 - Min) / 100) then row^ := black;
inc(row);
end;
bBitmap2.endUpdate(False);
end;
//ePath.Text := 'Time: ' + inttostr(GetTickCount() - startTime) + ' ms';
//bBitmap2.endUpdate(False);
OutB.Canvas.Draw(0,0,bBitmap2);
//OutB.Assign(bBitmap2);
bBitmap2.Free;
end;
2 Веб-камеру для тестов можно: во первых из любого смартфона сделать (подробно описано где-то в этой теме ), во вторых "одолжить" в интернете, в третьих использовать захват окна с почти любого плеера. (Все три способа опробованы на моей "подопытной" программе захват кадров из чужих окон есть в Unit6.pas ) Стянуть кадр из сети вообще проще простого.
Код: Выделить всё
uses httpsend,...
...
function HttpGetBinary2(const URL,Port: string; const Response: TStream): Boolean; //Http Port =80
var
HTTP: THTTPSend;
FS:TFileStream ;
begin
begin
HTTP := THTTPSend.Create;
try
cHttpProtocol:=Port;
Result := HTTP.HTTPMethod('GET', URL);
if Result then
begin
Response.Seek(0, soFromBeginning);
Response.CopyFrom(HTTP.Document, 0);
end;
finally
HTTP.Free;
end;
end;
end;
//Загрузка изображений из сети
procedure NetLoadImg(Url,Port:String;var BMP:Tbitmap );
var
Image1:TImage;
s:TMemoryStream;
begin
s:=TMemoryStream.Create;
If HttpGetBinary2(URL,Port, s) then begin
if bmp<>Nil then bmp.Free;
BMP:=Tbitmap.Create;
s.Seek(0, soFromBeginning);
Image1:=TImage.Create(nil);
Image1.Picture.LoadFromStream(S);
bmp.Assign(Image1.Picture.Bitmap);
Image1.Free;
end ;
s.Free;
end;
3 Отследить движение можно достаточно быстро, но быстрее всего в OpenCV .
Код: Выделить всё
uses Windows,ipl,OpenCV...
Procedure MotionDetect( Frame :pIplImage) ;
// Проверка наложения и близости двух CvRect
// LX,LY - дополнительное расстояние от края областей...
Function CR(r1,r2 :CvRect;LX,LY:Integer):boolean;
var RR1,RR2,RR3:TRect;
begin
RR1:=Classes.Bounds(r1.x-lx,r1.y-ly,r1.width+lx,r1.height+ly);
RR2:=Classes.Bounds(r2.x-lx,r2.y-ly,r2.width+lx,r2.height+ly);
Result:=//RR1.IntersectsWith(rr2);//c версии Лазарус 1.8
(RR1.Left < RR2.Right) and (RR2.Left < RR1.Right)
and (RR1.Top < RR2.Bottom) and (RR2.Top < RR1.Bottom);
end;
// Простое слияние двух CvRect в один
Function SumRecT(r1,r2 :CvRect): CvRect;
begin
With result do begin
X:=Min(r1.x,r2.x);width:=Max(r1.width,r2.width);
Y:=Min(r1.Y,r2.Y); height:=Max(r1.height,r2.height);
end
end;
Var I,J:Integer;
PR:PCvRect;
rect1: CvRect;
rect2d: CvBox2D;
storage : pCvMemStorage;
cs: CvSize;
black, white: CvScalar;
Const
HSV :pIplImage = nil;
frame_grey :pIplImage = nil;
contours: pCvSeq = nil;
c: pCvSeq = nil;
difference_img: PIplImage = nil;
oldframe_grey : PIplImage = nil;
RecList:TList=Nil;
label l1;
begin
// Инициализация
if frame.Width =0 then exit;
Cs.width:=frame.Width;
Cs.height:=frame.Height;
storage := cvCreateMemStorage(0);
if RecList=Nil then RecList:=TList.create;
if difference_img = nil then
begin
frame_grey := cvCreateImage(CS, IPL_DEPTH_8U, 1);
difference_img := cvCloneImage(frame_grey);
oldframe_grey := cvCloneImage(frame_grey);
//cvConvertScale(frame_grey, oldframe_grey, 1.0, 0.0);;
end;
//Конверсия и фильтрация
cvCvtColor(frame, frame_grey, CV_RGB2GRAY);
if Cs.width <> oldframe_grey.Width then
begin
cvReleaseImage(frame_grey);
cvConvertScale(frame_grey, oldframe_grey, 1.0, 0.0);;
end;
cvAbsDiff(oldframe_grey, frame_grey, difference_img);
cvSmooth(difference_img, difference_img, CV_BLUR);
cvThreshold(difference_img, difference_img, 25, 255, CV_THRESH_BINARY);
// Удаляем мелкие объекты
difference_img:= remove_small_objects(difference_img, 100);
// Поиск контуров на карте изменений
contours := AllocMem(SizeOf(CvSeq));
cvFindContours(difference_img, storage, @contours, SizeOf(CvContour),
CV_RETR_LIST,
// CV_RETR_EXTERNAL ,
CV_CHAIN_APPROX_SIMPLE
, cvPoint_(0, 0));
//Поиск фреймов
white:=CV_RGB(255, 255, 255);
c:=contours;
while (c <> nil) do
begin
rect2d := cvMinAreaRect2(c);
rect1.x:=Round(rect2d.center.x - rect2d.size.width / 2);
rect1.y:=Round(rect2d.center.Y - rect2d.size.height / 2);
rect1.width:=Round(rect2d.size.width);
rect1.height:=Round(rect2d.size.height);
{ // Странно !
В примере cvBoundingRect работал идеально
rect1:=cvBoundingRect(c, 0);
}
new(pr);
Pr ^:= Rect1;
RecList.Add(pr);
C:=c.h_next;
end;
// Складываю близкие области ...
if RecList.Count>0 then begin
L1:for i:=0 to RecList.Count-1 do
for j:=0 to RecList.Count-1 do
if (I<>J) and Cr(CvRect(RecList[i]^),CvRect(RecList[j]^),100,50) then
begin
CvRect(RecList[i]^):=SumRecT(CvRect(RecList[i]^),CvRect(RecList[j]^));
Dispose( RecList[j] ); RecList.Delete(j);
goto l1; // Некрасиво? Зато наглядно!
end;
// Вывод результатов.
for I:=0 to RecList.Count-1 do begin
rect1:=CvRect(RecList[i]^);
cvRectangle(frame, cvPoint_(rect1.x, rect1.y),
cvPoint_(rect1.x + rect1.width, rect1.y + rect1.height),
cvScalar_(255, 0, 255, 0), 2, 8, 0);
end;
// Очистка списка .
for I:=0 to RecList.Count-1 do Dispose( RecList[I] ); RecList.Clear;
end;
cvConvertScale(frame_grey, oldframe_grey, 1.0, 0.0);
//чистка
//cvClearMemStorage(storage);
contours := nil;
c := nil;
FreeMem(contours, SizeOf(CvSeq));
cvReleaseMemStorage(storage);
// cvReleaseImage(frame_grey);
storage := nil;
end;