Re[3]: Aufgabe::tupledDivisors

["Udo und Susanne Krause" <su.krause@XXXXXXX.ch>]

Hello again,

> In[14]:= With[{N = 10},
>    Table[Length[
>       tupledDivisors[12, Times @@ Table[Prime[j], {j, A}]]], {A, N}] ==
>      BellB[Range[N]]
>    ] // Timing
>
> Out[14]= {196.468, True}

branch[] kann schneller laufen, indem es nur verschiedene Elemente der  
_geordneten_ Liste l behandelt. Das Feststellen der Ersetzungspositionen  
braucht weniger Zeit als das Auskämmen der Duplikate in der Berechnung von  
z. Das verbliebene DeleteDuplicates[] in branch[] kann nur mit einer  
zusätzlichen Idee vermieden werden, denn ohne weiteres führen z.B.  
Zwischenergebnisse {4, 4, 8} und {2, 4, 16} auf der nächsten Stufe beide  
zu {2, 2, 4, 8}.

In[1]:= Remove[tupledDivisors, branch, leaf]
leaf[o_Integer /; PrimeQ[o]] := leaf[o] = {{1, o}}
leaf[o_Integer /; ! PrimeQ[o]] := leaf[o] = (* Skip {1,o} terms *)
  Rest[Take[Transpose[{#, Reverse[#]} &[#]], Ceiling[Length[#]/2]] &[
    Divisors[o]]]
branch[l_List] :=
 Block[ (* handle distinct members of l only *) {z =
    Flatten[Thread /@
      Transpose[{Most[FoldList[Plus, 1, Length /@ #]],
          leaf /@ First /@ #} &[Split[l]]], 1]},
  DeleteDuplicates[
   Sort /@ MapThread[
     Flatten[ReplacePart[#1, Rule @@ #2]] &, {Table[l, {Length[z]}],
      z}]]
  ]
tupledDivisors[A_Integer, l_List] :=
 ((Join[{1}, #] & /@ #) \[Union] Flatten[branch /@ #, 1]) &[
   tupledDivisors[A - 1, l]] /; A > Length[l]
tupledDivisors[A_Integer, l_List] := l /; A == Length[l]
tupledDivisors[A_Integer?Positive, P_Integer?Positive] :=
 tupledDivisors[A, {{P}}]

In[8]:= (* rekursiv optimiert *)
Length[tupledDivisors[12, 8 5 7 18 36]] // Timing

Out[8]= {5.616, 6756}

In[10]:= With[{N = 29,(* jede Primzahl funktioniert hier *) x = 17},
 Table[Length[tupledDivisors[N, x^A]], {A, N}] ==
  Table[Length[IntegerPartitions[A]], {A, N}]
 ]

Out[10]= True

In[11]:= With[{N = 10},
  Table[Length[
     tupledDivisors[12, Times @@ Table[Prime[j], {j, A}]]], {A, N}] ==
    BellB[Range[N]]
  ] // Timing

Out[11]= {162.335, True}

Gruss
Udo.