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

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!

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.
• that's amazing! thank you so much! btw, the res = Reap[build[l[], flists, n - 1]][[2, 1]];, I think you mean res = Reap[build[l[], lists, n - 1]][[2, 1]];. for side question, can you method work for lists which don't have the all elements such as lists={{{1, 2}, {3, 4}, {5, 6}}, {{1, 6}, {2, 3}, {4, 5}}}? Jul 13, 2021 at 14:45
• @Xuemei Thanks, there was indeed a typo in that expression. With your side question: Do you mean whether it can find subsets that do not contain the maximum number of elements, or do you mean whether it can work when lists does not contain all possible elements? Jul 13, 2021 at 14:48
• thank you, I mean whether it works when lists does not contain all possible elements. Is that possiable? It can be connected to graph theory, such as gg = CycleGraph[6]; getpairs = EdgeList[gg] /. UndirectedEdge -> List; lists =Select[DuplicateFreeQ@*Catenate]@Subsets[getpairs, {Length[VertexList[gg]]/2}]; Instead of gg=CompleteGraph[6]. Jul 13, 2021 at 14:52
• @Xuemei Yes, the code should also work if lists contains only some of the elements. If you run into any issues, please let me know Jul 13, 2021 at 14:53
• If I makelists={{{1, 2}, {3, 4}, {5, 6}}, {{1, 6}, {2, 3}, {4, 5}}} and n=6 (correspond to gg=CycleGraph[6]), I get some errors when it run to res = Reap[build[l[], lists, n - 1]][[2, 1]];, which shows Part::partw: Part 1 of {} does not exist.. Jul 13, 2021 at 14:59