Cod sursa(job #61191)

Utilizator cezar305Mr. Noname cezar305 Data 18 mai 2007 16:18:48
Problema Patrate 3 Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.83 kb
var c:char; e:extended;
    caut1,caut2,i,j,n,nr,pos,m,aux,l1,l2,h:longint;
    x,y:array[1..1001] of longint;
    f1,f2:text;

procedure search(li,ls:integer);
begin
nr:=0;
m:=(li+ls) div 2;
if (caut1=x[m])and(caut2=y[m]) then nr:=1
        else if li<ls then if caut1<x[m] then search(li,m-1)
                else if (caut1=x[m])and(caut2<y[m]) then search(li,m-1)
                        else search(m+1,ls);
end;

begin
        assign(f1,'patrate3.in');
        reset(f1);
        assign(f2,'patrate3.out');
        rewrite(f2);
        readln(f1,n);
        for i:=1 to n do
        begin
                h:=1;
                while c<>' ' do
                begin
                        read(f1,c);
                        if c='-' then h:=0;
                        if (c<>'.')and(c<>' ')and(c<>'-') then if h=1 then x[i]:=x[i]*10+ord(c)-48 else x[i]:=x[i]*10-ord(c)+48 ;
                end;
                h:=1;
                while not eoln(f1) do
                begin
                        read(f1,c);
                        if c='-' then h:=0;
                        if (c<>'.')and(c<>'-') then if h=1 then y[i]:=y[i]*10+ord(c)-48 else y[i]:=y[i]*10-ord(c)+48;
                end;
                readln(f1);
        end;
        for i:=1 to n-1 do
                for j:=i+1 to n do
                begin
                        if x[i]>x[j] then
                        begin
                                aux:=x[i];
                                x[i]:=x[j];
                                x[j]:=aux;
                                aux:=y[i];
                                y[i]:=y[j];
                                y[j]:=aux;
                        end;
                        if (x[i]=x[j])and(y[i]>y[j]) then
                        begin
                                aux:=x[i];
                                x[i]:=x[j];
                                x[j]:=aux;
                                aux:=y[i];
                                y[i]:=y[j];
                                y[j]:=aux;
                        end;
                end;
        for i:=1 to n-3 do
                for j:=i+1 to n-2 do
                begin
                        l1:=abs(x[i]-x[j]);
                        l2:=abs(y[i]-y[j]);
                        caut1:=x[i]+l2;
                        if y[j]>y[i] then l1:=l1*-1;
                        caut2:=y[i]+l1;
                        search(j+1,n);
                        if nr=1 then
                        begin
                                caut1:=x[j]+l2;
                                caut2:=y[j]+l1;
                                search(j+1,n);
                                if nr=1 then inc(pos);
                        end;
                end;
        writeln(f2,pos);
        close(f1);
        close(f2);
end.