Cod sursa(job #330485)

Utilizator ionutz32Ilie Ionut ionutz32 Data 10 iulie 2009 09:33:19
Problema Frac Scor 20
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.51 kb
{$N+}
var v:array[1..35] of comp;
a,b,m:array[1..20] of 0..19;
n,p,d,aux,p1,q,m2,nr1,nr2:comp;
i,x,r,s,t,rest,j:longint;
f,g:text;
k:boolean;
begin
assign(f,'frac.in');
assign(g,'frac.out');
reset(f);rewrite(g);
read(f,n,p);
d:=1;
while n<>1 do
      begin
      d:=d+1;
      aux:=n/d;
      if aux*d=n then
         begin
         x:=x+1;
         v[x]:=d;
         end;
      while aux*d=n do
            begin
            n:=n/d;
            aux:=n/d;
            end;
      end;
p1:=1;
q:=v[1];
for i:=2 to x do
    begin
    p1:=p1*v[i]+q-p1;
    q:=q*v[i];
    end;
p1:=q-p1;
r:=1;
a[1]:=1;
s:=19;
b[18]:=2;
b[19]:=9;
k:=true;
while k do
      begin
      t:=s;
      m[s+1]:=0;
      for i:=1 to s do
          m[i]:=a[i]+b[i];
      for i:=1 to s do
          if m[i]>=10 then
             begin
             m[i+1]:=m[i+1]+m[i] div 10;
             m[i]:=m[i] mod 10;
             if i+1>s then
                t:=i+1;
             end;
      rest:=0;
      for i:=t downto 1 do
          begin
          m[i]:=rest*10+m[i];
          rest:=m[i] mod 2;
          m[i]:=m[i] div 2;
          end;
      m2:=0;
      if m[t]=0 then
         t:=t-1;
      for i:=t downto 1 do
          m2:=m2*10+m[i];
      nr2:=m2/q*p1+0.4999999999999999999999999999999999999999999999;
      if nr2>=p then
         begin
         i:=1;
         while m[i]=0 do
               begin
               b[i]:=9;
               i:=i+1;
               end;
         b[i]:=m[i]-1;
         while i<t do
               begin
               i:=i+1;
               b[i]:=m[i];
               end;
         if m[t]=0 then
            s:=t-1
         else
             s:=t;
         end
      else
          begin
          i:=1;
          while m[i]=9 do
                begin
                a[i]:=0;
                i:=i+1;
                end;
          a[i]:=m[i]+1;
          if i>t then
             t:=i;
          while i<t do
                begin
                i:=i+1;
                a[i]:=m[i];
                end;
          r:=t;
          end;
      k:=true;
      if r>s then
         j:=r
      else
          j:=s;
      i:=j;
      while (a[i]=b[i]) and (i>1) do
            i:=i-1;
      if a[i]>b[i] then
         k:=false
      else
          k:=true;
      end;
i:=1;
while b[i]=9 do
      begin
      b[i]:=0;
      i:=i+1;
      end;
b[i]:=b[i]+1;
if i>s then
   s:=i;
for i:=s downto 1 do
    write(g,b[i]);
close(f);close(g);
end.