Cod sursa(job #610971)

Utilizator ctlin04UAIC.VlasCatalin ctlin04 Data 30 august 2011 00:18:34
Problema Patrate 3 Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.84 kb
Program patrate3;
type point=record
           x,y:double;
           end;
const er=0.0001;
var a,b:array[1..1000] of point;
    b1:array [1..1 shl 15] of char;
    w:point;
    f,g:text;
    nr,i,j,n,e,r:longint;
    x,y:extended; 
procedure inter(st,dr,mij:longint);
var i,j,t,k:longint;
begin
for i:=st to dr do
 b[i]:=a[i];
i:=st; k:=st; j:=mij+1;
while (i<=mij) and (j<=dr) do begin
 if (b[i].x<b[j].x) or
  ((abs(b[i].x-b[j].x)<=er) and (b[i].y<b[j].y)) then begin
 a[k]:=b[i];
inc(i);
end
 else begin 
  a[k]:=b[j]; 
   inc(j);
    end;
inc(k);
end;
for t:=i to mij do
 a[k+t-i]:=b[t];
for t:=j to dr do
 a[k+t-j]:=b[t];
end;
procedure merge(st,dr:longint);
var mij:longint;
begin
if st<dr then begin 
 mij:=(st+dr) shr 1;
  merge(st,mij);
   merge(mij+1,dr);
    inter(st,dr,mij);
end;
end;
function cauta(st,dr:longint):longint;
var mij:longint;
begin
if st>dr then cauta:=0
else begin
  mij:=(st+dr) shr 1;
   if (abs(a[mij].x-w.x)<=er) and (abs(a[mij].y-w.y)<=er) then
    cauta:=mij
else if (abs(a[mij].x-w.x)<=er) then
  if a[mij].y<w.y then
    cauta:=cauta(mij+1,dr)
else
cauta:=cauta(st,mij-1)
else
if (a[mij].x<w.x) then
cauta:=cauta(mij+1,dr)
else
cauta:=cauta(st,mij-1);
end;
end;
begin
assign(f,'patrate3.in'); reset(f);
settextbuf(f,b1);
assign(g,'patrate3.out'); rewrite(g);
read(f,n);
for i:=1 to n do
 read(f,a[i].x,a[i].y);
merge(1,n);
for i:=2 to n do
 for j:=1 to i-1 do begin
  x:=a[i].x-a[j].x;
  y:=a[i].y-a[j].y;
  w.x:=a[j].x+y;
  w.y:=a[j].y-x;
  e:=cauta(1,n);
  w.x:=a[i].x+y;
  w.y:=a[i].y-x;
  r:=cauta(1,n);
   if (x>=0) and (y>=0) and (r<>0) and (e<>0) and (r<>i) and (r<>j) and (e<>i) and (e<>j) then
                                                                                             inc(nr);
               end;
 writeln(g,nr);
close(g);
end.