Cod sursa(job #68670)

Utilizator mlazariLazari Mihai mlazari Data 28 iunie 2007 23:49:45
Problema Fractii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.24 kb
Program Fractii;
var N : longint;
    raspuns : real;
    Q : array[1..1000000] of boolean;

procedure Citeste;
var Intrare : text;
begin
  assign(Intrare,'fractii.in');
  reset(Intrare);
  readln(Intrare,N);
  close(Intrare);
end;

function Prim(a : longint) : boolean;
var i : longint;
    P : boolean;
begin
  if a=2 then Prim:=true
   else
    begin
      P:=true;
      for i:=2 to trunc(sqrt(a)) do
       if a mod i=0 then
        begin
          P:=false;
          break;
        end;
      Prim:=P;
    end;
end;

procedure Calculeaza;
var realN,reductibile,cit,nr : real;
    i,j,id : longint;
begin
  for i:=1 to 1000000 do Q[i]:=false;
  realN:=N;
  reductibile:=N-1;
  for i:=2 to N div 2 do
   if Prim(i) then
    begin
      cit:=N div i;
      nr:=0;
      for j:=1 to trunc(cit) do
       begin
         id:=trunc(cit)*j;
         if Q[id] then nr:=nr+1;
         Q[id]:=true;
       end;
      reductibile:=reductibile+sqr(cit)-cit-sqr(nr);
    end;
  raspuns:=sqr(realN)-reductibile;
end;

procedure Scrie;
var Iesire : text;
begin
  assign(Iesire,'fractii.out');
  rewrite(Iesire);
  write(Iesire,raspuns:0:0);
  close(Iesire);
end;

begin
  Citeste;
  Calculeaza;
  Scrie;
end.