module Game.Tournament (
seeds
, duelExpected
, groups
, robin
, GameId(..)
, Elimination(..)
, Bracket(..)
, Rules(..)
, Results
, results
, Result
, player
, placement
, wins
, total
, Size
, Tournament
, Score
, GroupSize
, Advancers
, tournament
, score
, count
, scorable
, keys
, testcase
) where
import Prelude hiding (round)
import Numeric (showIntAtBase, readInt)
import Data.Char (intToDigit, digitToInt)
import Data.List (sort, sortBy, group, groupBy, genericTake, zipWith4)
import Data.Ord (comparing)
import Data.Function (on)
import Data.Bits (shiftL)
import Data.Maybe (fromJust, isJust, fromMaybe)
import qualified Data.Map.Lazy as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Control.Arrow ((&&&), second)
import Control.Monad (when)
import Control.Monad.State (State, get, put, modify, execState, gets)
seeds :: Int -> Int -> (Int, Int)
seeds p i
| p > 0, i > 0, i <= 2^(p1) = (1 lastSeed + 2^p, lastSeed)
| otherwise = error "seeds called outside well defined power game region"
where
lastSeed = let (k, r) = ((floor . logBase 2 . fromIntegral) i, i 2^k) in
case r of
0 -> 2^(pk)
_ -> 2^(pk1) + nr `shiftL` (p length bstr) where
bstr = reverse $ showIntAtBase 2 intToDigit (i 2*r) ""
nr = fst $ head $ readInt 2 (`elem` "01") digitToInt bstr
duelExpected :: Integral a => a -> (a, a) -> Bool
duelExpected p (a, b) = odd a && even b && a + b == 1 + 2^p
groups :: Int -> Int -> [[Int]]
groups 0 _ = []
groups s n = map (sort . filter (<=n) . makeGroup) [1..ngrps] where
ngrps = ceiling $ fromIntegral n / fromIntegral s
gs = until ((< ngrps + n) . (*ngrps)) (subtract 1) s
modl = ngrps*gs
npairs = ngrps * (gs `div` 2)
pairs = zip [1..npairs] [modl, modl1..]
leftovers = [npairs+1, npairs+2 .. modlnpairs]
makeGroup i = leftover ++ concatMap (\(x,y) -> [x,y]) gpairs where
gpairs = filter ((`elem` [i, i+ngrps .. i+npairs]) . fst) pairs
leftover = take 1 . drop (i1) $ leftovers
robin :: Integral a => a -> [[(a,a)]]
robin n = map (filter notDummy . toPairs) rounds where
n' = if odd n then n+1 else n
m = n' `div` 2
permute (x:xs@(_:_)) = x : last xs : init xs
permute xs = xs
rounds = genericTake (n'1) $ iterate permute [1..n']
notDummy (x,y) = all (<=n) [x,y]
toPairs x = genericTake m $ zip x (reverse x)
data GameId = GameId {
bracket :: Bracket
, round :: Int
, game :: Int
} deriving (Show, Eq, Ord)
data Elimination = Single | Double deriving (Show, Eq, Ord)
data Bracket = WB | LB deriving (Show, Eq, Ord)
data Game = Game {
players :: [Player]
, result :: Maybe [Score]
} deriving (Show, Eq)
type Games = Map GameId Game
type Position = Int
type Score = Int
type Player = Int
type Seed = Int
data Result = Result {
player :: Int
, placement :: Int
, wins :: Int
, total :: Int
} deriving (Show)
type Results = [Result]
type GroupSize = Int
type Advancers = Int
data Rules = FFA GroupSize Advancers | Duel Elimination
type Size = Int
data Tournament = Tourney {
size :: Size
, crossover :: Bool
, rules :: Rules
, games :: Games
, results :: Maybe Results
}
gameZip :: Game -> [(Player, Score)]
gameZip m = zip (players m) (fromJust (result m))
gameSort :: [(Player, Score)] -> [(Player, Score)]
gameSort = reverse . sortBy (comparing snd)
scores :: Game -> [Player]
scores g@(Game pls msc)
| Just _ <- msc = map fst . gameSort . gameZip $ g
| otherwise = replicate (length pls) 0
winner, loser :: Game -> Player
winner = head . scores
loser = last . scores
pow :: Int -> Int
pow = ceiling . logBase 2 . fromIntegral
count :: Tournament -> Bracket -> Int
count Tourney { rules = Duel Single, size = np } br = if br == WB then pow np else 0
count Tourney { rules = Duel Double, size = np } br = (if br == WB then 1 else 2) * pow np
count Tourney { rules = FFA _ _, games = ms } WB = round . fst . Map.findMax $ ms
count Tourney { rules = FFA _ _} LB = 0
woScores :: [Player] -> Maybe [Score]
woScores ps
| 0 `notElem` ps && 1 `elem` ps = Just $ map (\x -> if x == 1 then 0 else 1) ps
| otherwise = Nothing
keys :: Tournament -> [GameId]
keys = Map.keys . games
tournament :: Rules -> Size -> Tournament
tournament rs@(FFA gs adv) np
| np <= 2 = error "Need >2 players for an FFA elimination"
| gs <= 2 = error "Need >2 players per match for an FFA elimination"
| np <= gs = error "Need >1 group for an FFA elimination"
| adv >= gs = error "Need to eliminate at least one player a match in FFA elimination"
| adv <= 0 = error "Need >0 players to advance per match in a FFA elimination"
| otherwise =
let minsize = minimum . map length
hideSeeds = map $ map $ const 0
nextGroup g = hideSeeds . groups gs $ leftover where
advm = max 1 $ adv (gs minsize g)
leftover = length g * advm
playoffs = takeWhile ((>1) . length) . iterate nextGroup . groups gs $ np
final = nextGroup $ last playoffs
grps = playoffs ++ [final]
makeRound grp r = zipWith makeMatch grp [1..] where
makeMatch g i = (GameId WB r i, Game g Nothing)
ms = Map.fromList . concat $ zipWith makeRound grps [1..]
in Tourney { size = np, rules = rs, games = ms, results = Nothing, crossover = False }
tournament rs@(Duel e) np
| np < 4 = error "Need >=4 competitors for an elimination tournament"
| otherwise = Tourney { size = np, rules = rs, games = ms, results = Nothing, crossover = True} where
p = pow np
markWO (x, y) = map (\a -> if a <= np then a else 1) [x,y]
makeWbR1 i = (l, Game pl (woScores pl)) where
l = GameId WB 1 i
pl = markWO $ seeds p i
propagateWbR1 br ((_, m1), (l2, m2)) = (l, Game pl (woScores pl)) where
(l, pl)
| br == WB = (GameId WB 2 g, map winner [m1, m2])
| br == LB = (GameId LB 1 g, map loser [m1, m2])
g = game l2 `div` 2
makeLbR2 (l1, m1) = (l, Game pl Nothing) where
l = GameId LB 2 $ game l1
plw = winner m1
pl = if odd (game l1) then [0, plw] else [plw, 0]
wbr1 = map makeWbR1 [1..2^(p1)]
wbr1pairs = take (2^(p2))
$ filter (even . game . fst . snd) $ zip wbr1 (tail wbr1)
wbr2 = map (propagateWbR1 WB) wbr1pairs
lbr1 = map (propagateWbR1 LB) wbr1pairs
lbr2 = map makeLbR2 lbr1
wbRest = concatMap makeRound [3..p] where
makeRound r = map (GameId WB r) [1..2^(pr)]
lbRest = map gfms [2*p1, 2*p] ++ concatMap makeRound [3..2*p2] where
makeRound r = map (GameId LB r) [1..(2^) $ p 1 (r+1) `div` 2]
gfms r = GameId LB r 1
toMap = Map.fromSet (const (Game [0,0] Nothing)) . Set.fromList
wb = Map.union (toMap wbRest) $ Map.fromList $ wbr1 ++ wbr2
lb = Map.union (toMap lbRest) $ Map.fromList $ lbr1 ++ lbr2
ms = if e == Single then wb else wb `Map.union` lb
placementSort :: Game -> Maybe Game -> (Int -> Position) -> Games -> [Position]
placementSort fg bf toPlacement = map snd . sortBy (comparing fst)
. prependTop 1 (Just fg)
. prependTop (((+1) . length . players) fg) bf
. excludeTop
. map (second toPlacement . (fst . head &&& foldr (max . snd) 1))
. groupBy ((==) `on` fst)
. sortBy (comparing fst)
. Map.foldrWithKey rfold []
where
pls = if isJust bf then concatMap players [fg, fromJust bf] else players fg
rfold (GameId _ r _) m acc = (++ acc) . map (id &&& const r) $ players m
prependTop :: Int -> Maybe Game -> [(Position, Player)] -> [(Position, Player)]
prependTop strt g
| isJust g = (++) . flip zip [strt..] . map fst . gameSort . gameZip . fromJust $ g
| otherwise = id
excludeTop :: [(Position, Player)] -> [(Position, Player)]
excludeTop = filter ((`notElem` pls) . fst)
sumScores :: Games -> [Score]
sumScores = map (foldr ((+) . snd) 0)
. groupBy ((==) `on` fst)
. sortBy (comparing fst)
. Map.foldr ((++) . gameZip) []
getWins :: Int -> Games -> [Int]
getWins np = map (subtract 1 . length)
. group . sort
. Map.foldr ((:) . winner) [1..np]
zipResults :: [Int] -> [Int] -> [Int] -> [Result]
zipResults a b = sortBy (comparing placement) . zipWith4 Result [1..] a b
makeResults :: Tournament -> Games -> Maybe Results
makeResults (Tourney {rules = Duel e, size = np}) ms
| e == Single
, Just wbf@(Game _ (Just _)) <- Map.lookup (GameId WB p 1) ms
= Just . scorify $ wbf
| e == Double
, Just gf1@(Game _ (Just gf1sc)) <- Map.lookup (GameId LB (2*p1) 1) ms
, Just gf2@(Game _ gf2sc) <- Map.lookup (GameId LB (2*p) 1) ms
, isJust gf2sc || maximum gf1sc == head gf1sc
= Just . scorify $ if isJust gf2sc then gf2 else gf1
| otherwise = Nothing
where
p = pow np
maxRnd = if e == Single then p else 2*p1
toPlacement :: Elimination -> Int -> Position
toPlacement Double maxlbr = if metric <= 4 then metric else 2^(k+1) + 1 + oddExtra where
metric = 2*p + 1 maxlbr
r = metric 4
k = (r+1) `div` 2
oddExtra = if odd r then 0 else 2^k
toPlacement Single maxr = if metric <= 1 then metric else 2^r + 1 where
metric = p+1 maxr
r = metric 1
scorify :: Game -> Results
scorify f = zipResults placements (getWins np ms) (sumScores msnwo) where
msnwo = Map.filter (all (>0) . players) ms
placements = placementSort f Nothing (toPlacement e)
. Map.filterWithKey lastBracketNotFinal $ msnwo
lastBracketNotFinal k _ = round k < maxRnd && lastBracket (bracket k)
lastBracket br = (e == Single && br == WB) || (e == Double && br == LB)
makeResults (Tourney {rules = FFA _ _, size = np}) ms
| (GameId _ maxRnd _, f@(Game _ (Just _))) <- Map.findMax ms
= Just $ scorify maxRnd f
| otherwise = Nothing
where
rsizes = map (fst . head &&& foldr ((+) . snd) 0)
. groupBy ((==) `on` fst)
. sortBy (comparing fst)
. Map.foldrWithKey rsizerf [] $ ms
where
rsizerf gid g acc = (round gid, (length . players) g) : acc
toPlacement :: Int -> Position
toPlacement maxrp = (1+) . fromJust . lookup (maxrp + 1) $ rsizes
scorify :: Int -> Game -> Results
scorify maxRnd f = zipResults placements (getWins np ms) (sumScores ms) where
placements = placementSort f Nothing toPlacement
. Map.filterWithKey (\k _ -> round k < maxRnd) $ ms
playersReady :: GameId -> Tournament -> Maybe [Player]
playersReady gid t
| Just (Game pls _) <- Map.lookup gid $ games t
, all (>0) pls
= Just pls
| otherwise = Nothing
scorable :: GameId -> Tournament -> Bool
scorable gid = isJust . playersReady gid
safeScorable :: GameId -> Tournament -> Bool
safeScorable = undefined
score :: GameId -> [Score] -> Tournament -> Tournament
score gid sc trn@(Tourney { rules = r, size = np, games = ms })
| Duel e <- r
, Just pls <- playersReady gid trn
, length sc == 2
= let msUpd = execState (scoreDuel (pow np) e gid sc pls) ms
rsUpd = makeResults trn msUpd
in trn { games = msUpd, results = rsUpd }
| FFA s adv <- r
, Just pls <- playersReady gid trn
, length sc == length pls
= let msUpd = execState (scoreFFA s adv gid sc pls) ms
rsUpd = makeResults trn msUpd
in trn { games = msUpd, results = rsUpd }
| otherwise = trn
scoreFFA :: GroupSize -> Advancers -> GameId -> [Score] -> [Player] -> State Games ()
scoreFFA gs adv gid@(GameId _ r _) scrs pls = do
let m = Game pls $ Just scrs
modify $ Map.adjust (const m) gid
currRnd <- gets $ Map.elems . Map.filterWithKey (const . (==r) . round)
when (all (isJust . result) currRnd) $ do
numNext <- gets $ Map.foldr ((+) . length . players) 0
. Map.filterWithKey (const . (==r+1) . round)
modify $ flip (Map.unionWith (flip const)) $ makeRnd currRnd numNext
return ()
where
makeRnd :: [Game] -> Size -> Games
makeRnd gms = Map.fromList . nextGames . grpMap (seedAssoc False gms) . groups gs
seedAssoc :: Bool -> [Game] -> [(Seed, Player)]
seedAssoc takeAll rnd
| takeAll = seedify . concatMap gameZip $ rnd
| otherwise = seedify . concatMap (take (rndAdv rnd) . gameSort . gameZip) $ rnd
where
rndAdv :: [Game] -> Advancers
rndAdv = max 1 . (adv gs +) . minimum . map (length . players)
seedify :: [(Player, Score)] -> [(Seed, Player)]
seedify = zip [1..] . map fst . gameSort
grpMap :: [(Seed, Player)] -> [[Seed]] -> [[Player]]
grpMap assoc = map . map $ fromJust . flip lookup assoc
nextGames :: [[Player]] -> [(GameId, Game)]
nextGames = zipWith (\i g -> (GameId WB (r+1) i, Game g Nothing)) [1..]
scoreDuel :: Int -> Elimination -> GameId -> [Score] -> [Player] -> State Games (Maybe Game)
scoreDuel p e gid scrs pls = do
let m = Game pls $ Just scrs
modify $ Map.adjust (const m) gid
let nprog = mRight True p gid
nres <- playerInsert nprog $ winner m
let dprog = mDown p gid
dres <- playerInsert dprog $ loser m
let dprog2 = woCheck p dprog dres
uncurry playerInsert $ fromMaybe (Nothing, 0) dprog2
let nprog2 = woCheck p nprog nres
uncurry playerInsert $ fromMaybe (Nothing, 0) nprog2
return Nothing
where
playerInsert :: Maybe (GameId, Position) -> Player -> State Games (Maybe Game)
playerInsert Nothing _ = return Nothing
playerInsert (Just (gid, idx)) x = do
tmap <- get
let (updated, tupd) = Map.updateLookupWithKey updFn gid tmap
put tupd
return updated
where updFn _ (Game plsi _) = Just $ Game plsm (woScores plsm) where
plsm = if idx == 0 then [x, last plsi] else [head plsi, x]
woCheck :: Player
-> Maybe (GameId, Position)
-> Maybe Game
-> Maybe (Maybe (GameId, Position), Player)
woCheck p (Just (gid, _)) (Just mg)
| w <- winner mg, w > 0 = Just (mRight False p gid, w)
| otherwise = Nothing
woCheck _ _ _ = Nothing
mRight :: Bool -> Int -> GameId -> Maybe (GameId, Position)
mRight gf2Check p (GameId br r g)
| r < 1 || g < 1 = error "bad GameId"
| r >= 2*p || (br == WB && (r > p || (e == Single && r == p))) = Nothing
| br == LB = Just (GameId LB (r+1) ghalf, pos)
| r == 2*p1 && br == LB && gf2Check && maximum scrs == head scrs = Nothing
| r == p = Just (GameId LB (2*p1) ghalf, 0)
| otherwise = Just (GameId WB (r+1) ghalf, pos)
where
ghalf = if br == LB && odd r then g else (g+1) `div` 2
pos
| br == WB = if odd g then 0 else 1
| r == 2*p2 = 1
| r == 2*p1 = 0
| r > 1 && odd r = 1
| r == 1 = if odd g then 1 else 0
| otherwise = if odd g then 0 else 1
mDown :: Int -> GameId -> Maybe (GameId, Position)
mDown p (GameId br r g)
| e == Single = Nothing
| r == 2*p1 = Just (GameId LB (2*p) 1, 1)
| br == LB || r > p = Nothing
| r == 1 = Just (GameId LB 1 ghalf, pos)
| otherwise = Just (GameId LB ((r1)*2) g, pos)
where
ghalf = (g+1) `div` 2
pos = if r > 2 || odd g then 0 else 1
upd :: [Score] -> GameId -> State Tournament ()
upd sc id = do
t <- get
put $ score id sc t
return ()
manipDuel :: [GameId] -> State Tournament ()
manipDuel = mapM_ (upd [1,0])
manipFFA :: State Tournament ()
manipFFA = do
upd [1,2,3,4] $ GameId WB 1 1
upd [5,3,2,1] $ GameId WB 1 2
upd [2,4,2,1] $ GameId WB 1 3
upd [6,3,2,1] $ GameId WB 1 4
upd [1,2,3,4] $ GameId WB 2 1
testor :: Tournament -> IO ()
testor Tourney { games = ms, results = rs } = do
mapM_ print $ Map.assocs ms
maybe (print "no results") (mapM_ print) rs
testcase :: IO ()
testcase = do
let t = tournament (Duel Double) 8
testor $ execState (manipDuel (keys t)) t