Finding lists with no intersections

Question

Lets say I have this list

jm = Union[Sort /@ Permutations[Range[9], {3}]]

which contains all sorted triplets with numbers 1-9

{{1, 2, 3}, {1, 2, 4}, {1, 2, 5}, {1, 2, 6}, {1, 2, 7}, {1, 2, 8}, {1, 2, 9}, {1, 3, 4}, {1, 3, 5}, {1, 3, 6}, {1, 3, 7}, {1, 3, 8}, {1, 3, 9}, {1, 4, 5}, {1, 4, 6}, {1, 4, 7}, {1, 4, 8}, {1, 4, 9}, {1, 5, 6}, {1, 5, 7}, {1, 5, 8}, {1, 5, 9}, {1, 6, 7}, {1, 6, 8}, {1, 6, 9}, {1, 7, 8}, {1, 7, 9}, {1, 8, 9}, {2, 3, 4}, {2, 3, 5}, {2, 3, 6}, {2, 3, 7}, {2, 3, 8}, {2, 3, 9}, {2, 4, 5}, {2, 4, 6}, {2, 4, 7}, {2, 4, 8}, {2, 4, 9}, {2, 5, 6}, {2, 5, 7}, {2, 5, 8}, {2, 5, 9}, {2, 6, 7}, {2, 6, 8}, {2, 6, 9}, {2, 7, 8}, {2, 7, 9}, {2, 8, 9}, {3, 4, 5}, {3, 4, 6}, {3, 4, 7}, {3, 4, 8}, {3, 4, 9}, {3, 5, 6}, {3, 5, 7}, {3, 5, 8}, {3, 5, 9}, {3, 6, 7}, {3, 6, 8}, {3, 6, 9}, {3, 7, 8}, {3, 7, 9}, {3, 8, 9}, {4, 5, 6}, {4, 5, 7}, {4, 5, 8}, {4, 5, 9}, {4, 6, 7}, {4, 6, 8}, {4, 6, 9}, {4, 7, 8}, {4, 7, 9}, {4, 8, 9}, {5, 6, 7}, {5, 6, 8}, {5, 6, 9}, {5, 7, 8}, {5, 7, 9}, {5, 8, 9}, {6, 7, 8}, {6, 7, 9}, {6, 8, 9}, {7, 8, 9}}

I want to make a program that finds me an instance of three triplets which contain ALL numbers from 1-9

I only want just ONE triplet of triplets (and I don't care about their position in the list)

i.e. any result like

{1,6,7},{2,4,5},{3,8,9} would be OK

I tried checking all triplets like

Length[Union@Flatten[{jm[[i]], jm[[j]], jm[[k]]}]] ==9

but it takes forever for bigger lists (in fact I am searching in much bigger lists for 5 triplets}

I also tried

FindInstance[
Length@Intersection[jm[A], jm[B], jm[C]] == 0 && 
0 < {A, B, C} < Length@jm, {A, B, C}, Integers]

which worked but it only compares AB and BC and not AC

Is there a way to get just one example of three elements containing all numbers?

of course the program must search in my list jm

Answer 1

DeleteDuplicates[RandomSample @ jm, Intersection @ ## =!= {} &]

{{2, 7, 8}, {1, 5, 9}, {3, 4, 6}}

In versions 10.0+, you can also use IntersectingQ as the second argument of DeleteDuplicates:

DeleteDuplicates[RandomSample@jm, IntersectingQ]

{{2, 3, 5}, {6, 7, 8}, {1, 4, 9}}

Answer 2

for the example it is not too unreasonable to just generate all of them and pick one:

Select[ Subsets[jm, {3}] , Union@Flatten@# == Range[9] & ] ; (*280 results*)
RandomChoice[%]

{{1, 5, 9}, {2, 3, 4}, {6, 7, 8}}

Here is a way to avoid generating all the subsets:

Needs["Combinatorica`"]
jm = Union[Sort /@ Permutations[Range[9], {3}]];
While[ Union@Flatten[x = RandomKSubset[jm, 3]] != Range[9]]; x

{{1, 8, 9}, {2, 3, 4}, {5, 6, 7}}

Aside I'm puzzled why there is no NthKSubset function in Combinatorica ?

note for this specific example you could do this as well:

Sort /@ Partition[RandomSample[Range[9], 9], 3]

Answer 3

For this size:

g = RelationGraph[DisjointQ, jm];
triples=Union[Join @@ #] & /@ (FindCycle[g, 3, All] /.UndirectedEdge[x__] :> List[x])

yiels 280 triples

Answer 4

jm // Nest[
 Replace[#, {___, Alternatives @@ Sow[RandomChoice[#]], ___} :> 
    Nothing, 2] &, #, 2] & // Reap // Join[#[[1]], #[[2, 1]]] &

{{2, 3, 5}, {4, 8, 9}, {1, 6, 7}}

 

Union[Sort /@ Permutations[Range[15], {5}]] // 
Nest[Replace[#, {___, Alternatives @@ Sow[RandomChoice[#]], ___} :>
     Nothing, 2] &, #, 2] & // Reap // Join[#[[1]], #[[2, 1]]] &

{{1, 3, 7, 8, 14}, {5, 6, 9, 12, 13}, {2, 4, 10, 11, 15}}

 

Edit

Just for fun:

jm // #@*# &@(Replace[#, {___, 
     Alternatives @@ Sow[RandomChoice[#]], ___} :> Nothing, 
   2] &) // Reap // Join[#[[1]], #[[2, 1]]] &

{{2, 6, 8}, {3, 5, 9}, {1, 4, 7}}

Answer 5

One can use a LinearProgramming approach. Using my answer to Selection of lists among list of lists to maximize coverage and avoid repetitions:

disjointMaximum[sets_] := Module[{elems = DeleteDuplicates @ Flatten @ sets, lp},
    lp = Quiet[
        LinearProgramming[
            - Length /@ sets,
            Table[Boole @ Map[Not@*FreeQ[k]] @ sets, {k, elems}],
            Table[{1, -1}, {Length[elems]}],
            0,
            Integers
        ],
        LinearProgramming::lpip
    ];
    Pick[sets, lp, 1]
]

We get:

disjointMaximum[jm]

{{1, 2, 6}, {3, 4, 5}, {7, 8, 9}}

Answer 6

Try this:

Partition[RandomSample[Range[9]], 3]

Answer 7

list = Union[Sort /@ Permutations[Range[9], {3}]];

UniqueTriplets[mx_?MatrixQ] :=
 Module[{f, a, b, c},
  f[e_] := DeleteMissing @ SelectFirst[mx, ContainsNone @ e];
  a = f[{}];
  b = f[a];
  c = f[a~Join~b];
  {a, b, c}]

UniqueTriplets[list]

{{1, 2, 3}, {4, 5, 6}, {7, 8, 9}}

UniqueTriplets[RandomSample @ list]

{{4, 6, 9}, {1, 7, 8}, {2, 3, 5}}