Cod sursa(job #238724)

Utilizator FllorynMitu Florin Danut Flloryn Data 2 ianuarie 2009 23:54:34
Problema Pairs Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.08 kb
 var fi,fo:text;  
       x,rez,l,nr_div,n:int64;  
       ct,i1,j1,max:longint;  
       nr,prime:array[1..1000000]of byte;  
       m:array[0..1000000]of int64;  
        primee:array[1..500000]of longint;  
    procedure gen(ba:int64);  
    var i,j:int64;  
    begin  
     i:=3; primee[1]:=2; l:=1; prime[1]:=1;  
     while i<=ba do  
       begin  
         if prime[i]=0 then  
           begin  
             j:=3*i;  
             inc(l);  
             primee[l]:=i;  
             while j<=ba 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; i:=1;  
     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;  
     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;  
   begin  
     assign(fi,'pairs.in'); reset(fi);  
     assign(fo,'pairs.out'); rewrite(fo);  
     readln(fi,n);  
     rez:=0; m[0]:=1; m[1]:=1;  
     max:=-maxint;  
     for i1:=1 to n do  
       begin  
         readln(fi,x); nr[x]:=1;  
         if max<x then max:=x; end;  
     gen(max shr 1);  
     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.