5
$\begingroup$

I am trying to generate a game schedule where $k$ players at the time, out of $n$ participants, meet in each game, but any player meets another player only once. In each game, with $k$ simultaneous players, the $k$ players compete against each other, there are no multi-player teams.

A 'raw and basic' method for a $(7,3)$-game is shown below, but there must be a more elegant way in Mathematica. It is not very customisable for a general $(n,k)$-game. TIA.

n = 7;
mat = Table[1, {x, n}, {y, n}];
For[i = 1, i <= n, i++,
 For[j = i + 1, j <= n, j++,
  For[k = j + 1, k <= n, k++,
   If[mat[[i,j]]*mat[[j,i]]*mat[[i,k]]*mat[[k,i]]*mat[[j,k]]*mat[[k,j]] == 1,
    p = {i, j, k};
    Print [p];
    mat[[i,j]] = 0;
    mat[[j,i]] = 0;
    mat[[i,k]] = 0;
    mat[[k,i]] = 0;
    mat[[j,k]] = 0;
    mat[[k,j]] = 0;
   ]
  ]
 ]
]

Result: {1,2,3}, {1,4,5}, {1,6,7}, {2,4,6}, {2,5,7}, {3,4,7}, {3,5,6}.

$\endgroup$
9
$\begingroup$
n = 7;
k = 3;

DeleteDuplicates[Subsets[Range @ n, {k}], Length[Intersection[##]] >= 2 &]

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

Update: Although DeleteDuplicates approach replicates the result of For loops in OP, both are greedy approaches and we don't have any guarantee that we get a schedule of maximum possible length. To get a schedule of maximum possible length we can use Roman's approach. The following is an alternative specification of the input graph that is slightly faster:

grph = RelationGraph[Length[Intersection[##]] <= 1 &, Subsets[Range @ n, {k}]];

allscheadules = FindClique[grph , ∞, All];

Length @ allscheadules

450

Max[Length /@ allscheadules]

7

So, for {n, k} = {7, 3} the schedule we get using the greedy approach cannot be made any longer.

For {n, k} = {9, 3} the two approaches give substantially different results:

{n, k} = {9, 3};

s1  = DeleteDuplicates[Subsets[Range @ n, {k}], Length[Intersection[##]] >= 2 &]

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

Length @ s1

8

Tally @ Sort @ Flatten @ s1

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

grph = RelationGraph[Length[Intersection[##]] <= 1 &, Subsets[Range @ n, {k}]];

allscheadules = FindClique[grph , ∞, All];

Length @ allscheadules

834960

Max[Length /@ allscheadules]

12

s2 = MaximalBy[allscheadules, Length, 1]

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

Tally @ Sort @ Flatten @ s2

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

$\endgroup$
  • $\begingroup$ Very compact and 'neat'. Could you please explain what it does? I tried to 'decompile' it but had no luck understanding some of the 'components'. $\endgroup$ – mf67 Aug 7 at 22:05
  • 1
    $\begingroup$ @mf67, Subsets[Range @ n, {k}] gives all k-player games, a list of k-tuples , {g1,g2,...}. Scanning this list from left to right DeleteDuplicates step eliminates all games $g_k$ that contains two or more players from $g_j$ (for $j<k$). $\endgroup$ – kglr Aug 7 at 22:17
  • $\begingroup$ I see. Much clearer now. The examples on the Mathematica help pages are often (too) short and do not display the more 'intricate' commands given on this site. $\endgroup$ – mf67 Aug 7 at 23:15
5
$\begingroup$
n = 7;
k = 3;

list all possible games:

g = Subsets[Range[n], {k}];

Find a maximal-size clique of games that don't overlap:

First@FindClique[AdjacencyGraph[Outer[Boole[Length[Intersection[##]] <= 1] &, g, g, 1]]]
(*    {1, 10, 15, 21, 24, 28, 29}    *)

Which games are these?

g[[%]]
(*    {{1, 2, 3}, {1, 4, 5}, {1, 6, 7}, {2, 4, 6}, {2, 5, 7}, {3, 4, 7}, {3, 5, 6}}    *)

This method gives the same result as @kglr's but is much slower, so I don't recommend using it. You can view it as a proof of the other method.

$\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.