Cod sursa(job #26031)

Utilizator AymdTrimbitas Viorel Stefan Aymd Data 5 martie 2007 04:25:11
Problema Fractii Scor 10
Compilator fpc Status done
Runda Arhiva de probleme Marime 0.74 kb
var b:array[1..1000000]of longint;
    a:array[1..1000000,1..7]of longint;
    n,x,i,j,k,r,l:longint;
    p:boolean;
    f,g:text;

begin
assign(f,'fractii.in');
reset(f);
assign(g,'fractii.out');
rewrite(g);
readln(f,n);
r:=1;
for i:=2 to n do begin
   if b[i]=0 then begin
                  x:=i*2;
                  while x<n+1 do begin
                    b[x]:=b[x]+1;
                    a[x,b[x]]:=i;
                    x:=x+i;
                  end;
                  b[i]:=1;
                  a[i,1]:=i;
                  end;
   for j:=i-1 downto 1 do begin
      p:=true;
      for k:=1 to b[i] do
        for l:=1 to b[j] do p:=p and (a[j,l]<>a[i,k]);
      if p then r:=r+2;
   end;
end;
write(g,r);
close(g);
end.