# Game schedule where each player meets only once

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

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];



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];



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

• 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'.
– mf67
Aug 7, 2019 at 22:05
• @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$).
– kglr
Aug 7, 2019 at 22:17
• 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.
– mf67
Aug 7, 2019 at 23:15
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.