Cod sursa(job #113215)

Utilizator RobybrasovRobert Hangu Robybrasov Data 9 decembrie 2007 11:15:16
Problema Numarare triunghiuri Scor 55
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.52 kb
var v:array[1..801] of integer;
    i,j,n:integer;
    kont:longint;
    f:text;

procedure sorteaza;
var i,t:integer;
    ok:boolean;
begin
  repeat
    ok:=true;
    i:=1;
    while (i<=n-1) and ok do
      begin
        if v[i]>v[i+1] then
          begin
            t:=v[i];
            v[i]:=v[i+1];
            v[i+1]:=t;
            ok:=false;
          end;
        inc(i);
      end;
  until ok;
end;
{
procedure cauta;
var val:longint;
    c,rez:integer;
begin
  val:=v[i]+v[j];
  c:=j+1;
  while (val>=v[c]) and (c<=n) do inc(c);
  rez:=c-1-j;
  inc(kont,rez);
end;
}
procedure binary_search;
var li,ls,m,rez:integer;
    val:longint;
    ok:boolean;
begin
  li:=j; ls:=n; ok:=true;
  val:=v[i]+v[j];
  while (li<ls) and ok do
    begin
      m:=(li+ls) div 2;
      if val<v[m] then ls:=m-1
      else if val>v[m] then li:=m+1
           else begin rez:=m; ok:=false; end;
    end;
  if ok then
    if val<v[li] then rez:=li-1
    else rez:=li;
  inc(kont,rez-j);
end;

begin
  assign(f,'nrtri.in');
  reset(f);
  readln(f,n);
  if n>2 then
    begin
      for i:=1 to n do
        read(f,v[i]);
      close(f);
      sorteaza;
      kont:=0;
      assign(f,'nrtri.out');
      rewrite(f);
      for i:=1 to n-2 do
        for j:=i+1 to n-1 do
          {cauta;}
          binary_search;
      write(f,kont);
      close(f);
    end
  else
    begin
      close(f);
      assign(f,'nrtri.out');
      rewrite(f);
      write(f,0);
      close(f);
    end;
end.