Cod sursa(job #388926)

Utilizator energizerBunnyCicu Mihai energizerBunny Data 31 ianuarie 2010 14:13:19
Problema Fractii Scor 30
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.81 kb
program pascal;
type
  pcelula = ^celula;
  celula = record
    info : longint;
    leg  : pcelula;
  end;

var
 f:text;
 v:array[1..1000000] of byte;
 n,calcul:longint;
 L,p:pcelula;

procedure prime;
var
  i,j:longint;
  temp:pcelula;
begin
  new(L);
  L^.leg:=nil;
  p:=L;
  for i:=1 to n do
    v[i]:=1;
  for i:=2 to trunc(sqrt(n)) do
    if v[i] = 1 then begin
      new(temp);
      temp^.leg:=nil;
      temp^.info:=i;
      p^.leg:=temp;
      p:=temp;
      for j:=2 to n div i do
        v[j*i]:=0;
    end;
  for i:=trunc(sqrt(n)) to n div 2 do
    if v[i]=1 then begin
      new(temp);
      temp^.leg:=nil;
      temp^.info:=i;
      p^.leg:=temp;
      p:=temp;
    end;
end;

function rid_p(a,b:longint):longint;
{functie de ridicare la puterea b a numarului a}
var
 t:integer;
 put:longint;
begin
  put:=1;
  for t:=1 to b do
    put:=put*a;
  rid_p:=put;
end;

procedure rezultat;
var
 i,j,fi,x,putere:longint;
begin
  calcul:=1;
  for i:=2 to n do begin
    x:=i;
    fi:=1;
    p:=L^.leg;
    while (p<>NIL) and (p^.info <= i div 2) do begin
      j:=p^.info;
      if x=1 then break
      else
      if x mod j = 0 then begin
        putere:=0;
        while (x mod j = 0) and (x<>1) do begin
          inc(putere);
          x:=x div j;
        end;
        fi:=fi * (j-1)*rid_p(j,putere-1);
      end;
      p:=p^.leg;
    end;

    if x<>1 then begin
      putere:=0;
      while (x mod i = 0) and (x<>1) do begin
        inc(putere);
        x:=x div i;
      end;
      fi:=fi * (i-1)*rid_p(i,putere-1);
    end;

    calcul:=calcul+fi;
  end;
end;

begin
  assign(f,'fractii.in');
  reset(f);
  read(f,n);
  close(f);

  prime;
  rezultat;


  assign(f,'fractii.out');
  rewrite(f);
  write(f,calcul*2-1);
  close(f);
end.