unit Demos.FaceDetection.Forms.Main;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtDlgs, System.ImageList,
  Vcl.ImgList, System.Actions, Vcl.ActnList, Vcl.ComCtrls, Vcl.ToolWin,
  Vcl.ExtCtrls, Vcl.BaseImageCollection, Vcl.ImageCollection, Vcl.Imaging.JPEG,
  Azure.CognitiveServices.Core.Entities,
  Azure.CognitiveServices.FaceDetection.Types, Vcl.ControlList,
  Vcl.VirtualImage, Vcl.StdCtrls;

type

  TMainForm = class(TForm)
    MainActionList: TActionList;
    LoadPhotoAction: TAction;
    DetectFacesAction: TAction;
    ClearFacesAction: TAction;
    AppExitAction: TAction;
    MainImageList: TImageList;
    PhotoOpenDialog: TOpenPictureDialog;
    MainToolbar: TToolBar;
    LoadPhotoButton: TToolButton;
    FindFaceButton: TToolButton;
    ClearDataButton: TToolButton;
    AppExitButton: TToolButton;
    PhotoScrollBox: TScrollBox;
    PhotoImage: TImage;
    MarkerBox: TPaintBox;
    MainSplitter: TSplitter;
    GenderImages: TImageCollection;
    ResultPanel: TPanel;
    SentimentImages: TImageCollection;
    FaceControlList: TControlList;
    FaceAgeLabel: TLabel;
    FaceGenderImage: TVirtualImage;
    FaceDetailButton: TControlListButton;
    FaceColorShape: TShape;
    procedure MainActionListUpdate(Action: TBasicAction; var Handled: Boolean);
    procedure LoadPhotoActionExecute(Sender: TObject);
    procedure DetectFacesActionExecute(Sender: TObject);
    procedure ClearFacesActionExecute(Sender: TObject);
    procedure AppExitActionExecute(Sender: TObject);
    procedure MarkerBoxPaint(Sender: TObject);
    procedure FaceControlListBeforeDrawItem(AIndex: Integer;
      ACanvas: TCanvas; ARect: TRect; AState: TOwnerDrawState);
    procedure FaceDetailButtonClick(Sender: TObject);
  private
    FFaceData: TAcsFaceDetectResponse;
    FPhotoData: TBytes;
    function HasFaceData: Boolean;
    function HasPhotoData: Boolean;
    procedure UpdateUI;
  public
    constructor Create(AOwner: TComponent); override;
  end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

uses
  System.IOUtils, System.Rtti,
  Azure.CognitiveServices.FaceDetection.HTTP;

{ Consts }

const
  FaceColors: array [0 .. StandardColorsCount - 1] of TColor = (
    clRed, clLime, clYellow, clBlue, clFuchsia, clAqua, clDkGray, clWhite,
    clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple, clTeal, clGray);

{ TMainForm }

constructor TMainForm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  UpdateUI;
end;

procedure TMainForm.AppExitActionExecute(Sender: TObject);
begin
  Close;
end;

procedure TMainForm.ClearFacesActionExecute(Sender: TObject);
begin
  SetLength(FFaceData.Faces, 0);
  UpdateUI;
end;

procedure TMainForm.DetectFacesActionExecute(Sender: TObject);
var
  LBroker: TAcsFaceDetectHttpBroker;
  LConfig: IAcsConfiguration;
  LRequest: TAcsFaceDetectRequest;
begin
  LConfig := LoadAcsConfiguration();

  with LRequest do
  begin
    ReturnFaceId := True;
    ReturnFaceLandmarks := True;
    ReturnFaceAttributes := [
      TAcsFaceAttributeType.Accessories,
      TAcsFaceAttributeType.Age,
      TAcsFaceAttributeType.Blur,
      TAcsFaceAttributeType.Emotion,
      TAcsFaceAttributeType.Exposure,
      TAcsFaceAttributeType.FacialHair,
      TAcsFaceAttributeType.Gender,
      TAcsFaceAttributeType.Glasses,
      TAcsFaceAttributeType.Hair,
      TAcsFaceAttributeType.HeadPose,
      TAcsFaceAttributeType.Makeup,
      TAcsFaceAttributeType.Noise,
      TAcsFaceAttributeType.Occlusion,
      TAcsFaceAttributeType.Smile
      // TAcsFaceAttributeType.Mask
    ];
    RecognitionModel := TAcsFaceRecognitionModel.Recognition01;
    ReturnRecognitionModel := True;
    DetectionModel := TAcsFaceDetectionModel.Detection01;
    FaceIdTimeToLive := 60;
    ImageData := FPhotoData;
  end;

  LBroker := TAcsFaceDetectHttpBroker.Create(LConfig);
  try
    LBroker.Endpoint := 'https://???-face.cognitiveservices.azure.com/face/v1.0/detect';
    FFaceData := LBroker.Execute(LRequest);
  finally
    LBroker.Free;
  end;

  if Length(FFaceData.Faces) > Length(FaceColors) then
    SetLength(FFaceData.Faces, Length(FaceColors));

  UpdateUI;
end;

procedure TMainForm.FaceDetailButtonClick(Sender: TObject);
begin
  var LFaceIndex := FaceControlList.ItemIndex;
  if LFaceIndex < 0 then
    Exit;
  var LFace := FFaceData.Faces[LFaceIndex];
  var LBuffer := TStringBuilder.Create;
  try

    // Numero viso
    LBuffer
      .AppendFormat('FACE NUMBER %d', [LFaceIndex + 1])
      .AppendLine()
      .AppendLine();

    // Attributi del viso
    var LFaceAttributes := LFace.FaceAttributes;
    if LFaceAttributes.Available then
    begin
      // Attributo: Smile
      if LFaceAttributes.Smile.Available then
        LBuffer
          .AppendLine(Format('Smile: %f', [LFaceAttributes.Smile.Smile]))
          .AppendLine();
      // Attributo: HeadPose
      if LFaceAttributes.HeadPose.Available then
        LBuffer
          .AppendLine('Head Pose')
          .AppendLine(Format('  Pitch: %f', [LFaceAttributes.HeadPose.Pitch]))
          .AppendLine(Format('  Roll: %f', [LFaceAttributes.HeadPose.Roll]))
          .AppendLine(Format('  Yaw: %f', [LFaceAttributes.HeadPose.Yaw]))
          .AppendLine();
      // Attributo: FacialHair
      if LFaceAttributes.FacialHair.Available then
        LBuffer
          .AppendLine('Facial Hair')
          .AppendLine(Format('  Moustache: %f', [LFaceAttributes.FacialHair.Moustache]))
          .AppendLine(Format('  Beard: %f', [LFaceAttributes.FacialHair.Beard]))
          .AppendLine(Format('  Sideburns: %f', [LFaceAttributes.FacialHair.Sideburns]))
          .AppendLine();
      // Attributo: Glasses
      if LFaceAttributes.Glasses.Available then
        LBuffer
          .AppendLine(Format('Glasses: %s', [TRttiEnumerationType.GetName(LFaceAttributes.Glasses.Glasses)]))
          .AppendLine();
      // Attributo: Emotion
      if LFaceAttributes.Emotion.Available then
        LBuffer
          .AppendLine('Emotion')
          .AppendLine(Format('  Anger: %f', [LFaceAttributes.Emotion.Anger]))
          .AppendLine(Format('  Contempt: %f', [LFaceAttributes.Emotion.Contempt]))
          .AppendLine(Format('  Disgust: %f', [LFaceAttributes.Emotion.Disgust]))
          .AppendLine(Format('  Fear: %f', [LFaceAttributes.Emotion.Fear]))
          .AppendLine(Format('  Happiness: %f', [LFaceAttributes.Emotion.Happiness]))
          .AppendLine(Format('  Neutral: %f', [LFaceAttributes.Emotion.Neutral]))
          .AppendLine(Format('  Sadness: %f', [LFaceAttributes.Emotion.Sadness]))
          .AppendLine(Format('  Surprise: %f', [LFaceAttributes.Emotion.Surprise]))
          .AppendLine();
    end
    else begin
      LBuffer.Append('--- No attributes ---');
    end;
    Application.MessageBox(PChar(LBuffer.ToString), PChar(Application.Title),
      MB_ICONINFORMATION or MB_OK);
  finally
    LBuffer.Free;
  end;
end;

function TMainForm.HasFaceData: Boolean;
begin
  Result := Length(FFaceData.Faces) > 0;
end;

function TMainForm.HasPhotoData: Boolean;
begin
  Result := Length(FPhotoData) > 0;
end;

procedure TMainForm.LoadPhotoActionExecute(Sender: TObject);
begin
  if not PhotoOpenDialog.Execute then
    Exit;

  FPhotoData := TFile.ReadAllBytes(PhotoOpenDialog.FileName);

  var LStream := TMemoryStream.Create;
  try
    LStream.Write(FPhotoData, Length(FPhotoData));
    LStream.Position := 0;
    PhotoImage.Picture.LoadFromStream(LStream);
  finally
    LStream.Free;
  end;

  PhotoImage.Left := 0;
  PhotoImage.Top := 0;
  PhotoImage.AutoSize := True;
  MarkerBox.Left := 0;
  MarkerBox.Top := 0;
  MarkerBox.Height := PhotoImage.Height;
  MarkerBox.Width := PhotoImage.Width;

  ClearFacesAction.Execute;
end;

procedure TMainForm.MainActionListUpdate(Action: TBasicAction;
  var Handled: Boolean);
begin
  LoadPhotoAction.Enabled := True;
  DetectFacesAction.Enabled := HasPhotoData;
  ClearFacesAction.Enabled := HasFaceData;
  Handled := True;
end;

procedure TMainForm.MarkerBoxPaint(Sender: TObject);
begin
  if not HasFaceData then
    Exit;

  var LCanvas := MarkerBox.Canvas;

  LCanvas.Lock;
  try
    LCanvas.Pen.Style := psSolid;
    LCanvas.Pen.Width := 2;
    LCanvas.Brush.Style := bsClear;
    for var LFaceIndex := Low(FFaceData.Faces) to High(FFaceData.Faces) do
    begin
      LCanvas.Pen.Color := FaceColors[LFaceIndex];
      LCanvas.Rectangle(FFaceData.Faces[LFaceIndex].FaceRectangle.AsRect);
    end;
  finally
    LCanvas.Unlock;
  end;
end;

procedure TMainForm.FaceControlListBeforeDrawItem(AIndex: Integer;
  ACanvas: TCanvas; ARect: TRect; AState: TOwnerDrawState);
begin
  if not HasFaceData then
    Exit;

  var LFace := FFaceData.Faces[AIndex];

  FaceColorShape.Brush.Color := FaceColors[AIndex];

  var LFaceAttributes := LFace.FaceAttributes;

  if LFaceAttributes.Available then
  begin
    // Visualizza gli attributi del genere.
    var LGenderAttributes := LFaceAttributes.Gender;
    if LGenderAttributes.Available then
    begin
      var LGenderName := TRttiEnumerationType.GetName(LGenderAttributes.Gender);
      FaceGenderImage.ImageName := LGenderName;
      FaceGenderImage.Hint := LGenderName;
      FaceGenderImage.Visible := True;
    end
    else begin
      FaceGenderImage.Visible := False;
    end;

    // Visualizza gli attributi legati all'età.
    var LAgeAttributes := LFaceAttributes.Age;
    if LAgeAttributes.Available then
    begin
      FaceAgeLabel.Caption := Format('Età: %f', [LAgeAttributes.Age]);
      FaceAgeLabel.Visible := True;
    end
    else begin
      FaceAgeLabel.Visible := False;
    end;
  end;
end;

procedure TMainForm.UpdateUI;
begin
  MarkerBox.Invalidate;
  FaceControlList.ItemCount := Length(FFaceData.Faces);
  ResultPanel.Visible := HasFaceData;
end;

end.
