Cod sursa(job #112819)

Utilizator RobybrasovRobert Hangu Robybrasov Data 7 decembrie 2007 21:37:32
Problema Numarare triunghiuri Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.43 kb
var v:array[1..800] of integer;
    i,j,n,kont:integer;
    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 binary_search;
var li,ls,m,rez,val:byte;
    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 begin ok:=false; rez:=m; end;
      if val<v[m] then ls:=m-1
      else li:=m+1;
    end;
    if ok then
      if val<v[li] then rez:=li-1
      else rez:=li;
    inc(kont,rez-j);
end;

{
procedure binary_search;
var li,ls,m,val:integer;
begin
  li:=j; ls:=n;
  val:=v[i]+v[j];
  while li<=ls do
    begin
      if val<v[ls] then m:=0;
      m:=(li+ls) div 2;
      if val=v[m] then break;
      if val<v[m] then ls:=m-1
      else li:=m+1;
    end;
    if val<v[li] then m:=li-1;
    if m<>0 then inc(kont,m-j);
end;
}
begin
  assign(f,'nrtri.in');
  reset(f);
  readln(f,n);
  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
      binary_search;
  write(f,kont);
  close(f);
end.