Cod sursa(job #159539)

Utilizator luigiPacala luigi Data 14 martie 2008 11:03:29
Problema Fractii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.56 kb
var f:text;
    n,j,i,s,a,e,z,c,t,q,x,r,p:longint;
    ok,ev,tre,sur:boolean;
    v:array [1..1000] of longint;
begin
assign(f, 'fractii.in');
reset(f);
read(f,n);
s:=n*n;
close(f);
for i:=2 to n do
begin
    a:=0;
    ok:=true;
    sur:=false;
    for j:=2 to (i div 2) do
     Begin
       if i mod j =0 then
        BEgin
          if ok=true then
           begin
            a:=a+1;
            v[a]:=j;
            ok:=false;
           end
          else
           BEGin
             ev:=true;
             e:=1;
             while e<=a do
             Begin
              if j mod v[e] =0 then
               begin
               ev:=false;
               e:=10000000;
               end;
              e:=e+1;
             End;
            if ev=true then
             begin
             a:=a+1;
             v[a]:=j;
             end
           END;
        end;
     End;
if ok=true then
 s:=s-(n div i)      {bine pana aici}

   else
begin
   for e:=1 to a do                {a -contorul vectorlui v}
    begin
     s:=s-(n div v[e]);
    end;
  if a=1 then
   s:=s+(n div v[1]);
  if a=2 then
  s:=s+(n div (v[2]*v[1]));
  if a>2 then
  BEGIN
   for e:=2 to a do
    for t:=1 to e-1 do
     for r:=1 to t-1 do
     begin
      p:=v[e];
      while p*v[t]<=i do
       begin
        if p*v[t] mod v[r]<>0 then
        s:=s+(n div (v[e]*v[t]));
        p:=p+v[e];
       end;
     end;
  END;
  for z:=1 to a do
   v[z]:=0;
end;
end;
assign(f, 'fractii.out');
rewrite(f);
write(f,s);
close(f);
end.