Cod sursa(job #13215)

Utilizator floringh06Florin Ghesu floringh06 Data 5 februarie 2007 23:08:38
Problema Fractii Scor 30
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.77 kb
{$IFDEF NORMAL}
  {$I-,Q-,R-,S-}
{$ENDIF NORMAL}
{$IFDEF DEBUG}
  {$I+,Q+,R+,S-}
{$ENDIF DEBUG}
{$IFDEF RELEASE}
  {$I-,Q-,R-,S-}
{$ENDIF RELEASE}

var fi,fo:text;
    n:longint;
    rez:int64;
    i,j,k,ll:longint;
    ok:boolean;
    lim:integer;
    bo:array[1..1000000] of integer;
    p:array[1..1000000] of longint;
    v,o:array[1..30] of longint;

 procedure prim;
  var i,j,k:longint;
    begin
     bo[1]:=0;
     bo[2]:=0;
      for i:=2 to n div 2 +1 do
       begin
        k:=i+i;
        while k<=n do
         begin
          bo[k]:=1;
          k:=k+i;
         end;
       end;
      k:=1;
      for i:=1 to n  do
        if bo[i]=0 then
             begin
               p[k]:=i;
               inc(k);
             end;
       lim:=k-1;
    end;





 function Euler(n:longint):longint;
   var i:longint;
       sum:real;
     begin
       sum:=n;
   {    for i:=1 to k do
         write(fo,o[i],' ');}
     {  writeln(fo);}
       for i:=1 to k do
         sum:=sum*(1-1/(o[i]));
       Euler:=trunc(sum);

      { writeln(fo,sum); }
     end;


  function min(i,j:longint):longint;
    begin
      if i>j then min:=j
        else min:=i;
    end;


begin
 assign(fi,'fractii.in'); reset(fi);
 assign(fo,'fractii.out'); rewrite(fo);
 read(fi,n);
 close(fi);
 prim;
 rez:=0;
 ll:=2;
 for i:=2 to n do
  begin
   k:=1;
   ok:=false;
   if p[ll]=i then begin inc(rez,p[ll]-1); inc(ll); end
    else
   for j:=2 to i do
     if p[j]>0 then if i mod p[j]=0 then
       begin
        o[k]:=p[j];
        inc(k);
        ok:=true;
       end;
   dec(k);
  if ok=true then rez:=rez+Euler(i);
  end;


{ for i:=1 to 100 do
  writeln(fo,p[i]);}
 rez:=(rez)*2+1;
 write(fo,rez);
close(fo);
end.