paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 04:59:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ patch by Rika to implement missing TPointF methods, resolves #40057

Browse Source 
+ test by Rika
This commit is contained in:
florian 2022-12-29 15:19:59 +01:00
parent d7870c81e9
commit 69eebe4c0c
2 changed files with 245 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
rtl/objpas/types.pp
View File

@ -132,6 +132,15 @@ type
function Floor : TPoint;
function Round : TPoint;
function Length : Single;
function Rotate(angle: single): TPointF;
function Reflect(const normal: TPointF): TPointF;
function MidPoint(const b: TPointF): TPointF;
class function PointInCircle(const pt, center: TPointF; radius: single): Boolean; static;
class function PointInCircle(const pt, center: TPointF; radius: integer): Boolean; static;
function Angle(const b: TPointF): Single;
function AngleCosine(const b: TPointF): single;
class function Create(const ax, ay: Single): TPointF; overload; static; inline;
class function Create(const apt: TPoint): TPointF; overload; static; inline;
class operator = (const apt1, apt2 : TPointF) : Boolean;
@ -729,10 +738,50 @@ begin
end;
function TPointF.Length: Single;
begin //distance(self) ?
begin
result:=sqrt(sqr(x)+sqr(y));
end;
function TPointF.Rotate(angle: single): TPointF;
var
sina, cosa: single;
begin
sincos(angle, sina, cosa);
result.x := x * cosa - y * sina;
result.y := x * sina + y * cosa;
end;
function TPointF.Reflect(const normal: TPointF): TPointF;
begin
result := self + (-2 * normal ** self) * normal;
end;
function TPointF.MidPoint(const b: TPointF): TPointF;
begin
result.x := 0.5 * (x + b.x);
result.y := 0.5 * (y + b.y);
end;
class function TPointF.PointInCircle(const pt, center: TPointF; radius: single): Boolean;
begin
result := sqr(center.x - pt.x) + sqr(center.y - pt.y) < sqr(radius);
end;
class function TPointF.PointInCircle(const pt, center: TPointF; radius: integer): Boolean;
begin
result := sqr(center.x - pt.x) + sqr(center.y - pt.y) < sqr(single(radius));
end;
function TPointF.Angle(const b: TPointF): Single;
begin
result := ArcTan2(y - b.y, x - b.x);
end;
function TPointF.AngleCosine(const b: TPointF): single;
begin
result := EnsureRange((self ** b) / sqrt((sqr(x) + sqr(y)) * (sqr(b.x) + sqr(b.y))), -1, 1);
end;
class operator TPointF.= (const apt1, apt2 : TPointF) : Boolean;
begin
result:=SameValue(apt1.x,apt2.x) and SameValue(apt1.y,apt2.y);

195
tests/test/units/types/ttpointf1.pp Normal file
View File

@ -0,0 +1,195 @@
{$mode objfpc} {$longstrings on}
uses
Types, Math;
var
anythingFailed: boolean = false;
procedure Fail(const msg: string);
begin
writeln(msg);
anythingFailed := true;
end;
function ToString(const pt: TPointF): string;
begin
WriteStr(result, '(', pt.x, ', ', pt.y, ')');
end;
function SamePoint(const a, b: TPointF; eps: single = 0): boolean;
begin
result := SameValue(a.x, b.x, eps) and SameValue(a.y, b.y, eps);
end;
procedure TestTPointF_Angle_AngleCosine;
type
TestRec = record
a, b: TPointF;
anBaOx, cosAnAB: single;
end;
const
Tests: array[0 .. 1] of TestRec =
(
(a: (x: 1; y: -2); b: (x: 3; y: 4); anBaOx: -1.892546892; cosAnAB: -1 / sqrt(5)),
(a: (x: 1; y: 2); b: (x: 3; y: 4); anBaOx: -3 * pi / 4; cosAnAB: 11 / (5 * sqrt(5)))
);
var
t: TestRec;
gotAnBaOx, gotCosAnAB: single;
msg: string;
begin
for t in Tests do
begin
gotAnBaOx := t.a.Angle(t.b);
if not SameValue(gotAnBaOx, t.anBaOx) then
begin
WriteStr(msg, 'TPointF', ToString(t.a), '.Angle', ', ', ToString(t.b), ' = ', gotAnBaOx, ', expected ', t.anBaOx, '.');
Fail(msg);
end;
gotCosAnAB := t.a.AngleCosine(t.b);
if not SameValue(gotCosAnAB, t.cosAnAB) then
begin
WriteStr(msg, 'TPointF', ToString(t.a), '.AngleCosine', ToString(t.b), ' = ', gotCosAnAB, ', expected ', t.cosAnAB, '.');
Fail(msg);
end;
end;
end;
procedure TestTPointF_MidPoint;
type
TestRec = record
a, b, mid: TPointF;
end;
const
Tests: array[0 .. 0] of TestRec =
(
(a: (x: 1; y: 2); b: (x: 3; y: 4); mid: (x: 2; y: 3))
);
var
t: TestRec;
gotMid: TPointF;
msg: string;
begin
for t in Tests do
begin
gotMid := t.a.MidPoint(t.b);
if not SamePoint(gotMid, t.mid) then
begin
WriteStr(msg, 'TPointF', ToString(t.a), '.MidPoint', ToString(t.b), ' = ', ToString(gotMid), ', expected ', ToString(t.mid), '.');
Fail(msg);
end;
end;
end;
procedure TestTPointF_PointInCircle;
type
TestRec = record
center: TPointF;
radius: float;
point: TPointF;
PiC: boolean;
end;
const
Tests: array[0 .. 16] of TestRec =
(
(center: (x: 10; y: 20); radius: 0; point: (x: 10; y: 20); PiC: false),
(center: (x: 10; y: 20); radius: 2; point: (x: 12; y: 20); PiC: false),
(center: (x: 10; y: 20); radius: 2; point: (x: 8; y: 20); PiC: false),
(center: (x: 10; y: 20); radius: 2; point: (x: 10; y: 22); PiC: false),
(center: (x: 10; y: 20); radius: 2; point: (x: 10; y: 18); PiC: false),
(center: (x: 10; y: 20); radius: 2; point: (x: 10 + sqrt(2.01); y: 20 + sqrt(2.01)); PiC: false),
(center: (x: 10; y: 20); radius: 2; point: (x: 10 - sqrt(2.01); y: 20 + sqrt(2.01)); PiC: false),
(center: (x: 10; y: 20); radius: 2; point: (x: 10 - sqrt(2.01); y: 20 - sqrt(2.01)); PiC: false),
(center: (x: 10; y: 20); radius: 2; point: (x: 10 + sqrt(2.01); y: 20 - sqrt(2.01)); PiC: false),
(center: (x: 10; y: 20); radius: 2.02; point: (x: 12; y: 20); PiC: true),
(center: (x: 10; y: 20); radius: 2.02; point: (x: 8; y: 20); PiC: true),
(center: (x: 10; y: 20); radius: 2.02; point: (x: 10; y: 22); PiC: true),
(center: (x: 10; y: 20); radius: 2.02; point: (x: 10; y: 18); PiC: true),
(center: (x: 10; y: 20); radius: 2.02; point: (x: 10 + sqrt(2.01); y: 20 + sqrt(2.01)); PiC: true),
(center: (x: 10; y: 20); radius: 2.02; point: (x: 10 - sqrt(2.01); y: 20 + sqrt(2.01)); PiC: true),
(center: (x: 10; y: 20); radius: 2.02; point: (x: 10 - sqrt(2.01); y: 20 - sqrt(2.01)); PiC: true),
(center: (x: 10; y: 20); radius: 2.02; point: (x: 10 + sqrt(2.01); y: 20 - sqrt(2.01)); PiC: true)
);
var
t: TestRec;
gotPiC: boolean;
msg: string;
begin
for t in Tests do
begin
gotPiC := TPointF.PointInCircle(t.point, t.center, t.radius);
if gotPiC <> t.PiC then
begin
WriteStr(msg, 'TPointF.PointInCircle(', ToString(t.point), ', ', ToString(t.center), ', ', t.radius, ') = ', pChar('-+')[ord(gotPiC)], ', expected ', pChar('-+')[ord(t.PiC)], '.');
Fail(msg);
end;
end;
end;
procedure TestTPointF_Rotate;
type
TestRec = record
point: TPointF;
angle: float;
rotated: TPointF;
end;
const
Tests: array[0 .. 1] of TestRec =
(
(point: (x: 1; y: 2); angle: 2 * pi + 1; rotated: (x: -1.142639637; y: 1.92207551)),
(point: (x: 1; y: 2); angle: 2 * pi - 1; rotated: (x: 2.22324419; y: 0.2391340137))
);
var
t: TestRec;
got: TPointF;
msg: string;
begin
for t in Tests do
begin
got := t.point.Rotate(t.angle);
if not SamePoint(got, t.rotated) then
begin
WriteStr(msg, 'TPointF', ToString(t.point), '.Rotate(', t.angle, ') = ', ToString(got), ', expected ', ToString(t.rotated), '.');
Fail(msg);
end;
end;
end;
procedure TestTPointF_Reflect;
type
TestRec = record
point, normal, reflected: TPointF;
end;
const
Tests: array[0 .. 1] of TestRec =
(
(point: (x: 1; y: 2); normal: (x: sqrt(2) / 2; y: sqrt(2) / 2); reflected: (x: -2; y: -1)),
(point: (x: 1; y: 2); normal: (x: -sqrt(2) / 2; y: sqrt(2) / 2); reflected: (x: 2; y: 1))
);
var
t: TestRec;
got: TPointF;
msg: string;
begin
for t in Tests do
begin
got := t.point.Reflect(t.normal);
if not SamePoint(got, t.reflected) then
begin
WriteStr(msg, 'TPointF', ToString(t.point), '.Reflect', ToString(t.normal), ' = ', ToString(got), ', expected ', ToString(t.reflected), '.');
Fail(msg);
end;
end;
end;
begin
TestTPointF_Angle_AngleCosine;
TestTPointF_MidPoint;
TestTPointF_PointInCircle;
TestTPointF_Rotate;
TestTPointF_Reflect;
if not anythingFailed then writeln('ok');
if anythingFailed then halt(1);
end.