Improvements to the Haskell matching.

1 files changed, 46 insertions, 11 deletions

diff --git a/scheduling/Main.hs b/scheduling/Main.hs
index 18f8ae5..3d08c30 100644
--- a/scheduling/Main.hs
+++ b/scheduling/Main.hs
@@ -1,8 +1,12 @@
+{-# LANGUAGE BangPatterns #-}
+
+import Debug.Trace
 import Control.Monad (forM_)
 import Data.Function (on)
-import Data.List (sortBy, unfoldr)
+import Data.List (sortBy, unfoldr, maximumBy)
 import System.Random (RandomGen, randoms, getStdGen, split)
 import Data.HashSet (HashSet, fromList, member)
+import qualified Data.HashMap.Strict as M
 
 data Player = Player { name :: String
                      , rank :: Int
@@ -10,12 +14,37 @@ data Player = Player { name :: String
                      } deriving (Show, Eq)
 
 players :: [Player]
-players = [ Player "orbekk" (-1) 4
-          , Player "ltsang" (-4) 4
-          , Player "sebh" 2 4
-          , Player "fringd" (-1) 4
-          , Player "sheyrax" (-2) 2
-          ]
+-- players = [ Player "orbekk" (-1) 4
+--           , Player "ltsang" (-4) 4
+--           , Player "sebh" 2 4
+--           , Player "fringd" (-1) 4
+--           , Player "sheyrax" (-2) 2
+--           ]
+
+players = [Player "orbekk"	(-1)	4
+          , Player "sebh"	2	4
+          , Player "ltsang"	(-4)	4
+          , Player "fringd"	(-1)	4
+          , Player "tysonjh"	(-14)	4
+          , Player "shreyax"	(-2)	4
+          , Player "bensley"	(-16)	4
+          , Player "taosong"	1	4
+          , Player "jtnapoli" (-17)	4
+          , Player "woojlee"	(-7)	4
+          , Player "binfu"	4	4
+          , Player "wschudy"	(-13)	3
+          , Player "hoffstaetter" (-17)	4
+          , Player "wwall"	(-2)	3]
+
+
+score :: M.HashMap String Player -> [(String, String)] -> [(String, String)]
+    -> Int
+score players history [] = 0
+score players history ((p1, p2):ms) =
+  rankScore + recencyScore + score players history ms
+    where rankScore = 100 - 10 * (abs (getRank p1 - getRank p2))
+          getRank p = rank (players M.! p)
+          recencyScore = -10 * length (filter (==(p1, p2)) history)
 
 shuffle :: (RandomGen g) => g -> [a] -> [a]
 shuffle g xs = map snd $ sortBy (compare `on` fst) (zip rs xs)
@@ -24,7 +53,9 @@ shuffle g xs = map snd $ sortBy (compare `on` fst) (zip rs xs)
 matchOnce :: [String] -> [String] -> [(String, String)]
 matchOnce (p:ps) (q:qs)
   | p == q    = matchOnce (p:ps) qs
-  | otherwise = (p, q) : matchOnce (filter (/=q) ps) (filter (/=p) qs)
+  | otherwise = (p', q') : matchOnce (filter (/=q) ps) (filter (/=p) qs)
+      where p' = min p q
+            q' = max p q
 matchOnce _ _ = []
 
 subtractMatches :: [(String, String)] -> [Player] -> [Player]
@@ -50,10 +81,14 @@ matchPlayers g players = matches ++ matchPlayers g3 nextPlayers
 iterativeMatchPlayers :: (RandomGen g) => g -> [Player] -> [[(String, String)]]
 iterativeMatchPlayers g players = unfoldr f (g, players)
   where f (g, players) = Just (matchPlayers g1 players, (g2, players))
-        (g1, g2) = split g
+                           where (g1, g2) = split g
 
 main = do
+  let n = 100000
   g <- getStdGen
-  let matches = iterativeMatchPlayers g players !! 1010
-  forM_ matches $ \(p, q) ->
+  let playerMap = M.fromList (map (\p -> (name p, p)) players)
+  let matchups = take n $ iterativeMatchPlayers g players
+  let matchup = maximumBy (compare `on` score playerMap []) matchups
+  forM_ matchup $ \(p, q) ->
     putStrLn $ p ++ " vs. " ++ q
+  putStrLn $ "Score: " ++ show (score playerMap [] matchup)