TransWikia.com

How to get the complete list of subsets the pairwise intersections of which are empty

Mathematica Asked on July 16, 2021

Given the list Range[6]. I want to get the sublists of length 2 where each element has length 2 and the pairwise intersections are empty. So I am looking for:

  {{{1, 2}, {3, 4}}, {{1, 3}, {2, 4}}, {{1, 4}, {2, 3}}}

Switched elements like {{1,2},{4,3}} should not appear. My code works well but when Range and lengths get bigger it consumes a lot of space and time. For sublists of length 3 with two elements the result
would look like:

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

Is there a function (maybe in Combinatorica) for this problem or a smarter way to do it? I am sure this is a standard problem and there must be a name for this kind of sublist. I would be grateful for further hints.

Here is my code:

k = 3;
t1 = Partition[#, {2}] & /@ Permutations[Range[2 k]]
t2 = Map[Sort, t1, {2}]
t3 = Map[Sort, t2, {1}]
t4 = DeleteDuplicates[t3]

One Answer

Avoid generating wrong lists as early as possible. Here is a recursive attempt. It beats your implementation starting from k=5. First define one step recursion transform

recursionStep[x_List, y_List] := 
 Flatten[Outer[
   If[DuplicateFreeQ[Flatten[{##}]] && OrderedQ[Flatten[{##}, 1]], 
     Flatten[{##}, 1], Nothing] &, x, y, 1], 1]

Next, apply it as many steps as needed.

 k = 5;
    
    Nest[recursionStep[List /@ Subsets[Range[2*k], {2}], #] &, 
      List /@ Subsets[Range[2*k], {2}], k - 1] // Length//AbsoluteTiming
(*{0.797619, 945}*)

Yours on my hardware yields {3.92687,945}. The difference will increase for larger k values.

Correct answer by Acus on July 16, 2021

Add your own answers!

Ask a Question

Get help from others!

© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP