Cod sursa(job #1269350)

Utilizator baolaptrinhbaolaptrinh baolaptrinh Data 22 noiembrie 2014 09:55:56
Problema Descompuneri Scor 30
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.72 kb
uses math;
const
        tfi     =  'desc.in';
        tfo     =  'desc.out';
        nmax    =  5100;
TYPE
        arr     =array [1..nmax] of int64;
        arr1    =array [1..nmax,0..nmax] of longint;
        arr2    =array [1..nmax,0..nmax] of longint;
VAR
        fi,fo   :text;
        n       :int64;
        k,m,p   :longint;
        uoc     :arr;
        f,g     :arr1;
        d       :arr2;
Procedure nhap;
      Var
        i       :longint;
      Begin
        assign(fi,tfi);reset(fi);
          read(fi,n,k);
        close(fi);
      End;
Procedure doicho(var x,y:int64);
      Var
        tg      :int64;
      Begin
        tg:=x;
        x:=y;
        y:=tg;
      End;
Procedure sort(l,r:longint);
var
   i,j,key:longint;
      Begin
        i:=l;j:=r;
        key:=uoc[l+random(r-l+1)];
        Repeat
          while uoc[i]<key do inc(i);
          while uoc[j]>key do dec(j);
          if i<=j then
            begin
              doicho(uoc[i],uoc[j]);
              inc(i);
              dec(j);
            end;
        Until i>j;
        if i<r then sort(i,r);
        if l<j then sort(l,j);
      End;
Procedure khoitao;
      Var
        i,j,t   :longint;
      Begin
        for i:=2 to trunc(sqrt(n)) do
          if n mod i=0 then
            begin
              inc(p);
              uoc[p]:=i;
              inc(p);
              uoc[p]:=n div i;
            end;
        if uoc[p]=uoc[p-1] then dec(p);
        inc(p);uoc[p]:=n;
        sort(1,p);
        for i:=2 to p do
          begin
            t:=1;
            for j:=i downto 1 do
              if uoc[i] mod uoc[j]=0 then
                begin
                  while uoc[t]<uoc[i] div uoc[j] do inc(t);
                  if uoc[t]=uoc[i] div uoc[j] then d[i,j]:=t;
                end;
          end;
      End;
Procedure xuly;
      Var
        i,j     :longint;
      Begin
        f[1,1]:=1;
        g[1,1]:=1;
        for i:=2 to p do
          begin
            f[i,i]:=1;
            for j:=i-1 downto 1 do
              if d[i,j]<>0 then
                f[i,j]:=f[i,j]+g[d[i,j],j];
            g[i,i]:=1;
            for j:=i-1 downto 1 do g[i,j]:=g[i,j+1]+f[i,j];
          end;
        writeln(fo,g[p,1]);
      End;
Procedure trace(i,j,k:longint);
      Var
        t :longint;
      Begin
        for t:=j to p do
          if f[i,t]<k then k:=k-f[i,t]
          else
            begin
              write(fo,uoc[t],' ');
              if d[i,t]=0 then exit;
              trace(d[i,t],t,k);
              exit;
            end;
      End;
BEGIN
      assign(fo,tfo);rewrite(fo);
        nhap;
        khoitao;
        xuly;
        trace(p,1,k);
      close(fo);
END.