Skip to content
Browse files

various tweaks to get a semi-generic test harness to work with specif…

…ically sized integers..
  • Loading branch information...
1 parent 182e32e commit f933c74e4c7c809bacd70debd1798e3cff435967 @clux committed Mar 25, 2012
Showing with 81 additions and 49 deletions.
  1. +10 −10 Game/Tournament.hs
  2. +63 −38 tests/Properties.hs
  3. +8 −1 tournament.cabal
View
20 Game/Tournament.hs
@@ -21,7 +21,7 @@ module Game.Tournament (
import Data.Char (intToDigit, digitToInt)
import Numeric (showIntAtBase, readInt)
-import Data.List (sort, sortBy)
+import Data.List (sort, sortBy, genericTake)
import Data.Ord (comparing)
import Data.Bits (shiftL)
@@ -49,9 +49,9 @@ seeds p i = (1 - lastSeed + 2^p, lastSeed) where
lastSeed = let (k, r) = ((floor . logBase 2 . fromIntegral) i, i - 2^k) in
case r of
0 -> 2^(p-k)
- _ -> let bstr = reverse $ showIntAtBase 2 intToDigit (i - 2*r) ""
- nr = fst $ head $ readInt 2 (`elem` "01") digitToInt bstr
- in 2^(p-k-1) + nr `shiftL` (p - length bstr)
+ _ -> 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.
@@ -80,15 +80,15 @@ n `inGroupsOf` s = map (sort . filter (<=n) . makeGroup) [1..ngrps] where
-- | 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 :: Int -> [RobinRound]
+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
- rounds = take (n'-1) $ iterate robinPermute [1..n']
+ rounds = genericTake (n'-1) $ iterate robinPermute [1..n']
notDummy (x,y) = all (<=n) [x,y]
- toPairs x = take m $ zip x (reverse x)
+ toPairs x = genericTake m $ zip x (reverse x)
-robinPermute :: [Int] -> [Int]
+robinPermute :: [a] -> [a]
robinPermute [] = []
robinPermute (x:xs) = x : last xs : init xs
@@ -150,7 +150,7 @@ duelElimination etype np
woScores ps
| 0 `elem` ps = Nothing
| -1 `elem` ps = Just $ map (\x -> if x == -1 then 0 else 1) ps
- | otherwise = Nothing
+ | otherwise = Nothing
-- 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]
@@ -208,7 +208,7 @@ duelElimination etype np
-- and the loser propagated to the loser bracket if applicable.
scoreElimination :: Tournament -> Match -> Tournament
scoreElimination t m =
- let e = if not $ any ((== Losers) . brac . locId) t then Single else Double
+ let e = if any ((== Losers) . brac . locId) t then Double else Single
l = locId m
mo = head $ filter ((== l) . locId) t
{-
View
101 tests/Properties.hs
@@ -1,77 +1,102 @@
-- | Tests for the 'Tournament' module.
-
+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}
module Main where
import qualified Game.Tournament as T
-import Test.QuickCheck (quickCheck, (==>), Property)
-import Data.List ((\\), nub)
+import Test.QuickCheck
+import Data.List ((\\), nub, genericLength)
+import Control.Monad (liftM)
+
+-- helper instances
+newtype RInt = RInt {rInt :: Int}
+ deriving (Eq, Ord, Show, Num, Integral, Real, Enum)
+
+instance Arbitrary RInt where
+ arbitrary = liftM RInt (choose (1, 256) :: Gen Int)
+
+instance Arbitrary (RInt, RInt) where
+ arbitrary = do
+ x <- choose (1, 256) :: Gen Int
+ y <- choose (1, 12) :: Gen Int
+ return (RInt x, RInt y)
+
+type GroupArgs = (RInt, RInt)
-- -----------------------------------------------------------------------------
-- inGroupsOf
+-- test positive n <= 256, s <= 12
-- 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
+groupsProp1 :: GroupArgs -> Bool
+groupsProp1 (n', s') = maximum (map length (n `T.inGroupsOf` s)) >= s
+ where (n:s:[]) = map fromIntegral [n', s']
-- players included == [1..n]
groupsProp2 :: Int -> Int -> Property
-groupsProp2 n s = n >= 0 && s >= 0 ==>
+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
+groupsProp3 n s = n > 0 && s > 0 && n `mod` s == 0 ==>
+ maximum gsums <= minimum gsums + length gs where
+ gs = n `T.inGroupsOf` s
+ gsums = map sum 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?
+groupsProp4 n s = n > 0 && s > 0 && n `mod` s == 0 && even (n `div` s) ==>
+ maximum gsums == minimum gsums where
+ gsums = map sum $ n `T.inGroupsOf` s
-- -----------------------------------------------------------------------------
-- robin
-- correct number of rounds
-robinProp1 :: Int -> Property
-robinProp1 n = n >= 2 ==>
- let rs = T.robin n in length rs == (if odd n then n else n-1)
+robinProp1 :: RInt -> Bool
+robinProp1 n =
+ (if odd n then n else n-1) == (genericLength . T.robin) n
-- each round contains the correct number of matches
-robinProp2 :: Int -> Property
-robinProp2 n = n >= 2 ==>
- let rs = T.robin n in all (== n `div` 2) $ map length rs
+robinProp2 :: RInt -> Bool
+robinProp2 n =
+ all (== n `div` 2) $ map (genericLength) $ T.robin n
-- a player is uniquely listed in each round
-robinProp3 :: Int -> Property
-robinProp3 n = n >= 2 ==>
- let rs = T.robin n
- plrs = map (concatMap (\(x,y) -> [x,y])) rs
- in map nub plrs == plrs
-
+robinProp3 :: RInt -> Bool
+robinProp3 n = map nub plrs == plrs where
+ plrs = map (concatMap (\(x,y) -> [x,y])) $ T.robin n
-- a player is playing all opponents [hence all exactly once by 3]
-robinProp4 :: Int -> Property
-robinProp4 n = n >= 2 ==>
- let rs = robin n
- pairsFor k = concatMap (filter (\(x,y) -> x == k || y == k)) rs
- combatants k = map (\(x,y) -> if x == k then y else x) $ pairsFor k
- in all (\i -> [1..n] \\ combatants i == [i]) [1..n]
+robinProp4 :: RInt -> Bool
+robinProp4 n = all (\i -> [1..n] \\ combatants i == [i]) [1..n] where
+ rs = T.robin n
+ pairsFor k = concatMap (filter (\(x,y) -> x == k || y == k)) rs
+ --filter (curry . any (==k))
+ combatants k = map (\(x,y) -> if x == k then y else x) $ pairsFor k
-- -----------------------------------------------------------------------------
-- eliminationOf
-- -----------------------------------------------------------------------------
-- Test harness
+qc = quickCheckWith stdArgs {
+ maxSuccess = 50
+ , chatty = True
+ }
+
main :: IO ()
-main = undefined
+main = do
+ putStrLn "test robin:"
+ mapM_ qc [
+ robinProp1
+ , robinProp2
+ , robinProp3
+ , robinProp4
+ ]
+ --putStrLn "test inGroupsOf"
+ --mapM_ qc [groupsProp1]
+
+ putStrLn "done"
View
9 tournament.cabal
@@ -23,16 +23,23 @@ Cabal-version : >= 1.2
Extra-source-files:
Readme.md
tests/Property.hs
+
+Flag test
+ Description: Build the test executable.
+ Default: False
--------------------------------------------------------------------------------
library
hs-source-dirs : .
exposed-modules : Game.Tournament
- build-depends : base >= 4 && < 5
+ build-depends : base >= 4 && < 5
ghc-options : -W
-------------------------------------------------------------------------------
executable tournament-test
+ if !flag( test )
+ Buildable : False
+
main-is : tests/Properties.hs
other-modules : Game.Tournament
build-depends :

0 comments on commit f933c74

Please sign in to comment.
Something went wrong with that request. Please try again.