Cod sursa(job #524216)

Utilizator elffikkVasile Ermicioi elffikk Data 20 ianuarie 2011 18:04:11
Problema Fractii Scor 10
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.65 kb
type bitvector=array[1..10]of byte;

var a:array[0..9,1..1000000]of integer;
    n:longint; s:int64;

function nextbit(var a:bitvector; n:byte):boolean;
var k:byte;
begin
  k:=1;
  while a[k]=1 do
  begin
    a[k]:=0;
    inc(k);
    if k>n then break;
  end;
  if k<=n then a[k]:=1;
  nextbit:=not(k>n);
end;

procedure zeros(var a:bitvector; n:byte);
var i:byte;
begin
  for i:=1 to n do a[i]:=0;
end;

procedure init;
var f:text; i,j:longint;
begin
  assign(f, 'fractii.in');
  reset(f);
  read(f,n);
  close(f);
  s:=0;
  for i:=0 to 9 do
  for j:=1 to n do
    a[i,j]:=0;
end;

procedure rez;
var f:text;
begin
  assign(f, 'fractii.out');
  rewrite(f);
  write(f,s);
  close(f);
end;

procedure calc;
var i,j,k,s1,p1,n1:longint;  bits:bitvector;
begin
  for i:=2 to 1000 do
  if a[0,i]=0
  then begin
    j:=i*2;
    while j<=n do
    begin
      inc(a[0,j]);
      a[a[0,j],j]:=i;
      inc(j,i);
    end;
  end;
  {
  for i:=0 to 9 do
  begin
    for j:=1 to n do write(a[i,j],' '); writeln;
  end;
  }
  s:=2*n-1;
  for i:=2 to n do
  if a[0,i]=0
  then
  begin
   s:=s+(n-i-(n-i)div i)*2;
   {write(n-i-(n-i)div i,' ');}
  end
  else
  begin
     s1:=0;
     zeros(bits, a[0,i]);
     while nextbit(bits, a[0,i]) do
     begin
       n1:=0; p1:=1;
       for k:=1 to a[0,i] do
         if bits[k]=1
         then
         begin
           p1:=p1*a[k,i];
           inc(n1);
         end;
       if n1 mod 2 = 1
       then s1:=s1+(n-i)div p1
       else s1:=s1-(n-i)div p1;
     end;
     {write(n-i-s1, ' ');}
     s:=s+(n-i-s1)*2;
  end;
end;

begin
 init;
 calc;
 rez;
end.