Cod sursa(job #113230)

Utilizator vrvpVlad Veigang vrvp Data 9 decembrie 2007 12:23:35
Problema Fractii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.31 kb
type vector=array[1..1000000000] of byte;
var a,b:vector;
n:longint;
f,g:text;
function cmmdc(a,b:longint):longint;
var r:longint;
begin
while b<>0 do
  begin
  r:=a mod b;
  a:=b;
  b:=r;
end;
cmmdc:=a;
end;

function cate(n:longint):longint;
var i,nr,d,p,k:longint;
begin
nr:=1;
d:=2;
repeat
      k:=0;p:=1;
      while n mod d=0 do
        begin
          inc(k);
          n:=n div d;
          p:=p*d;
      end;
if k>1 then
  nr:=nr*(p-p div d)
  else
  if k=1 then
    nr:=nr*(d-1);
    d:=d+1;
until n=1;
cate:=nr;


end;
procedure suma(var a,b,c:vector;m,n:longint;var p:longint);
var x,t,i:longint;
begin
if m<n then
begin
  for i:=m+1 to n do
    a[i]:=0;
  p:=n;
  end
  else
  begin
  for i:=n+1 to m do
    b[i]:=0;
  p:=m;
  end;
t:=0;
for i:=1 to p do begin
  x:=a[i]+b[i]+t;
  c[i]:=x mod 10;
  t:=x div 10;
end;
if t>0 then
  begin
    inc(p);
    c[p]:=t;
  end;
end;

procedure nr(n:longint);
var i,k,x,m:longint;
begin
m:=1;
a[1]:=1;
for i:=2 to n do
  begin
  x:=2*cate(i);
  k:=0;
  repeat
  inc(k);
  b[k]:=x mod 10;
  x:=x div 10;
  until x=0;
suma(a,b,a,m,k,m);
end;
for i:=m downto 1 do
  write(g,a[i]);
close(g);
end;
begin
assign(f,'fractii.in');reset(f);
assign(g,'fractii.out');rewrite(g);
readln(f,n);
nr(n);
end.