Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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 :/

share|improve this question
1  
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 at 17:34
    
@SquareOne Thanks for the interest, please see update :) –  martin Oct 29 at 17:39

2 Answers 2

up vote 1 down vote accepted

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

enter image description here

or if you prefer :

(Times @@@ #) & /@ res

enter image description here

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

enter image description here


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 :

enter image description here

share|improve this answer
    
this is great!! Thank you very much - will have a play now :) –  martin Oct 29 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 at 20:26
    
this works really wel :) - Would it be possible to add an extra exponent a -> aaa? –  martin Oct 29 at 20:51
    
@martin Please see my update. –  SquareOne Oct 30 at 2:05
    
the update is great - works really well - thank you so much :) –  martin Oct 30 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}}

enter image description here

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

enter image description here

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

enter image description here


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] & 

enter image description here

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

enter image description here

share|improve this answer
    
this is fantastic! Thank you so much!! :) –  martin Oct 29 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? –  kguler Oct 29 at 19:54
    
doesn't matter at all :) –  martin Oct 29 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 at 20:17
    
note - I changed f to ff to accomodate new f –  martin Oct 29 at 20:18

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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