トップへ(mam-mam.net/)

人物写真から目の領域、顔の領域座標を取得(Haar Cascade) ~Delphiソースコード集

検索:

人物写真から目の領域、顔の領域座標を取得(Haar Cascade) ~Delphiソースコード集

DelphiでHaar Cascade識別器(分類器)を実装し、画像から顔領域や目の領域を認識検出します。

顔・目などを検出できるカスケード識別器の学習済みファイルの準備

学習済みファイルは以下のいずれかで用意してください。どちらの方法で用意してもかまいません。

「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個、をフォームへドラッグ&ドロップします。

DelphiでHaar Cascade識別器(分類器)を実装し、画像から顔領域や目の領域を認識検出する

「ファイル」⇒「全て保存」でプロジェクトフォルダを作成して、プロジェクトとユニットを保存します。

プロジェクトフォルダ内にUMamHaar.pasファイルを配置します。
プロジェクトフォルダ内に「haarcascades」フォルダを配置します。
プロジェクトフォルダ内に、顔領域や目の領域を検出したい「.jpg」ファイルを配置します。
(pixabay(https://pixabay.com/ja/)からフリー素材をダウンロードして使用させていただきました。)
face.jpg
eye.jpg
画像の大きさはなるべく小さいサイズに縮小したもの(縦横320ピクセル以下を推奨)を使用しないと処理が重くなります。

ソースコードを記述する

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をクリックすると、顔の領域を検出して四角形を描きます。

DelphiでHaar Cascade識別機(分類器)を実装し、画像から顔領域を認識検出

Button2をクリックすると、目の領域を検出して四角形を描きます。

DelphiでHaar Cascade識別機(分類器)を実装し、画像から目の領域を認識検出

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.