Organizing matches between sports teams

Question

How could I improve this algorithm? The goal is to organize matches between sport teams such that:

• Each team affront each other
• A minimum number of team should start a match after just finishing one

The interesting part is here:

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

It is a way to remove from the enumeration of permutations all sub-sequences not being good enough. Even with this, the problem for 6 teams is very long to resolve.

Here is the complete program:

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

-- The number of items we keeps to only search 
-- from bests local results
nbToKeep :: Int
nbToKeep = 10

type Match = (Int,Int)
type MatchSequence = [Match]

-- Give all sport matches in the form
-- (1,2) => match between Team 1 and Team 2
all_matches :: Int -> MatchSequence
all_matches n = [ (x,y) | x <- [1..n], y <- [1..n], x < y ]

-- A price function for sequence of matches
-- 0 if no team make a match just after finishing one
-- Possible with 5 teams not for 3 and 4
price :: MatchSequence -> 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

-- Simple adjoin the price to a MatchSequence
addPrices :: MatchSequence -> (Int,MatchSequence)
addPrices xs = (price xs, xs)

-- Instead of listing _all_ permutations
-- Just keep the one such that its subsequece price
-- is under the threshold
myPerm [] _ = [[]]
myPerm xs threshold = [x:ys | x <- xs,
                    ys <- take nbToKeep $
                            filter
                              (\ts -> price ts <= threshold)
                              (myPerm (delete x xs) threshold)]


-- Keep the best one under some threshold
find_best_under n threshold = take nbToKeep $
                                sortBy (comparing fst) $
                                    map addPrices ( myPerm (all_matches n) threshold)

isNonEmpty [] = False
isNonEmpty _ = True

-- Try to test with the minimal threshold (0)
-- Then repeat until a solution is found for some threshold
find_best n = head $ filter isNonEmpty $ map (find_best_under n) [0..]

showMatchSequence :: MatchSequence -> String
showMatchSequence [] = []
showMatchSequence ((team1,team2):[]) = show team1 ++ "-" ++ show team2
showMatchSequence ((team1,team2):xs) = show team1 ++ "-" ++ show team2 ++ "   " ++ showMatchSequence xs

showResult :: (Int,MatchSequence) -> String
showResult (score,xs) = show score ++ " collisions: " ++ showMatchSequence xs

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

I know I do a linear number of computation using price, while, I shouldn't need it if I integrate the price computation inside the myPerm function.

I take all advice, concerning not only style but also sytactic optimisations. For example, I am pretty sure I could have used a Monad to find the first n for which there is a solution.

Answer 1

No algorithmic improvement, just some cosmetics...

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

-- The number of items we keeps to only search
-- from bests local results
nbToKeep :: Int
nbToKeep = 10

type Match = (Int,Int)
type MatchSequence = [Match]

-- gives a different order, but I think this is okay
all_matches :: Int -> MatchSequence
all_matches n = [ (x,y) | y <- [2..n], x <- [1..(y-1)]] 

-- A price function for sequence of matches
-- 0 if no team make a match just after finishing one
-- Possible with 5 teams not for 3 and 4
price :: MatchSequence -> Int
price xs =  sum $ zipWith comp xs $ tail xs where
   comp (x,y) (z,t) = fromEnum $ x==z || x==t || y==z || y==t 

-- Simple adjoin the price to a MatchSequence
addPrices :: MatchSequence -> (Int,MatchSequence)
addPrices xs = (price xs, xs)

-- Instead of listing _all_ permutations
-- Just keep the one such that its subsequece price
-- is under the threshold
myPerm [] _ = [[]]
myPerm xs threshold = [x:ys | x <- xs,
                    ys <- take nbToKeep $
                            filter
                              ((<= threshold).price)
                              (myPerm (delete x xs) threshold)]


-- Keep the best one under some threshold
find_best_under n threshold = take nbToKeep $
                                sortBy (comparing fst) $
                                    map addPrices ( myPerm (all_matches n) threshold)

-- Try to test with the minimal threshold (0)
-- Then repeat until a solution is found for some threshold
find_best n = head $ filter (not.null) $ map (find_best_under n) [0..]

showMatchSequence :: MatchSequence -> String
showMatchSequence [] = []
showMatchSequence ((team1,team2):[]) = show team1 ++ "-" ++ show team2 --is this case needed?
showMatchSequence ((team1,team2):xs) = show team1 ++ "-" ++ show team2 ++ "   " ++ showMatchSequence xs

showResult :: (Int,MatchSequence) -> String
showResult (score,xs) = show score ++ " collisions: " ++ showMatchSequence xs

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