7
$\begingroup$

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

$\endgroup$
  • 5
    $\begingroup$ Would jl = jm; Reap[Do[Sow[t = RandomChoice[jl]]; jl = Select[jl, FreeQ[#, Alternatives @@ t] &], {3}]][[-1, 1]] work here? $\endgroup$ – J. M. will be back soon May 11 '17 at 15:44
  • $\begingroup$ It worked fine even in my bigger list when I changed 3 to five.Many thanks.Post an answer if you like and I will accept it $\endgroup$ – J42161217 May 11 '17 at 15:51
5
$\begingroup$
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}}

$\endgroup$
3
$\begingroup$

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]
$\endgroup$
2
$\begingroup$

Try this:

Partition[RandomSample[Range[9]], 3]
$\endgroup$
  • $\begingroup$ the list I gave is just an example. The code must search into the list jm and find an example (if one exists). $\endgroup$ – J42161217 May 12 '17 at 10:00
2
$\begingroup$

For this size:

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

yiels 280 triples

$\endgroup$
2
$\begingroup$
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}}

$\endgroup$
2
$\begingroup$

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

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.