Cod sursa(job #1026840)

Utilizator hungntnktpHungntnktp hungntnktp Data 12 noiembrie 2013 03:22:23
Problema Descompuneri Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.13 kb
USES math;
CONST
        tfi     ='desc.in';
        tfo     ='desc.out';
        nmax    =4000;
TYPE
        arr     =array [1..nmax] of int64;
        arr1    =array [1..nmax,1..nmax] of longint;
VAR
        fi,fo   :text;
        n       :int64;
        k,m,p   :longint;
        c       :arr;
        f       :arr1;
 (***********************************************************************)
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     :longint;
        key     :int64;
      Begin
        i:=l;j:=r;
        key:=c[l+random(r-l+1)];
        Repeat
          while c[i]<key do inc(i);
          while c[j]>key do dec(j);
          if i<=j then
            begin
              doicho(c[i],c[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);
              c[p]:=i;
              inc(p);
              c[p]:=n div i;
            end;
        if c[p]=c[p-1] then dec(p);
        inc(p);c[p]:=n;
        sort(1,p);
      End;
 (***********************************************************************)
Procedure lam;
      Var
        i,j,t   :longint;
      Begin
        f[1,1]:=1;
        for i:=2 to p do
          begin
            f[i,i]:=1;
            t:=1;
            for j:=i-1 downto 1 do
              if c[i] mod c[j]=0 then
                begin
                  while c[t]<c[i] div c[j] do inc(t);
                  if c[t]=c[i] div c[j] then
                    f[i,j]:=f[i,j]+f[t,j];
                end;
            for j:=i-1 downto 1 do f[i,j]:=f[i,j+1]+f[i,j];
          end;
        writeln(fo,f[p,1]);
      End;
 (************************************************************************)
Procedure truyvet(i,j,k:longint);
      Var
        t,l     :longint;
      Begin
        for t:=j to p do
          if f[i,t]-f[i,t+1]<k then k:=k-(f[i,t]-f[i,t+1])
          else
            begin
              write(fo,c[t],' ');
              for l:=i downto 1 do
                if c[i] div c[t]=c[l] then
                  begin
                    truyvet(l,t,k);
                    break;
                  end;
              exit;
            end;
      End;
 (************************************************************************)
BEGIN
      assign(fo,tfo);rewrite(fo);
        nhap;
        khoitao;
        lam;
        truyvet(p,1,k);
      close(fo);
END.