fourier/Unit1.pas

   1 unit Unit1;
   2
   3 interface
   4
   5 uses
   6   System.SysUtils, System.Types, System.UITypes, System.Classes,
   7   System.Variants,
   8   FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Ani, FMX.Layouts,
   9   FMX.Gestures, FMX.Graphics,
  10   FMX.TabControl, FMX.StdCtrls, System.Actions, FMX.ActnList, FMX.StdActns,
  11   FMX.MediaLibrary.Actions, FMX.Objects, FMX.Controls.Presentation, FMX.Edit,
  12   FMX.Media, Unit2, Math, FMX.ListBox;
  13
  14 type
  15   TForm1 = class(TForm)
  16     StyleBook1: TStyleBook;
  17     ToolbarHolder: TLayout;
  18     ToolbarPopup: TPopup;
  19     ToolbarPopupAnimation: TFloatAnimation;
  20     ToolBar1: TToolBar;
  21     ToolbarApplyButton: TButton;
  22     ToolbarCloseButton: TButton;
  23     ToolbarAddButton: TButton;
  24     TabControl1: TTabControl;
  25     TabItem1: TTabItem;
  26     TabItem2: TTabItem;
  27     TabItem3: TTabItem;
  28     Label1: TLabel;
  29     Label2: TLabel;
  30     Edit1: TEdit;
  31     Edit2: TEdit;
  32     Label3: TLabel;
  33     Edit3: TEdit;
  34     Image1: TImage;
  35     Label4: TLabel;
  36     Edit4: TEdit;
  37     Label5: TLabel;
  38     Button3: TButton;
  39     Label6: TLabel;
  40     Edit5: TEdit;
  41     RadioButton1: TRadioButton;
  42     RadioButton2: TRadioButton;
  43     CameraComponent1: TCameraComponent;
  44     Panel1: TPanel;
  45     SpinEditButton1: TSpinEditButton;
  46     SpinEditButton2: TSpinEditButton;
  47     SpinEditButton3: TSpinEditButton;
  48     GroupBox1: TGroupBox;
  49     Button1: TButton;
  50     Button2: TButton;
  51     Button4: TButton;
  52     Label7: TLabel;
  53     Image2: TImage;
  54     Image3: TImage;
  55     ListBox1: TListBox;
  56     Image4: TImage;
  57     Button5: TButton;
  58     TabItem4: TTabItem;
  59     Button6: TButton;
  60     Button7: TButton;
  61     ListBox2: TListBox;
  62     procedure ToolbarCloseButtonClick(Sender: TObject);
  63     procedure FormGesture(Sender: TObject; const EventInfo: TGestureEventInfo;
  64       var Handled: Boolean);
  65     procedure FormKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char;
  66       Shift: TShiftState);
  67     procedure Button1Click(Sender: TObject);
  68     procedure Button2Click(Sender: TObject);
  69     procedure Button4Click(Sender: TObject);
  70     procedure FormCreate(Sender: TObject);
  71     procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
  72       Shift: TShiftState; X, Y: Single);
  73     procedure FormDestroy(Sender: TObject);
  74     procedure CameraComponent1SampleBufferReady(Sender: TObject;
  75       const ATime: Int64);
  76     procedure Button3Click(Sender: TObject);
  77     procedure Button5Click(Sender: TObject);
  78   private
  79     FGestureOrigin: TPointF;
  80     FGestureInProgress: Boolean;
  81     bmp: TBitmap;
  82     buf, back: TBitmap;
  83     cap: Boolean;
  84     Fourier, recg: TFourier;
  85     thBinary: integer;
  86     { private \90é\8c¾ }
  87     procedure ShowToolbar(AShow: Boolean);
  88     procedure detectImage;
  89     procedure recognition;
  90     function SingleSortS(item1, item2: TFmxObject): integer;
  91     function SingleSortL(item1, item2: TFmxObject): integer;
  92   public
  93     { public \90é\8c¾ }
  94   end;
  95
  96 var
  97   Form1: TForm1;
  98
  99 implementation
 100
 101 {$R *.fmx}
 102
 103 procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char;
 104   Shift: TShiftState);
 105 begin
 106   if Key = vkEscape then
 107     ShowToolbar(not ToolbarPopup.IsOpen);
 108 end;
 109
 110 procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
 111   Shift: TShiftState; X, Y: Single);
 112 var
 113   r, rr: TRectF;
 114   i: integer;
 115   s: TFourier;
 116 begin
 117   if Sender = Image1 then
 118     s := Fourier
 119   else
 120     s := recg;
 121   with Sender as TImage do
 122   begin
 123     Bitmap.BitmapScale := Width / Bitmap.Width;
 124   end;
 125   TImage(Sender).Canvas.BeginScene;
 126   for i := 0 to s.numEntry - 1 do
 127   begin
 128     r := RectF(s.ar[i].Left, s.ar[i].Top, s.ar[i].Right, s.ar[i].Bottom);
 129     if (X > r.Left) and (X < r.Right) and (Y > r.Top) and (Y < r.Bottom) then
 130     begin
 131       if r.Width < r.Height then
 132       begin
 133         rr.Height := r.Height;
 134         rr.Width := r.Width * rr.Height / r.Height;
 135       end
 136       else
 137       begin
 138         rr.Width := r.Width;
 139         rr.Height := r.Height * rr.Width / r.Width;
 140       end;
 141       s.rIndex := i;
 142       if Sender = Image1 then
 143       begin
 144         Image2.Canvas.BeginScene;
 145         Image2.Canvas.FillRect(Image2.BoundsRect, 0, 0, [], 1.0);
 146         Image2.Canvas.DrawBitmap(Image1.Bitmap, r, rr, 1.0);
 147         Image2.Canvas.EndScene;
 148       end
 149       else
 150       begin
 151         Image3.Canvas.BeginScene;
 152         Image3.Canvas.FillRect(Image3.BoundsRect, 0, 0, [], 1);
 153         Image3.Canvas.DrawBitmap(Image4.Bitmap, r, rr, 1);
 154         Image3.Canvas.EndScene;
 155       end;
 156       break;
 157     end;
 158   end;
 159   TImage(Sender).Canvas.EndScene;
 160   if Sender = Image1 then
 161     Edit4.SetFocus
 162   else
 163     recognition;
 164 end;
 165
 166 procedure TForm1.recognition;
 167 var
 168   dist: Single;
 169   i: integer;
 170   a, b: array of Single;
 171   estima: array of Single;
 172   X, Y, wr, wi: array [0 .. TBoundary.MAX_POINT] of Single;
 173   n, cnt: integer;
 174   test: TModel;
 175   j: integer;
 176   fr, fi, cc, ss: Single;
 177   bnd: TBoundary;
 178 begin
 179   SetLength(a, 4 * recg.numDescriptor);
 180   SetLength(b, 4 * recg.numDescriptor);
 181   SetLength(estima, recg.numEntry);
 182   bnd := recg.boundary[recg.rIndex];
 183   test := recg.model[recg.rIndex];
 184   n := bnd.Count;
 185   for i := 0 to recg.numDescriptor - 1 do
 186   begin
 187     test.coReal1[i] := 0;
 188     test.coImag1[i] := 0;
 189     test.coReal2[i] := 0;
 190     test.coImag2[i] := 0;
 191     for j := 0 to bnd.Count - 1 do
 192     begin
 193       fr := bnd.X[j + 1] - bnd.X[j];
 194       fi := bnd.Y[j + 1] - bnd.Y[j];
 195       cc := cos(2 * pi * i * j / n);
 196       ss := sin(2 * pi * i * j / n);
 197       test.coReal1[i] := test.coReal1[i] + fr * cc + fi * ss;
 198       test.coImag1[i] := test.coImag1[i] - fr * ss + fi * cc;
 199       test.coReal2[i] := test.coReal2[i] + fr * cc - fi * ss;
 200       test.coImag2[i] := test.coImag2[i] + fr * ss + fi * cc;
 201     end;
 202     test.coReal1[i] := test.coReal1[i] / n;
 203     test.coImag1[i] := test.coImag1[i] / n;
 204     test.coReal2[i] := test.coReal2[i] / n;
 205     test.coImag2[i] := test.coImag2[i] / n;
 206   end;
 207   X[0] := bnd.X[0];
 208   Y[0] := bnd.Y[0];
 209   for i := 0 to bnd.Count - 1 do
 210   begin
 211     wr[i] := 0;
 212     wi[i] := 0;
 213     for j := 0 to recg.numDescriptor - 1 do
 214     begin
 215       cc := cos(2 * pi * i * j / n);
 216       ss := sin(2 * pi * i * j / n);
 217       wr[i] := wr[i] + test.coReal1[j] * cc - test.coImag1[j] * ss +
 218         test.coReal2[j] * cc + test.coImag2[j] * ss;
 219       wi[i] := wi[i] + test.coReal1[j] * ss + test.coImag1[j] * cc -
 220         test.coReal2[j] * ss + test.coImag2[j] * cc;
 221     end;
 222   end;
 223   Image3.Canvas.BeginScene;
 224   Image3.Canvas.FillRect(Image3.BoundsRect, 0, 0, [], 1);
 225   Image3.Canvas.DrawRect(Image3.BoundsRect, 0, 0, [], 1);
 226   for i := 1 to bnd.Count - 1 do
 227   begin
 228     X[i] := X[i - 1] + wr[i - 1];
 229     Y[i] := Y[i - 1] + wi[i - 1];
 230     Image3.Canvas.DrawLine(PointF(X[i - 1], Y[i - 1]), PointF(X[i], Y[i]), 1);
 231   end;
 232   Image3.Canvas.EndScene;
 233   cnt := 0;
 234   for i := 0 to recg.numDescriptor - 1 do
 235   begin
 236     a[cnt] := test.coReal1[i];
 237     a[recg.numDescriptor + cnt] := test.coImag1[i];
 238     a[2 * recg.numDescriptor + cnt] := test.coReal2[i];
 239     a[3 * recg.numDescriptor + cnt] := test.coImag2[i];
 240     inc(cnt);
 241   end;
 242   for n := 0 to Fourier.numEntry - 1 do
 243   begin
 244     cnt := 0;
 245     for i := 0 to Fourier.numDescriptor - 1 do
 246     begin
 247       b[cnt] := Fourier.model[n].coImag1[i];
 248       b[recg.numDescriptor + cnt] := Fourier.model[n].coImag1[i];
 249       b[2 * recg.numDescriptor + cnt] := Fourier.model[n].coReal2[i];
 250       b[3 * recg.numDescriptor + cnt] := Fourier.model[n].coImag2[i];
 251       inc(cnt);
 252     end;
 253     if RadioButton1.IsChecked = true then
 254     begin
 255       dist := 0;
 256       for i := 0 to 4 * recg.numDescriptor - 1 do
 257         dist := dist + (a[i] - b[i]) * (a[i] - b[i]);
 258       estima[n] := Sqrt(dist);
 259     end
 260     else
 261       estima[n] := recg.Correlation(a, b, 4 * recg.numDescriptor);
 262   end;
 263   ListBox1.Items.Clear;
 264   i := 0;
 265   for i := 0 to recg.numEntry - 1 do
 266   begin
 267     j := ListBox1.Items.Add('(' + Fourier.model[i].name + ')' +
 268       estima[i].ToString);
 269     ListBox1.ListItems[j].TagFloat := estima[i];
 270   end;
 271   if RadioButton1.IsChecked = true then
 272     ListBox1.Sort(SingleSortS)
 273   else
 274     ListBox1.Sort(SingleSortL);
 275   for i := ListBox1.Items.Count - 1 downto 5 do
 276     ListBox1.Items.Delete(i);
 277   Finalize(a);
 278   Finalize(b);
 279   Finalize(estima);
 280 end;
 281
 282 procedure TForm1.ToolbarCloseButtonClick(Sender: TObject);
 283 begin
 284   Application.Terminate;
 285 end;
 286
 287 procedure TForm1.Button1Click(Sender: TObject);
 288 begin
 289   CameraComponent1.Active := true;
 290   cap := true;
 291 end;
 292
 293 procedure TForm1.Button2Click(Sender: TObject);
 294 begin
 295   CameraComponent1.Active := false;
 296   detectImage;
 297   TabControl1.TabIndex := 0;
 298 end;
 299
 300 procedure TForm1.Button3Click(Sender: TObject);
 301 begin
 302   Fourier.model[Fourier.rIndex].name := Edit4.Text;
 303   Edit4.Text := '';
 304 end;
 305
 306 procedure TForm1.Button4Click(Sender: TObject);
 307 var
 308   i, n, m: integer;
 309   j: integer;
 310   k: integer;
 311   fr, fi, ss, cc: Single;
 312 begin
 313   Fourier.numDescriptor := Edit5.Text.ToInteger;
 314   if Fourier.numDescriptor > 50 then
 315   begin
 316     Fourier.numDescriptor := 50;
 317     Edit5.Text := '50';
 318   end;
 319   for i := 0 to Fourier.numEntry - 1 do
 320   begin
 321     n := Fourier.boundary[i].Count;
 322     for j := 0 to Fourier.numDescriptor - 1 do
 323     begin
 324       with Fourier.model[i] do
 325       begin
 326         coReal1[j] := 0;
 327         coReal2[j] := 0;
 328         coImag1[j] := 0;
 329         coImag2[j] := 0;
 330       end;
 331       with Fourier.boundary[i] do
 332       begin
 333         m := Count div n;
 334         X[n * m] := X[0];
 335         Y[n * m] := Y[0];
 336       end;
 337       for k := 0 to n - 1 do
 338       begin
 339         fr := Fourier.boundary[i].X[(k + 1) * m] - Fourier.boundary[i].X[k * m];
 340         fi := Fourier.boundary[i].Y[(k + 1) * m] - Fourier.boundary[i].Y[k * m];
 341         cc := cos(2 * pi * j * k / n);
 342         ss := sin(2 * pi * j * k / n);
 343         with Fourier.model[i] do
 344         begin
 345           coReal1[j] := coReal1[j] + fr * cc + fi * ss;
 346           coReal2[j] := coReal2[j] - fr * ss + fi * cc;
 347           coImag1[j] := coImag1[j] + fr * cc - fi * ss;
 348           coImag2[j] := coImag2[j] + fr * ss + fi * cc;
 349         end;
 350       end;
 351       with Fourier.model[i] do
 352       begin
 353         coReal1[j] := coReal1[j] / n;
 354         coReal2[j] := coReal2[j] / n;
 355         coImag1[j] := coImag1[j] / n;
 356         coImag2[j] := coImag2[j] / n;
 357       end;
 358     end;
 359   end;
 360   thBinary := Edit3.Text.ToInteger;
 361   recg.minWidth := Edit1.Text.ToInteger;
 362   recg.minHeight := Edit2.Text.ToInteger;
 363   Image4.Bitmap.Assign(back);
 364   recg.BinaryGray(Image4.Bitmap, thBinary, true);
 365   recg.DetectArea(Image4.Bitmap);
 366   recg.numDescriptor := Fourier.numDescriptor;
 367   TabControl1.TabIndex := 2;
 368 end;
 369
 370 procedure TForm1.Button5Click(Sender: TObject);
 371 var
 372   i: integer;
 373 begin
 374   ListBox2.Items.Clear;
 375   for i := 0 to Fourier.numEntry - 1 do
 376     ListBox2.Items.Add(Fourier.model[i].name + ' / ' + i.ToString);
 377 end;
 378
 379 procedure TForm1.CameraComponent1SampleBufferReady(Sender: TObject;
 380   const ATime: Int64);
 381 begin
 382   CameraComponent1.SampleBufferToBitmap(Image1.Bitmap, true);
 383 end;
 384
 385 procedure TForm1.detectImage;
 386 begin
 387   if cap = true then
 388   begin
 389     bmp.Assign(Image1.Bitmap);
 390     buf.Assign(bmp);
 391   end
 392   else
 393     bmp.Assign(buf);
 394   cap := false;
 395   buf.Assign(bmp);
 396   thBinary := Edit3.Text.ToInteger;
 397   Fourier.minWidth := Edit1.Text.ToInteger;
 398   Fourier.minHeight := Edit2.Text.ToInteger;
 399   Fourier.BinaryGray(bmp, thBinary, true);
 400   Fourier.DetectArea(bmp);
 401   Image1.Bitmap.Assign(bmp);
 402 end;
 403
 404 function TForm1.SingleSortL(item1, item2: TFmxObject): integer;
 405 var
 406   s: Single;
 407 begin
 408   s := TListBoxItem(item1).TagFloat - TListBoxItem(item2).TagFloat;
 409   if s < 0 then
 410     result := 1
 411   else if s > 0 then
 412     result := -1
 413   else
 414     result := 0;
 415 end;
 416
 417 function TForm1.SingleSortS(item1, item2: TFmxObject): integer;
 418 var
 419   s: Single;
 420 begin
 421   s := TListBoxItem(item1).TagFloat - TListBoxItem(item2).TagFloat;
 422   if s > 0 then
 423     result := 1
 424   else if s < 0 then
 425     result := -1
 426   else
 427     result := 0;
 428 end;
 429
 430 procedure TForm1.FormCreate(Sender: TObject);
 431 begin
 432   bmp := TBitmap.Create;
 433   buf := TBitmap.Create;
 434   back := TBitmap.Create;
 435   cap := not Image1.Bitmap.IsEmpty;
 436   Fourier := TFourier.Create;
 437   Fourier.color := TAlphaColors.Blue;
 438   recg := TFourier.Create;
 439   recg.color := TAlphaColors.Red;
 440   back.Assign(Image4.Bitmap);
 441 end;
 442
 443 procedure TForm1.FormDestroy(Sender: TObject);
 444 begin
 445   bmp.Free;
 446   buf.Free;
 447   back.Free;
 448   Fourier.Free;
 449   recg.Free;
 450 end;
 451
 452 procedure TForm1.FormGesture(Sender: TObject;
 453   const EventInfo: TGestureEventInfo; var Handled: Boolean);
 454 var
 455   DX, DY: Single;
 456 begin
 457   if EventInfo.GestureID = igiPan then
 458   begin
 459     if (TInteractiveGestureFlag.gfBegin in EventInfo.Flags) and
 460       ((Sender = ToolbarPopup) or (EventInfo.Location.Y > (ClientHeight - 70)))
 461     then
 462     begin
 463       FGestureOrigin := EventInfo.Location;
 464       FGestureInProgress := true;
 465     end;
 466
 467     if FGestureInProgress and (TInteractiveGestureFlag.gfEnd in EventInfo.Flags)
 468     then
 469     begin
 470       FGestureInProgress := false;
 471       DX := EventInfo.Location.X - FGestureOrigin.X;
 472       DY := EventInfo.Location.Y - FGestureOrigin.Y;
 473       if (Abs(DY) > Abs(DX)) then
 474         ShowToolbar(DY < 0);
 475     end;
 476   end
 477 end;
 478
 479 procedure TForm1.ShowToolbar(AShow: Boolean);
 480 begin
 481   ToolbarPopup.Width := ClientWidth;
 482   ToolbarPopup.PlacementRectangle.Rect :=
 483     TRectF.Create(0, ClientHeight - ToolbarPopup.Height, ClientWidth - 1,
 484     ClientHeight - 1);
 485   ToolbarPopupAnimation.StartValue := ToolbarPopup.Height;
 486   ToolbarPopupAnimation.StopValue := 0;
 487
 488   ToolbarPopup.IsOpen := AShow;
 489 end;
 490
 491 end.