Cod sursa(job #26069)

Utilizator AymdTrimbitas Viorel Stefan Aymd Data 5 martie 2007 09:23:07
Problema Fractii Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.19 kb
var a:array[1..1000000,1..7]of longint;
    b:array[1..1000000]of byte;
    n,i,x,j,ir:longint;
    f,g:text;
    r:array[1..100]of integer;

procedure suma;
var k,s:longint;
begin
s:=0;
while x<>0 do begin
   s:=s+1;
   r[s]:=r[s]+x mod 10;
   x:=x div 10;
end;
if ir<s then ir:=s;
for k:=1 to ir do begin
   if r[k]>9 then begin
                  r[k+1]:=r[k+1]+1;
                  r[k]:=r[k] mod 10;
                  end;
end;
if r[ir+1]<>0 then ir:=ir+1;
end;

begin
assign(f,'fractii.in');
reset(f);
readln(f,n);
r[1]:=1;
ir:=1;
for i:=2 to n do begin
   if b[i]=0 then begin
                  x:=2*i;
                  while x<n+1 do begin
                     b[x]:=b[x]+1;
                     a[x,b[x]]:=i;
                     x:=x+i;
                  end;
                  end;
   if b[i]=0 then begin
                  x:=2*i-2;
                  suma;
                  end
             else begin
                  x:=i-1;
                  for j:=1 to b[i] do x:=x-x div a[i,j];
                  x:=2*x;
                  suma;
                  end;
end;
assign(g,'fractii.out');
rewrite(g);
for i:=ir downto 1 do write(g,r[i]);
close(g);
end.