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

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?

• I meant that it should be (and it is, in the example I gave) a list of lists of pairs, not a list of pairs as you suggested: it is a List of all the possible List of pairs in which one can partition the original list. Jul 13, 2015 at 9:01
• Ok, thanks. Does order matter on any level?
– Kuba
Jul 13, 2015 at 9:01
• @Kuba The order does not matter, but it is important that repeated identical elements are treated as different, i.e. for {x1,x1,x3,x4} I would like to get {{{x1,x1},{x3,x4}},{{x1,x3}{x1,x4}}, {x1,x4},{x1.x3}}} Jul 13, 2015 at 9:04
– Kuba
Jul 13, 2015 at 9:09
• I've been looking at that, the top answer works except it does not handle identical elements properly, ie. it counts them as one. I couldn't figure out how to change that. I've tried some of the other answers but they are doing slightly different things Jul 13, 2015 at 9:14

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}}} *)

• This seems to work! I'll test it later and get back here for feedback. Jul 13, 2015 at 12:13
• Perhaps more efficient is KSetPartitions[Length[list],Length[list]/2] Jul 13, 2015 at 17:30
• @LLlAMnYP this does something different, it finds all partitions in a given number of sets but they can all be of different length. Jul 13, 2015 at 18:13
• belisarius's answer does the job as far as I can tell. Jul 13, 2015 at 18:15
• @belisarius That's true, however all partitions that we seek are split into Length[list]/2 chunks, so this slightly narrows down the search space, no? @user2596320 I think I'm onto a non-bruteforce algorithm that may be much more efficient. Jul 13, 2015 at 18:17

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.

• Wow, much faster than what I posted. Sometimes it's really not a good idea to force an old solution to fit a new problem. :-/ Jul 14, 2015 at 5:01
• By the way how is posting something like this as a community wiki helping to improve the admittedly problematic "reputation" system? If you feel your generous bounties improve justice do you not want to build the points necessary to continue them? Jul 14, 2015 at 5:03
• @Mr.Wizard: Glad you find it interesting - there's performance left in there, and if I get the hankering, I might tweak it, pretty it up, and extend it to arbitrary set sizes (there's a pretty relationship with figurate numbers and the cut-offs for taking the subsets buried here). As for wiki? Part of not giving a poop about "rep".
– ciao
Jul 14, 2015 at 7:49
• I like the use of ArrayReshape (an alternative would be nested Partitions). +1. Similarly, e.g. Fold[Partition, genIdx[l], {2, l/2}] Jul 14, 2015 at 11:48
• However, the prime benefit is amortization of time over multiple lists to be transformed IMO, this can be done with any of the functions on offer here, by supplying them with a list idxN = function[Range[length]] to partition, then doing Map[list[[#]]&,idxN,{2}] Jul 14, 2015 at 12:49

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 =
Prepend, {sublists, ({First@list, list[[#]]} & /@
Range[2, Length[list]])}];
Flatten[help /@ inter, 1]
];


Timing:

iterate[Range] // 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

• Pretty elegant, +1
– ciao
Jul 13, 2015 at 20:43
• A good bit faster than what I just posted. +1 Jul 14, 2015 at 4:59

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}}}

• Actually, partitions[list,2] on its own appears to do the job just fine and about two times as fast as my solution. Simply use Map[list[[#]]&,partitions[Range... as I mentioned under ciao's answer. Jul 14, 2015 at 14:14
• @LLlAMnYP That sounds like a much better idea. I'll write it up later and replace this mess. Thank you! Jul 15, 2015 at 0:12
• ciao also warns that Map is quite slow to replace indices with elements, but see the comment thread under his answer for details :-) Jul 15, 2015 at 0:30

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.