# Combination and Permutation

How could I obtain the list of all the groups of 5 numbers taken from Range[12] such that the 2 lists have an empty intersection :

{{1,2,3,4,5},{6,7,8,9,10}} would be a solution while

{{1,2,3,4,5}, {5,6,7,8,9}} should be rejected as 5 is common to both.

I am currently trying to do so using Position of empty Intersection very unsuccessfully.

allCombinations =
DeleteDuplicates@(Sort /@ Permutations[Range[12], {5}])

Function[base,
Flatten[
Position[
Intersection[allCombinations[[base]], allCombinations[[#]]] & /@
Drop[Range[792], {base}], {}], 1]] /@ Range[792]


With which I am trying to obtain the position of the lists in allCombination s, but I still get duplicates...

-
I'm assuming you want all possible pairs of lists, right? –  The Toad Jan 29 '12 at 17:29
Subsets[Range[12], {5}] has 792 elements. Pairing up results in a further combinatorial explosion. Some cleverness will be necessary. –  Guess who it is. Jan 29 '12 at 17:37
Is the question general, i.e. how to get all non-intersecting size-$n$ subsets of a size-$m$ set? (This would cover all non-intersecting 3-element subsets of a 25 element set as well.) Or do you only need to partition sets into two parts (but not more than two)? –  Szabolcs Jan 29 '12 at 17:58
@Szabolcs, both ! My present problem was your second argument, but it is great to learn from solutions how to extend it :-) –  500 Jan 30 '12 at 3:07

Take all subsets of length 10, then for each one find all splits into two sets of five such that the first of the ten is in the first part of the split.

In[29]:= Timing[
msets = Subsets[Range[12], {10}];
m2 = Flatten[
Map[With[{fst = First[#], subs = Subsets[Rest[#], {4}], mset = #},
With[{s2 = Map[Join[{fst}, #] &, subs]},
Map[{#, Complement[mset, #]} &, s2]]] &, msets], 1];]

Out[29]= {0.07799999999999985, Null}

In[30]:= Length[m2]

Out[30]= 8316

-

This should be fast enough:

 Flatten[
Map[
Transpose[{ConstantArray[#1,{Length[#2]}],#2}]&@@
{#,Subsets[Complement[Range[12],#],{5}]}&,
Subsets[Range[12],{5}]
],
1]//Short//Timing

(*
==>  {0.031,{{{1,2,3,4,5},{6,7,8,9,10}},<<16630>>,{{8,9,10,11,12},{3,4,5,6,7}}}}
*)


If you don't want double- counting, apply Union[Sort/@#]& to the result - will still be fast.

-
@R.M That could be fixed by using Complement[Range[12], #, Range[Min[#]]]. –  Heike Jan 29 '12 at 18:06
@R.M. I added a note on that, while you were writing the comment - the overhead of avoiding duplicates is not very large. The biggest win is to avoid blind search over millions of combinations - post-processing a relatively small list of results is not a big deal. –  Leonid Shifrin Jan 29 '12 at 18:06
@LeonidShifrin, you could make it right with the duplicates and faster by asking only for half of the subsets, Subsets[Range[12], {5}, Binomial[12, 5]/2] –  Rojo Jan 29 '12 at 18:18
@Rojo Thanks, that's a good point. –  Leonid Shifrin Jan 29 '12 at 18:32
@Leonid, fast indeed ! Thank You ! –  500 Jan 29 '12 at 20:27

Perhaps

res = With[{list = Range[12]},
Function[{candidates}, DeleteDuplicates[
Sort /@ ({#, Complement[candidates, #]} & /@
Subsets[candidates, {5}])]] /@
(Complement[list, #] & /@ Subsets[list, {2}])
]~Flatten~1;

In[42]:= Length[res]

Out[42]= 8316


Takes 0.06 secs Finds 8316 solutions. I first built all the subsets of 10 numbers out of Range[12]. Then, for each subset of 10 numbers, you find all the 5 subsets and their complements. Number of subsets of 10 numbers out of 12 is

In[44]:= Binomial[12, 10]

Out[44]= 66


Now, all the subsets of 5 out of 10

In[51]:= Binomial[10, 5]

Out[51]= 252


You get

In[52]:= % %%

Out[52]= 16632


Now, those are counting double. The pair {{1,2,3,5,7}, {4,6,9,10,11}} as well as the pair {{4,6,9,10,11} ,{1,2,3,5,7}} would be found. So I just flatten and delete half of them. Perhaps there's a way to avoid this but it seemed good enough at first.

In[53]:= %/2

Out[53]= 8316

-

Here is a straightforward solution using Outer to get you started. It takes 3 seconds on my machine.

Outer[If[OrderedQ[{#1, #2}] && Intersection[#1, #2] == {}, {#1, #2}, ## &[]] &,
#, #, 1] &@Subsets[Range@12, {5}]~Flatten~1


-
+1. If we add // Flatten[#, 1]& to the end, then a list of pairs is returned. Also, if the OP does not care about the order within each pair, then the extra condition OrderedQ[{#1, #2}] will eliminate equivalent solutions. –  WReach Jan 29 '12 at 18:07
@WReach Thanks! updated. –  The Toad Jan 29 '12 at 18:19

Or maybe something like

lst = ReplaceList[Subsets[Range[12], {5}], {___, a_, ___, b_, ___} /;
Intersection[a, b] === {} :> {a, b}]


Slightly different approach would be

Flatten[{Position[#, 1], Position[#, 2]} & /@
Permutations[
Join[ConstantArray[1, 5], ConstantArray[2, 5], ConstantArray[0, 2]]],
{{1}, {2}, {4, 3}}]


It's a lot faster than the first approach but has the disadvantage that every pair appears twice.

-
I like the idea behind you second solution (I came up with the same independently). My version looks like: {Pick[Range[12], #, 1], Pick[Range[12], #, 2]} & /@ Permutations[{1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 3, 3}] (just a concept to illustrate, not yet generalized to arbitrary-length sets). Union will easily get rid of duplicates. +1 –  Szabolcs Jan 29 '12 at 18:33
@Szabolcs Thanks, I tried Pick first but it was a factor 8 slower than this version. Plus it gave me a chance to use the fancy form of Flatten ;-) –  Heike Jan 29 '12 at 18:36
@Heike, Thank you, I dont get the mechanism by which you remove duplicates, could you explain ? –  500 Jan 29 '12 at 20:26
@500 Which mechanism are you referring to? Neither of my solutions uses a mechanism to remove duplicates. –  Heike Jan 29 '12 at 20:35
The First one (pairs only appear once) which i believe other solution dont do ? –  500 Jan 29 '12 at 20:37

The idea is generating all subsets of length $s$. For each of these sets, the complement with respect to the whole list is calculated, then the subsets of the complement lists, and then each of the original sublists has to be combined with the complement lists.

n = 4;
s = 2;
groupings[range_, subrange_] := Module[{rest, subsets, result, list},

(* Generate all subsets of length s *)

list = Subsets[Range[n], {s}];

(* Find the complement of each subset w.r.t. the whole thing *)

rest = Complement[Range[range], #] & /@ list;

(* Generate possible subsets of that complement *)

subsets = Subsets[#, {subrange}] & /@ rest;

(* Everything's been generated now,
all that's left is data aggregation magic. *)

result = {list, subsets} // Transpose;
result = (llist \[Function] {llist[[1]], #} & /@ llist[[2]]) /@
result;
result = Flatten[result, 1];
result = Sort[#, #1[[1]] < #2[[1]] &] & /@ result;
Union[result]
]
groupings[n, s]

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


For $n=12$, $s=5$, this produces $8316$ pairings and takes $0.1$ seconds.

-

This appears to be about 40X faster than Daniel's method and 16X faster than Leonid's.

It works by calculating the sequence of parts for sets of 2 n (ten in the example) only once, and then extracting those parts from each subset of set (Range[12] in the example).

splits[set_List, n_Integer] :=
Fold[Partition,
Join @@ DeveloperToPackedArray[Subsets[set, {2 n}]][[All, #]],
{n, 2}
] & @ Flatten[{#, Range[2 n] ~Complement~ #} & /@ Subsets[Range[2 n - 1], {n}], 2]


Usage:

splits[Range@12, 5]


A minor speed improvement may be had by also packing the parts list, but it does not seem worth the extra code.

-
Good idea. I had toyed with doing it once and then using replacement rules but discarded that as likely to be hopelessly slow. But using the "basic case" for parts is very nice (even if it sounds cannibalistic when worded that way). –  Daniel Lichtblau Jan 31 '12 at 22:57
@Daniel thank you. Please see my update for another nice performance boost. Of course this is only faster if set` is packable. –  Mr.Wizard Jan 31 '12 at 23:49
OK, I'll look. (Can't do anything more than that, I already gave you an upvote.) –  Daniel Lichtblau Jan 31 '12 at 23:56
@Daniel Thanks for the vote; I wanted your eyes because (1) I thought this was of interest (2) I often make mistakes and I hoped you'd catch any. –  Mr.Wizard Feb 1 '12 at 0:14