Permalink
Browse files

small train tweaks + basic properties for quickcheck suite

  • Loading branch information...
1 parent 4c73815 commit 780aa4c2740986327177cd836927c949d2dfe648 @clux committed Mar 20, 2012
Showing with 96 additions and 16 deletions.
  1. +65 −0 test.hs
  2. +31 −16 tournament.hs
View
65 test.hs
@@ -0,0 +1,65 @@
+import qualified Tournament as T
+import Test.QuickCheck (quickCheck)
+import Data.List ((\\))
+
+-- -----------------------------------------------------------------------------
+-- inGroupsOf
+
+-- group size <= input size
+groupsProp1 :: Int -> Int -> Property
+groupsProp1 n s = n >= 0 && s >= 0 ==>
+ let gs = n `T.inGroupsOf` s
+ in maximum (map length gs) <= s
+
+-- players included == [1..n]
+groupsProp2 :: Int -> Int -> Property
+groupsProp2 n s = n >= 0 && s >= 0 ==>
+ let pls = concat $ n `T.inGroupsOf` s
+ in length pls == n && null $ pls \\ [1..n]
+
+-- sum of seeds of groups in full groups differ by at most num_groups
+groupsProp3 :: Int -> Int -> Property
+groupsProp3 n s = n >= 0 && s >= 0 && n `mod` s == 0 ==>
+ let gs = n `T.inGroupsOf` s
+ ms = map sum gs
+ in maximum ms <= minimum ms + length gs
+
+-- sum of seeds is perfect when groups are full and even sized
+groupsProp4 :: Int -> Int -> Property
+groupsProp4 n s = n >= 0 && s >= 0 && n `mod` s == 0 && even (n `div` s) ==>
+ let gs = n `T.inGroupsOf` s
+ ms = map sum gs
+ in maximum ms == minimum ms
+
+
+--quickCheck (groupsProp3 :: Int -> Int -> Property) ? need cast still? how to import?
+
+-- -----------------------------------------------------------------------------
+-- robin
+
+-- correct number of rounds
+robinProp1 :: Int -> Property
+robinProp1 n = n >= 2 ==>
+ let rs = robin n in length rs == (if odd n then n else n-1)
+
+-- each round contains the correct number of matches
+robinProp2 :: Int -> Property
+robinProp2 n = n >= 2 ==>
+ let rs = robin n in all (== n `div` 2) map length rs
+
+-- a player is uniquely listed in each round
+robinProp3 :: Int -> Property
+robinProp3 n = n >= 2 ==>
+ let rs = robin n
+ --TODO
+
+
+-- a player is playing all opponents [hence all exactly once by 3]
+robinProp4 :: Int -> Property
+robinProp4 n = n >= 2 ==>
+ let rs = robin n
+ --TODO
+
+
+-- -----------------------------------------------------------------------------
+-- eliminationOf
View
@@ -33,7 +33,7 @@ module Tournament (
import Data.Char (intToDigit, digitToInt)
import Numeric (showIntAtBase, readInt)
-import Data.List (sort, splitAt)
+import Data.List (sort, splitAt, genericLength, partition)
import Data.Bits (shiftL)
@@ -78,7 +78,7 @@ duelValid n (a, b) = odd a && even b && a + b == 1 + 2^n
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.
-inGroupsOf :: Int -> Int -> [Group]
+inGroupsOf :: Int -> Int -> [[Int]]
0 `inGroupsOf` _ = []
n `inGroupsOf` s = map (sort . filter (<=n) . makeGroup) [1..ngrps] where
ngrps = ceiling $ fromIntegral n / fromIntegral s
@@ -208,10 +208,18 @@ e `eliminationOf` np
-- returns an updated tournament with the winner propagated to the next round,
-- and the loser propagated to the loser bracket if applicable.
scoreElimination :: Tournament -> Match -> Tournament
-scoreElimination t m =
+scoreElimination t m =
let e = if null $ filter ((== Losers) . brac . locId) t then Single else Double
l = locId m
mo = head $ filter ((== l) . locId) t
+ {-
+ STATEGY:
+ for all rounds before in this bracket: copy from t
+ for current round: get current round from t, partition it around l and concat
+ for next round: need to do similar except need to splice in at the proceeding position (but it should preserve existing player so cant remake it)
+ for lb round:..
+
+ -}
in t
@@ -222,15 +230,17 @@ tournamentValid t =
let (wb, lb) = partition ((== Winners) . brac . locId) r
roundRightWb k = rightSize && uniquePlayers where
rightSize = 2^(p-k) == length $ filter ((== k) . rnd . locId) wb
- uniquePlayers =
+ 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]
-}
--- | Create match shells for an FFA elimination tournament
---ffaElimination :: Int -> Int -> [Match]
+-- | 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.
+ffaElimination :: Int -> Int -> Int -> Tournament
ffaElimination 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.
@@ -240,16 +250,21 @@ ffaElimination gs adv np
| adv >= gs = error "Need to eliminate at least one player a match in FFA elimination"
| adv <= 0 = error "Need >0 players to advance per match in a FFA elimination"
| otherwise =
- let first = np `inGroupsOf` gs
- makeMatch r g i = Match { locId = l, players = g, scores = Nothing }
- where l = Location { brac = Winners, rnd = r, num = i }
- second = zipWith (makeMatch 1) first [1..]
+ let minsize g = foldr min gs $ map length g
- nextGroup g = left `inGroupsOf` gs where
- left = adv * length g
+ nextGroup g = leftover `inGroupsOf` gs where
+ adv' = adv - (gs - (minsize g)) -- force zero non-eliminating matches
+ adv'' = max adv' 1 -- but not if we only left 1 ^^ should still hold
+ leftover = length g * adv''
- final = [gs `inGroupsOf` gs]
- gps = takeWhile ((>1) . length) $ iterate nextGroup first
- allGps = gps ++ final
+ gps = takeWhile ((>1) . length) $ iterate nextGroup $ np `inGroupsOf` gs
+ allGps = gps ++ [nextGroup (last gps)]
- in allGps
+ -- finally convert raw group lists to matches
+ makeRound gs r = zipWith makeMatch gs [1..] where
+ makeMatch g i = Match { locId = l, players = g, scores = Nothing } where
+ l = Location { brac = Winners, rnd = r, num = i }
+
+ in concat $ zipWith makeRound allGps [1..]
+
+ffa gs adv np = mapM_ print (ffaElimination gs adv np)

0 comments on commit 780aa4c

Please sign in to comment.