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 yesterday
    
@SquareOne Thanks for the interest, please see update :) –  martin yesterday

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 yesterday
    
If I wanted to go to higher powers of a,b,c,d, is that possible? eg- a->aaaa , etc? –  martin yesterday
    
this works really wel :) - Would it be possible to add an extra exponent a -> aaa? –  martin yesterday
    
@martin Please see my update. –  SquareOne yesterday
    
the update is great - works really well - thank you so much :) –  martin 18 hours ago

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 yesterday
    
@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 yesterday
    
doesn't matter at all :) –  martin yesterday
    
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 yesterday
    
note - I changed f to ff to accomodate new f –  martin yesterday

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.