DelphiでHaar Cascade XMLを使った画像認識｜顔・身体検出の実装例
このページでは、Delphiを使ってHaar Cascade XMLファイルによる画像認識を行う方法を紹介します。
顔や目、身体、ナンバープレートなど、用途に応じたXMLファイルを使って領域を検出し、リアルタイム処理にも対応した実装例を掲載しています。
処理速度と精度のバランス調整、並列処理による高速化、環境依存への対策など、実務で役立つノウハウをまとめています。
顔・目などを検出できるカスケード識別器の学習済みファイルの準備
学習済みファイルは以下のいずれかで用意してください。どちらの方法で用意してもかまいません。
-
本サイトからダウンロードhaarcascades.zip（1491KB）してください。
ダウンロードして解凍した「haarcascades」フォルダをこれから作成するプロジェクトフォルダ直下にフォルダごとコピーする - OpenCV本家（https://opencv.org/releases/）のサイトからOpenCV 4.xをダウンロードして解凍した 「opencv\sources\data\haarcascades」フォルダをプロジェクトフォルダ直下にフォルダごとコピーする
| ファイル名 | 分類機 |
|---|---|
| haarcascade_eye.xml | 目 |
| haarcascade_eye_tree_eyeglasses.xml | 眼鏡 |
| haarcascade_frontalcatface.xml | 猫の顔（正面） |
| haarcascade_frontalcatface_extended.xml | 猫の顔（正面） |
| haarcascade_frontalface_alt.xml | 人の顔（正面） |
| haarcascade_frontalface_alt2.xml | 人の顔（正面） |
| haarcascade_frontalface_alt_tree.xml | 人の顔（正面） |
| haarcascade_frontalface_default.xml | 人の顔（正面） |
| haarcascade_fullbody.xml | 人の全身 |
| haarcascade_lefteye_2spits.xml | 人の左目 |
| haarcascade_licence_plate_rus_16stages.xml | ロシアのナンバープレート（全体） |
| haarcascade_lowerbody.xml | 下半身 |
| haarcascade_profileface.xml | 顔（証明写真） |
| haarcascade_righteye_2splits.xml | 右目 |
| haarcascade_russian_plate_number.xml | ロシアのナンバープレート（数字） |
| haarcascade_smile.xml | 笑顔 |
| haarcascade_upperbody.xml | 上半身 |
Delphi用Haar Cascadeユニットファイルの準備
本ページ下部にあるDelphi用ユニットファイル「UMamHaar.pas」をこれから作成するプロジェクトフォルダ内に配置します。
Delphiを起動して新規作成を行い、必要なコンポーネントをドラッグ&ドロップする
Delphi起動⇒ファイル⇒新規作成⇒WindowsVCLアプリケーション を選択します。
TButton 2個、TImage 1個、をフォームへドラッグ＆ドロップします。
「ファイル」⇒「全て保存」でプロジェクトフォルダを作成して、プロジェクトとユニットを保存します。
プロジェクトフォルダ内にUMamHaar.pasファイルを配置します。
プロジェクトフォルダ内に「haarcascades」フォルダを配置します。
プロジェクトフォルダ内に、顔領域や目の領域を検出したい「.jpg」ファイルを配置します。
（pixabay(https://pixabay.com/ja/)からフリー素材をダウンロードして使用させていただきました。）
- face.jpg
- eye.jpg
ソースコードを記述する
Button1のOnClickイベント、Button2のOnClickイベントに以下ソースコードを記述します。
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls,
VCL.Imaging.jpeg, UMamHaar;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private 宣言 }
public
{ Public 宣言 }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var haar:THaar;
jpg:TJPegImage;
bmp:TBitmap;
r:TArray<TRect>;
i:integer;
begin
Image1.Proportional:=True;
Image1.Stretch:=True;
haar:=THaar.Create('..\..\haarcascades\haarcascade_frontalface_default.xml');
jpg:=TJpegImage.Create;
bmp:=TBitmap.Create;
try
jpg.LoadFromFile('..\..\face.jpg');
bmp.Assign(jpg);
//パラメータの値は使用するxmlファイルや画像ファイルにより調整が必要です
haar.Cascade(bmp, r, 1.2, 2, 0.1);
Image1.Picture.Bitmap.Assign(bmp);
image1.Picture.Bitmap.Canvas.Pen.Color:=clRed;
Image1.Picture.Bitmap.Canvas.Pen.Width:=4;
Image1.Picture.Bitmap.Canvas.Brush.Style:=bsClear;
for i := Low(r) to High(r) do
begin
image1.Picture.Bitmap.Canvas.Rectangle(r[i]);
end;
finally
haar.Free;
jpg.free;
bmp.free;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var haar:THaar;
jpg:TJPegImage;
bmp:TBitmap;
r:TArray<TRect>;
i:integer;
begin
Image1.Proportional:=True;
Image1.Stretch:=True;
haar:=THaar.Create('..\..\haarcascades\haarcascade_eye.xml');
jpg:=TJpegImage.Create;
bmp:=TBitmap.Create;
try
jpg.LoadFromFile('..\..\eye.jpg');
bmp.Assign(jpg);
//パラメータの値は使用するxmlファイルや画像ファイルにより調整が必要です
haar.Cascade(bmp, r, 1.2, 2, 0.05);
Image1.Picture.Bitmap.Assign(bmp);
image1.Picture.Bitmap.Canvas.Pen.Color:=clRed;
Image1.Picture.Bitmap.Canvas.Pen.Width:=4;
Image1.Picture.Bitmap.Canvas.Brush.Style:=bsClear;
for i := Low(r) to High(r) do
begin
image1.Picture.Bitmap.Canvas.Rectangle(r[i]);
end;
finally
haar.Free;
jpg.free;
bmp.free;
end;
end;
end.
実行する
実行ボタンを押して実行します。（デバッグ実行でもOK）
Button1をクリックすると、顔の領域を検出して四角形を描きます。
Button2をクリックすると、目の領域を検出して四角形を描きます。
UMamHaar.pas（通常版）ソースコード
以下ソースコードは通常版です。
同時に複数タスクで処理を行う高速版はもう少し下にあります。
unit UMamHaar;
interface
uses System.Types, System.SysUtils, Vcl.Graphics,
Xml.xmldom, Xml.XMLIntf, Xml.XMLDoc,System.Math,
System.RegularExpressions, System.Classes;
type
TWeakClassifier=record
LeftId,RightId,Idx:Integer;
Threshold:Double;
LeftId2,RightId2,Idx2:Integer;
Threshold2:Double;
Leaf:array[0..2] of Double;
end;
TStage=record
StageCount:Integer;
Threshold:Double;
WC:TArray<TWeakClassifier>;
end;
TFeatureRect=record
x,y,w,h:Integer;
Weight:Double;
x2,y2,w2,h2:Integer;
Weight2:Double;
end;
TFeature=record
Rects:TArray<TFeatureRect>;
end;
THaarRect=record
Left,Top,Width,Height:Integer;
end;
THaarRGB=record
b,g,r:Byte;
end;
PHaarRGB=^THaarRGB;
THaar=class(TObject)
private
Stages:TArray<TStage>;
Features:TArray<TFeature>;
FeaturesW,FeaturesH:Integer;
function MergeRect(Rects:TArray<THaarRect>):TArray<THaarRect>;
function IsRectEquals(r1,r2:THaarRect):Boolean;
public
constructor Create(FileName:String);
destructor Destroy;override;
procedure Cascade(Img:TBitmap;out r:TArray<TRect>;
ScaleFactor:Double=1.2;MinScale:Double=2.0;WindowMoveRate:Double=0.10);
end;
implementation
{ THaar }
procedure THaar.Cascade(Img: TBitmap; out r: TArray<TRect>;
ScaleFactor:Double=1.2;MinScale:Double=2.0;WindowMoveRate:Double=0.10);
var bmp:TBitmap;
i,j,k:Integer;
x,y,w,h:Integer;
rgb:PHaarRGB;
Gray:TArray<TArray<Cardinal>>;
Integ1:TArray<TArray<Cardinal>>;
Integ2:TArray<TArray<Cardinal>>;
MaxScale:Double;
StepX,StepY:Integer;
IsStagePass:boolean;
StageSum,RectSum:Double;
rx1,rx2,ry1,ry2:Cardinal;
Areas:Cardinal;
TotalInteg1,TotalInteg2,moy,Norm:Cardinal;
VNorm:Double;
Idx:Integer;
HitRect:TArray<THaarRect>;
MergedRect:TArray<THaarRect>;
Scale:Double;
begin
//FeatureW,FeatureHのMinScale倍の窓サイズで検出を開始する
//小さい値を設定すると小さいオブジェクトを検出できるが遅い
if MinScale<0.5 then MinScale:=0.5;
if MinScale>5 then MinScale:=5;
Scale:=MinScale;
//窓サイズをscaleFactor倍ずつ大きくして検出する
//小さい値を設定すると検出率は上がるが遅い
if ScaleFactor<1.01 then ScaleFactor:=1.01;
if ScaleFactor>2 then ScaleFactor:=2.0;
//（畳み込み時）窓サイズに対する窓の移動割合(デフォルト10%)
//小さい値を設定すると検出率は上がるが遅い
if WindowMoveRate<0.01 then WindowMoveRate:=0.01;
if WindowMoveRate>1.00 then WindowMoveRate:=1.00;
//グレースケール画像の作成
bmp:=TBitmap.Create;
try
bmp.Assign(Img);
bmp.PixelFormat:=pf24bit;
SetLength(Gray,bmp.Width);
for x := Low(Gray) to High(Gray) do
SetLength(Gray[x],bmp.Height);
for y := 0 to bmp.Height-1 do
begin
rgb:=bmp.ScanLine[y];
for x := 0 to bmp.Width-1 do
begin
Gray[x][y]:=(30*rgb.r+59*rgb.g+11*rgb.b) div 100;
inc(rgb);
end;
end;
finally
bmp.Free;
end;
//積分画像、2乗積分画像の作成
SetLength(Integ1,Length(Gray));
SetLength(Integ2,Length(Gray));
for x := Low(Integ1) to High(Integ1) do
begin
SetLength(Integ1[x],Length(Gray[x]));
SetLength(Integ2[x],Length(Gray[x]));
end;
for x := Low(Integ1) to High(Integ1) do
begin
for y := Low(Integ1[0]) to High(Integ1[0]) do
begin
if (x>0) and (y>0) then
begin
Integ1[x][y]:=
Integ1[x-1][y]+Integ1[x][y-1]-Integ1[x-1][y-1]+
Gray[x][y];
Integ2[x][y]:=
Integ2[x-1][y]+Integ2[x][y-1]-Integ2[x-1][y-1]+
Gray[x][y]*Gray[x][y];
end
else if (x=0) and (y>0) then
begin
Integ1[x][y]:=Integ1[x][y-1]+Gray[x][y];
Integ2[x][y]:=Integ2[x][y-1]+Gray[x][y]*Gray[x][y];
end
else if (x>0) and (y=0) then
begin
Integ1[x][y]:=Integ1[x-1][y]+Gray[x][y];
Integ2[x][y]:=Integ2[x-1][y]+Gray[x][y]*Gray[x][y];
end
else
begin
Integ1[x][y]:=Gray[x][y];
Integ2[x][y]:=Gray[x][y]*Gray[x][y];
end
end;
end;
MaxScale:=Min(Length(Gray)/FeaturesW,Length(Gray[0])/FeaturesH);
while Scale<MaxScale do //窓サイズ毎の処理
begin
//窓サイズ
w:=trunc(Scale*FeaturesW);
h:=trunc(Scale*FeaturesH);
//窓面積
Areas:=w*h;
//畳み込み横方向の移動距離
StepX:=trunc(w*WindowMoveRate);
if StepX<2 then StepX:=2;
//畳み込み縦方向の移動距離
StepY:=trunc(h*WindowMoveRate);
if StepY<2 then StepY:=2;
x:=0;
while x<(Length(Gray)-w) do //畳み込み横方向
begin
y:=0;
while y<(Length(Gray[x])-h) do //畳み込み縦方向
begin
IsStagePass:=True;
TotalInteg1:=Integ1[x+w][y+h]+Integ1[x][y]-Integ1[x][y+h]-Integ1[x+w][y];
TotalInteg2:=Integ2[x+w][y+h]+Integ2[x][y]-Integ2[x][y+h]-Integ2[x+w][y];
moy:=TotalInteg1 div Areas;
Norm:=TotalInteg2 div Areas - moy*moy;
if Norm>1 then VNorm:=sqrt(Norm) else VNorm:=1;
//ステージごとの処理
for i := Low(Stages) to High(Stages) do
begin
StageSum:=0;
for j := Low(Stages[i].WC) to High(Stages[i].WC) do
begin
//Lidx1 Lidx1 インデックス 閾値 Lidx3 Lidx4 インデックス 閾値
//Lidx1,Lidx2,Lidx3,Lidx4はそれぞれ0以下の場合は
//リーフノード（葉）であることを示し、1の場合は枝であることを示す
Idx:=Stages[i].WC[j].Idx;
RectSum:=0;
for k := Low(Features[Idx].Rects) to High(Features[Idx].Rects) do
begin
rx1:=x+trunc(Scale*(Features[Idx].Rects[k].x));
rx2:=x+trunc(Scale*(Features[Idx].Rects[k].x+Features[Idx].Rects[k].w));
ry1:=y+trunc(Scale*(Features[Idx].Rects[k].y));
ry2:=y+trunc(Scale*(Features[Idx].Rects[k].y+Features[Idx].Rects[k].h));
RectSum:=RectSum+
(Integ1[rx2][ry2]-Integ1[rx1][ry2]-Integ1[rx2][ry1]+Integ1[rx1][ry1])
*Features[Idx].Rects[k].Weight;
end;
RectSum:=RectSum/Areas;
if RectSum<(Stages[i].WC[j].Threshold*VNorm) then
begin
if Stages[i].WC[j].LeftId<=0 then
begin
StageSum:=StageSum+Stages[i].WC[j].Leaf[Trunc(Abs(Stages[i].WC[j].LeftId))];
end
else
begin
Idx:=Stages[i].WC[j].Idx2;
RectSum:=0;
for k := Low(Features[Idx].Rects) to High(Features[Idx].Rects) do
begin
rx1:=x+trunc(Scale*(Features[Idx].Rects[k].x));
rx2:=x+trunc(Scale*(Features[Idx].Rects[k].x+Features[Idx].Rects[k].w));
ry1:=y+trunc(Scale*(Features[Idx].Rects[k].y));
ry2:=y+trunc(Scale*(Features[Idx].Rects[k].y+Features[Idx].Rects[k].h));
RectSum:=RectSum+
(Integ1[rx2][ry2]-Integ1[rx1][ry2]-Integ1[rx2][ry1]+Integ1[rx1][ry1])
*Features[Idx].Rects[k].Weight;
end;
RectSum:=RectSum/Areas;
if RectSum<(Stages[i].WC[j].Threshold2*VNorm) then
StageSum:=StageSum+Stages[i].WC[j].Leaf[Trunc(Abs(Stages[i].WC[j].LeftId2))]
else
StageSum:=StageSum+Stages[i].WC[j].Leaf[Trunc(Abs(Stages[i].WC[j].RightId2))];
end;
end
else
begin
if Stages[i].WC[j].RightId<=0 then
StageSum:=StageSum+Stages[i].WC[j].Leaf[Trunc(Abs(Stages[i].WC[j].RightId))]
else
begin
Idx:=Stages[i].WC[j].Idx2;
RectSum:=0;
for k := Low(Features[Idx].Rects) to High(Features[Idx].Rects) do
begin
rx1:=x+trunc(Scale*(Features[Idx].Rects[k].x));
rx2:=x+trunc(Scale*(Features[Idx].Rects[k].x+Features[Idx].Rects[k].w));
ry1:=y+trunc(Scale*(Features[Idx].Rects[k].y));
ry2:=y+trunc(Scale*(Features[Idx].Rects[k].y+Features[Idx].Rects[k].h));
RectSum:=RectSum+
(Integ1[rx2][ry2]-Integ1[rx1][ry2]-Integ1[rx2][ry1]+Integ1[rx1][ry1])
*Features[Idx].Rects[k].Weight;
end;
RectSum:=RectSum/Areas;
if RectSum<(Stages[i].WC[j].Threshold2*VNorm) then
StageSum:=StageSum+Stages[i].WC[j].Leaf[Trunc(Abs(Stages[i].WC[j].LeftId2))]
else
StageSum:=StageSum+Stages[i].WC[j].Leaf[Trunc(Abs(Stages[i].WC[j].RightId2))];
end;
end;
end;
if StageSum<(Stages[i].Threshold) then
begin
//ステージを通過できなかったら以降のステージは処理しない
IsStagePass:=False;
Break;
end;
end;
if IsStagePass then
begin
//全てのステージを通過したらヒット
SetLength(HitRect,length(HitRect)+1);
HitRect[High(HitRect)].Left:=x;
HitRect[High(HitRect)].Top:=y;
HitRect[High(HitRect)].Width:=w;
HitRect[High(HitRect)].Height:=h;
end;
y:=y+StepY;
end;
x:=x+StepX;
end;
Scale:=Scale*ScaleFactor;
end;
//ヒットした範囲をマージする
MergedRect:=Self.MergeRect(HitRect);
SetLength(r,length(MergedRect));
for x := Low(MergedRect) to High(MergedRect) do
begin
r[x].Left:=MergedRect[x].Left;
r[x].Top:=MergedRect[x].Top;
r[x].Width:=MergedRect[x].Width;
r[x].Height:=MergedRect[x].Height;
end;
end;
constructor THaar.Create(FileName: String);
var xml:IXMLDocument;//インターフェースで宣言する
n1,n2,n3,n4:IXMLNode;
i,j:Integer;
snum:Integer;
st:string;
opt:TRegExOptions;
val:TArray<String>;
begin
//Haar Cascade XMLファイルの読み込み
XML:=TXMLDocument.Create(nil);
TXMLDocument(XML).DOMVendor:=GetDOMVendor('MSXML');
xml.LoadFromFile(FileName);
st:=xml.XML.Text;
opt:=[roSingleLine];
//コメントの削除
st:=TRegEx.Replace(st,'<!--.*?-->','',opt);
xml.XML.Text:=st;
xml.Active:=True;
FeaturesW:=StrToInt(
xml.ChildNodes.FindNode('opencv_storage')
.ChildNodes.FindNode('cascade')
.ChildNodes.FindNode('width').GetText
);
FeaturesH:=StrToInt(
xml.ChildNodes.FindNode('opencv_storage')
.ChildNodes.FindNode('cascade')
.ChildNodes.FindNode('height').GetText
);
snum:=StrToInt(
xml.ChildNodes.FindNode('opencv_storage')
.ChildNodes.FindNode('cascade')
.ChildNodes.FindNode('stageNum').GetText
);
SetLength(Stages,snum);
n1:=xml.ChildNodes.FindNode('opencv_storage')
.ChildNodes.FindNode('cascade')
.ChildNodes.FindNode('stages');
for i := 0 to snum-1 do
begin
n2:=n1.ChildNodes.Get(i);
Stages[i].StageCount:=
StrToInt(n2.ChildNodes.FindNode('maxWeakCount').GetText);
Stages[i].Threshold:=
StrToFloat(n2.ChildNodes.FindNode('stageThreshold').GetText);
SetLength(Stages[i].WC,Stages[i].StageCount);
n3:=n2.ChildNodes.FindNode('weakClassifiers');
for j := 0 to Stages[i].StageCount-1 do
begin
n4:=n3.ChildNodes.Get(j);
st:=Trim(n4.ChildNodes.FindNode('internalNodes').GetText);
st:=StringReplace(st,#10,'',[rfReplaceAll]);
st:=TRegEx.Replace(st,' {2,}',' ',opt);
val:=st.Split([' ']);
Stages[i].WC[j].LeftId:=StrToInt(val[0]);
Stages[i].WC[j].RightId:=StrToInt(val[1]);
Stages[i].WC[j].Idx:=StrToInt(val[2]);
Stages[i].WC[j].Threshold:=StrToFloat(val[3]);
if length(val)=8 then
begin
Stages[i].WC[j].LeftId2:=StrToInt(val[4]);
Stages[i].WC[j].RightId2:=StrToInt(val[5]);
Stages[i].WC[j].Idx2:=StrToInt(val[6]);
Stages[i].WC[j].Threshold2:=StrToFloat(val[7]);
end
else
begin
Stages[i].WC[j].LeftId2:=0;
Stages[i].WC[j].RightId2:=0;
Stages[i].WC[j].Idx2:=0;
Stages[i].WC[j].Threshold2:=0;
end;
st:=Trim(n4.ChildNodes.FindNode('leafValues').GetText);
st:=StringReplace(st,#10,'',[rfReplaceAll]);
st:=TRegEx.Replace(st,' {2,}',' ',opt);
val:=st.Split([' ']);
Stages[i].WC[j].Leaf[0]:=StrToFloat(val[0]);
Stages[i].WC[j].Leaf[1]:=StrToFloat(val[1]);
if Length(val)=3 then
Stages[i].WC[j].Leaf[2]:=StrToFloat(val[2])
else
Stages[i].WC[j].Leaf[2]:=0;
end;
end;
n1:=xml.ChildNodes.FindNode('opencv_storage')
.ChildNodes.FindNode('cascade')
.ChildNodes.FindNode('features');
SetLength(Features,n1.ChildNodes.Count);
for i := 0 to n1.ChildNodes.Count-1 do
begin
n2:=n1.ChildNodes.Get(i).ChildNodes.FindNode('rects');
SetLength(Features[i].Rects,n2.ChildNodes.Count);
for j := 0 to n2.ChildNodes.Count-1 do
begin
st:=Trim(n2.ChildNodes.Get(j).GetText);
val:=st.Split([' ']);
Features[i].Rects[j].x:=StrToInt(val[0]);
Features[i].Rects[j].y:=StrToInt(val[1]);
Features[i].Rects[j].w:=StrToInt(val[2]);
Features[i].Rects[j].h:=StrToInt(val[3]);
Features[i].Rects[j].Weight:=StrToFloat(val[4]);
end;
end;
xml.Active:=False;
end;
destructor THaar.Destroy;
begin
inherited;
end;
function THaar.IsRectEquals(r1, r2: THaarRect): boolean;
var distance:Integer;
begin
Result:=false;
distance:=Trunc(r1.Width*0.2);
if (r2.Left<=(r1.Left+distance)) and
(r2.Left>=(r1.Left-distance)) and
(r2.Top <=(r1.Top +distance)) and
(r2.Top >=(r1.Top -distance)) and
(r2.Width<=trunc(r1.Width*1.2)) and
(trunc(r2.Width*1.2)>=r1.Width) then
begin
Result:=true;
end
else if (r1.Left>=r2.Left) and
((r1.Left+r1.Width )<=(r2.Left+r2.Width )) and
(r1.Top>=r2.Top) and
((r1.Top +r1.Height)<=(r2.Top +r2.Height)) then
begin
result:=true;
end;
end;
function THaar.MergeRect(Rects: TArray<THaarRect>): TArray<THaarRect>;
const MinNeighbors:Integer=1;
var i,j:Integer;
IsFound:boolean;
nb_classes:Integer;
ret:TArray<Integer>;
Neighbors:TArray<Integer>;
n:Integer;
MyRect:TArray<THaarRect>;
r:THaarRect;
begin
nb_classes:=0;
setLength(ret,Length(Rects));
for i := Low(Rects) to High(Rects) do
ret[i]:=0;
for i := Low(Rects) to High(Rects) do
begin
IsFound:=false;
for j := 0 to i-1 do
begin
if(IsRectEquals(Rects[j],Rects[i]))then
begin
IsFound:=true;
ret[i]:=ret[j];
end;
end;
if not IsFound then
begin
ret[i]:=nb_classes;
inc(nb_classes);
end;
end;
setLength(Neighbors,nb_classes);
setLength(MyRect,nb_classes);
for i := 0 to nb_classes-1 do
begin
Neighbors[i]:=0;
MyRect[i].Left:=0;
MyRect[i].Top:=0;
MyRect[i].Width:=0;
MyRect[i].Height:=0;
end;
for i := Low(Rects) to High(Rects) do
begin
inc(Neighbors[ret[i]]);
MyRect[ret[i]].Left :=MyRect[ret[i]].Left +Rects[i].Left;
MyRect[ret[i]].Top :=MyRect[ret[i]].Top +Rects[i].Top;
MyRect[ret[i]].Width :=MyRect[ret[i]].Width +Rects[i].Width;
MyRect[ret[i]].Height:=MyRect[ret[i]].Height +Rects[i].Height;
end;
for i := 0 to nb_classes-1 do
begin
n:=Neighbors[i];
if n>=MinNeighbors then
begin
r.Left :=(MyRect[i].Left *2+n)div(2*n);
r.Top :=(MyRect[i].Top *2+n)div(2*n);
r.Width :=(MyRect[i].Width *2+n)div(2*n);
r.Height:=(MyRect[i].Height*2+n)div(2*n);
SetLength(result,Length(result)+1);
result[High(result)]:=r;
end;
end;
end;
end.
UMamHaar.pas（高速版）ソースコード
以下ソースコードは同時に複数タスクで処理を行う高速版です。
処理速度は速いですがCPUリソースを多く消費しますのでご注意ください。
unit UMamHaar;
interface
uses System.Types, System.SysUtils, Vcl.Graphics, Xml.xmldom, Xml.XMLIntf,
Xml.XMLDoc,System.Math, System.RegularExpressions,
System.Classes, System.Threading, System.SyncObjs;
type
TWeakClassifier=record
LeftId,RightId,Idx:Integer;
Threshold:Double;
LeftId2,RightId2,Idx2:Integer;
Threshold2:Double;
Leaf:array[0..2] of Double;
end;
TStage=record
StageCount:Integer;
Threshold:Double;
WC:TArray<TWeakClassifier>;
end;
TFeatureRect=record
x,y,w,h:Integer;
Weight:Double;
x2,y2,w2,h2:Integer;
Weight2:Double;
end;
TFeature=record
Rects:TArray<TFeatureRect>;
end;
THaarRect=record
Left,Top,Width,Height:Integer;
end;
THaarRGB=record
b,g,r:Byte;
end;
PHaarRGB=^THaarRGB;
THitRects=class
public
Rects:TArray<THaarRect>;
end;
THaarStagesTask = class(TTask, ITask)
private
fStages:TArray<TStage>;
fFeatures:TArray<TFeature>;
fx,fy,fw,fh:Integer;
fScale:Double;
fAreas:Cardinal;
fHitRects:THitRects;
fInteg1:TArray<TArray<Cardinal>>;
fInteg2:TArray<TArray<Cardinal>>;
public
constructor Create(var Stages:TArray<TStage>;
var Features:TArray<TFeature>; var x,y,w,h:Integer; var Scale:Double;
var Areas:Cardinal; var HitRects:THitRects;
var Integ1:TArray<TArray<Cardinal>>; var Integ2:TArray<TArray<Cardinal>>
);
procedure TaskStart;
end;
THaar=class(TObject)
private
fStages:TArray<TStage>;
fFeatures:TArray<TFeature>;
fFeaturesW,fFeaturesH:Integer;
fHitRects:THitRects;
function MergeRect(Rects:THitRects):TArray<THaarRect>;
function IsRectEquals(r1,r2:THaarRect):Boolean;
public
constructor Create(FileName:String);
destructor Destroy;override;
procedure Cascade(Img:TBitmap;out r:TArray<TRect>;
ScaleFactor:Double=1.2;MinScale:Double=2.0;WindowMoveRate:Double=0.10);
end;
implementation
{ THaar }
procedure THaar.Cascade(Img: TBitmap; out r: TArray<TRect>;
ScaleFactor:Double=1.2;MinScale:Double=2.0;WindowMoveRate:Double=0.10);
var bmp:TBitmap;
i:Integer;
x,y,w,h:Integer;
rgb:PHaarRGB;
Gray:TArray<TArray<Cardinal>>;
Integ1:TArray<TArray<Cardinal>>;
Integ2:TArray<TArray<Cardinal>>;
MaxScale:Double;
StepX,StepY:Integer;
Areas:Cardinal;
MergedRect:TArray<THaarRect>;
Scale:Double;
Tasks:TArray<ITask>;
TaskNum:Integer;
MaxWorkerThreadsCount:Integer;
begin
SetLength(fHitRects.Rects,0);
//ハール分類器処理を同時に処理するスレッドの最大数
//コア数×25がデフォルトの値
MaxWorkerThreadsCount:=TThreadPool.Default.MaxWorkerThreads;
//FeatureW,FeatureHのMinScale倍の窓サイズで検出を開始する
//小さい値を設定すると小さいオブジェクトを検出できるが遅い
if MinScale<0.5 then MinScale:=0.5;
if MinScale>5 then MinScale:=5;
Scale:=MinScale;
//窓サイズをscaleFactor倍ずつ大きくして検出する
//小さい値を設定すると検出率は上がるが遅い
if ScaleFactor<1.01 then ScaleFactor:=1.01;
if ScaleFactor>2 then ScaleFactor:=2.0;
//（畳み込み時）窓サイズに対する窓の移動割合(デフォルト10%)
//小さい値を設定すると検出率は上がるが遅い
if WindowMoveRate<0.01 then WindowMoveRate:=0.01;
if WindowMoveRate>1.00 then WindowMoveRate:=1.00;
//グレースケール画像の作成
bmp:=TBitmap.Create;
try
bmp.Assign(Img);
bmp.PixelFormat:=pf24bit;
SetLength(Gray,bmp.Width);
for x := Low(Gray) to High(Gray) do
SetLength(Gray[x],bmp.Height);
for y := 0 to bmp.Height-1 do
begin
rgb:=bmp.ScanLine[y];
for x := 0 to bmp.Width-1 do
begin
Gray[x][y]:=(30*rgb.r+59*rgb.g+11*rgb.b) div 100;
inc(rgb);
end;
end;
finally
bmp.Free;
end;
//積分画像、2乗積分画像の作成
SetLength(Integ1,Length(Gray));
SetLength(Integ2,Length(Gray));
for x := Low(Integ1) to High(Integ1) do
begin
SetLength(Integ1[x],Length(Gray[x]));
SetLength(Integ2[x],Length(Gray[x]));
end;
for x := Low(Integ1) to High(Integ1) do
begin
for y := Low(Integ1[0]) to High(Integ1[0]) do
begin
if (x>0) and (y>0) then
begin
Integ1[x][y]:=
Integ1[x-1][y]+Integ1[x][y-1]-Integ1[x-1][y-1]+
Gray[x][y];
Integ2[x][y]:=
Integ2[x-1][y]+Integ2[x][y-1]-Integ2[x-1][y-1]+
Gray[x][y]*Gray[x][y];
end
else if (x=0) and (y>0) then
begin
Integ1[x][y]:=Integ1[x][y-1]+Gray[x][y];
Integ2[x][y]:=Integ2[x][y-1]+Gray[x][y]*Gray[x][y];
end
else if (x>0) and (y=0) then
begin
Integ1[x][y]:=Integ1[x-1][y]+Gray[x][y];
Integ2[x][y]:=Integ2[x-1][y]+Gray[x][y]*Gray[x][y];
end
else
begin
Integ1[x][y]:=Gray[x][y];
Integ2[x][y]:=Gray[x][y]*Gray[x][y];
end
end;
end;
MaxScale:=Min(Length(Gray)/fFeaturesW,Length(Gray[0])/fFeaturesH);
while Scale<MaxScale do //窓サイズ毎の処理
begin
//窓サイズ
w:=trunc(Scale*fFeaturesW);
h:=trunc(Scale*fFeaturesH);
//窓面積
Areas:=w*h;
//畳み込み横方向の移動距離
StepX:=trunc(w*WindowMoveRate);
if StepX<2 then StepX:=2;
//畳み込み縦方向の移動距離
StepY:=trunc(h*WindowMoveRate);
if StepY<2 then StepY:=2;
x:=0;
while x<(Length(Gray)-w) do //畳み込み横方向
begin
y:=0;
while y<(Length(Gray[x])-h) do //畳み込み縦方向
begin
//TTask/ITaskの数（並列処理するタスクの数）
TaskNum:=((Length(Gray[x])-h)-y)div StepY;
if TaskNum>MaxWorkerThreadsCount then TaskNum:=MaxWorkerThreadsCount;
//タスクの並列処理
SetLength(Tasks,TaskNum);
if TaskNum>0 then
begin
for i := 0 to TaskNum-1 do
begin
Tasks[i]:=THaarStagesTask.Create(
fStages, fFeatures, x, y, w, h,
Scale,Areas, fHitRects, Integ1,Integ2
) as ITask;
Tasks[i].Start;
y:=y+StepY;
end;
TTask.WaitForAll(Tasks);
end
else
begin
y:=y+StepY;
end;
end;
x:=x+StepX;
end;
Scale:=Scale*ScaleFactor;
end;
//ヒットした範囲をマージする
MergedRect:=Self.MergeRect(fHitRects);
SetLength(r,length(MergedRect));
for x := Low(MergedRect) to High(MergedRect) do
begin
r[x].Left:=MergedRect[x].Left;
r[x].Top:=MergedRect[x].Top;
r[x].Width:=MergedRect[x].Width;
r[x].Height:=MergedRect[x].Height;
end;
end;
constructor THaar.Create(FileName: String);
var xml:IXMLDocument;//インターフェースで宣言する
n1,n2,n3,n4:IXMLNode;
i,j:Integer;
snum:Integer;
st:string;
opt:TRegExOptions;
val:TArray<String>;
begin
//Haar Cascade XMLファイルの読み込み
XML:=TXMLDocument.Create(nil);
TXMLDocument(XML).DOMVendor:=GetDOMVendor('MSXML');
xml.LoadFromFile(FileName);
st:=xml.XML.Text;
opt:=[roSingleLine];
//コメントの削除
st:=TRegEx.Replace(st,'<!--.*?-->','',opt);
xml.XML.Text:=st;
xml.Active:=True;
fFeaturesW:=StrToInt(
xml.ChildNodes.FindNode('opencv_storage')
.ChildNodes.FindNode('cascade')
.ChildNodes.FindNode('width').GetText
);
fFeaturesH:=StrToInt(
xml.ChildNodes.FindNode('opencv_storage')
.ChildNodes.FindNode('cascade')
.ChildNodes.FindNode('height').GetText
);
snum:=StrToInt(
xml.ChildNodes.FindNode('opencv_storage')
.ChildNodes.FindNode('cascade')
.ChildNodes.FindNode('stageNum').GetText
);
SetLength(fStages,snum);
n1:=xml.ChildNodes.FindNode('opencv_storage')
.ChildNodes.FindNode('cascade')
.ChildNodes.FindNode('stages');
for i := 0 to snum-1 do
begin
n2:=n1.ChildNodes.Get(i);
fStages[i].StageCount:=
StrToInt(n2.ChildNodes.FindNode('maxWeakCount').GetText);
fStages[i].Threshold:=
StrToFloat(n2.ChildNodes.FindNode('stageThreshold').GetText);
SetLength(fStages[i].WC,fStages[i].StageCount);
n3:=n2.ChildNodes.FindNode('weakClassifiers');
for j := 0 to fStages[i].StageCount-1 do
begin
n4:=n3.ChildNodes.Get(j);
st:=Trim(n4.ChildNodes.FindNode('internalNodes').GetText);
st:=StringReplace(st,#10,'',[rfReplaceAll]);
st:=TRegEx.Replace(st,' {2,}',' ',opt);
val:=st.Split([' ']);
fStages[i].WC[j].LeftId:=StrToInt(val[0]);
fStages[i].WC[j].RightId:=StrToInt(val[1]);
fStages[i].WC[j].Idx:=StrToInt(val[2]);
fStages[i].WC[j].Threshold:=StrToFloat(val[3]);
if length(val)=8 then
begin
fStages[i].WC[j].LeftId2:=StrToInt(val[4]);
fStages[i].WC[j].RightId2:=StrToInt(val[5]);
fStages[i].WC[j].Idx2:=StrToInt(val[6]);
fStages[i].WC[j].Threshold2:=StrToFloat(val[7]);
end
else
begin
fStages[i].WC[j].LeftId2:=0;
fStages[i].WC[j].RightId2:=0;
fStages[i].WC[j].Idx2:=0;
fStages[i].WC[j].Threshold2:=0;
end;
st:=Trim(n4.ChildNodes.FindNode('leafValues').GetText);
st:=StringReplace(st,#10,'',[rfReplaceAll]);
st:=TRegEx.Replace(st,' {2,}',' ',opt);
val:=st.Split([' ']);
fStages[i].WC[j].Leaf[0]:=StrToFloat(val[0]);
fStages[i].WC[j].Leaf[1]:=StrToFloat(val[1]);
if Length(val)=3 then
fStages[i].WC[j].Leaf[2]:=StrToFloat(val[2])
else
fStages[i].WC[j].Leaf[2]:=0;
end;
end;
n1:=xml.ChildNodes.FindNode('opencv_storage')
.ChildNodes.FindNode('cascade')
.ChildNodes.FindNode('features');
SetLength(fFeatures,n1.ChildNodes.Count);
for i := 0 to n1.ChildNodes.Count-1 do
begin
n2:=n1.ChildNodes.Get(i).ChildNodes.FindNode('rects');
SetLength(fFeatures[i].Rects,n2.ChildNodes.Count);
for j := 0 to n2.ChildNodes.Count-1 do
begin
st:=Trim(n2.ChildNodes.Get(j).GetText);
val:=st.Split([' ']);
fFeatures[i].Rects[j].x:=StrToInt(val[0]);
fFeatures[i].Rects[j].y:=StrToInt(val[1]);
fFeatures[i].Rects[j].w:=StrToInt(val[2]);
fFeatures[i].Rects[j].h:=StrToInt(val[3]);
fFeatures[i].Rects[j].Weight:=StrToFloat(val[4]);
end;
end;
xml.Active:=False;
fHitRects:=THitRects.Create;
end;
destructor THaar.Destroy;
begin
fHitRects.Free;
inherited;
end;
function THaar.IsRectEquals(r1, r2: THaarRect): boolean;
var distance:Integer;
begin
Result:=false;
distance:=Trunc(r1.Width*0.2);
if (r2.Left<=(r1.Left+distance)) and
(r2.Left>=(r1.Left-distance)) and
(r2.Top <=(r1.Top +distance)) and
(r2.Top >=(r1.Top -distance)) and
(r2.Width<=trunc(r1.Width*1.2)) and
(trunc(r2.Width*1.2)>=r1.Width) then
begin
Result:=true;
end
else if (r1.Left>=r2.Left) and
((r1.Left+r1.Width )<=(r2.Left+r2.Width )) and
(r1.Top>=r2.Top) and
((r1.Top +r1.Height)<=(r2.Top +r2.Height)) then
begin
result:=true;
end;
end;
function THaar.MergeRect(Rects: THitRects): TArray<THaarRect>;
const MinNeighbors:Integer=1;//通常は３らしいが、検出力が下がってしまう
var i,j:Integer;
IsFound:boolean;
nb_classes:Integer;
ret:TArray<Integer>;
Neighbors:TArray<Integer>;
n:Integer;
MyRect:TArray<THaarRect>;
r:THaarRect;
begin
nb_classes:=0;
setLength(ret,Length(Rects.Rects));
for i := Low(Rects.Rects) to High(Rects.Rects) do
ret[i]:=0;
for i := Low(Rects.Rects) to High(Rects.Rects) do
begin
IsFound:=false;
for j := 0 to i-1 do
begin
if(IsRectEquals(Rects.Rects[j],Rects.Rects[i]))then
begin
IsFound:=true;
ret[i]:=ret[j];
end;
end;
if not IsFound then
begin
ret[i]:=nb_classes;
inc(nb_classes);
end;
end;
setLength(Neighbors,nb_classes);
setLength(MyRect,nb_classes);
for i := 0 to nb_classes-1 do
begin
Neighbors[i]:=0;
MyRect[i].Left:=0;
MyRect[i].Top:=0;
MyRect[i].Width:=0;
MyRect[i].Height:=0;
end;
for i := Low(Rects.Rects) to High(Rects.Rects) do
begin
inc(Neighbors[ret[i]]);
MyRect[ret[i]].Left :=MyRect[ret[i]].Left +Rects.Rects[i].Left;
MyRect[ret[i]].Top :=MyRect[ret[i]].Top +Rects.Rects[i].Top;
MyRect[ret[i]].Width :=MyRect[ret[i]].Width +Rects.Rects[i].Width;
MyRect[ret[i]].Height:=MyRect[ret[i]].Height +Rects.Rects[i].Height;
end;
for i := 0 to nb_classes-1 do
begin
n:=Neighbors[i];
if n>=MinNeighbors then
begin
r.Left :=(MyRect[i].Left *2+n)div(2*n);
r.Top :=(MyRect[i].Top *2+n)div(2*n);
r.Width :=(MyRect[i].Width *2+n)div(2*n);
r.Height:=(MyRect[i].Height*2+n)div(2*n);
SetLength(result,Length(result)+1);
result[High(result)]:=r;
end;
end;
end;
{ THaarStagesTask }
constructor THaarStagesTask.Create(var Stages:TArray<TStage>;
var Features:TArray<TFeature>; var x,y,w,h:Integer; var Scale:Double;
var Areas:Cardinal; var HitRects:THitRects;
var Integ1:TArray<TArray<Cardinal>>; var Integ2:TArray<TArray<Cardinal>>);
begin
//プライベート変数に保存する
fStages:=Stages;
fFeatures:=Features;
fx:=x;
fy:=y;
fw:=w;
fh:=h;
fScale:=Scale;
fAreas:=Areas;
fHitRects:=HitRects;
fInteg1:=Integ1;
fInteg2:=Integ2;
inherited Create(nil, nil,
procedure
begin
Self.TaskStart;
end,
nil, nil, [], nil
);
end;
procedure THaarStagesTask.TaskStart;
var IsStagePass:boolean;
TotalInteg1,TotalInteg2,moy,Norm:Cardinal;
VNorm:Double;
i,j,k:Integer;
StageSum,RectSum:Double;
Idx:Integer;
rx1,rx2,ry1,ry2:Cardinal;
RNum:Integer;
Ret:Boolean;
begin
IsStagePass:=True;
TotalInteg1:=fInteg1[fx+fw][fy+fh]+fInteg1[fx][fy]-fInteg1[fx][fy+fh]-fInteg1[fx+fw][fy];
TotalInteg2:=fInteg2[fx+fw][fy+fh]+fInteg2[fx][fy]-fInteg2[fx][fy+fh]-fInteg2[fx+fw][fy];
moy:=TotalInteg1 div fAreas;
Norm:=TotalInteg2 div fAreas - moy*moy;
if Norm>1 then VNorm:=sqrt(Norm) else VNorm:=1;
//ステージごとの処理
for i := Low(fStages) to High(fStages) do
begin
StageSum:=0;
for j := Low(fStages[i].WC) to High(fStages[i].WC) do
begin
//Lidx1 Lidx1 インデックス 閾値 Lidx3 Lidx4 インデックス 閾値
//Lidx1,Lidx2,Lidx3,Lidx4はそれぞれ0以下の場合は
//リーフノード（葉）であることを示し、1の場合は枝であることを示す
Idx:=fStages[i].WC[j].Idx;
RectSum:=0;
for k := Low(fFeatures[Idx].Rects) to High(fFeatures[Idx].Rects) do
begin
rx1:=fx+trunc(fScale*(fFeatures[Idx].Rects[k].x));
rx2:=fx+trunc(fScale*(fFeatures[Idx].Rects[k].x+fFeatures[Idx].Rects[k].w));
ry1:=fy+trunc(fScale*(fFeatures[Idx].Rects[k].y));
ry2:=fy+trunc(fScale*(fFeatures[Idx].Rects[k].y+fFeatures[Idx].Rects[k].h));
RectSum:=RectSum+
(fInteg1[rx2][ry2]-fInteg1[rx1][ry2]-fInteg1[rx2][ry1]+fInteg1[rx1][ry1])
*fFeatures[Idx].Rects[k].Weight;
end;
RectSum:=RectSum/fAreas;
if RectSum<(fStages[i].WC[j].Threshold*VNorm) then
begin
if fStages[i].WC[j].LeftId<=0 then
begin
StageSum:=StageSum+fStages[i].WC[j].Leaf[Trunc(Abs(fStages[i].WC[j].LeftId))];
end
else
begin
Idx:=fStages[i].WC[j].Idx2;
RectSum:=0;
for k := Low(fFeatures[Idx].Rects) to High(fFeatures[Idx].Rects) do
begin
rx1:=fx+trunc(fScale*(fFeatures[Idx].Rects[k].x));
rx2:=fx+trunc(fScale*(fFeatures[Idx].Rects[k].x+fFeatures[Idx].Rects[k].w));
ry1:=fy+trunc(fScale*(fFeatures[Idx].Rects[k].y));
ry2:=fy+trunc(fScale*(fFeatures[Idx].Rects[k].y+fFeatures[Idx].Rects[k].h));
RectSum:=RectSum+
(fInteg1[rx2][ry2]-fInteg1[rx1][ry2]-fInteg1[rx2][ry1]+fInteg1[rx1][ry1])
*fFeatures[Idx].Rects[k].Weight;
end;
RectSum:=RectSum/fAreas;
if RectSum<(fStages[i].WC[j].Threshold2*VNorm) then
StageSum:=StageSum+fStages[i].WC[j].Leaf[Trunc(Abs(fStages[i].WC[j].LeftId2))]
else
StageSum:=StageSum+fStages[i].WC[j].Leaf[Trunc(Abs(fStages[i].WC[j].RightId2))];
end;
end
else
begin
if fStages[i].WC[j].RightId<=0 then
StageSum:=StageSum+fStages[i].WC[j].Leaf[Trunc(Abs(fStages[i].WC[j].RightId))]
else
begin
Idx:=fStages[i].WC[j].Idx2;
RectSum:=0;
for k := Low(fFeatures[Idx].Rects) to High(fFeatures[Idx].Rects) do
begin
rx1:=fx+trunc(fScale*(fFeatures[Idx].Rects[k].x));
rx2:=fx+trunc(fScale*(fFeatures[Idx].Rects[k].x+fFeatures[Idx].Rects[k].w));
ry1:=fy+trunc(fScale*(fFeatures[Idx].Rects[k].y));
ry2:=fy+trunc(fScale*(fFeatures[Idx].Rects[k].y+fFeatures[Idx].Rects[k].h));
RectSum:=RectSum+
(fInteg1[rx2][ry2]-fInteg1[rx1][ry2]-fInteg1[rx2][ry1]+fInteg1[rx1][ry1])
*fFeatures[Idx].Rects[k].Weight;
end;
RectSum:=RectSum/fAreas;
if RectSum<(fStages[i].WC[j].Threshold2*VNorm) then
StageSum:=StageSum+fStages[i].WC[j].Leaf[Trunc(Abs(fStages[i].WC[j].LeftId2))]
else
StageSum:=StageSum+fStages[i].WC[j].Leaf[Trunc(Abs(fStages[i].WC[j].RightId2))];
end;
end;
end;
if StageSum<(fStages[i].Threshold) then
begin
//ステージを通過できなかったら以降のステージは処理しない
IsStagePass:=False;
Break;
end;
end;
if IsStagePass then
begin
//全てのステージを通過したらヒット
Ret:=System.MonitorEnter(fHitRects);
try
RNum:=length(fHitRects.Rects);
SetLength(fHitRects.Rects,RNum+1);
fHitRects.Rects[RNum].Left:=fx;
fHitRects.Rects[RNum].Top:=fy;
fHitRects.Rects[RNum].Width:=fw;
fHitRects.Rects[RNum].Height:=fh;
finally
System.MonitorExit(fHitRects);
end;
end;
end;
end.