Symbolic combinations

If I have 3 lists: {a,a},{b,b},{c,c}, then the desired output is

{{a,b c}, {a b,c}, {a c,b},
{a a,b c}, {a a b,c}, {a a c,b},
{a,b b c}, {a b b,c}, {a c,b b},
{a,b c c}, {a b,c c}, {a c c,b},
{a a,b b c}, {a a b b,c}, {a a c,b b},
{a,b b c c}, {a b b,c c}, {a c c,b b},
{a a,b c c}, {a a b,c c}, {a a c,b b},
{a a,b b c c}, {a a b b,c c},{a a c c,b b}}


This gets some of the way there

list = SetPartitions[{a, a, b, b, c, c}];
list1 = DeleteDuplicates@
Flatten[{DeleteDuplicates@
Take[Table[Times @@ Rest[list][[n, 1]], {n, 1, Length@list}],
Length@list - 1],
DeleteDuplicates@
Take[Table[Times @@ Rest[list][[n, 2]], {n, 1, Length@list}],
Length@list - 1]}];
Transpose[{list1, Reverse@list1}]


but there are some anomalies.

This does it (I think)

{Most@Rest@SetPartitions[{a, b, c}],
Most@Rest@SetPartitions[{a a, b, c}],
Most@Rest@SetPartitions[{a a, b b, c}],
Most@Rest@SetPartitions[{a a, b b, c c}],
Most@Rest@SetPartitions[{a , b b, c}],
Most@Rest@SetPartitions[{a , b b, c c}],
Most@Rest@SetPartitions[{a a, b , c c}],
Most@Rest@SetPartitions[{a a, b b, c }],
Most@Rest@SetPartitions[{a a, b b, c c}]}


but I'm not sure if it works for larger sets - eg {a,a,a,b,b,b,c,c,c,d,d,d}, and I'm sure there is a cleaner way of doing it.

Update

For larger set:

{a,b c d} {a a, b c d} {a a c, b b d d}

are all OK, but

{a, a b c d}

is not, because a is in parts 1 and part two of the pair.

Also,

{b,c d d}

isn't, because not all elements a,b,c,d are included.

list2 = {c^2, a^2, b^2, c, a, b};
list3 = DeleteDuplicates@
Sort@Flatten@Table[list2[[i]]*list2[[j]], {i, 1, 6}, {j, 1, i - 1}];
Transpose[{list3, Reverse@list3}]


Is another attempt - not going too well here :/

-
Could you give few elements of the desired output for a larger set (a,b,c,d) ? Still pairs ? For example: {a,bcd} ? but not {a,bdc} ? not {bcd,a} ? Right ? – SquareOne Oct 29 '14 at 17:34
@SquareOne Thanks for the interest, please see update :) – martin Oct 29 '14 at 17:39

Update

Update to take into account any "power" and list size as requested.

Here you just define what you want :

list = {a, b, c};
power=3;


Then just run these steps :

replist = Table[{# -> #^i}, {i, power}] & /@ list;
s1 = Subsets[Rest@list][[1 ;; -2]];
s2 = {Join[{First@list}, #], Complement[Rest@list, #]} & /@ s1;
res = Fold[ReplaceAll, s2, replist] // Flatten[#, Length@list] &


gives here

or if you prefer :

(Times @@@ #) & /@ res


Original post

Here is a solution in 2 steps.

1. I think that first the most important is to form all the pair combinations including only the single letters (a not aa, b not bb, ...). This can be achieved with Subsets.

list={b,c};
s1 = Subsets[list][[1 ;; -2]]
s2 = {Join[{a}, #], Complement[list, #]} & /@ s1


gives

{{}, {b}, {c}}
{{{a}, {b, c}}, {{a, b}, {c}}, {{a, c}, {b}}}


s2contains already the correct "shape" of the final solution : if you replace a by aa (b by bb, etc ...) you notice that the lists are part of the solutions. You just need to form all possible substitutions ...

2. This can be achieved with :

res = Fold[{#, ReplaceAll[##]} &, s2, {a -> aa, b -> bb, c -> cc}] // Flatten[#, Length@list+1] &


gives

Application for the subset {a,b,c,d} :

list = {b, c, d};
s1 = Subsets[list][[1 ;; -2]]
s2 = {Join[{a}, #], Complement[list, #]} & /@ s1
res = Fold[{#, ReplaceAll[##]} &, s2, {a -> aa, b -> bb, c -> cc, d -> dd}] // Flatten[#, Length@list + 1] &


gives the following steps :

-
this is great!! Thank you very much - will have a play now :) – martin Oct 29 '14 at 19:52
If I wanted to go to higher powers of a,b,c,d, is that possible? eg- a->aaaa , etc? – martin Oct 29 '14 at 20:26
this works really wel :) - Would it be possible to add an extra exponent a -> aaa? – martin Oct 29 '14 at 20:51
@martin Please see my update. – SquareOne Oct 30 '14 at 2:05
the update is great - works really well - thank you so much :) – martin Oct 30 '14 at 12:54

Update:

ClearAll[f2];
Join @@ (With[{k = #}, (Times @@@ {Complement[k, #], #}) & /@ Subsets[k, {2}]] & /@
Tuples[{#1, Times@##} & @@@ #]) &;

f2@{{a, a}, {b, b}, {c, c}}


f2@{{a, a, a, a}, {b, b, b, b}, {c, c, c, c}}


f2@{{a, a}, {b, b}, {c, c}, {d, d}}


Original post:

ClearAll[f1];
f1 = With[{k = #}, Times @@@ SortBy[#, First] & /@ ({Complement[k, #], #} & /@ Subsets[k, {2}])] &;

list = {{a, a}, {b, b}, {c, c}};
nlist = {#1, HoldForm[Times@##]} & @@@ list;
f1 /@ Tuples[nlist] // Grid[#, Alignment -> Left] &


list = {{a, a}, {b, b}, {c, c}, {d, d}};
nlist = {#1, HoldForm[Times@##]} & @@@ list;
f1 /@ Tuples[nlist] // Grid[#, Alignment -> Left] &


-
this is fantastic! Thank you so much!! :) – martin Oct 29 '14 at 19:50
@martin, my pleasure. I was worried that you wanted the final list in a specific order. Can we assume that ordering of elements does not matter? – kglr Oct 29 '14 at 19:54
doesn't matter at all :) – martin Oct 29 '14 at 19:56
If I try list = {Table[a, {x, 1, exp}], Table[b, {x, 1, exp}], Table[c, {x, 1, exp}], Table[d, {x, 1, exp}], Table[e, {x, 1, exp}], Table[f, {x, 1, exp}], Table[g, {x, 1, exp}], Table[h, {x, 1, exp}]}; nlist = {#1, Times@##} & @@@ list; Take[ff /@ Tuples[nlist], 10] it seems to jump straight to 4th power. Is there any way of keeping lower powers in there? – martin Oct 29 '14 at 20:17
note - I changed f to ff to accomodate new f – martin Oct 29 '14 at 20:18