# Symbolic multiplicative partitions

Let $p_n\#\equiv\prod_{k=1}^{n}p_k$ (primorial):

p[n_] := Times @@ Prime[Range[n]]


then the multiplicative partitions of $p_{1,2,3,4}\#$ are

$$\{\{2\}\},$$$$\{\{6\},\{2,3\}\},$$$$\{\{30\},\{2,15\},\{3,10\},\{5,6\},\{2,3,5\}\},$$$$\{\{210\},\{2,105\},\{3,70\},\{5,42\},\{6,35\},\{7,30\},\{10,21\},\{14,15\},\{2,3,35\},\{2,5,21\},\{2,7,15\},\{3,5,14\},\{3,7,10\},\{5,6,7\},\{2,3,5,7\}\}$$ computed with

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]}]]];

z[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];

Table[z[p[n]], {n, 1, 4}]


What is the best way to turn this into a symbolic function, so the output of the above becomes $$\{\{a\}\}$$$$\{\{ab\}\},\{\{a,b\}\}$$$$\{\{abc\}\},\{\{a,bc\},\{b,ac\},\{c,ab\}\},\{\{a,b,c\}\}$$$$\{\{abcd\},\{a,bcd\},\{b,acd\},\{c,abd\},\{d,abc\},\{ab,cd\},\{ac,bd\},\{ad,bc\}, \{a,b,cd\},\{a,c,bd\},\{a,d,bc\},\{b,c,ad\},\{b,d,ac\},\{c,d,ab\},\{a,b,c,d\}\}$$ ?

The primorial example above is given for combinatorial simplicity. I would ideally like the function to be applicable to any number, e.g.: $72$ ($2^3\cdot 3^2$) would be tackled as $a^3\cdot b^2$.

Of course, it is possible to take this approach:

n = 4; ColumnForm[Map[FactorInteger[z[p[n]]][[#]] &, Range[Length[z[p[n]]]]]
/. 2 -> a /. 3 -> b /. 5 -> c /. 7 -> d]


... etc., but I wondered whether there was a more direct route?

NB - This question is an extension of this one.

# Update

Have got this far:

n = p[4];
m = ColumnForm[Map[FactorInteger[z[n]][[#]] &, Range[w[n]]]
/. 2 -> a /. 3 -> b /. 5 -> c /. 7 -> d];
ColumnForm[Table[Table[Map[m[[1, k]][[v]][[#]][[1]]^m[[1, k]][[v]][[#]][[2]] &,
Range[Length[m[[1, k]][[v]]]]], {v, 1, Length[m[[1, k]]]}], {k, 1, w[n]}]]


BTW, is there an easier way of doing

/. 2 -> a /. 3 -> b /. 5 -> c /. 7 -> d /. 11 -> e /. 13 -> f /.
17 -> g /. 19 -> h /.


...etc.?

-

<< Combinatorica
SetPartitions[{a, b, c, d}]
ru = Thread[{a, b, c, d} -> {2, 3, 5, 7}]
Apply[Times, SetPartitions[{a, b, c, d}] /. ru, {2}]


-
Ha! I have been somewhat over-complicating things then!! - except this is only applicable to primorials ... I can live with that though :) – martin May 27 '14 at 15:15
@Wouter, that's nice. – alancalvitti Oct 12 '14 at 17:15

I slightly modified the set partition code from the book Computational Discrete Mathematics by Pemmaraju and Skiena.

kSetPartitions[{}, 0] := {{}}
kSetPartitions[s_List, 0] := {}
kSetPartitions[s_List, k_Integer] := {} /; (k > Length[s])
kSetPartitions[s_List, k_Integer] := {Map[{#} &, s]} /; (k === Length[s])
kSetPartitions[s_List, k_Integer] :=
Block[{\$RecursionLimit = Infinity},
Union[Map[Sort, Join[
Union[Map[Sort, Map[Prepend[#, {First[s]}] &,
Union[Map[Sort, kSetPartitions[Rest[s], k - 1]]]]]],
Union[Map[Sort, Flatten[Map[
Table[Prepend[Delete[#, j], Prepend[#[[j]], s[[1]]]], {j, Length[#]}] &,
Union[Map[Sort, kSetPartitions[Rest[s], k]]]], 1]]]
]]]
] /; (k > 0) && (k < Length[s])


Use this in the following.

MartinPartitions[s_List]:=
Flatten[Map[Apply[Times, #, {2}] &,
Table[kSetPartitions[s, k], {k, 1, Length[s]}]], 1]


For example,

MartinPartitions[{a,b,c}]
(* {{a b c}, {a, b c}, {b, a c}, {c, a b}, {a, b, c}} *)


And, if I understood your question correctly,

MartinPartitions[{a,a,a,b,b}]
(* {{a^3 b^2}, {a, a^2 b^2}, {b, a^3 b}, {a^2, a b^2}, {a b,a^2 b}, {b^2, a^3},
{a, a, a b^2}, {a, b, a^2 b}, {a, a^2, b^2}, {a, a b, a b}, {b, b, a^3},
{b, a^2, a b}, {a, a, a, b^2}, {a, a, b, a b}, {a, b, b, a^2},
{a, a, a, b, b}} *)

-
MartinPartitions` (!!!) works nicely - thanks! :) – martin Aug 17 '15 at 10:46