1
$\begingroup$

I have the following lists:

l1 = {{a,b},{a,c},{a,d},{a,e},{a,f}};
l2 = {{b,c},{b,d},{b,e},{b,f}};
l3 = {{c,d},{c,e},{c,f}};
l4 = {{d,e},{d,f}};
l5 = {e,f};

I want to create a list of combinations of exactly three of the above sublists, with no repeating elemenst. It should look like:

L = {{{a,b},{c,d},{e,f}},{{a,b},{c,e},{d,f}},...,{{{a,c},{b,d},{e,f}}...};

For example, for four lists $l$ with elements {a,b,c,d}, the final list should look like this:

L = {{{a,b},{c,d}},{{a,c},{b,d}},{{a,d},{b,c}}};

For five lists $l$, the dimensions should be {15,3,2}, but I want to generalize this for more lists $l$. As the dimension of $L$ grows as $n!!$, I'm trying to write a general code.
Is there an easy way to do this? Thank you!

EDIT

As chyanog pointed out in the comments, this question has been answered here. The following function posted by Rojo gives a general list $L$ of dimensions $\{n!!,\frac{n}{2},l\}$:

  partitions[list_, l_] := Join @@
  Table[
    {x, ##} & @@@ partitions[list ~Complement~ x, l],
    {x, Subsets[list, {l}, Binomial[Length[list] - 1, l - 1]]}
  ]

partitions[list_, l_] /; Length[list] === l := {{list}}

, and to get the lists I'm looking for, $l=2$.

$\endgroup$
1

1 Answer 1

2
$\begingroup$

Wasteful but general code that uses the numbers $1\ldots n$ instead of variables $\{a,b,c,\ldots\}$:

f[n_ /; n >= 2 && EvenQ[n]] := 
  Select[Subsets[Subsets[Range[n], {2}], {n/2}], 
         DuplicateFreeQ@*Flatten]

f[2]
(*    {{{1, 2}}}    *)

f[4]
(*    {{{1, 2}, {3, 4}},
       {{1, 3}, {2, 4}},
       {{1, 4}, {2, 3}}}    *)

f[6]
(*    {{{1, 2}, {3, 4}, {5, 6}}, {{1, 2}, {3, 5}, {4, 6}},
       {{1, 2}, {3, 6}, {4, 5}}, {{1, 3}, {2, 4}, {5, 6}},
       {{1, 3}, {2, 5}, {4, 6}}, {{1, 3}, {2, 6}, {4, 5}},
       {{1, 4}, {2, 3}, {5, 6}}, {{1, 4}, {2, 5}, {3, 6}},
       {{1, 4}, {2, 6}, {3, 5}}, {{1, 5}, {2, 3}, {4, 6}},
       {{1, 5}, {2, 4}, {3, 6}}, {{1, 5}, {2, 6}, {3, 4}},
       {{1, 6}, {2, 3}, {4, 5}}, {{1, 6}, {2, 4}, {3, 5}},
       {{1, 6}, {2, 5}, {3, 4}}}                              *)

Table[Length[f[n]], {n, 2, 12, 2}]
(*    {1, 3, 15, 105, 945, 10395}    *)

This procedure is easily extended to splitting $n$ numbers (symbols) into non-overlapping bunches of $k$:

f[n_Integer?Positive, k_Integer?Positive] /; Divisible[n, k] :=
  Select[Subsets[Subsets[Range[n], {k}], {n/k}],
         DuplicateFreeQ@*Flatten]

f[6, 1]
(*    {{{1}, {2}, {3}, {4}, {5}, {6}}}    *)

f[6, 2]
(*    {{{1, 2}, {3, 4}, {5, 6}},
       {{1, 2}, {3, 5}, {4, 6}},
       {{1, 2}, {3, 6}, {4, 5}},
       {{1, 3}, {2, 4}, {5, 6}},
       {{1, 3}, {2, 5}, {4, 6}},
       {{1, 3}, {2, 6}, {4, 5}},
       {{1, 4}, {2, 3}, {5, 6}},
       {{1, 4}, {2, 5}, {3, 6}},
       {{1, 4}, {2, 6}, {3, 5}},
       {{1, 5}, {2, 3}, {4, 6}},
       {{1, 5}, {2, 4}, {3, 6}},
       {{1, 5}, {2, 6}, {3, 4}},
       {{1, 6}, {2, 3}, {4, 5}},
       {{1, 6}, {2, 4}, {3, 5}},
       {{1, 6}, {2, 5}, {3, 4}}}    *)

f[6, 3]
(*    {{{1, 2, 3}, {4, 5, 6}},
       {{1, 2, 4}, {3, 5, 6}},
       {{1, 2, 5}, {3, 4, 6}},
       {{1, 2, 6}, {3, 4, 5}},
       {{1, 3, 4}, {2, 5, 6}},
       {{1, 3, 5}, {2, 4, 6}},
       {{1, 3, 6}, {2, 4, 5}},
       {{1, 4, 5}, {2, 3, 6}},
       {{1, 4, 6}, {2, 3, 5}},
       {{1, 5, 6}, {2, 3, 4}}}    *)

f[6, 6]
(*    {{{1, 2, 3, 4, 5, 6}}}    *)
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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