Cod sursa(job #604339)

Utilizator ctlin04UAIC.VlasCatalin ctlin04 Data 21 iulie 2011 18:54:36
Problema Numarare triunghiuri Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.31 kb
Program nr_triunghiuri;
 var n,i,j,p,s,t,x:integer;
     a:array [1..800] of integer;
     b1,b2: array [1..1 shl 17] of char;
     nr:longint;
     fi,fo:text;
 procedure qsort(l,r:integer);
 var k,i,j,y:integer;
 begin
  i:=l; j:=r;
   k:=a[(l+r) div 2];
 repeat
  while a[i]<k do inc(i);
   while a[j]>k do dec(j);
 if i<=j then
              begin
               y:=a[i];
                a[i]:=a[j];
                  a[j]:=y;
                     inc(i); dec(j);
              end;
 until i>=j;
  if l<j then qsort(l,j);
   if i<r then qsort(i,r);
  end;
begin
assign(fi,'nrtri.in');
 assign(fo,'nrtri.out');
 settextbuf(fi,b1);
 settextbuf(fo,b2);
reset(fi);
 rewrite(fo);
readln(fi,n);
 for i:=1 to n do read(fi,a[i]);
 qsort(1,n);
 for i:=1 to n-2 do
  for j:=i+1 to n-1 do begin
    p:=(j+n+1) div 2;
    if a[p]<=a[i]+a[j] then begin
                             nr:=nr+p-j;
                             for s:=p+1 to n do
                              if a[s]<=a[i]+a[j] then inc(nr)
                               else break;
                              end
     else for s:=p-1 downto j+1 do
      if a[s]<=a[i]+a[j] then begin
                            nr:=nr+p-j;
                            break;
                            end;
      end;
 write(fo,nr);
close(fo);
end.