module Dominion (
module Dominion,
Option(..),
has, handValue, pileEmpty, getPlayer, cardsOf, validateBuy, validatePlay, getRound) where
import Prelude hiding (log)
import qualified Dominion.Types as T
import Dominion.Types (Option(..))
import qualified Dominion.Cards as CA
import Control.Monad hiding (join)
import Data.Maybe
import Control.Monad.State hiding (state, join)
import Control.Lens hiding (indices, has)
import Control.Monad.IO.Class
import Text.Printf
import Data.List
import Dominion.Utils
import Data.Either
import Control.Applicative
import Dominion.Internal
uses :: String -> T.Strategy -> (T.Player, T.Strategy)
name `uses` strategy = ((makePlayer name), strategy)
dominion :: [(T.Player, T.Strategy)] -> IO [T.Result]
dominion = dominionWithOpts []
dominionWithOpts :: [T.Option] -> [(T.Player, T.Strategy)] -> IO [T.Result]
dominionWithOpts options list = do
actionCards_ <- deckShuffle CA.allCards
let players = map fst list
strategies = map snd list
iterations = fromJust $ findIteration options <|> Just 1000
verbose_ = fromJust $ findLog options <|> Just False
requiredCards = take 10 . fromJust $ findCards options <|> Just []
actionCards = take (10 (length requiredCards)) actionCards_ ++ requiredCards
cards = concatMap pileOf $ CA.treasureCards ++ CA.victoryCards ++ (take 10 actionCards)
when verbose_ $ putStrLn $ "Playing with: " ++ (join ", " . map T._name $ actionCards)
results <- forM [1..iterations] $ \i -> if even i
then run (T.GameState players cards 1 verbose_) strategies
else run (T.GameState (reverse players) cards 1 verbose_) (reverse strategies)
let winnerNames = (map T.winner results)
forM_ players $ \player -> do
let name = player ^. T.playerName
putStrLn $ printf "player %s won %d times" name (count name winnerNames)
return results
buys :: T.PlayerId -> T.Card -> T.Dominion (T.PlayResult ())
buys playerId card = do
validation <- validateBuy playerId card
case validation of
Left x -> return $ Left x
Right _ -> do
money <- handValue playerId
modifyPlayer playerId $ \p -> over T.discard (card:) $
over T.buys (subtract 1) $
over T.extraMoney (subtract $ card ^. T.cost) p
modify $ over T.cards (delete card)
log playerId $ printf "bought a %s" (card ^. T.name)
return $ Right ()
buysByPreference :: T.PlayerId -> [T.Card] -> T.Dominion ()
buysByPreference playerId cards = do
purchasableCards <- filterM (\card -> eitherToBool <$> validateBuy playerId card) cards
when (not (null purchasableCards)) $ do
playerId `buys` (head purchasableCards)
playerId `buysByPreference` cards
playsByPreference :: T.PlayerId -> [T.Card] -> T.Dominion ()
playsByPreference playerId cards = do
playableCards <- filterM (\card -> eitherToBool <$> validatePlay playerId card) cards
when (not (null playableCards)) $ do
playerId `plays` (head playableCards)
playerId `playsByPreference` cards
plays :: T.PlayerId -> T.Card -> T.Dominion (T.PlayResult (Maybe T.Followup))
playerId `plays` card = do
validation <- validatePlay playerId card
case validation of
Left x -> return $ Left x
Right _ -> do
log playerId $ printf "plays a %s!" (card ^. T.name)
results <- mapM (usesEffect playerId) (card ^. T.effects)
modifyPlayer playerId (over T.actions (subtract 1))
if trashThisCard card
then playerId `trashesCard` card
else playerId `discardsCard` card
return . Right . listToMaybe . catMaybes $ results
with :: T.Dominion (T.PlayResult (Maybe T.Followup)) -> T.FollowupAction -> T.Dominion (T.PlayResult (Maybe [T.Followup]))
result_ `with` followupAction = do
result <- result_
case result of
Left str -> return $ Left str
Right Nothing -> return $ Right Nothing
Right (Just followup) -> followup `_with` followupAction
withMulti :: T.Dominion (T.PlayResult (Maybe [T.Followup])) -> [T.FollowupAction] -> T.Dominion (T.PlayResult (Maybe [T.Followup]))
results_ `withMulti` followupActions = do
results <- results_
case results of
Left str -> return $ Left str
Right Nothing -> return $ Right Nothing
Right (Just followups) -> do
allResults <- mapM (uncurry _with) (zip followups followupActions)
return $ Right $ case (concat . catMaybes . rights $ allResults) of
[] -> Nothing
xs -> Just xs
_with :: T.Followup -> T.FollowupAction -> T.Dominion (T.PlayResult (Maybe [T.Followup]))
(playerId, T.PlayActionCard x) `_with` (T.ThroneRoom card) = do
hasCard <- playerId `has` card
if not hasCard
then return . Left $ printf "You don't have a %s in your hand!" (card ^. T.name)
else do
log playerId $ printf "playing %s twice!" (card ^. T.name)
results <- mapM (usesEffect playerId) ((card ^. T.effects) ++ (card ^. T.effects))
playerId `discardsCard` card
return $ Right $ case (catMaybes results) of
[] -> Nothing
xs -> Just xs
(playerId, T.CellarEffect) `_with` (T.Cellar cards) = do
forM_ cards $ \card -> do
hasCard <- playerId `has` card
when hasCard $ do
playerId `discardsCard` card
[drawnCard] <- drawFromDeck playerId 1
log playerId $ printf "discarded a %s and got a %s" (card ^. T.name) (drawnCard ^. T.name)
return $ Right Nothing
(playerId, T.ChancellorEffect) `_with` (T.Chancellor moveDeck) = do
when moveDeck $ do
log playerId "Moving deck into the discard pile"
modifyPlayer playerId $ \p -> set T.deck [] $ over T.discard (++ (p ^. T.deck)) p
return $ Right Nothing
(playerId, T.TrashCards x) `_with` (T.Chapel cards) = do
let toTrash = take x cards
forM_ toTrash $ \card_ -> playerId `trashesCard` card_
return $ Right Nothing
(playerId, T.GainCardUpto x) `_with` (T.Feast card) = gainCardUpTo playerId x card
(playerId, T.GainCardUpto x) `_with` (T.Workshop card) = gainCardUpTo playerId x card
(playerId, T.MineEffect) `_with` (T.Mine card) = do
hasCard <- playerId `has` card
if not hasCard
then return . Left $ printf "You don't have a %s in your hand!" (card ^. T.name)
else if (not . isTreasure $ card)
then return . Left $ printf "Mine only works with treasure cards, not %s" (card ^. T.name)
else if (card == CA.gold)
then return . Left $ "can't upgrade gold!"
else do
newCard_ <- getCard (if (card == CA.copper) then CA.silver else CA.gold)
case newCard_ of
Nothing -> return . Left $ "Sorry, we are out of the card you could've upgraded to."
Just newCard -> do
playerId `trashesCard` card
modifyPlayer playerId $ over T.hand (newCard:)
log playerId $ printf "trashed a %s for a %s" (card ^. T.name) (newCard ^. T.name)
return $ Right Nothing
(playerId, T.RemodelEffect) `_with` (T.Remodel (toTrash, toGain)) = do
hasCard <- playerId `has` toTrash
if not hasCard
then return . Left $ printf "You don't have a %s in your hand!" (toTrash ^. T.name)
else if ((toGain ^. T.cost) > (toTrash ^. T.cost) + 2)
then return . Left $ printf "You're remodeling a %s, a %s is too expensive" (toTrash ^. T.name) (toGain ^. T.name)
else do
newCard_ <- getCard toGain
case newCard_ of
Nothing -> return . Left $ printf "Sorry, no more %s left" (toGain ^. T.name)
Just card -> do
modifyPlayer playerId $ over T.discard (card:)
return $ Right Nothing
(playerId, T.SpyEffect) `_with` (T.Spy (myself, others)) = do
modifyPlayer playerId (discardTopCard myself)
modifyOtherPlayers playerId (discardTopCard others)
return $ Right Nothing
(playerId, T.ThiefEffect) `_with` (T.Thief func) = do
state <- get
let players = (indices (state ^. T.players)) \\ [playerId]
forM_ players $ \pid -> do
player <- getPlayer pid
let topCards = take 2 (player ^. T.deck)
treasures = filter isTreasure topCards
discards = topCards \\ treasures
modifyPlayer pid $ over T.deck (drop 2)
if (null treasures)
then do
modifyPlayer pid $ over T.discard (++discards)
return . Left $ "Sorry, this player had no treasures."
else do
let action = func treasures
case action of
T.TrashOnly card -> do
let other = treasures \\ [card]
modifyPlayer pid $ over T.discard (++other)
return $ Right Nothing
T.GainTrashedCard card -> do
let other = treasures \\ [card]
modifyPlayer pid $ over T.discard (++other)
if (card `elem` treasures)
then do
modifyPlayer playerId $ over T.discard (card:)
return $ Right Nothing
else return $ Left "That card wasn't one of the treasures you could trash!"
return $ Right Nothing
_ `_with` _ = return $ Left "sorry, you can't play that effect with that extra effect."