Cod sursa(job #182921)

Utilizator TudorutzuMusoiu Tudor Tudorutzu Data 21 aprilie 2008 14:48:40
Problema Medie Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.22 kb
var f,g:text;
    v:array[1..9010] of integer;
    nr,nra:array[1..9010] of integer;
    n,i,j,x:integer;
    s,st:longint;
procedure quick(s,d:integer);
var i,j,w,x:integer;
begin
     i:=s; j:=d; x:=v[(s+d)shr 1];
     repeat
          while v[i]<x do inc(i);
          while v[j]>x do dec(j);
          if i<=j then
          begin
               w:=v[i]; v[i]:=v[j]; v[j]:=w;
               inc(i); dec(j);
          end
     until i>j;
     if i<d then quick(i,d);
     if s<j then quick(s,j);
end;
begin
     assign(f,'medie.in'); reset(f);
     assign(g,'medie.out'); rewrite(g);
     readln(f,n);
     for i:=1 to 7000 do nra[i]:=0;
     for i:=1 to n do
     begin
          readln(f,x);
          v[i]:=x;
          inc(nra[v[i]]);
     end;
     quick(1,n);
     i:=1;       st:=0;
     while i<=n do
     begin
          s:=0;
          for j:=1 to v[i]-1 do
             if 2*v[i]-j<=7000 then
               s:=s+nra[j]*nra[2*v[i]-j];
          if nra[v[i]]<=2 then s:=s*nra[v[i]]
                          else s:=nra[v[i]]*(((nra[v[i]]-2)*(nra[v[i]]-1))shr 1+s);
          while v[i]=v[i+1] do inc(i);
          inc(i);
          st:=st+s;
     end;
     writeln(g,st);
     close(g);
end.