Organize a tournament

Question

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:

1. 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 -> 1, 1, 1 (sorted => 1, 1, 1, median => 1)
   team 2 -> 2, 1, 1 (sorted => 1, 1, 2, median => 1)
   team 3 -> 2, 2, 2 (sorted => 2, 2, 2, median => 2)
   team 4 -> 1, 2, 1 (sorted => 1, 1, 2, median => 1)
   team 5 -> 1, 2, 2 (sorted => 1, 2, 2, median => 2)
   
   medians: (1, 1, 2, 1, 2), sorted => (1, 1, 1, 2, 2)
   median of the medians = 1.
   

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

Answer 1

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<-[1..n],y<-[1..n],x<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<1=[(x,y):ys|ys<-s((x',y'):xs)]
main=do
 args <- getArgs
 print $ head $ s $ a (read(head args)::Int)

Answer 2

Python 282 247 chars

import sys
n=int(sys.argv[1])+1
r=range
l=[(i,j)for i in r(1,n)for j in r(i+1,n)]
m=[(),()]
while l:
 o,p=h=l.pop(0);v=[]
 for k in r(len(m)-1):g=m[k]+m[k+1];v+=[o in g or p in g]
 m.insert(v.index(0)+1,h)if min(v)<1 else l.append(h)
print m[1:-1]

UPD: working for n>4, for testing add:

lst = m[1:-1]
conflicts = 0
for i in range(len(lst)-1):
    if lst[i][0] in lst[i+1] or lst[i][1] in lst[i+1]:
        conflicts += 1

print 'Conflicts: {}'.format(conflicts)

Answer 3

Haskell 585 chars

import System.Environment
import Data.Ord
import Data.List
a::Int->[(Int,Int)]
a n=[(x,y)|x<-[1..n],y<-[1..n],x<y]
b::[(Int,Int)]->Int
b ((x,y):((z,t):rest))|x==z=1+b ((z,t):rest)
 |x==t=1+b ((z,t):rest)
 |y==z=1+b ((z,t):rest)
 |y==t=1+b ((z,t):rest)
 |otherwise=b ((z,t):rest)
b _=0
c l=(b l,l)
d [] _=[[]]
d l minimal=[x:s|x<-l,s<-take 10 $ filter (\ts->b ts<minimal) (d (delete x l) minimal)]
e n minimal=take 1 $ sortBy (comparing fst) $ map c (d (a n) minimal)
f []=False
f _=True
g n=head $ filter f $ map (e n) [0..]
main = do
 args<-getArgs
 print $ g (read (head args)::Int)

Here is the non code golfed version:

import System.Environment
import Data.Ord
import Data.List

all_matches :: Int -> [(Int,Int)]
all_matches n = [ (x,y) | x <- [1..n], y <- [1..n], x < y ]

price :: [(Int,Int)] -> Int
price ((x,y):((z,t):rest))
    | x==z = 1 + price ((z,t):rest)
    | x==t = 1 + price ((z,t):rest)
    | y==z = 1 + price ((z,t):rest)
    | y==t = 1 + price ((z,t):rest)
    | otherwise = price ((z,t):rest)
price _ = 0

addPrices xs = (price xs, xs)

myPerm [] _ = [[]]
myPerm xs minimal = [x:ys | x <- xs,
                    ys <- take 10 $ filter (\ts -> price ts < minimal) (myPerm (delete x xs) minimal)]


find_best_under n minimal = take 1 $ sortBy (comparing fst) $ map addPrices ( myPerm (all_matches n) minimal)

isNonEmpty [] = False
isNonEmpty _ = True

find_best n = head $ filter isNonEmpty $ map (find_best_under n) [0..]

main = do
    args <- getArgs
    putStrLn $ show $ find_best (read (head args)::Int)

It only search for local optima. But in this case, local optima are also global one up to 6 teams.