Cod sursa(job #201282)

Utilizator cypherMircea Grecu cypher Data 30 iulie 2008 10:50:44
Problema Fractii Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.59 kb
program fractii;
var n,m,rn:longint;
	a:array[0..1000001] of int64;
	p:array[1..1000001] of longint;
	b:array[1..1000] of longint;
	k:int64;

	procedure citire;
	var f:text;
	begin
		assign(f,'fractii.in'); reset(f);
		readln(f,n);
		close(f);
		rn:=trunc(sqrt(n));
	end;

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

	function prim2(x:longint):boolean;
	var j,y:longint;
	begin
		y:=trunc(sqrt(x));
		for j:=1 to m do begin
			if p[j]>y then exit(true);
			if x mod p[j]=0 then exit(false);
		end;
		exit(true);
	end;

	procedure prime;
	var i,j:longint;
	begin
		m:=0;
		for i:=2 to rn do begin
			if prim(i) then begin
				inc(m); p[m]:=i;
			end;
		end;
		for i:=rn+1 to (n div 2) do begin
			if prim2(i) then begin
				inc(m); p[m]:=i;
			end;
		end;
	end;

	procedure solutie(x,j:int64);
	var l:longint;
	begin
		a[x]:=x;
		for l:=1 to j do begin
			a[x]:=(a[x] div b[l]) * (b[l]-1);
		end;
	end;

	procedure go(i,j:word; x:int64);
	var l:longint; y:int64;
	begin
		if x<=n then solutie(x,j-1); y:=x;
		for l:=i+1 to m do begin
			b[j]:=p[l]; y:=x*p[l];
			if y>n then exit;
			while y<=n do begin
				go(l,j+1,y);
				y:=y*p[l];
			end;
		end;
	end;

	procedure scriere;
	var f:text; i:longint;
	begin
		k:=0;
		for i:=2 to n do begin
			if a[i]=0 then a[i]:=i-1;
			inc(k,a[i]);
		end;
		k:=k*2 +1;
		assign(f,'fractii.out'); rewrite(f);
		writeln(f,k);
		close(f);
	end;

BEGIN
	citire;
	prime;
	go(0,1,1);
	scriere;
END.