Cod sursa(job #9009)

Utilizator AymdTrimbitas Viorel Stefan Aymd Data 26 ianuarie 2007 12:09:44
Problema Patrate 3 Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.15 kb
var x,y:array[1..1000]of real;
    n:integer;
    r:longint;

procedure cit;
var f:text;
    i:integer;
begin
assign(f,'patrate3.in');
reset(f);
readln(f,n);
for i:=1 to n do readln(f,x[i],y[i]);
end;

procedure rez;
var i,j,k,m:integer;
    l,a,b,c,d,e,f,g,h:real;
begin
for i:=1 to n-3 do begin
   a:=x[i];
   b:=y[i];
   for j:=i+1 to n do begin
      c:=x[j];
      d:=y[j];
      l:=sqrt((a-c)*(a-c)+(b-d)*(b-d));
      for k:=i+1 to n do begin
         if (k<>i)and(k<>j) then begin
         e:=x[k];
         f:=y[k];
         if (l=sqrt((c-e)*(c-e)+(d-f)*(d-f)))and(l*sqrt(2)=sqrt((a-e)*(a-e)+(b-f)*(b-f))) then begin
           for m:=i+1 to n do begin
              if (m<>i)and(m<>j)and(m<>k) then begin
              g:=x[m];
              h:=y[m];
              if (l=sqrt((a-g)*(a-g)+(b-h)*(b-h)))and(l=sqrt((e-g)*(e-g)+(f-h)*(f-h))) then begin
                 r:=r+1;
                 end;
              end;
           end;
         end;
         end;
      end;
   end;
end;
end;

procedure tip;
var g:text;
begin
assign(g,'patrate3.out');
rewrite(g);
write(g,r);
close(g);
end;

begin
cit;
rez;
tip;
end.