Cod sursa(job #116159)

Utilizator ionescu88alex ionescu ionescu88 Data 17 decembrie 2007 21:46:42
Problema Pairs Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.83 kb
var fi,fo:text;
    x,rez,l,nr_div,max:int64;
    ct:longint;
    nr:array[1..1000100]of byte;
    m:array[1..1000000]of int64;
    prime:array[1..1000100]of byte;
    primee:array[1..500000]of int64;
procedure gen;
var i,j:int64;
begin
  i:=3;
  primee[1]:=2;
  l:=1;
  prime[1]:=1;
  while i<=1000000 do
    begin
      if prime[i]=0 then
        begin
          j:=3*i;
          inc(l);
          primee[l]:=i;
          while j<=1000000 do
             begin
                prime[j]:=1;
                inc(j,i);
             end;
        end;
      inc(i,2);
    end;
end;
procedure prim(nr:int64);
var i:int64;
begin
  ct:=1; nr_div:=0;
  if (nr=2)or((prime[nr]=0)and(nr and 1=1)) then begin inc(nr_div); exit; end;
  if (sqrt(nr)=trunc(sqrt(nr)))or(nr mod 4=0) then begin ct:=2; exit; end;
  i:=1;
  while i<=l do
   if (nr mod primee[i]=0) then
     begin
       inc(nr_div);
       nr:=nr div primee[i];
       if nr=1 then exit;
       if nr mod primee[i] = 0 then begin ct:=2; exit; end;
       if prime[nr]=0 then begin inc(nr_div); exit; end;
       inc(i);
     end
   else inc(i);
end;
procedure verif(i:int64);
begin
  prim(i);
  if ct=1 then
    if nr_div and 1 = 1 then rez:=rez + (m[i]*(m[i]-1)) shr 1
                        else rez:=rez - (m[i]*(m[i]-1)) shr 1;
end;
var i1,j1:longint;
    n:int64;
begin
  assign(fi,'pairs.in'); reset(fi);
  assign(fo,'pairs.out'); rewrite(fo);
  readln(fi,n);
  rez:=0;
  gen;
  max:=-maxint;
  while not eof(fi) do
    begin
      readln(fi,x);
      nr[x]:=1;
      if max<x then max:=x;
    end;
  for i1:=2 to max do
    begin
      for j1:=1 to max div i1 do
         if nr[i1*j1]=1 then inc(m[i1]);
      if (m[i1]>0) then verif(i1);
    end;
  rez:=(n*(n-1)) shr 1 - rez;
  writeln(fo,rez);
  close(fi);
  close(fo);
end.