module Haverer.Round (
Round
, makeRound
, playTurn
, playTurn'
, BadAction
, Result(..)
, Event(..)
, currentPlayer
, currentTurn
, getActivePlayers
, getPlayer
, getPlayerMap
, getPlayers
, getWinners
, nextPlayer
, remainingCards
, Victory(..)
, victory
, prop_allCardsPresent
, prop_burnCardsSame
, prop_multipleActivePlayers
, prop_ringIsActivePlayers
) where
import BasicPrelude hiding (round)
import Control.Error
import Control.Monad.Except
import Control.Monad.State
import Control.Lens hiding (chosen)
import Data.Maybe (fromJust)
import qualified Data.Map as Map
import Haverer.Action (
BadPlay,
bustingHand,
Play(..),
Action,
getTarget,
playToAction,
viewAction)
import Haverer.Deck (Card(..), Complete, Deck, deal, Incomplete, pop)
import qualified Haverer.Deck as Deck
import Haverer.Player (
bust,
discardAndDraw,
eliminate,
getDiscards,
getHand,
isProtected,
makePlayer,
playCard,
Player,
PlayerSet,
protect,
swapHands,
toPlayers,
unprotect
)
import Haverer.Internal.Error (assertRight)
import Haverer.Internal.Ring (Ring, advance1, currentItem, dropItem1, makeRing, nextItem)
import qualified Haverer.Internal.Ring as Ring
data RoundState = NotStarted | Turn Card | Playing | Over deriving Show
data Round playerId = Round {
_stack :: Deck Incomplete,
_playOrder :: Ring playerId,
_players :: Map playerId Player,
_roundState :: RoundState,
_burn :: Card
} deriving Show
makeLenses ''Round
makeRound :: (Ord playerId, Show playerId) => Deck Complete -> PlayerSet playerId -> Round playerId
makeRound deck playerSet =
nextTurn $ case deal deck (length playerList) of
(Just cards, remainder) ->
case pop remainder of
(Nothing, _) -> terror ("Not enough cards for burn: " ++ show deck)
(Just burn', stack') -> Round {
_stack = stack',
_playOrder = fromJust (makeRing playerList),
_players = Map.fromList $ zip playerList (map makePlayer cards),
_roundState = NotStarted,
_burn = burn'
}
_ -> terror ("Given a complete deck - " ++ show deck ++ "- that didn't have enough cards for players - " ++ show playerSet)
where playerList = toPlayers playerSet
remainingCards :: Round playerId -> Int
remainingCards = length . Deck.toList . view stack
getPlayers :: Round playerId -> [playerId]
getPlayers = Map.keys . view players
getActivePlayers :: Round playerId -> [playerId]
getActivePlayers = Ring.toList . view playOrder
getPlayerMap :: Round playerId -> Map playerId Player
getPlayerMap = view players
getPlayer :: Ord playerId => Round playerId -> playerId -> Maybe Player
getPlayer round pid = view (players . at pid) round
drawCard :: Monad m => StateT (Round playerId) m (Maybe Card)
drawCard = do
(card, stack') <- pop <$> use stack
assign stack stack'
return card
nextTurn :: (Show playerId, Ord playerId) => Round playerId -> Round playerId
nextTurn round = flip execState round $ do
current <- use roundState
case current of
Over -> return ()
Turn _ -> terror "Cannot advance to next turn while waiting for play."
NotStarted -> do
card <- drawCard
assign roundState $ case card of
Just card' -> Turn card'
Nothing -> Over
Playing -> do
card <- drawCard
newPlayOrder <- advance1 <$> use playOrder
case (card, newPlayOrder) of
(Nothing, _) -> end round
(_, Left _) -> end round
(Just card', Right newPlayOrder') -> do
modify $ unprotectPlayer (currentItem newPlayOrder')
assign roundState (Turn card')
assign playOrder newPlayOrder'
where
end :: Round playerId -> State (Round playerId) ()
end rnd = do
put rnd
assign roundState Over
unprotectPlayer pid rnd = assertRight "Couldn't unprotect current player: "
(modifyActivePlayer rnd pid unprotect)
currentPlayer :: Round playerId -> Maybe playerId
currentPlayer rnd =
case view roundState rnd of
Over -> Nothing
NotStarted -> Nothing
Turn _ -> Just $ (currentItem . view playOrder) rnd
Playing -> Just $ (currentItem . view playOrder) rnd
currentTurn :: Ord playerId => Round playerId -> Maybe (playerId, (Card, Card))
currentTurn rnd = do
pid <- currentPlayer rnd
hand <- getHand =<< getPlayer rnd pid
d <- dealt
return (pid, (d, hand))
where
dealt = case view roundState rnd of
Turn d -> Just d
_ -> Nothing
nextPlayer :: Round playerId -> Maybe playerId
nextPlayer rnd =
case view roundState rnd of
Over -> Nothing
NotStarted -> Just $ currentItem playOrder'
Turn _ -> Just $ nextItem playOrder'
Playing -> Just $ nextItem playOrder'
where playOrder' = view playOrder rnd
data BadAction playerId = NoSuchPlayer playerId
| InactivePlayer playerId
| InvalidPlay (BadPlay playerId)
| WrongCard Card (Card, Card)
| PlayWhenBusted
| NoPlaySpecified
| RoundOver
deriving Show
data Event playerId =
NoChange |
Protected playerId |
SwappedHands playerId playerId |
Eliminated playerId |
ForcedDiscard playerId |
ForcedReveal playerId playerId Card
deriving (Eq, Show)
data Result playerId =
BustedOut playerId Card Card |
Played (Action playerId) (Event playerId)
deriving (Eq, Show)
type ActionM id a = Either (BadAction id) a
actionToEvent :: (Ord playerId, Show playerId) => Round playerId -> Action playerId -> ActionM playerId (Event playerId)
actionToEvent round action@(viewAction -> (pid, _, play)) = do
(_, sourceHand) <- getActivePlayerHand round pid
case getTarget play of
Nothing -> return $ noTarget action
Just target -> do
(targetPlayer, targetHand) <- getActivePlayerHand round target
if fromJust (isProtected targetPlayer)
then return NoChange
else return $ withTarget sourceHand targetHand action
where
noTarget (viewAction -> (_, Priestess, NoEffect)) = Protected pid
noTarget (viewAction -> (_, Minister, NoEffect)) = NoChange
noTarget (viewAction -> (_, Prince, NoEffect)) = Eliminated pid
noTarget _ = terror $ "We thought " ++ show action ++ " had no target."
withTarget _ targetCard (viewAction -> (_, Soldier, Guess target guess))
| targetCard == guess = Eliminated target
| otherwise = NoChange
withTarget _ targetCard (viewAction -> (_, Clown, Attack target)) =
ForcedReveal pid target targetCard
withTarget sourceHand targetHand (viewAction -> (_, Knight, Attack target)) =
case compare sourceHand targetHand of
LT -> Eliminated pid
EQ -> NoChange
GT -> Eliminated target
withTarget _ Prince (viewAction -> (_, Wizard, Attack target)) = Eliminated target
withTarget _ _ (viewAction -> (_, Wizard, Attack target)) = ForcedDiscard target
withTarget _ _ (viewAction -> (_, General, Attack target)) = SwappedHands target pid
withTarget _ _ _ = terror $ "Invalid action: " ++ show action
applyEvent :: Ord playerId => Round playerId -> Event playerId -> ActionM playerId (Round playerId)
applyEvent round NoChange = return round
applyEvent round (Protected pid) = modifyActivePlayer round pid protect
applyEvent round (SwappedHands pid1 pid2) = do
p1 <- getActivePlayer round pid1
p2 <- getActivePlayer round pid2
let (p1', p2') = swapHands p1 p2 in
return $ (replace pid2 p2' . replace pid1 p1') round
where replace pid p rnd = setActivePlayer rnd pid p
applyEvent round (Eliminated pid) = modifyActivePlayer round pid eliminate
applyEvent round (ForcedDiscard pid) =
let (card, round') = runState drawCard round in
modifyActivePlayer round' pid (`discardAndDraw` card)
applyEvent round (ForcedReveal {}) = return round
playTurn :: (Ord playerId, Show playerId)
=> Round playerId
-> Either (ActionM playerId (Result playerId, Round playerId))
(Card -> Play playerId -> ActionM playerId (Result playerId, Round playerId))
playTurn round = do
(playerId, (dealt, hand)) <- note (Left RoundOver) (currentTurn round)
let player = assertRight "Current player is not active: " (getActivePlayer round playerId)
if bustingHand dealt hand
then Left $ return $ bustOut playerId dealt hand
else Right $ handlePlay playerId player dealt hand
where
handlePlay playerId player dealt hand chosen play = do
player' <- note (WrongCard chosen (dealt, hand)) (playCard player dealt chosen)
let round' = setActivePlayer (set roundState Playing round) playerId player'
action <- fmapL InvalidPlay (playToAction playerId chosen play)
result <- actionToEvent round' action
round'' <- applyEvent round' result
return (Played action result, nextTurn round'')
bustOut pid dealt hand =
let bustedRound = assertRight "Could not bust out player: "
(modifyActivePlayer round pid (`bust` dealt))
in (BustedOut pid dealt hand, nextTurn (set roundState Playing bustedRound))
playTurn' :: (Ord playerId, Show playerId)
=> Round playerId
-> Maybe (Card, Play playerId)
-> ActionM playerId (Result playerId, Round playerId)
playTurn' round optionalPlay = do
result <- case playTurn round of
Left action -> action
Right handler -> do
(card, play) <- note NoPlaySpecified optionalPlay
handler card play
case (optionalPlay, result) of
(Just _, (BustedOut {}, _)) -> throwError PlayWhenBusted
_ -> return result
data Victory playerId
= SoleSurvivor playerId Card
| HighestCard Card [playerId] [(playerId, Card)]
deriving (Eq, Show)
survivors :: Round playerId -> [(playerId, Card)]
survivors = Map.toList . Map.mapMaybe getHand . view players
victory :: Round playerId -> Maybe (Victory playerId)
victory (round@Round { _roundState = Over }) =
case survivors round of
[(pid, card)] -> Just $ SoleSurvivor pid card
xs -> let (best:rest) = reverse (groupBy ((==) `on` snd) (sortBy (compare `on` snd) xs))
in Just $ HighestCard (snd $ head best) (map fst best) (concat rest)
victory _ = Nothing
getWinners :: Victory playerId -> [playerId]
getWinners (SoleSurvivor pid _) = [pid]
getWinners (HighestCard _ pids _) = pids
modifyActivePlayer :: Ord playerId => Round playerId -> playerId -> (Player -> Player) -> ActionM playerId (Round playerId)
modifyActivePlayer rnd pid f = setActivePlayer rnd pid <$> f <$> getActivePlayer rnd pid
setActivePlayer :: Ord playerId => Round playerId -> playerId -> Player -> Round playerId
setActivePlayer round pid newP =
case getHand newP of
Nothing -> dropPlayer pid
Just _ -> round'
where
round' = over players (set (at pid) (Just newP)) round
dropPlayer p =
case dropItem1 (view playOrder round') p of
Left _ -> set roundState Over round'
Right newOrder -> set playOrder newOrder round'
getActivePlayer :: Ord playerId => Round playerId -> playerId -> ActionM playerId Player
getActivePlayer round pid = fst <$> getActivePlayerHand round pid
getActivePlayerHand :: Ord playerId => Round playerId -> playerId -> ActionM playerId (Player, Card)
getActivePlayerHand round pid = do
player <- note (NoSuchPlayer pid) (getPlayer round pid)
hand <- note (InactivePlayer pid) (getHand player)
return (player, hand)
prop_allCardsPresent :: Round playerId -> Bool
prop_allCardsPresent =
isJust . Deck.makeDeck . allCards
where allCards rnd =
_burn rnd : (
(Deck.toList . view stack) rnd
++ (concatMap getDiscards . Map.elems . view players) rnd
++ (mapMaybe getHand . Map.elems . view players) rnd)
++ (
case _roundState rnd of
Turn x -> [x]
_ -> [])
prop_burnCardsSame :: [Round playerId] -> Bool
prop_burnCardsSame (x:xs) = all ((== view burn x) . view burn) xs
prop_burnCardsSame [] = True
prop_ringIsActivePlayers :: Eq playerId => Round playerId -> Bool
prop_ringIsActivePlayers r =
(Map.keys . Map.mapMaybe getHand . _players) r ==
(Ring.toList . view playOrder) r
prop_multipleActivePlayers :: Round playerId -> Bool
prop_multipleActivePlayers r =
case view roundState r of
Over -> True
_ -> Ring.ringSize (view playOrder r) > 1