From 9af8d0a226bad32b6304cf287010f5b6e20c18ab Mon Sep 17 00:00:00 2001
From: Kjetil Orbekk <kjetil.orbekk@gmail.com>
Date: Fri, 31 Jul 2015 16:05:43 -0400
Subject: Add random matching.

Creates random match schedule subject to the match limit constraints for
each player.
---
 scheduling/Main.hs | 55 ++++++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 41 insertions(+), 14 deletions(-)

diff --git a/scheduling/Main.hs b/scheduling/Main.hs
index e08d171..18f8ae5 100644
--- a/scheduling/Main.hs
+++ b/scheduling/Main.hs
@@ -1,4 +1,9 @@
 import Control.Monad (forM_)
+import Data.Function (on)
+import Data.List (sortBy, unfoldr)
+import System.Random (RandomGen, randoms, getStdGen, split)
+import Data.HashSet (HashSet, fromList, member)
+
 data Player = Player { name :: String
                      , rank :: Int
                      , matchLimit :: Int
@@ -12,21 +17,43 @@ players = [ Player "orbekk" (-1) 4
           , Player "sheyrax" (-2) 2
           ]
 
-remove :: Eq a => a -> [a] -> [a]
-remove p = filter (/=p)
+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)
+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)
 
-matchPlayers :: [Player] -> [Player] -> ([Player], [(Player, Player)])
-matchPlayers [] qs = (qs, [])
-matchPlayers ps [] = (ps, [])
-matchPlayers (p:ps) (q:qs)
-  | p == q    = matchPlayers (p:ps) qs
-  | otherwise = ([p', q'] ++ s', (p, q) : m')
-      where p' = p { matchLimit = matchLimit p - 1 }
-            q' = q { matchLimit = matchLimit q - 1 }
-            (s', m') = matchPlayers (remove q ps) (remove p qs)
+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
 
 main = do
-  let (players', matches) = matchPlayers players players
-  print players'
+  g <- getStdGen
+  let matches = iterativeMatchPlayers g players !! 1010
   forM_ matches $ \(p, q) ->
-    putStrLn ((name p) ++ " vs. " ++ (name q))
+    putStrLn $ p ++ " vs. " ++ q
-- 
cgit v1.2.3