Cod sursa(job #1026205)

Utilizator hungntnktpHungntnktp hungntnktp Data 11 noiembrie 2013 12:50:38
Problema Descompuneri Scor 80
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.25 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;
        c       :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     :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);
        for i:=2 to p do
          begin
            t:=1;
            for j:=i 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 d[i,j]:=t;
                end;
          end;
      End;
 (***********************************************************************)
Procedure lam;
      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 truyvet(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,c[t],' ');
              if d[i,t]=0 then exit;
              truyvet(d[i,t],t,k);
              exit;
            end;
      End;
 (************************************************************************)
BEGIN
      assign(fo,tfo);rewrite(fo);
        nhap;
        khoitao;
        lam;
        truyvet(p,1,k);
      close(fo);
END.