Matchmaker Algo

MatchmakerAlgo.hs

module Main where

import           Control.Applicative            ( liftA2 )
import           Control.Arrow
import           Control.Monad                  ( replicateM )
import           Data.List                      ( maximumBy
                                                , minimumBy
                                                , nubBy
                                                , unfoldr
                                                )
import           Data.Tuple                     ( swap )
import           System.Random

data Team = Team
  { tid :: Int
  , elo :: Float
  }
  deriving Show
instance Eq Team where
  (==) t1 t2 = (==) (tid t1) (tid t2)

newtype Match = Match {teams :: (Team, Team) } deriving (Show, Eq)
newtype Set = Set {matches :: [Match]} deriving (Show)

data Method = MaxSum | MinVariance | MaxMin | MinMax | First deriving (Show, Eq)

matchUtility :: Match -> Float
matchUtility m = (exp . negate . abs) $ (-) e1 e2
  where (e1, e2) = (elo) *** (elo) $ teams m

variance :: [Float] -> Float
variance xs = sum $ map ((^ 2) . (-) avg) xs
  where avg = ((/) <$> sum <*> realToFrac . length) xs

iscohesive :: [Match] -> Bool
iscohesive s = l == lengthDup ts && l == lengthDup (map swap ts)
 where
  ts        = map teams s
  l         = length s
  lengthDup = length . nubBy (\(t1, t2) (t3, t4) -> (==) t1 t3 || (==) t1 t4)

pmatches :: [Team] -> [Match]
pmatches teams = map Match . filter noSelfDup . nubBy noDup $ liftA2 (,)
                                                                     teams
                                                                     teams
 where
  noSelfDup (a, b) = (/=) a b
  noDup x y = (==) x y || (==) (swap x) y

psets :: Int -> [Match] -> [Set]
psets n matches = map Set . filter iscohesive $ replicateM n matches

matchmake :: Method -> [Team] -> Set
matchmake m team = case m of
  MaxSum      -> maximumBy (compareSetBy sum) pm
  MinVariance -> minimumBy (compareSetBy variance) pm
  MaxMin      -> maximumBy (compareSetBy minimum) pm
  MinMax      -> minimumBy (compareSetBy maximum) pm
  First       -> head pm
 where
  compareSetBy f s1 s2 = compare (mapMatches f s1) (mapMatches f s2)
  mapMatches f = f . map matchUtility . matches
  pm = (psets (div (length team) 2) . pmatches) team

randomList :: (Float, Float) -> IO [Float]
randomList interval = newStdGen >>= return . unfoldr (Just . randomR interval)

main :: IO ()
main = do
  es <- randomList (900, 1100)
  let teams = [ Team { tid = x, elo = e } | (x, e) <- zip [1 .. 6] es ]
  print $ matchmake MaxSum teams