2
\$\begingroup\$

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.

\$\endgroup\$
1
\$\begingroup\$

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