1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
{-# LANGUAGE BangPatterns #-}
import Debug.Trace
import Control.Monad (forM_)
import Data.Function (on)
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
, matchLimit :: Int
} 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 "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)
where rs = randoms g :: [Int]
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)
where p' = min p q
q' = max p q
matchOnce _ _ = []
subtractMatches :: [(String, String)] -> [Player] -> [Player]
subtractMatches matches players = fmap subtractMatch players
where matchPlayers :: HashSet String
matchPlayers = fromList (map fst matches ++ map snd matches)
subtractMatch p
| (name p) `member` matchPlayers =
p { matchLimit = matchLimit p - 1 }
| otherwise = p
matchPlayers :: (RandomGen g) => g -> [Player] -> [(String, String)]
matchPlayers _ [] = []
matchPlayers _ [p] = []
matchPlayers g players = matches ++ matchPlayers g3 nextPlayers
where matches = matchOnce (shuffle g1 playerNames) (shuffle g2 playerNames)
playerNames = fmap name players
(g', g1) = split g
(g2, g3) = split g'
nextPlayers =
filter ((>0) . matchLimit) (subtractMatches matches players)
iterativeMatchPlayers :: (RandomGen g) => g -> [Player] -> [[(String, String)]]
iterativeMatchPlayers g players = unfoldr f (g, players)
where f (g, players) = Just (matchPlayers g1 players, (g2, players))
where (g1, g2) = split g
main = do
let n = 100000
g <- getStdGen
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)
|
