Organize a tournament Here is a real question somebody asked me. Suppose you have n teams, one terrain.


Each team must play each other team exactly once.
The number of times a team plays two matches in a row should be minimized.


The problem is hard if not optimized. Your program should be able to answer this question for up to 6 teams (at least) in a reasonable time (say less than an hour). For 5 teams I have a working program which works in less than a minute.

Here is an example for 5 teams.

$ organize_for 5
[(3,5),(1,2),(4,5),(1,3),(2,4),(1,5),(2,3),(1,4),(2,5),(3,4)]


And another for 6 teams.

$ organize_for 6
[(2,4),(1,5),(2,3),(1,6),(3,5),(1,4),(2,5),(1,3),(4,6),(1,2),(3,6),(4,5),(2,6),(3,4),(5,6)]


NB for 3 and 4 teams, you'll have at least two occurrences of a team playing two matches in a row.

To win: make the shortest program to answer this problem fast enough to give you a correct answer for 6 teams.

Bonuses:


The median of the median of the waiting time between two matches for all teams should be maximized.
Example: from organize_for 5 ;
nb match between the next one (sorted, median is the one in the center)

team 1 -&gt; 1, 1, 1 (sorted =&gt; 1, 1, 1, median =&gt; 1)
team 2 -&gt; 2, 1, 1 (sorted =&gt; 1, 1, 2, median =&gt; 1)
team 3 -&gt; 2, 2, 2 (sorted =&gt; 2, 2, 2, median =&gt; 2)
team 4 -&gt; 1, 2, 1 (sorted =&gt; 1, 1, 2, median =&gt; 1)
team 5 -&gt; 1, 2, 2 (sorted =&gt; 1, 2, 2, median =&gt; 2)

medians: (1, 1, 2, 1, 2), sorted =&gt; (1, 1, 1, 2, 2)
median of the medians = 1.

Generalize for k terrains. All match have the same duration.


The most important rules remains a team shouldn't do a match just after another.
The global time for all matches should be minimized
Haskell: 291 chars

Another solution which terminate only if there is a solution without any collision (5 and 6). It is also very fast:

import System.Environment
import Data.List
a n=[(x,y)|x&lt;-[1..n],y&lt;-[1..n],x&lt;y]
s []=[[]]
s (m:[])=[[m]]
s ((x,y):(x',y'):xs )
 |(x==x')||(x==y')||(y==x')||(y==y')=s((x,y):xs++[(x',y')])
 |0&lt;1=[(x,y):ys|ys&lt;-s((x',y'):xs)]
main=do
 args &lt;- getArgs
 print $ head $ s $ a (read(head args)::Int)