Tournament (empty) → 0.0.1

raw patch · 5 files changed

+851/−0 lines, 5 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, mtl, test-framework, test-framework-quickcheck2

Files

• Game/Tournament.hs +736/−0
• LICENSE +22/−0
• Readme.md +39/−0
• Setup.hs +2/−0
• Tournament.cabal +52/−0

@@ -0,0 +1,736 @@+{-# LANGUAGE PatternGuards #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Game.Tournament+-- Copyright   :  (c) Eirik Albrigtsen 2012+-- License     :  MIT+-- Maintainer  :  Eirik <clux> 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 <http://clux.org/entries/view/2407>.+-- 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<gs<=s s.t. even distribution => 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]+-}

@@ -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.

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <clux> 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