I've trying all the way? I should so grateful If someone can find out the bugs.
{$N+}
const
maxn = 100;
zero = 1e-14;
type
tpoint = record
x, y: double;
end;
tsquare = record
p1, p2, p3, p4: tpoint;
end;
var
dis: array[1..maxn]of double;
sq: array[1..maxn]of tsquare;
num: array[1..maxn]of integer;
n, i, j, t0: integer;
p0: tpoint;
t: double;
function min(a, b, c, d: double): double;
var
res: double;
begin
res := a;
if b < res then res := b;
if c < res then res := c;
if d < res then res := d;
min := res;
end;
function distant(p1, p2: tpoint): double;
var
res: double;
begin
res := sqrt(sqr(p1.x - p2.x) + sqr(p1.y - p2.y));
distant := res;
end;
function d(pn, pm: tpoint): double;
var
res, p, a, b, c: double;
begin
a := distant(pn, p0);
b := distant(pm, p0);
c := distant(pn, pm);
if (a + b = c)or(a - b = c)or(b - a = c) then
begin
d := 0;
exit;
end;
if (a = 0)or(b = 0) then
begin
d := 0;
exit;
end;
if( (sqr(c) + sqr(b) - sqr(a))/(b * c) < 0 )
or( (sqr(c) + sqr(a) - sqr(b))/(a * c) < 0 ) then
res := min(a, b, maxlongint, maxlongint)
else
begin
p := (a + b + c) / 2;
res := 2 * sqrt(p * (p - a) * (p - b) * (p - c)) / c;
end;
d := res;
end;
begin
readln(n);
fillchar(sq, sizeof(sq), 0);
fillchar(dis, sizeof(dis), 0);
for i := 1 to n do
with sq[i] do
begin
readln(p1.x, p1.y, p3.x, p3.y);
p2.x := (p1.x + p3.x) / 2 - (p3.y - p1.y) / 2;
p2.y := p3.y - (p1.x - p2.x);
p4.x := (p1.x + p3.x) / 2 + (p3.y - p1.y) / 2;
p4.y := p1.y + (p4.x - p3.x);
end;
readln(p0.x, p0.y);
for i := 1 to n do
with sq[i] do
begin
dis[i] := min(d(p1, p2), d(p2, p3), d(p3, p4), d(p4, p1));
if abs(d(p2, p3) + d(p4, p1) - distant(p1, p2)) <= 1e-10 then
dis[i] := 0;
end;
for i := 1 to n do
num[i] := i;
for i := 1 to n - 1 do
for j := i + 1 to n do
if dis[i] > dis[j] then
begin
t := dis[i]; dis[i] := dis[j]; dis[j] := t;
t0 := num[i]; num[i] := num[j]; num[j] := t0;
end
else if abs(dis[i] - dis[j]) <= zero then
if num[i] > num[j] then
begin
t0 := num[i]; num[i] := num[j]; num[j] := t0;
end;
for i := 1 to n do write(num[i], ' ');
end.