diff --git a/Game/Tournament.hs b/Game/Tournament.hs new file mode 100644 --- /dev/null +++ b/Game/Tournament.hs @@ -0,0 +1,736 @@ +{-# 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] +-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +(The MIT License) + +Copyright (c) 2012 Eirik Albrigtsen + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +'Software'), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Readme.md b/Readme.md new file mode 100644 --- /dev/null +++ b/Readme.md @@ -0,0 +1,39 @@ +#Tournament.hs ![travis build status](https://secure.travis-ci.org/clux/tournament.hs.png) + +Tournament is a pure library for generating tournanaments and handling match scoring and +propagation of winners/losers internally. +It is currently under development, but a +[preliminary version](http://hackage.haskell.org/packages/archive/tournament/0.0.1/) +is available on hackage. + +## Features + +- `Double | Single` elimination style `Duel` tournaments +- Intelligent `FFA` elimination tournament for experimental setups +- Round robin scheduling +- Group creation +- Encapsulated scoring system. + +## Installation +Install the Haskell platform, then + +````bash +$ cabal-dev update && cabal-dev install tournament +```` + +## Running tests +Install development dependencies. Note on older versions of cabal: +you may have to install the Test-Suite dependencies manually with `cabal-dev install depName`. + +````bash +$ cabal-dev update && cabal-dev install --enable-tests +```` + +Run the tests + +````bash +$ cabal-dev configure --enable-tests && cabal-dev build && cabal-dev test +```` + +## License +MIT-Licensed. See LICENSE file for details. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Tournament.cabal b/Tournament.cabal new file mode 100644 --- /dev/null +++ b/Tournament.cabal @@ -0,0 +1,52 @@ +Name : Tournament +Version : 0.0.1 +Synopsis : Tournament related algorithms +Homepage : http://github.com/clux/tournament.hs +Description : + + Tournament is a pure library which generates and updates competition + based structures that represent basic FFA or Duel tournaments. + +License : MIT +License-file : LICENSE +Author : Eirik Albrigtsen +Copyright : 2012, Eirik Albrigtsen +Maintainer : analsandblaster@gmail.com +Category : Game +Bug-reports : http://github.com/clux/tournament.hs/issues + +Build-type : Simple +Stability : Unstable +tested-with : GHC == 7.0.4 +Cabal-version : >= 1.10 + +Extra-source-files: + Readme.md + +source-repository head + type: git + location: git://github.com/clux/tournament.hs.git +-------------------------------------------------------------------------------- +library + default-language : Haskell2010 + hs-source-dirs : . + exposed-modules : Game.Tournament + build-depends : + base == 4.* + , mtl == 2.0.* + , containers == 0.5.* + ghc-options : -W +------------------------------------------------------------------------------- +Test-Suite test-tournament + main-is : Test.hs + default-language : Haskell2010 + type : exitcode-stdio-1.0 + other-modules : Game.Tournament + build-depends : + base == 4.* + , mtl == 2.0.* + , containers == 0.5.* + , QuickCheck == 2.4.* + , test-framework-quickcheck2 == 0.2.* + , test-framework == 0.6.* + ghc-options : -W