Cod sursa(job #1026289)

Utilizator baolaptrinhbaolaptrinh baolaptrinh Data 11 noiembrie 2013 14:34:18
Problema Descompuneri Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 3.71 kb
Type
        mat=array [1..5000,1..5000] of int64;
Var     f:mat;
        a,kq:array [1..5000] of int64;
        n,kk:int64;
        m,top:longint;
        fi,fo:text;

Procedure Doc;
        Begin
                Readln(fi,n,kk);
        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:=a[l+random(r-l+1)];
                Repeat
                        While a[i]<key do inc(i);
                        While a[j]>key do dec(j);
                         If i<=j then
                          Begin
                                Doicho(a[i],a[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,k:longint;
        Begin
                For i:=2 to trunc(sqrt(n)) do
                 If n mod i=0 then
                  Begin
                        inc(m);
                        a[m]:=i;
                        inc(m);
                        a[m]:=n div i;
                  end;
                 inc(m);
                 a[m]:=n;
                 Sort(1,m);
                 For i:=1 to m do f[i,i]:=1;
                 For i:=1 to m do
                 Begin
                  k:=1;
                  For j:=i-1 downto 1 do
                   Begin
                    f[i,j]:=f[i,j]+f[i,j+1];
                    If a[i] mod a[j]=0 then
                     Begin
                        While (a[i] div a[j]>a[k]) do inc(k);
                        f[i,j]:=f[i,j]+f[k,j];
                     end;
                   end;
                 end;
        end;

Function Find(x:int64):longint;
        Var l,r,mid:longint;
        Begin
                l:=1;
                r:=m;
                While l<=r do
                 Begin
                        mid:=(l+r) div 2;
                        If a[mid]=x then exit(mid)
                        else If a[mid]>x then r:=mid-1
                        else l:=mid+1;
                 end;
                exit(0);
        end;

Procedure Lam;
        Var i,j,k,t:longint;
           tg,x:int64;
        Begin
                Khoitao;
                Writeln(fo,f[m,1]);
                j:=1;
                Repeat
                        tg:=0;
                        For i:=j to m do
                        If n mod a[i]=0 then
                         Begin
                                If n div a[i]=1 then break;
                                k:=Find(n div a[i]);
                                If k<>0 then
                                Begin
                                x:=f[k,i];
                                If tg+x>=kk then break;
                                tg:=tg+x;
                                end;
                         end;
                        inc(top);
                        kq[top]:=a[i];
                        j:=i;
                        n:=n div a[i];
                        kk:=kk-tg;
                Until n=1;
                For i:=1 to top do Write(fo,kq[i],' ');
        end;

Procedure Inkq;
        Begin
        end;

        Begin
                Assign(fi,'desc.in');Reset(fi);
                Assign(fo,'desc.out');Rewrite(fo);
                        Doc;
                        Lam;
                        Inkq;
                Close(fo);Close(fi);
        end.