Cod sursa(job #51780)

Utilizator h_istvanHevele Istvan h_istvan Data 16 aprilie 2007 20:14:59
Problema Fractii Scor 20
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.19 kb
program fractii;
var f:text;
    n,e,np,i:longint;
    v:array[1..1000000] of byte;
    p:array[1..1000] of longint;

procedure bont(x:longint);
var i:longint;
begin
     np:=0;
     i:=2;
     while(x > 1) do
     begin
          if(x mod i = 0) then
          begin
               np:=np+1;
               p[np]:=i;
          end;
          while(x mod i = 0) do x:=x div i;

          i:=i+1;
     end;
end;

function szamol:longint;
var e,i,j:longint;
begin
     e:=n;
     for i:=1 to np do
     begin
          j:=p[i];

          while(j<=n) do
          begin
               if(v[j] = 0) then
               begin
                    v[j]:=1;
                    e:=e-1;
               end;

               j:=j+p[i];
          end;
     end;
     szamol:=e;
end;

procedure urit;
var i:longint;
begin
     for i:=1 to n do
          v[i]:=0;
end;

begin
     assign(f,'fractii.in');
     reset(f);
     readln(f,n);
     close(f);

     e:=n;

     for i:=2 to n do
     begin
          bont(i);
          e:=e+szamol;
          urit;
     end;

     assign(f,'fractii.out');
     rewrite(f);
     writeln(f,e);
     close(f);
end.