Skip to content

Commit

Permalink
add embargo and native village
Browse files Browse the repository at this point in the history 
Tested-on: figaro i686 GNU/Linux
  • Loading branch information
@shicks
shicks committed Dec 3, 2009
1 parent fb4959e commit e657c0d
Show file tree
Hide file tree
Showing 6 changed files with 203 additions and 85 deletions.
16 changes: 12 additions & 4 deletions Dominion/Attack.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,9 @@ module Dominion.Attack ( attack, attackNow ) where
import Dominion.Types
import Dominion.Question
import Dominion.Stack
import Dominion.Message ( tellAll )

import Control.Monad.Error ( catchError )
import Control.Monad.State ( gets )

isReaction :: Card -> Bool
Expand All @@ -12,17 +14,23 @@ isReaction c = not $ null [() | Reaction _ <- cardType c]
getReaction :: Card -> Reaction -- unsafe!
getReaction c = head [r | Reaction r <- cardType c]

-- put some stuff here to say whether order matters, once we start
-- parallelizing the attacks.

attack :: String -> Game (Attack -> Game ())
attack name = do self <- getSelf
n <- gets $ length . gamePlayers
let opps = filter (/=self) $ map PId [0..n-1]
let react :: PId -> Game (Attack -> Attack)
react p = do h <- getStack $ hand p
let rs = filter isReaction h
r <- askCards p rs (SelectReaction name)
(0,1)
if null r then return id else do
getReaction (head r) p (react p)
catchError `flip` (\_ -> return id) $ do
[r] <- askCards p rs (SelectReaction name)
(0,1)
name <- withPlayer p $ gets playerName
tellAll $ CardReveal name
[describeCard r] "hand"
getReaction r p (react p)
rs <- mapM react opps
let att a = mapM_ (\(p,r) -> r a self p) $ zip opps rs
return att
Expand Down
52 changes: 40 additions & 12 deletions Dominion/Cards.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,8 +11,7 @@ import Control.Monad.Error ( catchError )
import Control.Monad ( when, unless, join, replicateM, forM, forM_,
zipWithM_, (<=<) )
import Data.Maybe ( listToMaybe, maybeToList, catMaybes, fromMaybe )
import Data.List ( (\\), nubBy, partition )
import Data.Function ( on )
import Data.List ( (\\), nubBy, partition, intercalate )

-- import Control.Monad.Trans ( liftIO ) -- for debugging!

Expand Down Expand Up @@ -133,8 +132,8 @@ intrigueSets =
]

seaside :: [Card] -- outpost, treasury, smugglers, .....
seaside = [bazaar, caravan, fishingVillage, lookout, merchantShip,
pearlDiver, salvager, tactician, warehouse, wharf]
seaside = [bazaar, caravan, embargo, fishingVillage, lookout, merchantShip,
nativeVillage, pearlDiver, salvager, tactician, warehouse, wharf]

seasideSets :: [(String,[Card])]
seasideSets =
Expand Down Expand Up @@ -171,6 +170,7 @@ adventurer = Card 0 6 "Adventurer" "..." [action $ getSelf >>= a ]
dig 2 = return ()
dig n = do self <- getSelf
[c] <-1<* deck self
revealCards self [c] "deck"
if isTreasure c
then do hand self << [c]
dig (n+1)
Expand All @@ -182,8 +182,9 @@ bureaucrat = Card 0 4 "Bureaucrat" "..." [action a]
where a = do attackNow "bureaucrat" $ \self opp -> try $ do
h <- getStack $ hand opp
let vs = filter isVictory h
if null vs then return () else do -- reveal hand...?
if null vs then revealHand opp else do -- reveal hand...?
[c] <- askCards opp vs (UndrawBecause "bureaucrat") (1,1)
revealCards opp [c] "hand"
deck opp *<< [c]
self <- getSelf
try $ gain self deck *<< [silver]
Expand Down Expand Up @@ -311,7 +312,7 @@ thief = Card 0 4 "Thief" "..." [action a]
let (ts,nts) = partition isTreasure cs
discard opp *<< nts
[c] <- askCards self ts (TrashBecause "thief") (1,1)
askMC self [("Steal",gain self discard *<< [c]),
askMC self [("Steal",gain' self discard *<< [c]),
("Trash",trash << [c])] $ "Steal "++show c++"?"

-- TR and durations - FV=Fishing Village
Expand Down Expand Up @@ -380,7 +381,7 @@ blackMarket = Card 0 3 "Black Market" "..." [Hook (SetupHook setup), action a]
coins' <- withTurn $ gets turnCoins
if cost <= coins'
then do plusCoin (-cost)
discard self *<< [c] -- only gain from supply
gain' self discard *<< [c]
return [c]
else return []
buy <- catchError f (\_ -> return [])
Expand All @@ -394,6 +395,7 @@ envoy = Card 0 4 "Envoy" "..." [action a]
self <- getSelf
lho <- getLHO self
cs <-5<* deck self
revealCards self cs "deck"
[c] <- askCards lho cs (Gain "envoy discard") (1,1)
discard self *<< [c]
hand self << filter (/=c) cs
Expand Down Expand Up @@ -529,6 +531,7 @@ scout = Card 0 4 "Scout" "..." [action a]
where a = do self <- getSelf
plusAction 1
cs <-4<* deck self
revealCards self cs "deck"
let (v,nv) = partition isVictory cs
n = length nv
hand self << v
Expand All @@ -548,8 +551,10 @@ secretChamber = Card 0 2 "Secret Chamber" "..." [action act,Reaction react]

shantyTown :: Card
shantyTown = Card 0 3 "Shanty Town" "..." [action a]
where a = do plusAction 2
as <- filter isAction `fmap` (getStack . hand =<< getSelf)
where a = do self <- getSelf
plusAction 2
revealHand self
as <- filter isAction `fmap` (getStack $ hand self)
when (null as) $ plusCard 2

steward :: Card
Expand Down Expand Up @@ -627,6 +632,16 @@ caravan :: Card
caravan = Card 0 4 "Caravan" "..." [duration a]
where a = plusABCD 1 0 0 1 >> nextTurn (plusCard 1)

embargo :: Card -- can we hook into the the card's show for supply?!?
embargo = Card 0 2 "Embargo" "..." [oneShot $ try a]
where a = do self <- getSelf
plusCoin 2
sup <- supplyCosting $ \_ -> True -- all piles
[c] <- askCards self sup (OtherQuestion "embargo") (1,1)
modify $ \s -> s { hookBuy = hook c:hookBuy s }
hook e p cs = forM_ cs $ \c -> when (sameName c e) $
gain p discard *<< [curse]

fishingVillage :: Card
fishingVillage = Card 0 3 "Fishing Village" "..." [duration a]
where a = plusABCD 2 0 1 0 >> nextTurn (plusABCD 1 0 1 0)
Expand All @@ -647,6 +662,22 @@ merchantShip :: Card
merchantShip = Card 0 5 "Merchant Ship" "..." [duration a]
where a = plusCoin 2 >> nextTurn (plusCoin 2)

nativeVillage :: Card
nativeVillage = Card 0 2 "Native Village" "..." [action a]
where a = do self <- getSelf
plusAction 2
cs <- map cardName `fmap` getStack (nvMat self)
tellSelf $ InfoMessage $ "Native Village Mat: "++
intercalate ", " cs
askMC self `flip` "Choose one" $
[("Set aside",setAside self),
("Draw from mat",hand self <<< nvMat self)]
setAside self = do nvMat self *<#1<* deck self
cs <- map cardName `fmap` getStack (nvMat self)
tellSelf $ InfoMessage $ "Native Village Mat: "++
intercalate ", " cs
nvMat = mat "nativeVillage"

pearlDiver :: Card
pearlDiver = Card 0 2 "Pearl Diver" "..." [action $ try a]
where a = do self <- getSelf
Expand Down Expand Up @@ -726,9 +757,6 @@ getActionPred :: Card -> Card -> Game ()
getActionPred pred c = foldl (>>) (return ())
[a c (Just pred) | Action a <- cardType c]

sameName :: Card -> Card -> Bool
sameName = (==) `on` cardName

finally :: Game () -> Game () -> Game ()
finally job after = try job >> after

Expand Down
67 changes: 35 additions & 32 deletions Dominion/Game.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,11 +9,11 @@ import Dominion.Stack
import Control.Concurrent ( forkIO )
import TCP.Chan ( Output, Input, pipe, readInput, writeOutput )
import Control.Monad.State ( execStateT, modify, gets, liftIO )
import Control.Monad ( replicateM, foldM, when, forever )
import Control.Monad ( replicateM, foldM, when, forever, liftM2 )
import Data.Array ( array )

newTurn :: TurnState
newTurn = TurnState 1 1 0 cardPrice faceValue []
newTurn = TurnState 1 1 0 cardPrice faceValue [] id

start :: [(String,Output MessageToClient)] -> Input ResponseFromClient
-> [Card] -> IO GameState
Expand Down Expand Up @@ -42,7 +42,7 @@ start ps c cs = do (chi,cho) <- pipe
emptyPlayer (i,(s,c)) = PlayerState i s c []
emptyState chi cho =
GameState (map emptyPlayer $ zip [0..] ps) (array (0,-1) [])
0 newTurn {-defaultGain-} chi cho [0..]
0 newTurn [] [] [] chi cho [0..]
copy cd = replicate (if isVictory cd then vic else 10) cd
vic = if length ps<3 then 8 else 12
provs = if length ps<=4 then vic else 3*(length ps)
Expand All @@ -63,7 +63,7 @@ play = do winner <- endGame
case winner of
Just s -> return s
Nothing -> turn >> play
where endGame = do provinces <- supplyCards "Province"
where endGame = do provinces <- supplyCards province
sups <- distinctSupplies
np <- gets $ length . gamePlayers
let piles = if np>4 then 4 else 3
Expand All @@ -89,20 +89,14 @@ play = do winner <- endGame

turn :: Game ()
turn = do self <- gets currentTurn
doTurn self
n <- gets $ length . gamePlayers
modify $ \s -> s { currentTurn = (self+PId 1)`mod`(PId n) }
where doTurn self = do modify $ \s -> s { turnState = newTurn }
duration self
actions self
coins <- gets $ turnCoins . turnState
treasure <- sum `fmap` (mapM getTreasure =<<
getStack (hand self))
buys <- gets $ turnBuys . turnState
-- tell self . ("Supply: "++) . show =<< allSupply
buy self buys (coins + treasure)
cleanup self
actions self = do h <- getStack $ hand self
runTurnHooks self
modify $ \s -> s { turnState = newTurn }
duration self
actions self
-- tell self . ("Supply: "++) . show =<< allSupply
buy self
cleanup self
where actions self = do h <- getStack $ hand self
a <- withTurn $ gets turnActions
tell self $ "Actions ("++show a++"): hand="++show h
let as = filter (isAction) h
Expand All @@ -113,30 +107,39 @@ turn = do self <- gets currentTurn
getAction $ head cs
acts <- gets $ turnActions . turnState
when (acts > 0) $ actions self
buy self buys money
= do -- supply <- gets gameSupply
buy self = do treasure <- filter isTreasure
`fmap` getStack (hand self)
played << treasure -- is this what we want?
money <- liftM2 (+)
(withTurn $ gets turnCoins)
(sum `fmap` mapM getTreasure treasure)
buys <- gets $ turnBuys . turnState
attemptBuy self buys money
attemptBuy self buys money = do
sup <- supplyCosting (<=money)
tell self $ "Buy: " ++ show money ++ " coins, "
++ show buys ++ " buys"
-- tell self $ " supply=" ++ show supply
price <- withTurn $ gets priceMod
sup <- supplyCosting (<=money)
cs <- askCards' self sup SelectBuys (0,buys)
totalCost <- sum `fmap` mapM priceM cs
if totalCost <= money then do name <- withPlayer self $
gets playerName
gain self discard *<< cs
gainSilent self discard *<< cs
runBuyHooks self cs
tellAll $ CardBuy name $
map describeCard cs
else buy self buys money
else attemptBuy self buys money
duration self = do prevDuration <<< durations self
withPlayer self (gets durationEffects)
>>= sequence_
withPlayer self (modify $
\s -> s { durationEffects = [] })
cleanupStacks self = do discard self *<<< played
discard self *<<< prevDuration
discard self *<<< hand self
cleanup self = do let rep = cleanupStacks self >> doTurn self
mapM_ ($rep) =<< withTurn (gets cleanupHooks)
cleanupStacks self
draw 5 self
cleanup self = do sequence =<< withTurn (gets cleanupHooks)
discard self *<<< played
discard self *<<< prevDuration
discard self *<<< hand self
withTurn (gets nextTurnHook) >>= ($defNextTurn)
defNextTurn = do self <- getSelf
n <- gets $ length . gamePlayers
draw 5 self
modify $ \s -> s { currentTurn =
(self+PId 1)`mod`(PId n) }
Loading

0 comments on commit e657c0d

Please sign in to comment.