人物写真から目の領域、顔の領域座標を取得(Haar Cascade) ~Delphiソースコード集
DelphiでHaar Cascade識別器(分類器)を実装し、画像から顔領域や目の領域を認識検出します。
顔・目などを検出できるカスケード識別器の学習済みファイルの準備
学習済みファイルは以下のいずれかで用意してください。どちらの方法で用意してもかまいません。
-
本サイトからダウンロード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;//通常は3らしいが、検出力が下がってしまう 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.