Re: Aufgabe::tupledDivisors

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

Hallo Peter,

> Wenn man beim Prozess des sukzessiven Anhängens kleiner Teiler am Anfang
> der Faktorenlisten die Listen rausschmeißt, die zu hohe Produkte
> bekommen haben und diejenigen, die exakt stimmen, speichert, aber der
> weiteren Bearbeitung entzieht, scheint sich der Aufwand in tolerablen
> Grenzen zu halten (siehe Anhang).

td[] besteht den ersten Plausibilitätstest

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

Out[9]:= True

problemlos, jedoch den zweiten

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

Out[10]:= $Aborted

nicht: der Memorybedarf ist > 3.7 GB
(nach dem Start von Mma sind 1.06 GB belegt auf diesem Rechner (4 GB RAM,
Windows 7 64 Bit Home Edition)), man kann nicht auf das Ergebnis warten,  
weil
der Rechner swapped (CPU Auslastung < 20%). Kommt dieser Test auf Ihrem  
Rechner
zu einem Schluss und wenn ja, in welcher Zeit mit welchem Speicherbedarf?
_________________________________________________________________________
Ich dachte zunächst mit package help an

In[1]:= (* Solution with Combinatorica *)
Remove[tupledDivisors]
Needs["Combinatorica`"]
tupledDivisors[A_Integer?Positive, P_Integer?Positive] :=
 Block[{l =
    Flatten[Join[Table[#[[1]], {o, #[[2]]}] & /@ FactorInteger[P]],
     1]},
  PadLeft[#, A, 1] & /@ If[A > Length[l],
    DeleteDuplicates[Sort /@ Apply[Times, SetPartitions[l], {2}]],
    DeleteDuplicates[
     Sort /@ Flatten[
       Join[Table[Apply[Times, KSetPartitions[l, k], {2}], {k, A}]],
       1]]
    ]
  ]

aber das ist langsam

In[4]:= (* mit Combinatorica *)
Length[tupledDivisors[12, 8 5 7 18 36]] // Timing

Out[4]= {34.445, 6756}

deshalb wurde daraus eine rekursive Funktion

In[5]:= 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[{z = Flatten[Thread /@
      DeleteDuplicates[
       Transpose[{Range[Length[#]], #} &[
         leaf /@ l]], (#1[[-1]] == #2[[-1]]) &], 1]},
  (* For all one {1,o} term *)
  If[And @@ Not /@ PrimeQ[l], Join[{{1, {1, First[l]}}}, z]];
  DeleteDuplicates[
   Sort /@ MapThread[
     Flatten[ReplacePart[#1, #2[[1]] -> #2[[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[12]:= Length[tupledDivisors[12, 8 5 7 18 36]] // Timing

Out[12]= {6.988, 6756}

langsamer als td[] an der Stelle, und

In[13]:= (* This is http://oeis.org/A000041, the number of partitions \
of n *)
With[{N = 29,(* jede Primzahl funktioniert hier *) x = 17},
 Table[Length[tupledDivisors[N, x^A]], {A, N}] ==
  Table[Length[IntegerPartitions[A]], {A, N}]
 ]

Out[13]= True

ebenfalls langsamer als td[], jedoch

In[14]:= (* This is http://oeis.org/A000110, Bell or exponential \
numbers: ways of placing n labeled balls into n indistinguishable \
boxes. *)
With[{N = 10},
  Table[Length[
     tupledDivisors[12, Times @@ Table[Prime[j], {j, A}]]], {A, N}] ==
    BellB[Range[N]]
  ] // Timing

Out[14]= {196.468, True}

Übrigens,

Table[{A, Length[tupledDivisors[12, Times @@ Table[Prime[j], {j, A}]]]},  
{A, 10}]

{{1, 1}, {2, 2}, {3, 5}, {4, 15}, {5, 52}, {6, 203}, {7, 877},
 {8, 4140}, {9, 21147}, {10, 115975}}

die nächste Zahl in Sloane's A000110 ist 678570, somit wird  
tupledDivisors[] ganz sicher
von beschränktem praktischen Interesse bleiben, so bald Zahlen mit vielen  
(> 10)
verschiedenen Primfaktoren zu betrachten sind.

> Frohe Ostern!

Frohe Ostern & Gruss
Udo.