interface
uses
- FMX.Graphics, FMX.Types, System.UITypes, System.Types;
+ FMX.Graphics, FMX.Types, System.UITypes, System.Types, Math;
type
TBinary = array of array of integer;
R, G, B, A: Byte;
end;
- TPreProcess = class
+ TModel = class
+ const
+ MAX_REPRESENTATIVE = 50;
+ private
+ FReal1: array [0 .. MAX_REPRESENTATIVE - 1] of Single;
+ FReal2: array [0 .. MAX_REPRESENTATIVE - 1] of Single;
+ FImag1: array [0 .. MAX_REPRESENTATIVE - 1] of Single;
+ FImag2: array [0 .. MAX_REPRESENTATIVE - 1] of Single;
+ FName: string;
+ function GetcoParam(X: integer; const Index: integer): Single;
+ procedure SetcoParam(X: integer; const Index: integer; const Value: Single);
+ public
+ numDescriptor: integer;
+ property coReal1[X: integer]: Single index 0 read GetcoParam
+ write SetcoParam;
+ property coReal2[X: integer]: Single index 1 read GetcoParam
+ write SetcoParam;
+ property coImag1[X: integer]: Single index 2 read GetcoParam
+ write SetcoParam;
+ property coImag2[X: integer]: Single index 3 read GetcoParam
+ write SetcoParam;
+ property name: string read FName write FName;
+ end;
+
+ TBoundary = class
+ const
+ MAX_POINT = 1000;
+ public
+ X, Y: array [0 .. MAX_POINT - 1] of Single;
+ Count: integer;
+ end;
+
+ TFourier = class
const
MAX_RECT = 50;
+ MAX_ENTRY = 100;
private
+ FModels: array [0 .. MAX_ENTRY] of TModel;
+ FBoundary: array [0 .. MAX_ENTRY] of TBoundary;
+ FnumEntry: integer;
+ farr: TBinary;
+ numRect: integer;
+ function Getmodel(X: integer): TModel;
+ function Getboundary(X: integer): TBoundary;
+ function GetnumDescriptor: integer;
+ procedure SetnumDescriptor(const Value: integer);
+ procedure Clear;
function labelborder8(nx, ny, X, Y, code, cnt: integer;
- f, id: TBinary): Boolean;
+ id: TBinary): Boolean;
+ procedure SetnumEntry(const Value: integer);
public
+ color: TAlphaColor;
ar: array [0 .. MAX_RECT - 1] of TRect;
minWidth, minHeight: integer;
- procedure BinaryGray(bmp: TBitmap; th: integer; f: TBinary;
- flagBinaryDisp: Boolean);
- function DetectArea(bmp: TBitmap; f: TBinary): integer;
- procedure sortingPos(numrect: integer);
+ rIndex: integer;
+ constructor Create;
+ destructor Destroy; override;
+ property model[X: integer]: TModel read Getmodel;
+ property boundary[X: integer]: TBoundary read Getboundary;
+ property numEntry: integer read FnumEntry write SetnumEntry;
+ property numDescriptor: integer read GetnumDescriptor
+ write SetnumDescriptor;
+ procedure BinaryGray(bmp: TBitmap; th: integer; flagBinaryDisp: Boolean);
+ procedure DetectArea(bmp: TBitmap);
+ procedure sortingPos;
+ function Correlation(A, B: array of Single; cnt: integer): Single;
+ procedure sortingSmall(A: array of Single; id: array of integer;
+ n: integer);
+ procedure sortingBig(A: array of Single; id: array of integer; n: integer);
end;
implementation
-procedure TPreProcess.BinaryGray(bmp: TBitmap; th: integer; f: TBinary;
+procedure TFourier.BinaryGray(bmp: TBitmap; th: integer;
flagBinaryDisp: Boolean);
var
i, k, nx, ny: integer;
begin
nx := bmp.Width;
ny := bmp.Height;
+ Initialize(farr);
+ SetLength(farr, nx, ny);
bmp.Map(TMapAccess.ReadWrite, AData);
try
Pointer(acc) := AData.Data;
color^.G := 255;
color^.B := 255;
end;
- f[i mod nx, i div nx] := k;
+ farr[i mod nx, i div nx] := k;
end;
finally
bmp.Unmap(AData);
end;
end;
-function TPreProcess.DetectArea(bmp: TBitmap; f: TBinary): integer;
+function TFourier.Correlation(A, B: array of Single; cnt: integer): Single;
+var
+ i: integer;
+begin
+ result := 0;
+ for i := 0 to cnt - 1 do
+ result := result + A[i] * B[i];
+ result := result / (Norm(A) * Norm(B) + 0.01);
+end;
+
+constructor TFourier.Create;
+begin
+ inherited;
+ SetnumEntry(1);
+end;
+
+procedure TFourier.DetectArea(bmp: TBitmap);
var
i: integer;
j: integer;
id[i, j] := 0;
i := 10;
j := 10;
- result := 0;
+ numRect := 0;
while j < ny - 10 do
begin
- if (f[i, j] = 1) and (id[i, j] = 0) then
+ if (farr[i, j] = 1) and (id[i, j] = 0) then
begin
cnt := 0;
for m := i - 1 to i + 1 do
for n := j - 1 to j + 1 do
- if f[i, j] = 1 then
+ if farr[i, j] = 1 then
inc(cnt);
if cnt <= 2 then
begin
- f[i, j] := 0;
+ farr[i, j] := 0;
increment;
continue;
end;
- if f[i - 1, j] = 0 then
+ if farr[i - 1, j] = 0 then
begin
- if result >= MAX_RECT - 1 then
+ if numRect >= MAX_RECT - 1 then
break;
- ar[result].TopLeft := Point(i - 1, j - 1);
- ar[result].Width := 3;
- ar[result].Height := 3;
+ ar[numRect].TopLeft := Point(i - 1, j - 1);
+ ar[numRect].Width := 3;
+ ar[numRect].Height := 3;
code := 7;
- if labelborder8(nx, ny, i, j, code, result, f, id) = true then
- inc(result);
+ if labelborder8(nx, ny, i, j, code, numRect, id) = true then
+ inc(numRect)
+ else
+ SetnumEntry(numEntry - 1);
end
- else if f[i + 1, j] = 0 then
+ else if farr[i + 1, j] = 0 then
begin
code := 3;
- labelborder8(nx, ny, i, j, code, result, f, id);
+ labelborder8(nx, ny, i, j, code, numRect, id);
end;
end;
increment;
end;
with bmp.Canvas do
begin
- Stroke.color := TAlphaColors.Blue;
+ Stroke.color := color;
StrokeThickness := 3;
BeginScene;
- for i := 0 to MAX_RECT - 1 do
- bmp.Canvas.DrawRect(RectF(ar[i].Left, ar[i].Top, ar[i].Right,
- ar[i].Bottom), 0, 0, [], 1.0);
+ for i := 0 to numRect - 1 do
+ bmp.Canvas.DrawRect(RectF(ar[i].Left - 3, ar[i].Top - 3, ar[i].Right + 3,
+ ar[i].Bottom + 3), 0, 0, [], 1.0);
EndScene;
end;
Finalize(id);
end;
-function TPreProcess.labelborder8(nx, ny, X, Y, code, cnt: integer;
- f, id: TBinary): Boolean;
+function TFourier.labelborder8(nx, ny, X, Y, code, cnt: integer;
+ id: TBinary): Boolean;
const
edge = 10;
var
- i1, i2, j1, j2: integer;
+ i1, i2, j1, j2, ii: integer;
begin
i1 := X;
j1 := Y;
i2 := 0;
j2 := 0;
+ ii := 0;
+ SetnumEntry(cnt + 1);
+ boundary[cnt].Count := 0;
while (i2 <> X) or (j2 <> Y) do
begin
case code of
begin
i2 := i1;
j2 := j1 + 1;
- if f[i2, j2] = 1 then
+ if farr[i2, j2] = 1 then
code := 7
else
code := 1;
begin
i2 := i1 + 1;
j2 := j1 + 1;
- if f[i2, j2] = 1 then
+ if farr[i2, j2] = 1 then
code := 0
else
code := 2;
begin
i2 := i1 + 1;
j2 := j1;
- if f[i2, j2] = 1 then
+ if farr[i2, j2] = 1 then
code := 1
else
code := 3;
begin
i2 := i1 + 1;
j2 := j1 - 1;
- if f[i2, j2] = 1 then
+ if farr[i2, j2] = 1 then
code := 2
else
code := 4;
begin
i2 := i1;
j2 := j1 - 1;
- if f[i2, j2] = 1 then
+ if farr[i2, j2] = 1 then
code := 3
else
code := 5;
begin
i2 := i1 - 1;
j2 := j1 - 1;
- if f[i2, j2] = 1 then
+ if farr[i2, j2] = 1 then
code := 4
else
code := 6;
begin
i2 := i1 - 1;
j2 := j1;
- if f[i2, j2] = 1 then
+ if farr[i2, j2] = 1 then
code := 5
else
code := 7;
begin
i2 := i1 - 1;
j2 := j1 + 1;
- if f[i2, j2] = 1 then
+ if farr[i2, j2] = 1 then
code := 6
else
code := 0;
result := false;
Exit;
end;
- if f[i2, j2] = 1 then
+ if farr[i2, j2] = 1 then
begin
id[i2, j2] := 1;
if i2 < ar[cnt].Left - 1 then
ar[cnt].Bottom := j2 + 1;
i1 := i2;
j1 := j2;
+ if ii < TBoundary.MAX_POINT then
+ begin
+ boundary[cnt].X[ii] := i1 - ar[cnt].Left + 5;
+ boundary[cnt].Y[ii] := j1 - ar[cnt].Top + 5;
+ inc(boundary[cnt].Count);
+ end
+ else
+ begin
+ result := false;
+ Exit;
+ end;
+ inc(ii);
end
else
begin
result := not((ar[cnt].Width < minWidth) or (ar[cnt].Height < minHeight));
end;
-procedure TPreProcess.sortingPos(numrect: integer);
+procedure TFourier.sortingBig(A: array of Single; id: array of integer;
+ n: integer);
+var
+ k, kk, i: integer;
+ min: Single;
+begin
+ for k := 0 to n - 1 do
+ begin
+ min := A[k];
+ i := id[k];
+ for kk := k + 1 to n - 1 do
+ if min > A[k] then
+ begin
+ A[k] := A[kk];
+ A[kk] := min;
+ id[k] := id[kk];
+ id[kk] := i;
+ end;
+ end;
+end;
+
+procedure TFourier.sortingPos;
const
- eps = 10;
+ eps = 30;
var
i: integer;
j: integer;
center: TPoint;
ar0: TRect;
begin
- for i := 0 to numrect do
+ for i := 0 to numRect do
begin
ar0 := ar[i];
center := ar[i].CenterPoint;
- for j := i to numrect do
- if (center.Y > ar[j].CenterPoint.Y - eps) or
+ for j := i to numRect do
+ if (center.Y > ar[j].CenterPoint.Y + eps) or
((Abs(center.Y - ar[j].CenterPoint.Y) < eps) and
(center.X > ar[j].CenterPoint.X)) then
begin
end;
end;
+procedure TFourier.sortingSmall(A: array of Single; id: array of integer;
+ n: integer);
+var
+ k, kk, i: integer;
+ max: Single;
+begin
+ for k := 0 to n - 1 do
+ begin
+ max := A[k];
+ i := id[k];
+ for kk := k to n - 1 do
+ if max < A[k] then
+ begin
+ A[k] := A[kk];
+ A[kk] := max;
+ id[k] := id[kk];
+ id[kk] := i;
+ end;
+ end;
+end;
+
+procedure TFourier.Clear;
+var
+ i: integer;
+begin
+ for i := 0 to FnumEntry - 1 do
+ begin
+ FModels[i].Free;
+ FBoundary[i].Free;
+ end;
+ Finalize(farr);
+end;
+
+destructor TFourier.Destroy;
+begin
+ Clear;
+ inherited;
+end;
+
+function TFourier.Getboundary(X: integer): TBoundary;
+begin
+ result := FBoundary[X];
+end;
+
+function TFourier.Getmodel(X: integer): TModel;
+begin
+ result := FModels[X];
+end;
+
+function TFourier.GetnumDescriptor: integer;
+begin
+ result := FModels[0].numDescriptor;
+end;
+
+procedure TFourier.SetnumDescriptor(const Value: integer);
+var
+ i: integer;
+begin
+ for i := 0 to FnumEntry - 1 do
+ FModels[i].numDescriptor := Value;
+end;
+
+procedure TFourier.SetnumEntry(const Value: integer);
+var
+ i: integer;
+begin
+ if Value > FnumEntry then
+ for i := FnumEntry to Value - 1 do
+ begin
+ FModels[i] := TModel.Create;
+ FBoundary[i] := TBoundary.Create;
+ end
+ else if Value < FnumEntry then
+ for i := Value to FnumEntry - 1 do
+ begin
+ FModels[i].Free;
+ FBoundary[i].Free;
+ end;
+ FnumEntry := Value;
+end;
+
+{ TModel }
+
+function TModel.GetcoParam(X: integer; const Index: integer): Single;
+begin
+ result := 0;
+ case Index of
+ 0:
+ result := FReal1[X];
+ 1:
+ result := FReal2[X];
+ 2:
+ result := FImag1[X];
+ 3:
+ result := FImag2[X];
+ end;
+end;
+
+procedure TModel.SetcoParam(X: integer; const Index: integer;
+ const Value: Single);
+begin
+ case Index of
+ 0:
+ FReal1[X] := Value;
+ 1:
+ FReal2[X] := Value;
+ 2:
+ FImag1[X] := Value;
+ 3:
+ FImag2[X] := Value;
+ end;
+end;
+
end.
OSDN Git Service
