{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module : Game.Tournament
-- Copyright : (c) Eirik Albrigtsen 2012
-- License : MIT
-- Maintainer : Eirik Albrigtsen
-- Stability : unstable
--
-- Tournament construction and maintenance including competition based structures and helpers.
--
-- This library is intended to be imported qualified as it exports functions that clash with
-- Prelude.
--
-- > import Game.Tournament as T
--
-- The Tournament structure contain a Map of 'GameId' -> 'Game' for its internal
-- representation and the 'GameId' keys are the location in the Tournament.
--
-- Duel tournaments are based on the theory from .
-- By using the seeding definitions listed there, there is almost only one way to
-- generate a tournament, and the ambivalence appears only in Double elimination.
--
-- We have additionally chosen that brackets should converge by having the losers bracket move upwards.
-- This is not necessary, but improves the visual layout when presented in a standard way.
--
-- FFA tournaments use a collection of sensible assumptions on how to
-- optimally split n people into s groups while minimizing the sum of seeds difference
-- between groups for fairness. At the end of each round, groups are recalculated from the scores
-- of the winners, and new groups are created for the next round.
-- TODO: This structure is meant to encapsulate this structure to ensure internal consistency,
-- but hopefully in such a way it can be safely serialized to DBs.
-----------------------------------------------------------------------------
module Game.Tournament (
-- * Building Block A: Duel helpers
seeds
, duelExpected
-- * Building Block B: Group helpers
, groups
, robin
-- * Tournament Types
, GameId(..)
, Elimination(..)
, Bracket(..)
, Rules(..)
, Results -- type synonym
, results
, Result -- no constructor, but accessors:
, player
, placement
, wins
, total
, Size
, Tournament -- no constructor
, Score
, GroupSize
, Advancers
--, Game(..)
--, Player
--, Games
-- * Tournament Interface
, tournament
, score
, count
, scorable
, keys
-- -* Match Inspection
--, scores
--, winner
--, loser
, 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)
--import System.IO.Unsafe (unsafePerformIO) -- while developing
-- -----------------------------------------------------------------------------
-- TODO should somehow ensure 0 < i <= 2^(p-1) in the next fn
-- | Power of a tournament.
-- It's defined as 2^num_players rounded up to nearest power of 2.
--type Power = Int
--type GameNumber = Int
-- TODO: use int synonyms more liberally?
-- | Computes both the upper and lower player seeds for a duel elimiation match.
-- The first argument is the power of the tournament:
--
-- p :: 2^num_players rounding up to nearest power of 2
--
-- The second parameter is the game number i (in round one).
--
-- The pair (p,i) must obey
--
-- >p > 0 && 0 < i <= 2^(p-1).
seeds :: Int -> Int -> (Int, Int)
seeds p i
| p > 0, i > 0, i <= 2^(p-1) = (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^(p-k)
_ -> 2^(p-k-1) + nr `shiftL` (p - length bstr) where
bstr = reverse $ showIntAtBase 2 intToDigit (i - 2*r) ""
nr = fst $ head $ readInt 2 (`elem` "01") digitToInt bstr
-- | Check if the 3 criteria for perfect seeding holds for the current
-- power and seed pair arguments.
-- This can be used to make a measure of how good the seeding was in retrospect
duelExpected :: Integral a => a -> (a, a) -> Bool
duelExpected p (a, b) = odd a && even b && a + b == 1 + 2^p
-- -----------------------------------------------------------------------------
-- Group helpers
--type Group = [Int]
-- | Splits a numer of players into groups of as close to equal seeding sum
-- as possible. When groupsize is even and s | n, the seed sum is constant.
-- Fixes the number of groups as ceil $ n / s, but will reduce s when all groups not full.
groups :: Int -> Int -> [[Int]]
groups 0 _ = []
groups s n = map (sort . filter (<=n) . makeGroup) [1..ngrps] where
ngrps = ceiling $ fromIntegral n / fromIntegral s
-- find largest 0 at least one full group, i.e. gs*ngrps - n < ngrps
gs = until ((< ngrps + n) . (*ngrps)) (subtract 1) s
modl = ngrps*gs -- modl may be bigger than n, e.e. groups 4 10 has a 12 model
npairs = ngrps * (gs `div` 2)
pairs = zip [1..npairs] [modl, modl-1..]
leftovers = [npairs+1, npairs+2 .. modl-npairs] -- [1..modl] \\ e in pairs
makeGroup i = leftover ++ concatMap (\(x,y) -> [x,y]) gpairs where
gpairs = filter ((`elem` [i, i+ngrps .. i+npairs]) . fst) pairs
leftover = take 1 . drop (i-1) $ leftovers
-- | Round robin schedules a list of n players and returns
-- a list of rounds (where a round is a list of pairs). Uses
-- http://en.wikipedia.org/wiki/Round-robin_tournament#Scheduling_algorithm
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 -- matches per round
permute (x:xs@(_:_)) = x : last xs : init xs
permute xs = xs -- not necessary, wont be called on length 1/2 lists
rounds = genericTake (n'-1) $ iterate permute [1..n']
notDummy (x,y) = all (<=n) [x,y]
toPairs x = genericTake m $ zip x (reverse x)
-- -----------------------------------------------------------------------------
-- Duel elimination
-- | The location of a game is written as to simulate the classical shorthand WBR2,
-- but includes additionally the game number for complete positional uniqueness.
--
-- A 'Single' elimination final will have the unique identifier
--
-- > let wbf = GameId WB p 1
--
-- where 'p == count t WB'.
data GameId = GameId {
bracket :: Bracket
, round :: Int
, game :: Int
} deriving (Show, Eq, Ord)
-- | Duel Tournament option.
--
-- 'Single' elimation is a standard power of 2 tournament tree,
-- wheras 'Double' elimination grants each loser a second chance in the lower bracket.
data Elimination = Single | Double deriving (Show, Eq, Ord)
-- | The bracket location of a game.
--
-- For 'Duel' 'Single' or 'FFA', most matches exist in the winners bracket ('WB')
-- , with the exception of the bronze final and possible crossover matches.
--
-- 'Duel' 'Double' or 'FFA' with crossovers will have extra matches in the loser bracket ('LB').
data Bracket = WB | LB deriving (Show, Eq, Ord)
-- | Players and Results zip to the correct association list.
-- 'scores' will obtain this ordered association list safely.
data Game = Game {
players :: [Player]
, result :: Maybe [Score]
} deriving (Show, Eq)
type Games = Map GameId Game
-- | 'score' clarification types.
type Position = Int
type Score = Int
type Player = Int
type Seed = Int
-- | Record of each player's accomplishments in the current tournament.
data Result = Result {
-- | Player associated with the record.
player :: Int
-- | Placement of the player associated with this record.
, placement :: Int
-- | Number of games the player associated with this record won.
, wins :: Int
-- | Sum of scores for the games the associated player played.
, total :: Int
} deriving (Show)
-- | Results in descending order of placement.
--
-- Only constructed by 'score' once the last game was played.
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
}
-- Internal helpers
gameZip :: Game -> [(Player, Score)]
gameZip m = zip (players m) (fromJust (result m))
gameSort :: [(Player, Score)] -> [(Player, Score)]
gameSort = reverse . sortBy (comparing snd)
-- | Sorted player identifier list by scores.
--
-- If this is called on an unscored match a (finite) list zeroes is returned.
-- This is consistent with the internal representation of placeholders in Matches.
scores :: Game -> [Player]
scores g@(Game pls msc)
| Just _ <- msc = map fst . gameSort . gameZip $ g
| otherwise = replicate (length pls) 0
-- | The first and last elements from scores.
winner, loser :: Game -> Player
winner = head . scores
loser = last . scores
-- Duel specific helper
pow :: Int -> Int
pow = ceiling . logBase 2 . fromIntegral
-- | Count the number of rounds in a given bracket in a Tournament.
-- TODO: rename to length once it has been less awkwardly moved into an internal part
count :: Tournament -> Bracket -> Int
count Tourney { rules = Duel Single, size = np } br = if br == WB then pow np else 0 -- 1 with bronze
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
-- Scoring and construction helper
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
-- | Get the list of all GameIds in a Tournament.
-- This list is also ordered by GameId's Ord, and in fact,
-- if the corresponding games were scored in this order, the tournament would finish,
-- and scorable would only return False for a few special walkover games.
-- TODO: if introducing crossovers, this would not be true for LB crossovers
-- => need to place them in WB in an 'interim round'
keys :: Tournament -> [GameId]
keys = Map.keys . games
-- | Create match shells for an FFA elimination tournament.
-- Result comes pre-filled in with either top advancers or advancers `intersect` seedList.
-- This means what the player numbers represent is only fixed per round.
-- TODO: Either String Tournament as return for intelligent error handling
tournament :: Rules -> Size -> Tournament
tournament rs@(FFA gs adv) np
-- Enforce >2 players, >2 players per match, and >1 group needed.
-- Not technically limiting, but: gs 2 <=> duel and 1 group <=> best of one.
| 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 =
--TODO: allow crossover matches when there are gaps intelligently..
let minsize = minimum . map length
hideSeeds = map $ map $ const 0
nextGroup g = hideSeeds . groups gs $ leftover where
-- force zero non-eliminating matches unless only 1 left
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]
-- finally convert raw group lists to matches
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 }
-- | Create match shells for an elimination tournament
-- hangles walkovers and leaves the tournament in a stable initial state
tournament rs@(Duel e) np
-- Enforce minimum 4 players for a tournament. It is possible to extend to 2 and 3, but:
-- 3p uses a 4p model with one WO => == RRobin in Double, == Unfair in Single
-- 2p Single == 1 best of 1 match, 2p Double == 1 best of 3 match
-- and grand final rules fail when LB final is R1 (p=1) as GF is then 2*p-1 == 1 ↯
| 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
-- complete WBR1 by filling in -1 as WO markers for missing (np'-np) players
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
-- make WBR2 and LBR1 shells by using the paired WBR1 results to propagate winners/WO markers
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
-- make LBR2 shells by using LBR1 results to propagate WO markers if 2x
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]
-- construct (possibly) non-empty rounds
wbr1 = map makeWbR1 [1..2^(p-1)]
wbr1pairs = take (2^(p-2))
$ filter (even . game . fst . snd) $ zip wbr1 (tail wbr1)
wbr2 = map (propagateWbR1 WB) wbr1pairs
lbr1 = map (propagateWbR1 LB) wbr1pairs
lbr2 = map makeLbR2 lbr1
-- construct (definitely) empty rounds
wbRest = concatMap makeRound [3..p] where
makeRound r = map (GameId WB r) [1..2^(p-r)]
--bfm = MID LB (R 1) (G 1) -- bronze final here, exception
lbRest = map gfms [2*p-1, 2*p] ++ concatMap makeRound [3..2*p-2] 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
-- finally, union the mappified brackets
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
-- | Helper to create the tie-correct Player -> Position association list.
-- Requires a Round -> Position function to do the heavy lifting where possible,
-- the final Game and Maybe bronzefinal to not take out
-- the list of games prefiltered away non-final bracket and final games.
-- result zips with Player == [1..]
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)
-- zips with Player == [1..]
sumScores :: Games -> [Score]
sumScores = map (foldr ((+) . snd) 0)
. groupBy ((==) `on` fst)
. sortBy (comparing fst)
. Map.foldr ((++) . gameZip) []
-- zips with Player == [1..]
getWins :: Int -> Games -> [Int]
getWins np = map (subtract 1 . length) -- started out with one of each so we can count zeroes
. 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 -- final played
-- bf lookup here if included!
= Just . scorify $ wbf
| e == Double
, Just gf1@(Game _ (Just gf1sc)) <- Map.lookup (GameId LB (2*p-1) 1) ms -- gf1 played
, Just gf2@(Game _ gf2sc) <- Map.lookup (GameId LB (2*p) 1) ms -- gf2 maybe played
, isJust gf2sc || maximum gf1sc == head gf1sc -- gf2 played || gf1 conclusive
= Just . scorify $ if isJust gf2sc then gf2 else gf1
| otherwise = Nothing
where
p = pow np
maxRnd = if e == Single then p else 2*p-1
-- maps (last bracket's) maxround to the tie-placement
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
-- all pipelines start with this. 0 should not exist, -1 => winner got further
-- scores not Just => should not have gotten this far by guard in score fn
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 :: [(RoundNr, NumPlayers)] lookup helper for toPlacement
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
-- maps a player's maxround to the tie-placement (called for r < maxRnd)
-- simplistic :: 1 + number of people who got through to next round
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
-- NB: WO markers or placeholders should NOT exist when scorify called!
-- placements using common helper, having prefiltered final game(round)
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
-- | Check if a GameId exists and is ready to be scored through 'score'.
scorable :: GameId -> Tournament -> Bool
scorable gid = isJust . playersReady gid
-- | Checks if a GameId is 'scorable' and it will not propagate to an already scored Game.
-- Guarding Tournament updates with this ensures it is never in an inconsistent state.
-- TODO: really needs access to mRight, mDown (if duel) to ensure they exist
-- TODO: if FFA only allow scoring if NO matches in the next round have been scored
safeScorable :: GameId -> Tournament -> Bool
safeScorable = undefined
-- | Score a match in a tournament and propagate winners/losers.
-- If match is not 'scorable', the Tournament will pass through unchanged.
--
-- For a Duel tournament, winners (and losers if Double) are propagated immediately,
-- wheras FFA tournaments calculate winners at the end of the round (when all games played).
--
-- There is no limitation on re-scoring old games, so care must be taken to not update too far
-- back ones and leaving the tournament in an inconsistent state. When scoring games more than one
-- round behind the corresponding active round, the locations to which these propagate must
-- be updated manually.
--
-- To prevent yourself from never scoring older matches, only score games for which
-- 'safeScorable' returns True. Though this has not been implemented yet.
--
-- > gid = (GameId WB 2 1)
-- > tUpdated = if safeScorable gid then score gid [1,0] t else t
--
-- TODO: strictify this function
-- TODO: better to do a scoreSafe? // call this scoreUnsafe
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 }
-- somewhat less ideally, if length sc /= length pls this now also fails silently even if socable passes
| otherwise = trn
scoreFFA :: GroupSize -> Advancers -> GameId -> [Score] -> [Player] -> State Games ()
scoreFFA gs adv gid@(GameId _ r _) scrs pls = do
-- 1. score given game
let m = Game pls $ Just scrs
modify $ Map.adjust (const m) gid
-- 2. if end of round, fill in next round
currRnd <- gets $ Map.elems . Map.filterWithKey (const . (==r) . round)
when (all (isJust . result) currRnd) $ do
-- find the number of players we need in next round
numNext <- gets $ Map.foldr ((+) . length . players) 0
. Map.filterWithKey (const . (==r+1) . round)
-- recreate next round by using last round results as new seeding
-- update next round by overwriting duplicate keys in next round
modify $ flip (Map.unionWith (flip const)) $ makeRnd currRnd numNext
return ()
where
-- make round (r+1) from the games in round r and the top n to take
makeRnd :: [Game] -> Size -> Games
makeRnd gms = Map.fromList . nextGames . grpMap (seedAssoc False gms) . groups gs
-- This sorts all players by overall scores (to help pick best crossover candidates)
-- Or, if !takeAll, sort normally by only including the advancers from each game.
seedAssoc :: Bool -> [Game] -> [(Seed, Player)]
seedAssoc takeAll rnd
| takeAll = seedify . concatMap gameZip $ rnd
| otherwise = seedify . concatMap (take (rndAdv rnd) . gameSort . gameZip) $ rnd
where
-- Find out how many to keep from each round before sorting overall
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
-- 1. score given game
let m = Game pls $ Just scrs
modify $ Map.adjust (const m) gid
-- 2. move winner right
let nprog = mRight True p gid
nres <- playerInsert nprog $ winner m
-- 3. move loser to down if we were in winners
let dprog = mDown p gid
dres <- playerInsert dprog $ loser m
-- 4. check if loser needs WO from LBR1
let dprog2 = woCheck p dprog dres
uncurry playerInsert $ fromMaybe (Nothing, 0) dprog2
-- 5. check if winner needs WO from LBR2
let nprog2 = woCheck p nprog nres
uncurry playerInsert $ fromMaybe (Nothing, 0) nprog2
return Nothing
where
-- insert player x into list index idx of mid's players, and woScore it
-- progress result determines location and must be passed in as fst arg
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]
-- given tourney power, progress results, and insert results, of previous
-- if it was woScored in playerInsert, produce new (progress, winner) pair
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
-- right progress fn: winner moves right to (GameId, Position)
mRight :: Bool -> Int -> GameId -> Maybe (GameId, Position)
mRight gf2Check p (GameId br r g)
| r < 1 || g < 1 = error "bad GameId"
-- Nothing if last Game. NB: WB ends 1 round faster depending on e
| r >= 2*p || (br == WB && (r > p || (e == Single && r == p))) = Nothing
| br == LB = Just (GameId LB (r+1) ghalf, pos) -- standard LB progression
| r == 2*p-1 && br == LB && gf2Check && maximum scrs == head scrs = Nothing
| r == p = Just (GameId LB (2*p-1) ghalf, 0) -- WB winner -> GF1 path
| otherwise = Just (GameId WB (r+1) ghalf, pos) -- standard WB progression
where
ghalf = if br == LB && odd r then g else (g+1) `div` 2
pos
| br == WB = if odd g then 0 else 1 -- WB maintains standard alignment
| r == 2*p-2 = 1 -- LB final winner => bottom of GF
| r == 2*p-1 = 0 -- GF(1) winnner moves to the top [semantic]
| r > 1 && odd r = 1 -- winner usually takes the bottom position
| r == 1 = if odd g then 1 else 0 -- first rounds sometimes goto bottom
| otherwise = if odd g then 0 else 1 -- normal progression only in even rounds + R1
-- by placing winner on bottom consistently in odd rounds the bracket moves upward each new refill
-- the GF(1) and LB final are special cases that give opposite results to the advanced rule above
-- down progress fn : loser moves down to (GameId, Position)
mDown :: Int -> GameId -> Maybe (GameId, Position)
mDown p (GameId br r g)
| e == Single = Nothing
-- or case for bf: | e == Single && r == p-1 = Just (MID LB (R 1) (G 1), if odd g then 0 else 1)
| r == 2*p-1 = Just (GameId LB (2*p) 1, 1) -- GF(1) loser moves to the bottom
| br == LB || r > p = Nothing
| r == 1 = Just (GameId LB 1 ghalf, pos) -- WBR1 -> r=1 g/2 (LBR1 only gets input from WB)
| otherwise = Just (GameId LB ((r-1)*2) g, pos) -- WBRr -> 2x as late per round in WB
where
ghalf = (g+1) `div` 2
-- drop on top >R2, and <=2 for odd g to match bracket movement
pos = if r > 2 || odd g then 0 else 1
-- testing stuff
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
--let t = tournament (FFA 4 1) 16
--testor $ execState manipFFA t
-- | Checks if a Tournament is valid
{-
PERHAPS BETTER:
WB: always has np (rounded to nearest power) - 1 matches -- i.e. np = 2^p some p > 1
LB: always has 2*[num_wb_matches - 2^(p-1) + 1] -- i.e. minus the first round's matches but plus two finals
tournamentValid :: Tournament -> Bool
tournamentValid t =
let (wb, lb) = partition ((== WB) . brac . locId) r
roundRightWb k = rightSize && uniquePlayers where
rightSize = 2^(p-k) == length $ filter ((== k) . rnd . locId) wb
uniquePlayers =
rountRightLb k = rightSize && uniquePlayers where
rightSize = 2^(p - 1 - (k+1) `div` 2) == length $ filter ((== k) . rnd . locId) lb
in all $ map roundRightWb [1..2^p]
-}