Skip to main content
added 312 characters in body
Source Link
Daniel Huber
  • 56.3k
  • 2
  • 24
  • 66

This works for the example you gave:

d = {{{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}}};;
i = 1;
While[++i <= Length[d],
  If[Or @@ 
    Flatten[Outer[Length[Intersection[#1, #2]] > 1 &, d[[i 
 - 1]], 
  Flatten[d[[;; i - 1]], 1], d[[i]], 1]], d = Delete[d, i]; --i;] 

  ];
d 

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

or:

d = {{{1, 2}, {3, 4}, {5, 6}}, {{1, 3}, {2, 5}, {4, 6}}, {{1, 4}, {2, 
     3}, {5, 6}}, {{1, 5}, {2, 4}, {3, 6}}, {{1, 6}, {2, 3}, {4, 5}}};

results in:

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

This works for the example you gave:

d = {{{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}}};;
i = 1;
While[++i <= Length[d],
  If[Or @@ 
    Flatten[Outer[Length[Intersection[#1, #2]] > 1 &, d[[i - 1]], 
       d[[i]], 1]], d = Delete[d, i]; --i;]
  ];
d

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

This works for the example you gave:

d = {{{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}}};;
i = 1;
While[++i <= Length[d],
If[Or @@ 
  Flatten[Outer[Length[Intersection[#1, #2]] > 1 &,  
    Flatten[d[[;; i - 1]], 1], d[[i]], 1]], d = Delete[d, i]; --i;] 

  ];
d 

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

or:

d = {{{1, 2}, {3, 4}, {5, 6}}, {{1, 3}, {2, 5}, {4, 6}}, {{1, 4}, {2, 
     3}, {5, 6}}, {{1, 5}, {2, 4}, {3, 6}}, {{1, 6}, {2, 3}, {4, 5}}};

results in:

{{{1, 2}, {3, 4}, {5, 6}}, {{1, 3}, {2, 5}, {4, 6}}, {{1, 5}, {2, 
   4}, {3, 6}}, {{1, 6}, {2, 3}, {4, 5}}}
Source Link
Daniel Huber
  • 56.3k
  • 2
  • 24
  • 66

This works for the example you gave:

d = {{{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}}};;
i = 1;
While[++i <= Length[d],
  If[Or @@ 
    Flatten[Outer[Length[Intersection[#1, #2]] > 1 &, d[[i - 1]], 
      d[[i]], 1]], d = Delete[d, i]; --i;]
  ];
d

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