Re[5]: Aufgabe::tupledDivisors

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

Guten Morgen,

durch Beobachtung der Abläufe kann man noch knapp die Hälfte der Laufzeit  
sparen

In[1]:= Remove[tupledDivisors, branch, generatorQ, 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]]]
(* divisor generator ist ein sortiertes m-tupel {Subscript[f, \
1],Subscript[f, 2],...,Subscript[f, m-1],x} genau dann, wenn eine \
Zerlegung x = Subscript[f, Subscript[x, 1]] Subscript[f, Subscript[x, \
2]]mit Subscript[f, Subscript[x, 1]]>= Subscript[f, m-1] und \
Subscript[f, Subscript[x, 2]]>= Subscript[f, m-1] existiert. *)
generatorQ[l_List] := If[Length[l] < 2,
  True,
  (First[l] >
     1) && (Or @@ (LessEqual[l[[-2]], #] & /@
       First[Transpose[leaf[Last[l]]]]))
  ]
branch[l_List] :=
 Block[ (* handle distinct members of l only *) {z =
    Flatten[Thread /@
      Transpose[{Most[FoldList[Plus, 1, Length /@ #]],
          leaf /@ First /@ #} &[Split[l]]], 1]},
  Sort /@
   MapThread[
    Flatten[ReplacePart[#1, Rule @@ #2]] &, {Table[l, {Length[z]}], z}]
  ]
tupledDivisors[A_Integer?Positive, P_Integer?Positive] :=
 Nest[((Join[{1}, #] & /@ #) \[Union]
     Select[Flatten[branch /@ Select[#, generatorQ], 1],
      First[#] > 1 &]) &, {{P}}, A - 1]

In[7]:= Length[tupledDivisors[12, 8 5 7 18 36]] // Timing
Out[7]= {0.483, 6756}

In[23]:= (* 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[23]= {10.14, True}

Gruss
Udo.


> Die tupledDivisors[] laufen besser, wenn man die rekursive Formulierung  
> vereinfacht und den Gedanken implementiert, dass Divisortupeln, denen  
> man selbst wg. der Graduierung der Tupel eine 1 vorangestellt hat, von  
> branch[] nicht zu behandeln sind:
>
> <snip>
> In[6]:= Length[tupledDivisors[12, 8 5 7 18 36]] // Timing
> Out[6]= {0.858, 6756}
>
> Zeichen der immer noch vorhandenen Mehrfacherzeugung von Tupeln ist das  
> Union[]: Einem effizienten Algorithmus sollte ein Join[] reichen.