Cod sursa(job #318352)

Utilizator adella_stanciuStanciu Adela adella_stanciu Data 28 mai 2009 08:47:56
Problema Fractii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.6 kb
var f : text;
    nr, n : longint;
    d : array[1..1000] of byte;

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

procedure divi(k : longint);
var x, i : longint;
    ok : boolean;
begin
     x := k;
     ok := true;
     i := 2;
        while k mod i = 0 do begin
                k := k div i;
                ok := true;
        end;
        if ok then begin
                nr := nr + d[i];
        end;

        if (k > 1) and prim(k) then begin
          d[x] := n - n div i + d[i];
          nr := nr + n - n div i;
          k := 1;
        end;
     i := 3;
     while ok and (k > 1) do begin
        ok := false;
        while k mod i = 0 do begin
                k := k div i;
                ok := true;
        end;
        if ok then begin
                nr := nr + d[i];
        end;

        if (k > 1) and prim(k) then begin
          d[x] := n - n div i + d[i];
          nr := nr + n - n div i;
          end;
        inc(i,2);
     end;
end;

procedure frac;
var i : longint;
begin
        assign(f,'fractii.in'); reset(f);
        readln(f,n);
        nr := n;
        for i := 2 to n do
            if prim(i) then begin
                d[i] := n - n div i;
                nr := nr + n - n div i
            end
            else begin
                divi(i);
            end;
        close(f);

end;

begin
        frac;
        assign(f,'fractii.out'); rewrite(f);
        writeln(nr);
        close(f);
end.