Find all the possible ways of partitioning a list into a set of pairs of element

Question

I have a list {x1,...,xN} where N is even, and I need to find all the possible ways to split it into pairs of elements, e.g. the output I would like is something like (say N = 4):

{{{x1,x2},{x3,x4}},{{x1,x3}{x2,x4}},...}

How can this be achieved?

Answer 1

My take:

genIdx[n_?EvenQ] := 
  Flatten@With[{r = Range@n}, Fold[With[{l1 = #, l2 = #2},
       Flatten[Map[With[{la = #, c = Complement[r, #]}, 
           Join[la, c[[#]]] & /@ l2] &, l1], 1]] &, 
     Subsets[Range@#, {2}, # - 1] & /@ Range[#, 2, -2] &@n]];

xformLst[lst_, idx_] :=
  If[(Length@lst*(Length@lst - 1)!!) == Length@idx, 
   With[{l = Length@lst}, ArrayReshape[lst[[idx]], {(l - 1)!!, l/2, 2}]], Abort[]];

Use examples:

source = {x1, x1, x3, x4} 
xformLst[source, genIdx@Length@source]

(* {{{x1, x1}, {x3, x4}}, {{x1, x3}, {x1, x4}}, {{x1, x4}, {x1, x3}}} *)

On its own, including genIdx time, this was ~15X faster than fastest answer so far on a list of length 14 (caveats as usual for loungebook performance).

However, the prime benefit is amortization of time over multiple lists to be transformed (I assume you're doing this for more than some one-shot). One simply uses genIdx to generate and save the index set(s) for the size(s) of lists to be transformed, once, and supply those to the transformation function, e.g.

source = {x1, x1, x3, x4};
idx4= genIdx@4;
result=xformLst[source,idx4];

Using this for tests against multiple randomly generated lists of length 14 showed it to be ~500X faster than the fastest answer so far posted...

Only rudimentary error checking is done (e.g., even length argument, will abort if called with list length not matching required index list) - season as desired.

Update: An explanation of what's going on...

I viewed this as a problem of getting the most efficient way of picking items from the source list in the needed order. I chose to do this as a flattened index, since nearly always grabbing with something like list[[{n1,n2,...nm}]] is faster than alternatives like say Map[list[[#]]&,{n1,n2,...}] and the like.

Let's use an example case of lists of length 6. For the output the OP is after, that means the first two positions picking for the first pair look like this:

{{1, 1, 0, 0, 0, 0}, {1, 0, 1, 0, 0, 0}, {1, 0, 0, 1, 0, 0}, 
 {1, 0, 0,0, 1, 0}, {1, 0, 0, 0, 0, 1}}

You'll note that is precisely described by

Subsets[Range@6, {2}, 5]
(* {{1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 6}} *)

For the next two positions to pick, we can only fill places not already occupied. So, we treat those as lists of length 4, meaning the picks look like

{{1, 1, 0, 0}, {1, 0, 1, 0}, {1, 0, 0, 1}}

and are precisely described by

Subsets[Range@4, {2}, 3]
(* {{1, 2}, {1, 3}, {1, 4}} *)

This continues until there are only two empty slots left, whatever the length of the source list.

This cascade of subset results forms the basis for our work, and is built via the part of the code

Subsets[Range@#, {2}, # - 1] & /@ Range[#, 2, -2] &@n

So for the length 6 example, we'd have a basis of

{{{1, 2}, {1, 3}, {1, 4}, {1, 5}, {1, 6}}, {{1, 2}, {1, 3}, {1, 4}}, {{1, 2}}}

N.b.: the #-1 term that reduces the length of the subsets returned hides a pretty relationship: we can extend this method to arbitrary sizes (triplets, etc.) by using the appropriate values for cut-offs there, and these are just the appropriate order figurate numbers.

Once we have the basis, we Fold over that list. For each sub-result, we derive what actual position(s) are available for that round (by Complementing the positions already taken with the span of possible positions), and then select from those using the appropriate subset(s) of those positions.

The end result is then just Flattened out to increase efficiency at picking the items from the list in the needed order, the result of which is then reshaped into the final form.

Answer 2

Not efficient:

<< Combinatorica`
list = {a, a, c, d};
idx[n_] := Select[SetPartitions[n], Union[Length /@ #] == {2} &];
confs[set_] := Map[set [[#]] &, idx[Length@set], {2}]
confs@list
(* {{{a, a}, {c, d}}, {{a, d}, {a, c}}, {{a, c}, {a, d}}} *)

Answer 3

Here's a completely different and non-bruteforcing approach, so I'm adding it as a separate answer.

Helper function:

help[list_] := Join[{First@list}, #] & /@ Rest@list

Main function:

iterate[list_List /; Length@list < 3] := {{list}}
iterate[list_List /; Length@list > 3] := Module[
   {sublists = 
     iterate /@ (Delete[list, {{1}, {#}}] & /@ 
        Range[2, Length[list]]), inter},

   inter = 
    MapThread[
     Prepend, {sublists, ({First@list, list[[#]]} & /@ 
        Range[2, Length[list]])}];
   Flatten[help /@ inter, 1]
   ];

Timing:

iterate[Range[14]] // AbsoluteTiming // First

6.89226

As compared to belisarius' approach, where a list of 12 elements takes about 38 seconds on my machine.

The algorithm is quite simple. Take the first element and pair it with the second, find all partitions of the remaining elements (3 to n). Append the 1st and 2nd element to these partitions. Then add to that the result of doing the same with the 1st and 3rd, 1st and 4th... 1st and nth.

Edit:

Here's a somewhat cleaned up attempt with recursive functions, but I guess there's no chance of it (recursion) beating ciao's approach and as you'll see, the first step towards improvement is already a step in the direction of his solution:

idx[{a_, b_}] := {{a, b}}
idx[list_List] := 
 Flatten[Function[{row}, Join[First@row, #] & /@ Last@row] /@
   (({#, idx[Complement[list, #]]} &) /@ (list[[{1, #}]] & /@ 
       Range[2, Length@list])), 1]
idx[n_?EvenQ] := idx[Range@n]
part[list_List /; EvenQ[Length@list]] := 
 Fold[Partition, 
  list[[Flatten[idx[Length@list]]]], {2, Length@list/2}]
part[Range@14] // AbsoluteTiming // First

4.08278

Answer 4

My first attempt was to port Leonid's unsortedComplement from Removing elements from a list which appear in another list into Rojo's partitions code from Partition a set into subsets of size $k$ (to allow repeated elments) but as LLlAMnYP commented that was a wasteful choice.

Starting again from scratch, though based on Rojo's function:

foo[a_List] :=
 Join @@ Table[{x, ##} & @@@ foo[a~Complement~x], {x, Tuples[{{First@a}, Rest@a}]}]

foo[a : {_, _}] := {{a}}

bar[a_List] := Partition[#, 2] & /@ Partition[a[[ Flatten@foo@Range@Length@a ]], Length@a]

Test:

bar[{x1, x1, x3, x4}]

{{{x1, x1}, {x3, x4}}, {{x1, x3}, {x1, x4}}, {{x1, x4}, {x1, x3}}}

Answer 5

Possibly similar to the solution in the comments.

list = {x1, x1, x3, x4};
Map[list[[#]] &, 
 DeleteDuplicates[
  Map[Sort, Partition[#, 2] & /@ Permutations[Range[Length@list]], 
   2]], {2}]

{{{x1, x1}, {x3, x4}}, {{x1, x3}, {x1, x4}}, {{x1, x4}, {x1, x3}}}

Efficiency decays fast (as length!). Treating repeated identical elements as distinct seems to basically be the same, as, well, only having distinct elements.