Cod sursa(job #197174)

Utilizator RobybrasovRobert Hangu Robybrasov Data 2 iulie 2008 14:48:38
Problema Fractii Scor 10
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.31 kb
var v:array[1..1001] of longint;
    c:array[1..1001] of boolean;
    n,i:longint;
    k:integer;
    kont:int64;
    f:text;

procedure ciur(x:longint);
var i,j,t:longint;
begin
  v[1]:=2;
  k:=1;
  i:=3;
  t:=trunc(sqrt(x));
  while i<=t do
    begin
      if c[i]=false then
        begin
          inc(k);
          v[k]:=i;
          j:=sqr(i);
          while j<=x do begin c[j]:=true; inc(j,i); end;
        end;
      inc(i,2);
    end;
  if not odd(i) then inc(i);
  while i<=x do
    begin
      if c[i]=false then begin inc(k); v[k]:=i; end;
      inc(i,2);
    end;
end;

function prim(x:longint):boolean;
var i,t:integer;
begin
  t:=trunc(sqrt(x));
  for i:=2 to t do
    if x mod i=0 then begin prim:=false; exit; end;
  prim:=true;
end;

function phi(x:longint):int64;
var p:currency; k:integer;
begin
  if prim(i) then phi:=x-1
  else
    begin
      p:=1; k:=1;
      while (v[k]>0) and (v[k]<=x shr 1) do
        begin
          if x mod v[k]=0 then p:=p*(1-1/v[k]);
          inc(k);
        end;
      p:=p*x;
      phi:=round(p);
    end;
end;

begin
  assign(f,'fractii.in');
  reset(f);
  read(f,n);
  close(f);
  ciur(1000);
  assign(f,'fractii.out');
  rewrite(f);
  if n=1 then write(f,1)
  else
    begin
      kont:=0;
      for i:=2 to n do inc(kont,phi(i));
      write(f,kont shl 1+1);
    end;
  close(f);
end.