Cod sursa(job #601706)

Utilizator ctlin04UAIC.VlasCatalin ctlin04 Data 7 iulie 2011 15:27:15
Problema Fractii Scor 30
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.51 kb
program fractii_2;
 var a:array [1..100000] of longint;
     b:array [1..1000000] of longint;
     i,j,n,m,k,l,s,v:longint;
     fi,fo:text;
function euler(x:longint):real;
 var i,j,p:longint;
 begin
  i:=1; p:=1; euler:=1;
   repeat
    if x mod a[i]=0 then begin
                          p:=p*a[i];
                          x:=x div a[i];
                          end;
    if (x mod a[i]<>0) or (x=1) then begin
     if p<>1 then euler:=(euler*(a[i]-1)*p)/(a[i]);
      p:=1;
       inc(i);
       end;
    until x=1;
 end;
 function prim(x:longint):boolean;
  var j,m:longint;
 begin
 m:=0; j:=0;
  repeat
   inc(j);
    if x mod a[j]=0 then m:=1;
     until (x div a[j]<=a[j]) or (m=1);
   if m=1 then prim:=false
           else prim:=true;
 end;
begin
 assign(fi,'fractii.in');
  reset(fi);
 assign(fo,'fractii.out');
  rewrite(fo);
   read(fi,n);
  l:=7; i:=17; a[1]:=2; a[2]:=3; a[3]:=5; a[4]:=7; a[5]:=11;a[6]:=13;
 while i<=n div 2 do begin
  repeat
   inc(j);
    if i mod a[j]=0 then m:=1;
     until (i div a[j]<=a[j]) or (m=1);
 if m=0 then begin
              a[l]:=i;
              inc(l);
              j:=0;
              end
        else begin
              m:=0;
              j:=0;
              end;
 inc(v);
 if v mod 2<>0 then
                  i:=i+2
                  else i:=i+4;
 end;
 b[1]:=1; b[2]:=1;
 for i:=3 to n do
  if prim(i) then b[i]:=i-1
   else b[i]:=trunc(euler(i));
 for i:=1 to n do
  s:=s+b[i];
 write(fo,2*s-1);
 close(fo);
end.