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(..), Complete, Deck, 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 (Deck Complete) 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 []