module Dominion.Internal (
module Dominion.Internal
) where
import Control.Applicative
import Control.Arrow
import Control.Lens hiding (has, indices)
import Control.Monad (liftM)
import Control.Monad.State hiding (state)
import Data.List
import Data.Map.Lazy ((!))
import qualified Data.Map.Lazy as M
import Data.Maybe
import Data.Ord
import qualified Dominion.Cards as CA
import qualified Dominion.Types as T
import Dominion.Utils
import Prelude hiding (log)
import System.IO.Unsafe
import Text.Printf
currentHand :: T.PlayerId -> T.Dominion [T.Card]
currentHand playerId = (^. T.hand) <$> getPlayer playerId
has :: T.PlayerId -> T.Card -> T.Dominion Bool
has playerId card = do
player <- getPlayer playerId
return $ card `elem` (player ^. T.hand)
countNum :: T.PlayerId -> T.Card -> T.Dominion Int
countNum playerId card = do
player <- getPlayer playerId
let allCards = player ^. T.deck ++ player ^. T.discard ++ player ^. T.hand
return $ count card allCards
coinValue :: T.Card -> Int
coinValue card = sum $ map effect (card ^. T.effects)
where effect (T.CoinValue num) = num
effect _ = 0
getRound :: T.Dominion Int
getRound = T._round <$> get
handValue :: T.PlayerId -> T.Dominion Int
handValue playerId = do
player <- getPlayer playerId
return $ sum (map coinValue (player ^. T.hand)) + (player ^. T.extraMoney)
pileEmpty :: T.Card -> T.Dominion Bool
pileEmpty card = do
state <- get
return $ case M.lookup card (state ^. T.cards) of
Nothing -> True
Just x -> x == 0
getCard :: T.Card -> T.Dominion (Maybe T.Card)
getCard card = do
empty <- pileEmpty card
if empty
then return Nothing
else do
modify $ over T.cards (decrement card)
return $ Just card
log :: T.PlayerId -> String -> T.Dominion ()
log playerId str = do
player <- getPlayer playerId
money <- handValue playerId
let name = player ^. T.playerName
buys = player ^. T.buys
actions = player ^. T.actions
statusLine = printf "[player %s, name: %s, money: %s, buys: %s, actions: %s]" (yellow . show $ playerId) (yellow name) (green . show $ money) (green . show $ buys) (red . show $ actions)
log_ $ statusLine ++ ": " ++ green str
log_ :: String -> T.Dominion ()
log_ str = do
state <- get
when (state ^. T.verbose) $ liftIO . putStrLn $ str
gameOver :: M.Map T.Card Int -> Bool
gameOver cards
| cards ! CA.province == 0 = True
| M.size (M.filter (== 0) cards) >= 3 = True
| otherwise = False
drawFromDeck :: T.PlayerId -> Int -> T.Dominion [T.Card]
drawFromDeck playerId numCards = do
player <- getPlayer playerId
let deck = player ^. T.deck
if length deck >= numCards
then draw numCards
else do
let inDeck = length deck
lastCards <- draw inDeck
shuffleDeck playerId
liftM (++ lastCards) $ draw (numCards inDeck)
where
draw numCards = do
player <- getPlayer playerId
let drawnCards = take numCards (player ^. T.deck)
modifyPlayer playerId $ over T.deck (drop numCards) . over T.hand (++ drawnCards)
return drawnCards
modifyPlayer :: T.PlayerId -> (T.Player -> T.Player) -> T.Dominion ()
modifyPlayer playerId func = modify $ over (T.players . element playerId) func
modifyOtherPlayers :: T.PlayerId -> (T.Player -> T.Player) -> T.Dominion ()
modifyOtherPlayers playerId func = do
state <- get
let players = indices (state ^. T.players) \\ [playerId]
forM_ players $ \pid -> modify $ over (T.players . element pid) func
setupForTurn :: T.PlayerId -> T.Dominion ()
setupForTurn playerId = do
drawFromDeck playerId 5
modifyPlayer playerId $ set T.actions 1 . set T.buys 1 . set T.extraMoney 0
playTurn :: T.PlayerId -> T.Strategy -> T.Dominion ()
playTurn playerId strategy = do
roundNum <- getRound
when (roundNum == 1) $ setupForTurn playerId
player <- getPlayer playerId
log playerId $ "player's hand has: " ++ (show . map T._name $ player ^. T.hand)
strategy playerId
discardHand playerId
setupForTurn playerId
makeGameState :: [T.Option] -> [T.Player] -> IO T.GameState
makeGameState options players = do
actionCards_ <- deckShuffle CA.allActionCards
let requiredCards = take 10 $ fromMaybe [] (findCards options)
verbose = fromMaybe False (findLog options)
actionCards = take (10 length requiredCards) actionCards_ ++ requiredCards
cards = M.fromList ([(CA.copper, 60), (CA.silver, 40), (CA.gold, 30),
(CA.estate, 12), (CA.duchy, 12), (CA.province, 12)]
++ [(c, 10) | c <- actionCards])
return $ T.GameState players cards 1 verbose
game :: [T.Strategy] -> T.Dominion ()
game strategies = do
state <- get
let ids = indices $ state ^. T.players
forM_ (zip ids strategies) (uncurry playTurn)
run :: T.GameState -> [T.Strategy] -> IO T.Result
run state strategies = do
(_, newState) <- runStateT (game strategies) state
let cards = newState ^. T.cards
if gameOver cards
then returnResults newState
else run (over T.round (+1) newState) strategies
returnResults :: T.GameState -> IO T.Result
returnResults state = do
let results = map (id &&& countPoints) (state ^. T.players)
winner = view (_1 . T.playerName) $ maximumBy (comparing snd) results
when (state ^. T.verbose) $ do
putStrLn "Game Over!"
forM_ results $ \(player, points) -> putStrLn $
printf "player %s got %d points" (player ^. T.playerName) points
return $ T.Result results winner
isAction card = T.Action `elem` (card ^. T.cardType)
isAttack card = T.Attack `elem` (card ^. T.cardType)
isReaction card = T.Reaction `elem` (card ^. T.cardType)
isTreasure card = T.Treasure `elem` (card ^. T.cardType)
isVictory card = T.Victory `elem` (card ^. T.cardType)
countPoints :: T.Player -> Int
countPoints player = sum $ map countValue effects
where cards = player ^. T.deck ++ player ^. T.discard ++ player ^. T.hand
victoryCards = filter isVictory cards
effects = concatMap T._effects victoryCards
countValue (T.VPValue x) = x
countValue (T.GardensEffect) = length cards `div` 10
countValue _ = 0
getPlayer :: T.PlayerId -> T.Dominion T.Player
getPlayer playerId = do
state <- get
return $ (state ^. T.players) !! playerId
cardsOf = replicate
eitherToBool :: Either String () -> Bool
eitherToBool (Left _) = False
eitherToBool (Right _) = True
shuffleDeck :: T.PlayerId -> T.Dominion ()
shuffleDeck playerId = modifyPlayer playerId shuffleDeck_
shuffleDeck_ :: T.Player -> T.Player
shuffleDeck_ player = set T.discard [] $ set T.deck newDeck player
where discard = player ^. T.discard
deck = player ^. T.deck
hand = player ^. T.hand
newDeck = unsafePerformIO $ deckShuffle (deck ++ discard ++ hand)
validateBuy :: T.PlayerId -> T.Card -> T.Dominion (T.PlayResult ())
validateBuy playerId card = do
money <- handValue playerId
state <- get
player <- getPlayer playerId
cardGone <- pileEmpty card
return $ do
failIf (money < (card ^. T.cost)) $ printf "Not enough money. You have %d but this card costs %d" money (card ^. T.cost)
failIf cardGone $ printf "We've run out of that card (%s)" (card ^. T.name)
failIf ((player ^. T.buys) < 1) "You don't have any buys remaining!"
validatePlay :: T.PlayerId -> T.Card -> T.Dominion (T.PlayResult ())
validatePlay playerId card = do
player <- getPlayer playerId
return $ do
failIf (not (isAction card)) $ printf "%s is not an action card" (card ^. T.name)
failIf ((player ^. T.actions) < 1) "You don't have any actions remaining!"
failIf (card `notElem` (player ^. T.hand)) $ printf
"You can't play a %s because you don't have it in your hand!" (card ^. T.name)
discardHand :: T.PlayerId -> T.Dominion ()
discardHand playerId = modifyPlayer playerId $ \player -> set T.hand [] $ over T.discard (++ (player ^. T.hand)) player
findIteration :: [T.Option] -> Maybe Int
findIteration [] = Nothing
findIteration (T.Iterations x : xs) = Just x
findIteration (_:xs) = findIteration xs
findLog :: [T.Option] -> Maybe Bool
findLog [] = Nothing
findLog (T.Log x : xs) = Just x
findLog (_:xs) = findLog xs
findCards :: [T.Option] -> Maybe [T.Card]
findCards [] = Nothing
findCards (T.Cards x : xs) = Just x
findCards (_:xs) = findCards xs
drawsUntil :: T.PlayerId -> ([T.Card] -> T.Dominion Bool) -> T.Dominion [T.Card]
drawsUntil = drawsUntil_ []
drawsUntil_ :: [T.Card] -> T.PlayerId -> ([T.Card] -> T.Dominion Bool) -> T.Dominion [T.Card]
drawsUntil_ alreadyDrawn playerId func = do
drawnCards <- drawFromDeck playerId 1
let cards = drawnCards ++ alreadyDrawn
stopDrawing <- func cards
if stopDrawing
then return cards
else drawsUntil_ cards playerId func
trashThisCard :: T.Card -> Bool
trashThisCard card = T.TrashThisCard `elem` (card ^. T.effects)
trashesCard :: T.PlayerId -> T.Card -> T.Dominion ()
playerId `trashesCard` card = do
hasCard <- playerId `has` card
when hasCard $ modifyPlayer playerId (over T.hand (delete card))
discardsCard :: T.PlayerId -> T.Card -> T.Dominion ()
playerId `discardsCard` card = do
hasCard <- playerId `has` card
when hasCard $ modifyPlayer playerId $ over T.hand (delete card) . over T.discard (card:)
returnsCard :: T.PlayerId -> T.Card -> T.Dominion ()
playerId `returnsCard` card = do
hasCard <- playerId `has` card
when hasCard $ modifyPlayer playerId $ over T.hand (delete card) . over T.deck (card:)
discardTopCard :: [T.Card] -> T.Player -> T.Player
discardTopCard cards player = if topCard `elem` cards
then set T.deck (tail deck) . over T.discard (topCard:) $ player
else player
where topCard = head $ player ^. T.deck
deck = player ^. T.deck
returnVPCard :: T.Player -> T.Player
returnVPCard player = let hand = player ^. T.hand
victoryCards = filter isVictory hand
card = head victoryCards
in if CA.moat `elem` hand || null victoryCards
then player
else over T.hand (delete card) $ over T.deck (card:) player
discardsTo :: T.Player -> Int -> T.Player
player `discardsTo` x = set T.hand toKeep . over T.discard (++ toDiscard) $ player
where hand = sortBy (comparing T._cost) $ player ^. T.hand
toDiscard = take (length hand x) hand
toKeep = hand \\ toDiscard
usesEffect :: T.PlayerId -> T.CardEffect -> T.Dominion (Maybe T.Followup)
playerId `usesEffect` (T.PlusAction x) = do
log playerId ("+ " ++ show x ++ " actions")
modifyPlayer playerId $ over T.actions (+x)
return Nothing
playerId `usesEffect` (T.PlusCoin x) = do
log playerId ("+ " ++ show x ++ " coin")
modifyPlayer playerId $ over T.extraMoney (+x)
return Nothing
playerId `usesEffect` (T.PlusBuy x) = do
log playerId ("+ " ++ show x ++ " buys")
modifyPlayer playerId $ over T.buys (+x)
return Nothing
playerId `usesEffect` (T.PlusCard x) = do
log playerId ("+ " ++ show x ++ " cards")
drawFromDeck playerId x
return Nothing
playerId `usesEffect` effect@(T.PlayActionCard x) = return $ Just (playerId, effect)
playerId `usesEffect` (T.AdventurerEffect) = do
log playerId "finding the next two treasures from your deck..."
drawnCards <- playerId `drawsUntil` (\cards -> return $ countBy isTreasure cards == 2)
forM_ (filter (not . isTreasure) drawnCards) $ \card -> playerId `discardsCard` card
return Nothing
playerId `usesEffect` (T.BureaucratEffect) = do
card_ <- getCard CA.silver
case card_ of
Nothing -> return ()
Just card -> do
log playerId "+ silver"
modifyPlayer playerId $ over T.deck (card:)
modifyOtherPlayers playerId returnVPCard
return Nothing
playerId `usesEffect` T.CellarEffect = return $ Just (playerId, T.CellarEffect)
playerId `usesEffect` T.ChancellorEffect = return $ Just (playerId, T.ChancellorEffect)
playerId `usesEffect` effect@(T.TrashCards x) = do
log playerId ("Trash up to " ++ show x ++ " cards from your hand.")
return $ Just (playerId, effect)
playerId `usesEffect` effect@(T.OthersPlusCard x) = do
log playerId ("Every other player draws " ++ show x ++ " card.")
state <- get
let players = indices (state ^. T.players) \\ [playerId]
forM_ players $ \pid -> drawFromDeck pid 1
return Nothing
playerId `usesEffect` effect@(T.GainCardUpto x) = do
log playerId ("Gain a card costing up to " ++ show x ++ " coins.")
return $ Just (playerId, effect)
playerId `usesEffect` effect@T.LibraryEffect = do
log playerId "Drawing to 7 cards..."
drawsUntil playerId $ \_ -> do
player <- getPlayer playerId
return $ length (player ^. T.hand) == 7
return Nothing
playerId `usesEffect` effect@(T.OthersDiscardTo x) = do
log playerId ("Every other player discards down to " ++ show x ++ " cards.")
modifyOtherPlayers playerId (`discardsTo` x)
return Nothing
playerId `usesEffect` T.MineEffect = return $ Just (playerId, T.MineEffect)
playerId `usesEffect` T.MoneylenderEffect = do
hasCard <- playerId `has` CA.copper
when hasCard $ do
log playerId "Trashing a copper. +3 coin"
playerId `trashesCard` CA.copper
modifyPlayer playerId $ over T.extraMoney (+3)
return Nothing
playerId `usesEffect` T.RemodelEffect = return $ Just (playerId, T.RemodelEffect)
playerId `usesEffect` T.SpyEffect = return $ Just (playerId, T.SpyEffect)
playerId `usesEffect` T.ThiefEffect = return $ Just (playerId, T.ThiefEffect)
playerId `usesEffect` (T.OthersGainCurse x) = do
log playerId ("All other players gain " ++ show x ++ " curses.")
let card = CA.curse
empty <- pileEmpty card
if empty
then return Nothing
else do
modifyOtherPlayers playerId (over T.discard (card:))
state <- get
times (length (state ^. T.players) 1) $ do
modify $ over T.cards (decrement card)
return ()
return Nothing
playerId `usesEffect` T.GardensEffect = return Nothing
playerId `usesEffect` _ = return Nothing
makePlayer :: String -> T.Player
makePlayer name = T.Player name [] (7 `cardsOf` CA.copper ++ 3 `cardsOf` CA.estate) [] 1 1 0
gainCardUpTo :: T.PlayerId -> Int -> T.Card -> T.Dominion (T.PlayResult (Maybe [T.Followup]))
gainCardUpTo playerId value card =
if (card ^. T.cost) > value
then return . Left $ printf "Card is too expensive. You can gain a card costing up to %d but this card costs %d" value (card ^. T.cost)
else do
result <- getCard card
case result of
Nothing -> return . Left $ printf "We've run out of that card (%s)" (card ^. T.name)
(Just card_) -> do
modifyPlayer playerId $ over T.discard (card_:)
return $ Right Nothing