Cod sursa(job #162403)

Utilizator luigiPacala luigi Data 19 martie 2008 23:33:59
Problema Fractii Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 1.53 kb
var f:text;
    i,a,n,j,y,q,p,r,s:longint;
    ok:boolean;
    v:array[1..10000] of longint;
begin
assign(f, 'fractii.in');
reset(f);
read(f,n);
close(f);
s:=0;
s:=s+n;
i:=2;
v[1]:=1333333;
while i<=n do
 begin
  q:=0;
  for j:=2 to (i div 2)+1 do
   begin
     if i mod j=0 then
      begin
       if q=0 then
        begin
         q:=q+1;
         v[q]:=j;
        end
        else
        begin
       ok:=true;
       a:=1;
         while a<=q do
         begin
         if j mod v[a]=0 then
         begin
         ok:=false;
         a:=1000000;
         end;
         a:=a+1;
         end;
       if ok=true then
         begin
         q:=q+1;
         v[q]:=j;
         end;
        end;
       end;
  end;
 if q=0 then
 s:=s+n-(n div i)
  else
 BEGIN
 if q=1 then
  s:=s+n-(n div v[1])
  else
  BEGIN
  s:=s+n-(n div v[1]); {la general}
  for j:=2 to q do
   begin
    for a:=1 to j-1 do
     if v[a]*v[j]<=n then  {numa prima oara adica cand a este 1}
       begin
        if a=1 then
         s:=(s-(n div v[j]))+(n div (v[a]*v[j]))
          else
         s:=s+(n div (v[a]*v[j]));
        p:=v[j];
        while p<=n do
          begin
           for r:=1 to a-1 do
           if (p mod v[r]=0) and (p mod v[a]=0) then
           y:=y+1;
          p:=p+v[j];
          end;
       s:=s-y;
       end
       else
       s:=s+(n div j);
   end;
  END;
 END;
 for j:=1 to q do
 v[j]:=0;
 i:=i+1;
 end;
assign(f, 'fractii.out');
rewrite(f);
write(f,s);
close(f);
end.