4
$\begingroup$

I am trying to create a multiplicative partition function that would generate something like

f[12]
(*{{2, 2, 3}, {4, 3}, {6, 2}}*)
f[24]
(*{{2, 2, 2, 3}, {2, 2, 6}, {4, 2, 3}, {8, 3}, {12, 2}, {4, 6}}*)
f[48]
(*{{2, 2, 2, 2, 3}, {2, 2, 2, 6}, {4, 2, 2, 3}, {2, 2, 12}, {2, 3, 8}, {2, 4, 6}, 
{4, 4, 3}, {6, 8}, {4, 12}, {3, 16}, {2, 24}}*)

I have got as far as

n = 30;
i = FactorInteger[n];
r = Range[Length[i]];
Join[{f = Flatten[Map[Table[i[[#]][[1]], {x, 1, i[[#]][[2]]}] &, r]]},
Transpose[{d = DeleteDuplicates[f], Map[n/d[[#]] &, Range[Length[d]]]}]]

but it is turning out to be more complicated than I thought. Is there a more efficient way of tackling this?

Update

Have got a little further, but still missing some:

n = 48;
i = FactorInteger[n];
r = Range[Length[i]];
f = Flatten[Map[Table[i[[#]][[1]], {x, 1, i[[#]][[2]]}] &, r]];
p = Drop[Drop[DeleteDuplicates[Subsets[f]], 1], -1];
d = Split[Drop[Drop[Reverse[Divisors[n]], 1], -1]];
Drop[Map[Sort[Join[p[[#]], d[[#]]]] &, Range[Length[d]]], -1]
$\endgroup$
  • 1
    $\begingroup$ Looked at that but can't see how that would help? Also looked at Combinatorica package - will keep going ... $\endgroup$ – martin May 26 '14 at 19:07
  • 2
    $\begingroup$ Please see the Mathematica Journal article on factorizations by Knopfmacher and Mays, volume 10, number 1. They give code to find multiplicative partitions, and counts of the numbers of such partitions. A similar question has been asked here. $\endgroup$ – KennyColnago May 26 '14 at 22:52
  • $\begingroup$ Thank you! Lots of choice now for further exploration :) $\endgroup$ – martin May 26 '14 at 23:13
6
$\begingroup$

A slightly more compact form of belisarius's answer (differs in that factors are pooped out in descending order of maximum factor in a set):

f2[x_] := 
 DeleteDuplicates[Sort /@ Map[Times @@ # &, 
    SetPartitions[Flatten[ConstantArray @@@ FactorInteger[x]]], {2}]]

Tiny bit more efficient, but really in the noise - both are probably about as efficient as is reasonable: You'd have to prevent creation of duplicate subsets (for later multiplication) to improve much, and I'd venture doing that would eat more time than just using them and deleting dupes post-hoc...

As to your comment question: A001055

ClearAll[c, r, ds, n, a];

c[1, r_] := c[1, r] = 1;

c[n_, r_] := 
  c[n, r] = 
   Module[{ds, i}, ds = Select[Divisors[n], 1 < # <= r &]; 
    Sum[c[n/ds[[i]], ds[[i]]], {i, 1, Length[ds]}]];

a[n_] := c[n, n];

(* count *)
a[1000]

(* calculate and get length to verify *)
Length@f2[1000]

(*

31
31

*)

Vastly faster for large n than calculating fully...

Update: Poking around A162247

g[lst_, p_] := 
 Module[{t, i, j}, 
  Union[Flatten[
    Table[t = lst[[i]]; t[[j]] = p*t[[j]]; 
     Sort[t], {i, Length[lst]}, {j, Length[lst[[i]]]}], 1], 
   Table[Sort[Append[lst[[i]], p]], {i, Length[lst]}]]]; 

f[n_] := Module[{i, j, p, e, lst = {{}}}, {p, e} = 
   Transpose[FactorInteger[n]]; 
  Do[lst = g[lst, p[[i]]], {i, Length[p]}, {j, e[[i]]}]; lst];

f[12]

(* {{12}, {2, 6}, {3, 4}, {2, 2, 3}} *)

But much faster on larger numbers than f2 (but still not as fast as count-only...)

$\endgroup$
  • $\begingroup$ Great - it is getting shorter & shorter! BTW, is there any way of counting the number of multiplicative partitions without actually calculating them? $\endgroup$ – martin May 26 '14 at 21:31
  • $\begingroup$ eg n = 12; Length[f2[Times @@ Prime[Range[n]]]] $\endgroup$ – martin May 26 '14 at 21:41
  • $\begingroup$ @martin: see update. There's probably a faster way than this, but it's plenty fast... $\endgroup$ – ciao May 26 '14 at 21:52
  • $\begingroup$ Great :) - still struggles with large n but I presume Divisors is the limiting function - don't think I can overcome that!! $\endgroup$ – martin May 26 '14 at 21:56
  • $\begingroup$ @martin: Check update - faster way to get full results. $\endgroup$ – ciao May 27 '14 at 5:45
2
$\begingroup$

I think I'm over-complicating it. Anyway:

<< Combinatorica`
f[x_] := DeleteDuplicates[
  Sort /@ Flatten[
    Apply[Times, (SetPartitions /@ 
       Flatten /@ 
        Tuples[Flatten[{#[[1]]^IntegerPartitions@#[[2]]} & /@ 
           FactorInteger[x], 1]]), {3}], 1]]}

f[24] // Column
(*
{24}
{3,8}
{4,6}
{2,12}
{2,3,4}
{2,2,6}
{2,2,2,3} 
*)
$\endgroup$
  • $\begingroup$ Wow - this is great - my head was really starting to ache!! $\endgroup$ – martin May 26 '14 at 20:03
  • $\begingroup$ Well, OP's example lacks of {24}. $\endgroup$ – Kuba May 26 '14 at 20:03
  • 1
    $\begingroup$ @Kuba And {2, 2, 6} $\endgroup$ – Dr. belisarius May 26 '14 at 20:04
  • $\begingroup$ @ Kuba, I thought that if I include 1 as factor things might get a little awkward ... $\endgroup$ – martin May 26 '14 at 20:04
  • $\begingroup$ @martin Don't feel the urge to accept. I'm sure it can be done much more efficiently. $\endgroup$ – Dr. belisarius May 26 '14 at 20:15
2
$\begingroup$

Here's another implementation that performs very similarly to ciao's f. It's a recursive approach using memoization. Maybe someone can see a clever way to speed this up some more...?

MultiplicativePartitions[1] := {{1}}
MultiplicativePartitions[x_] := MultiplicativePartitions[x] = 
  DeleteDuplicatesBy[
   If[PrimeQ[x],
    {{x}},
    Flatten[
     Prepend[
      Table[(Flatten[{#, x/i}] & /@ MultiplicativePartitions[i]), {i, 
        Divisors[x][[2 ;; -2]]}],
      {{x}}
      ],
     1]
    ],
   Sort
   ]

MultiplicativePartitions[12]

{{12}, {2, 6}, {3, 4}, {2, 2, 3}}

Calculation the multiplicative partitions of all numbers up to $n$ for $n = 10, 100, 1000, 10000, 50000$ (clearing the memoized values each time), the timings for this and ciao's f are very similar:

enter image description here

I don't hold out much hope for scaling my solution to $n \gg 10000$ as the scaling of Divisors is no better...!

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.