Cod sursa(job #7921)

Utilizator ProtomanAndrei Purice Protoman Data 22 ianuarie 2007 23:35:10
Problema Numarare triunghiuri Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.12 kb
var f1,f2:text; i,j,r,n,l,s,c,x:longint; a:array[1..800] of integer;

procedure pozitie(var m:longint; p,u:longint);
var i,j,di,dj,aux:longint;
begin
di:=0;
dj:=-1;
i:=p;
j:=u;
while i<j do
begin
if a[i]>a[j] then
begin
aux:=di;
di:=-dj;
dj:=-aux;
aux:=a[i];
a[i]:=a[j];
a[j]:=aux;
end;
i:=i+di;
j:=j+dj;
end;
m:=i;
end;

procedure quick(p,u:longint);
var m:longint;
begin
if p<u then
begin
pozitie(m,p,u);
quick(p,m-1);
quick(m+1,u);
end;
end;

procedure cauta(li,ls:longint);
var m:longint;
begin
m:=(li+ls) div 2;
if (x>=a[m])and(x<=a[m+1]) then s:=m
          else if li<ls then if x<a[m] then cauta(li,m-1)
                        else cauta(m+1,ls);
end;

begin
        assign(f1,'nrtri.in');
        reset(f1);
        assign(f2,'nrtri.out');
        rewrite(f2);
        read(f1,n);
        for i:=1 to n do
        read(f1,a[i]);
        quick(1,n);
        for i:=1 to n-1 do
        for j:=i+1 to n do begin
        s:=0;
        x:=a[i]+a[j];
        cauta(j,n);
        if s<>0 then c:=c+(s-j);
        end;
        write(f2,c);
        close(f1);
        close(f2);
end.