3

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.?

Community
  • 1
martin
  • 8,678
  • 4
  • 23
  • 70

2 Answers2

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

should do what you asked.

Wouter
  • 1,343
  • 7
  • 11
2

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}} *)
KennyColnago
  • 15,209
  • 26
  • 62