Cod sursa(job #14388)

Utilizator floringh06Florin Ghesu floringh06 Data 8 februarie 2007 21:35:21
Problema Fractii Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.54 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;
    p,sol:array[1..1000000] of longint;
    i,j,k,n:longint;
    rez:int64;

  procedure generate;
    var i,j,k:longint;
     begin
       p[1]:=0;
       p[2]:=0;
       for i:=5 to n div 2 + 1 do
         begin
           k:=i+i;
           while k<=n do
            begin
              p[k]:=1;
              k:=k+i;
            end;
         end;
     end;

  procedure Euler(x,y:longint);
   var vl:real;
    begin
      vl:=sol[y];
      vl:=vl*(1-1/x);
      sol[y]:=trunc(vl);
    end;

  procedure solve;
   var i,j,k:longint;
    begin
     for i:=1 to n do
      begin
       sol[i]:=i;
       if i>3 then
        begin
         if i mod 2=0 then p[i]:=1;
         if i mod 3=0 then p[i]:=1;
        end;
      end;
      for i:= 2 to n div 2 do

         if p[i]=0 then
          begin
           Euler(i,i);
            k:=i+i;
            while k<=n do
             begin
              Euler(i,k);
              k:=k+i;
             end;
          end;
      for i:= n div 2+1 to n do
       if p[i]=0 then Euler(i,i);
      for i:=1 to n do
        rez:=rez+sol[i];
    end;



begin
 assign(fi,'fractii.in'); reset(fi);
 assign(fo,'fractii.out'); rewrite(fo);
 readln(fi,n);
 generate;
 solve;
 {for i:=1 to n do
  if p[i]=0 then write(fo,i,' ');}
 rez:=rez*2-1;
 writeln(fo,rez);
 close(fi);
 close(fo);
end.