Delphi-OpenCV/samples/MultiDemo/FaceDetect/FaceDetect.dpr

{$APPTYPE CONSOLE}
// JCL_DEBUG_EXPERT_GENERATEJDBG OFF
// JCL_DEBUG_EXPERT_INSERTJDBG OFF
// JCL_DEBUG_EXPERT_DELETEMAPFILE OFF
program FaceDetect;

{$R *.res}

uses
  System.Character,
  System.SysUtils,
uLibName in '..\..\..\include\uLibName.pas',
highgui_c in '..\..\..\include\highgui\highgui_c.pas',
core_c in '..\..\..\include\ñore\core_c.pas',
Core.types_c in '..\..\..\include\ñore\Core.types_c.pas',
imgproc.types_c in '..\..\..\include\imgproc\imgproc.types_c.pas',
imgproc_c in '..\..\..\include\imgproc\imgproc_c.pas',
legacy in '..\..\..\include\legacy\legacy.pas',
calib3d in '..\..\..\include\calib3d\calib3d.pas',
imgproc in '..\..\..\include\imgproc\imgproc.pas',
haar in '..\..\..\include\objdetect\haar.pas',
objdetect in '..\..\..\include\objdetect\objdetect.pas',
tracking in '..\..\..\include\video\tracking.pas',
Core in '..\..\..\include\ñore\core.pas'
  ;

Var
  // Create memory for calculations
  storage: pCvMemStorage = nil;
  // Create a new Haar classifier
  cascade: pCvHaarClassifierCascade = nil;
  // Create a string that contains the cascade name
  cascade_name: AnsiString = 'FaceDetectXML\haarcascade_frontalface_alt.xml'; // "haarcascade_profileface.xml";

  // Function prototype for detecting and drawing an object from an image
procedure detect_and_draw(image: pIplImage);
Var
  scale: Integer;
  temp: pIplImage;
  // two points to represent the face locations
  pt1, pt2: TCvPoint;
  i: Integer;
  faces: pCvSeq;
  r: pCvRect;
begin
  scale := 1;
  // Create a new image based on the input image
  temp := cvCreateImage(cvSize(image^.width div scale, image^.height div scale), 8, 3);
  // Clear the memory storage which was used before
  cvClearMemStorage(storage);

  // Find whether the cascade is loaded, to find the faces. If yes, then:
  if Assigned(cascade) then
  begin
    // There can be more than one face in an image. So create a growable sequence of faces.
    // Detect the objects and store them in the sequence
    faces := cvHaarDetectObjects(image, cascade, storage, 1.1, 2, CV_HAAR_DO_CANNY_PRUNING, cvSize(40, 40),
      cvSize(0, 0));

    // Loop the number of faces found.
    for i := 1 to faces^.total do
    begin
      // Create a new rectangle for drawing the face
      r := pCvRect(cvGetSeqElem(faces, i));
      // Find the dimensions of the face,and scale it if necessary
      pt1.x := r^.x * scale;
      pt2.x := (r^.x + r^.width) * scale;
      pt1.y := r^.y * scale;
      pt2.y := (r^.y + r^.height) * scale;

      // Draw the rectangle in the input image
      cvRectangle(image, pt1, pt2, CV_RGB(255, 0, 0), 3, 8, 0);
    end;
  end;

  // Show the image in the window named "result"
  cvShowImage('result', image);

  // Release the temp image created.
  cvReleaseImage(temp);
end;

Var
  // Structure for getting video from camera or avi
  capture: pCvCapture = nil;
  // Images to capture the frame from video or camera or from file
  frame: pIplImage = nil;
  frame_copy: pIplImage = nil;
  // Input file name for avi or image file.
  input_name: AnsiString;

const
  opt = '--cascade=';

begin
  try
    // Check for the correct usage of the command line
    if (ParamCount > 1) and (Pos(opt, ParamStr(1)) <> 0) then
    begin
      cascade_name := Copy(ParamStr(1), Length(opt) + 1, Length(ParamStr(1)));
      input_name := ParamStr(2);
    end
    else
    begin
      Writeln('Usage: facedetect --cascade=<cascade_path> [filename|camera_index]');
      Halt(1);
    end;

    // Load the HaarClassifierCascade
    cascade := cvLoad(pCVChar(@cascade_name[1]), 0, 0, 0);

    // Check whether the cascade has loaded successfully. Else report and error and quit
    if not Assigned(cascade) then
    begin
      Writeln('ERROR: Could not load classifier cascade');
      Halt(1);
    end;

    // Allocate the memory storage
    storage := cvCreateMemStorage(0);

    // Find whether to detect the object from file or from camera.
    if isDigit(input_name, 1) and (Length(input_name) = 1) then
      capture := cvCreateCameraCapture(StrToInt(input_name))
    else
      capture := cvCreateFileCapture(pCVChar(@input_name[1]));
    // Create a new named window with title: result
    cvNamedWindow('result', 1);

    // Find if the capture is loaded successfully or not.

    // If loaded succesfully, then:
    if Assigned(capture) then
    begin
      // Capture from the camera.
      While true do
      begin

        // Capture the frame and load it in IplImage
        frame := cvQueryFrame(capture);
        if not Assigned(frame) then
          Break;

        // Allocate framecopy as the same size of the frame
        if not Assigned(frame_copy) then
          frame_copy := cvCreateImage(cvSize(frame^.width, frame^.height), IPL_DEPTH_8U, frame^.nChannels);

        // Check the origin of image. If top left, copy the image frame to frame_copy.
        if (frame^.origin = IPL_ORIGIN_TL) then
          cvCopyImage(frame, frame_copy, 0)
          // Else flip and copy the image
        else
          cvFlip(frame, frame_copy, 0);

        // Call the function to detect and draw the face
        detect_and_draw(frame_copy);
        // Wait for a while before proceeding to the next frame
        if (cvWaitKey(1) >= 0) then
          Break;

      end;
      // Release the images, and capture memory
      cvReleaseImage(frame_copy);
      cvReleaseCapture(capture);
    end
    else
    // If the capture is not loaded succesfully, then:
    begin // Assume the image to be lena.jpg, or the input_name specified
      input_name := 'resource\lena.jpg';

      // Load the image from that filename
      frame := cvLoadImage(pCVChar(@input_name[1]), 1);

      // If Image is loaded succesfully, then:
      if Assigned(frame) then
      begin
        // Detect and draw the face
        detect_and_draw(frame);
        //
        // Wait for user input
        cvWaitKey(0);

        // Release the image memory
        cvReleaseImage(frame);
      end;
    end;
    // Destroy the window previously created with filename: "result"
    cvDestroyWindow('result');

  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;

end.