module Haverer.Testing ( PlayerId
, inRoundEvent
, playTurn'
, randomRound
, randomRounds
, shuffled
) where
import BasicPrelude hiding (round)
import Data.Maybe (fromJust)
import qualified System.Random.Shuffle as Shuffle
import Test.Tasty.QuickCheck
import Haverer.Action (Play(..))
import Haverer.Deck (baseCards, Card(..), FullDeck, makeDeck)
import Haverer.Player (PlayerSet, toPlayerSet)
import Haverer.Round (
Round
, Result(..)
, makeRound
, playTurn
)
import Haverer.ValidMoves (getValidMoves)
import Haverer.Internal.Error (assertRight)
type PlayerId = Int
instance Arbitrary FullDeck where
arbitrary = fmap (fromJust . makeDeck) (shuffled baseCards)
instance Arbitrary (PlayerSet PlayerId) where
arbitrary =
makePlayerSet <$> elements [2, 3, 4]
where
makePlayerSet n =
assertRight "Couldn't make set: " (toPlayerSet $ take n [1..])
instance Arbitrary (Round PlayerId) where
arbitrary = makeRound <$> arbitrary <*> arbitrary
playTurn' :: (Ord a, Show a) => Round a -> Card -> Play a -> (Result a, Round a)
playTurn' round card play = assertRight "Should have generated valid play: " $
case playTurn round of
Left action -> action
Right handler -> handler card play
playRandomTurn :: (Ord a, Show a) => Round a -> Gen (Maybe (Result a, Round a))
playRandomTurn round = do
move <- randomCardPlay round
case move of
Nothing -> return Nothing
Just (card, play) -> return $ Just $ playTurn' round card play
where
randomCardPlay round' =
case getValidMoves round' of
[] -> return Nothing
xs -> elements (fmap Just xs)
randomNextMove :: (Ord a, Show a) => Round a -> Gen (Round a)
randomNextMove round = do
result <- playRandomTurn round
case result of
Nothing -> return round
Just (_, round') -> return round'
manyMoves :: Int -> Gen [Round PlayerId]
manyMoves 0 = return []
manyMoves n = do
initial <- arbitrary
rest <- iterateM' (n 2) randomNextMove initial
return (initial:rest)
randomRounds :: Gen [Round PlayerId]
randomRounds = do
num <- choose (2, 14)
manyMoves num
randomRound :: Gen (Round PlayerId)
randomRound = last <$> randomRounds
roundAndPlay :: Gen (Round PlayerId, Card, Play PlayerId)
roundAndPlay = do
round <- randomRound `suchThat` (not . null . getValidMoves)
(card, play) <- elements $ getValidMoves round
return (round, card, play)
inRoundEvent :: Gen (Result PlayerId)
inRoundEvent = do
(round, card, play) <- roundAndPlay
return $ fst $ playTurn' round card play
shuffled ::[a] -> Gen [a]
shuffled xs = do
rs <- randomOrdering (length xs 1)
return $ Shuffle.shuffle xs rs
where
randomOrdering 0 = return []
randomOrdering n =
do y <- choose (0, n)
ys <- randomOrdering (n 1)
return (y:ys)
iterateM' :: (Monad m) => Int -> (a -> m a) -> a -> m [a]
iterateM' n f x
| n == 0 = return [x]
| n > 0 = do y <- f x
ys <- iterateM' (n 1) f y
return (y:ys)
| otherwise = return []