Enumerate all possible subsets such that all are of the same length which is maximum and each contains non-repeating elements?

Question

Given a list lists:

lists={{{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}}};

I would like to get the following results:

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

Notice that for every subsets (i.e. results[[1]]), there are no repeated elements (i.e. {1, 2}) and every subsets contains the maxmum elements.

When lists={{{1, 2}, {3, 4}}, {{1, 3}, {2, 4}}, {{1, 4}, {2, 3}}}, we can easily have results={{{{1, 2}, {3, 4}}, {{1, 3}, {2, 4}}, {{1, 4}, {2, 3}}}}. Here is the example code which seems only works for n=4:

n = 4; 
lists = Select[Subsets[Subsets[Range[n], {2}], {Length[Range[n]]/2}], 
   DuplicateFreeQ@*Catenate];

results = {};
res = {};
For[i = 1, i <= Length[lists], i++,
  AppendTo[results, SortBy[res, First]];
  res = {};
  AppendTo[res, lists[[i]]];
  For[j = 1, j <= Length[lists], j++,
   If[DisjointQ[lists[[i]], lists[[j]]],
     If[Length[res] <= 1,
         AppendTo[res, lists[[j]]];,
         If[DisjointQ[Flatten[res, 1], lists[[j]]], AppendTo[res, lists[[j]]];];
       ];
     ];
   ];
  ];
results = DeleteDuplicates[DeleteCases[results, {}]];
len = Length[results];

Questions:

• Is there a simple way to do the above task? How to do the above task for n=6?
• When n goes large, my code doesn't work (i.e. n=8, len should be 6240; see A000438). Is there a systematically way?

Thank you very much in advance! Any hints or suggestions are appreciated!

Answer 1

The following takes around 10 seconds for n=8 on my laptop:

(* the input list of lists *)
n = 8;
lists = Select[DuplicateFreeQ@*Catenate]@Subsets[Subsets[Range@n, {2}], {n/2}];

(* return the elements of list that are "compatible" with l*)
comp[l_, list_] := Select[DisjointQ[#, l] &]@list[[FirstPosition[list, l][[1]] + 1 ;;]]

(* recursively build the candidate subsets*)
build[rem_] := MaximalBy[Length]@Reap[build[l[], rem]][[2, 1]]
build[cur_, rem_] := (build[l[#, cur], comp[#, rem]] & /@ rem;)
build[cur_, {}] := Sow[List @@ Flatten@cur]

(* compute the result *)
res = build[lists];
Length@res
(* 6240 *)

This works by building up the subsets step-by-step, while trying to be somewhat clever about it:

• We keep track of the lists that we can still use, i.e. the lists that have no element in common with the previously used ones. This is handled by comp above. One important point is that we only consider elements coming after l to be compatible. This ensures that we are not double counting possibilities.
• We building up the valid lists, we hand down the list of compatible lists (That list will only get shorter at each step). If we can add any lists anymore, we Sow the list we have built up. At the end, we only keep those lists of maximal length.
• Instead of using Append or similar, we build a linked-list type structure that looks like l[elem3, l[elem2, l[elem1, l[]]]]. This is way more efficient, and we can get the final list using Flatten. Similarly, we use Reap and Sow to collect the result list, again since it is faster than using Append.