nybble
/
waterdeep
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

implement remaining actions; still missing conditional plot actions

This commit is contained in:
Jesse D. McDonald 2014-05-18 23:34:19 -05:00
parent 55a4b74cc5
commit 14e622a846
4 changed files with 196 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

215
src/Waterdeep/Actions.hs
View File

@ -1,6 +1,9 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Waterdeep.Actions
@ -24,6 +27,7 @@ module Waterdeep.Actions
, playIntrigue
, returnAgent
, returnAgentFromHarbor
, assignAmbassador
, assignAgent
, assignAgentToBuildersHall
, assignAgentToOpponentsSpace
@ -46,18 +50,20 @@ module Waterdeep.Actions
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad (when, unless, guard, join, replicateM, replicateM_)
import Control.Monad.Random
import Control.Monad.State
import Control.Monad.State (get)
import Control.Monad.Trans.Writer
import Data.Function
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Traversable (traverse)
import Data.Foldable (foldMap, forM_, mapM_)
import Data.Traversable (traverse, for, forM, mapM)
import Lens.Family2
import Lens.Family2.State
import Lens.Family2.Stock
import Prelude hiding (forM, mapM)
import System.Random.Shuffle
import Text.Printf
import Waterdeep.Types
@ -173,41 +179,36 @@ completeQuest = do
let choices = map (\(i,q) -> (q ^. questTitle, (i, q))) availQuests
(i, quest) <- solicitChoice "Complete one quest:" $ nubOn fst choices
activePlayerState . playerIncompleteQuests %= deleteAt i
completeQuest' quest
chooseAndCompleteQuest :: GameAction -> GameAction
chooseAndCompleteQuest bonusAction = do
quest <- chooseQuest'
join $ solicitChoice "Complete this quest immediately?" $
[ ("Yes", do { incompleteQuests <- use (activePlayerState . playerIncompleteQuests)
; guard . and $ map ((/= Mandatory) . view questType) incompleteQuests
; completeQuest' quest
; bonusAction
})
, ("No", activePlayerState . playerIncompleteQuests <>= [quest])
]
-- common to both completeQuest and chooseAndCompleteQuest
completeQuest' :: Quest -> GameAction
completeQuest' quest = do
tavern <- use $ activePlayerState . playerTavern
guard $ ((quest ^. questCost) `MS.isSubsetOf` tavern)
activePlayerState . playerTavern %= (`MS.difference` (quest ^. questCost))
name <- use activePlayerName
broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest."
quest ^. questReward
forM_ (filter ((==Immediately) . fst) (quest^.questPlotActions)) $ snd
if (quest ^. questType == Mandatory)
then gameIntrigueDiscard <>= [mandatoryQuestCard quest]
else if null (quest ^. questPlotActions)
then activePlayerState . playerCompletedQuests <>= [quest]
else activePlayerState . playerActivePlotQuests <>= [quest]
chooseAndCompleteQuest :: GameAction -> GameAction
chooseAndCompleteQuest bonusAction = do
quest <- chooseQuest'
doQuest <- solicitChoice "Complete this quest immediately?"
[("Yes", True), ("No", False)]
case doQuest of
True -> do
incompleteQuests <- use (activePlayerState . playerIncompleteQuests)
guard . and $ map ((/= Mandatory) . view questType) incompleteQuests
tavern <- use $ activePlayerState . playerTavern
guard $ ((quest ^. questCost) `MS.isSubsetOf` tavern)
activePlayerState . playerTavern %= (`MS.difference` (quest ^. questCost))
name <- use $ activePlayerName
broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest."
quest ^. questReward
if null (quest ^. questPlotActions)
then activePlayerState . playerCompletedQuests <>= [quest]
else activePlayerState . playerActivePlotQuests <>= [quest]
bonusAction
False -> do
activePlayerState . playerIncompleteQuests <>= [quest]
return ()
discardUncompletedQuest :: GameAction
discardUncompletedQuest = do
choices <- zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] <$>
@ -299,64 +300,145 @@ playIntrigue = do
return ()
returnAgent :: GameAction
returnAgent = fail "TODO - not implemented"
returnAgent = do
w <- get
let p = w^.gameActivePlayer
let buildings = flip foldMapBuildings w $ \_ bl ->
let agents = w^.bl.buildingAgents
title = w^.bl.building.buildingTitle
in mif (p `elem` agents) [(title, bl.buildingAgents %= (\\[p]))]
join $ solicitChoice "Recall an agent from:" $ nubOn fst buildings
activePlayerState . playerAgentsInPool += 1
returnAgentFromHarbor :: GameAction
returnAgentFromHarbor = fail "TODO - not implemented"
returnAgentFromHarbor = do
w <- get
let p = w ^. gameActivePlayer
let choices = flip foldMap [1,2,3] $ \i ->
let bl :: Lens' WaterdeepState BuildingState
bl = gameWaterdeepHarbor . intAt i . singular _Just
in mif (p `elem` (w^.bl.buildingAgents))
[(w^.bl.building.buildingTitle, bl.buildingAgents %= (\\[p]))]
join $ solicitChoice "Recall an agent from:" $ choices
activePlayerState . playerAgentsInPool += 1
assignAgentToBuilding :: Traversal' WaterdeepState BuildingState -> Waterdeep ()
assignAgentToBuilding bt = do
activePlayerState.playerAgentsInPool -= 1
foldMapBuildings ::
(Monoid m) => (Bool -> Lens' WaterdeepState BuildingState -> m) -> WaterdeepState -> m
foldMapBuildings f w = normal <> harbor <> hall
where
normal = flip foldMap (w ^. gameBuildings . to IM.keys) $ \i ->
f False $ gameBuildings . intAt i . singular _Just
(harborOccupied, harborUnoccupied) = flip foldMap [1,2,3] $ \i ->
let bl :: Lens' WaterdeepState BuildingState
bl = gameWaterdeepHarbor . intAt i . singular _Just
in if null (w^.bl.buildingAgents)
then (mempty, First $ Just $ f False bl)
else (f False bl, mempty)
harbor = harborOccupied <> (maybe mempty id $ getFirst harborUnoccupied)
hall = flip foldMap (w ^. gameBuildersHall . to IM.keys) $ \i ->
f True $ gameBuildersHall . intAt i . singular _Just
useBuilding :: Lens' WaterdeepState BuildingState -> Waterdeep ()
useBuilding bl = do
p <- use gameActivePlayer
bt.buildingAgents <>= [p]
name <- use $ activePlayerName
bName <- fromJust . firstOf (bt.building.buildingTitle) <$> get
broadcast $ name ++ " assigned an agent to " ++ bName ++ "."
owner <- fromJust . firstOf (bt.buildingOwner) <$> get
owner <- use $ bl.buildingOwner
when (owner `notElem` [noPlayerID, p]) $
withActivePlayer owner . fromJust . firstOf (bt.building.buildingOwnerAction) =<< get
fromJust . firstOf (bt.building.buildingAction) =<< get
withActivePlayer owner =<< use (bl.building.buildingOwnerAction)
join . use $ bl.building.buildingAction
assignAgentToHarbor :: Traversal' WaterdeepState [PlayerID] -> Waterdeep ()
assignAgentToHarbor t = do
activePlayerState.playerAgentsInPool -= 1
p <- use gameActivePlayer
t <>= [p]
assignAgentToBuilding :: PlayerID -> Lens' WaterdeepState BuildingState -> Waterdeep ()
assignAgentToBuilding agent bl = do
when (agent /= noPlayerID) $
gamePlayerState agent . playerAgentsInPool -= 1
bl.buildingAgents <>= [agent]
name <- use $ activePlayerName
broadcast $ name ++ " assigned an agent to Waterdeep Harbor."
playIntrigue
bName <- use $ bl.building.buildingTitle
broadcast $ name ++ " assigned an agent to " ++ bName ++ "."
useBuilding bl
findAssignableBuildings :: WaterdeepState -> [(String, Waterdeep ())]
findAssignableBuildings w = execWriter $ do
forM_ (w ^. gameBuildings . to IM.keys) $ \i -> do
let t :: Traversal' WaterdeepState BuildingState
t = gameBuildings . intAt i . traverse
let b = fromJust $ firstOf t w
tell [(b ^. building . buildingTitle, assignAgentToBuilding t)]
let harbor = getFirst $ flip F.foldMap [1,2,3] $ \i -> First $
let t :: Traversal' WaterdeepState [PlayerID]
t = gameWaterdeepHarbor . intAt i . traverse
agents = fromJust $ firstOf t w
in if null agents then Just (assignAgentToHarbor t) else Nothing
case harbor of
Just f -> tell [("Waterdeep Harbor", f)]
Nothing -> return ()
assignAmbassador :: GameAction
assignAmbassador = do
w <- get
let p = w^.gameActivePlayer
let opponents = (w^..gamePlayerStates.traverse.playerNumber) \\ [p]
let includesOpponent = any (`elem` opponents)
let usedOpSpace = (activePlayerState . playerCanUseOpSpace .= False)
let canUseOpSpace = w ^. activePlayerState . playerCanUseOpSpace
let buildings = flip foldMapBuildings w $ \inHall bl ->
let agents = w^.bl.buildingAgents
title = w^.bl.building.buildingTitle
in if | canUseOpSpace && includesOpponent agents ->
[(title, usedOpSpace >> assignAgentToBuilding noPlayerID bl)]
| null agents && not inHall ->
[(title, assignAgentToBuilding noPlayerID bl)]
| otherwise -> []
join $ solicitChoice "Assign an agent to:" $ nubOn fst buildings
assignAgent :: GameAction
assignAgent = do
agents <- use (activePlayerState . playerAgentsInPool)
guard (agents > 0)
buildings <- findAssignableBuildings <$> get
join $ solicitChoice "Assign one agent to:" $ nubOn fst buildings
w <- get
let p = w^.gameActivePlayer
let opponents = (w^..gamePlayerStates.traverse.playerNumber) \\ [p]
let includesOpponent = any (`elem` opponents)
let usedOpSpace = (activePlayerState . playerCanUseOpSpace .= False)
let canUseOpSpace = w ^. activePlayerState . playerCanUseOpSpace
let buildings = flip foldMapBuildings w $ \inHall bl ->
let agents = w^.bl.buildingAgents
title = w^.bl.building.buildingTitle
in if | canUseOpSpace && includesOpponent agents ->
[(title, usedOpSpace >> assignAgentToBuilding p bl)]
| null agents && not inHall ->
[(title, assignAgentToBuilding p bl)]
| otherwise -> []
join $ solicitChoice "Assign an agent to:" $ nubOn fst buildings
assignAgentToBuildersHall :: GameAction
assignAgentToBuildersHall = fail "TODO - not implemented"
assignAgentToBuildersHall = do
agents <- use (activePlayerState . playerAgentsInPool)
guard (agents > 0)
w <- get
let p = w^.gameActivePlayer
let opponents = (w^..gamePlayerStates.traverse.playerNumber) \\ [p]
let includesOpponent = any (`elem` opponents)
let usedOpSpace = (activePlayerState . playerCanUseOpSpace .= False)
let canUseOpSpace = w ^. activePlayerState . playerCanUseOpSpace
let buildings = flip foldMapBuildings w $ \inHall bl -> mif inHall $
let agents = w^.bl.buildingAgents
title = w^.bl.building.buildingTitle
in if null agents
then [(title, assignAgentToBuilding p bl)]
else if canUseOpSpace && includesOpponent agents
then [(title, usedOpSpace >> assignAgentToBuilding p bl)]
else []
join $ solicitChoice "Assign an agent to:" $ nubOn fst buildings
assignAgentToOpponentsSpace :: GameAction
assignAgentToOpponentsSpace = fail "TODO - not implemented"
assignAgentToOpponentsSpace = do
agents <- use (activePlayerState . playerAgentsInPool)
guard (agents > 0)
w <- get
let p = w^.gameActivePlayer
let opponents = (w^..gamePlayerStates.traverse.playerNumber) \\ [p]
let includesOpponent = any (`elem` opponents)
let buildings = flip foldMapBuildings w $ \inHall bl ->
mif (includesOpponent (w^.bl.buildingAgents)) $
[(w^.bl.building.buildingTitle, assignAgentToBuilding p bl)]
join $ solicitChoice "Assign an agent to:" $ nubOn fst buildings
useOpponentsSpace :: GameAction
useOpponentsSpace = fail "TODO - not implemented"
useOpponentsSpace = do
agents <- use (activePlayerState . playerAgentsInPool)
guard (agents > 0)
w <- get
let p = w^.gameActivePlayer
let opponents = (w^..gamePlayerStates.traverse.playerNumber) \\ [p]
let includesOpponent = any (`elem` opponents)
let buildings = flip foldMapBuildings w $ \inHall bl ->
mif (includesOpponent (w^.bl.buildingAgents)) $
[(w^.bl.building.buildingTitle, useBuilding bl)]
join $ solicitChoice "Use the effect of one building:" $ nubOn fst buildings
gainLieutenant :: GameAction
gainLieutenant = do
@ -370,7 +452,8 @@ gainAmbassador :: GameAction
gainAmbassador = do
guard . not . or . toListOf (traverse . playerHasAmbassador) =<< use gamePlayerStates
gameBuildings . traverse . buildingAgents %= (\\ [noPlayerID])
gameWaterdeepHarbor . traverse %= (\\ [noPlayerID])
gameWaterdeepHarbor . traverse . buildingAgents %= (\\ [noPlayerID])
gameBuildersHall . traverse . buildingAgents %= (\\ [noPlayerID])
activePlayerState . playerHasAmbassador .= True
name <- use $ activePlayerName
broadcast $ name ++ " gained the Ambassador."

28
src/Waterdeep/Logic.hs
View File

@ -56,14 +56,26 @@ newGame players quests intrigues buildings rndgen =
, _gameBuildingDiscard = buildings
, _gameBuildersHall = IM.empty
, _gameBuildings = IM.fromAscList buildingStates
, _gameWaterdeepHarbor = IM.fromAscList [(1,[]),(2,[]),(3,[])]
, _gameWaterdeepHarbor = IM.fromAscList harborStates
, _gameReassigningAgents = False
, _gameStdGen = rndgen
}
where
playerStates = zipWith (\i p -> (i, newPlayerState i p)) [1..] players
buildingStates = zipWith (\i b -> (i, newBuildingState np b)) [1..] basicBuildings
harborStates = map (\i -> (i, newHarborState i)) [1..3]
np = noPlayerID
newHarborState :: Int -> BuildingState
newHarborState i = newBuildingState noPlayerID $
Building
{ _buildingCost = 0
, _buildingTitle = "Waterdeep Harbor #" ++ show i
, _buildingAction = playIntrigue
, _buildingOwnerAction = noAction
, _buildingAccumType = NoAccumulation
}
waterdeepGame :: Waterdeep [PlayerID]
waterdeepGame = do
np <- use gameNumberOfPlayers
@ -76,7 +88,10 @@ waterdeepGame = do
takeResources (3 + p) [Gold]
forM_ [1..8] $ \round -> do
beginRound round
-- TODO: Assign ambassador (if in play)
ambassadorIM <- IM.filter (view playerHasAmbassador) <$> use gamePlayerStates
unless (IM.null ambassadorIM) $ do
let p = head $ IM.keys ambassadorIM
withActivePlayer p $ assignAmbassador
fix $ \loop -> do
assign gameActivePlayer =<< use gameCurrentPlayer
filterChoices assignAgent >>= \case
@ -111,8 +126,8 @@ beginRound round = do
assign gameActivePlayer =<< use gameFirstPlayer
gameBuildings . traverse . buildingAgents .= []
gameBuildersHall . traverse . buildingAgents .= []
gameWaterdeepHarbor . traverse . buildingAgents .= []
gameBuildersHall . traverse . buildingAccumulation += 1
gameWaterdeepHarbor . traverse .= []
np <- use gameNumberOfPlayers
let agents = initialAgents np round
forM_ [1..np] $ \p -> withActivePlayer p $ do
@ -120,11 +135,14 @@ beginRound round = do
activePlayerState . playerUsedPlotQuests .= []
activePlayerState . playerActivePlotQuests <>= qs
activePlayerState . playerAgentsInPool .= agents
activePlayerState . playerCanUseOpSpace .= False
use (activePlayerState . playerHasLieutenant) >>= \case
True -> activePlayerState . playerAgentsInPool += 1 >> return ()
False -> return ()
--TODO: Start-of-round plot actions
forM_ [1..np] $ \p -> withActivePlayer p $ do
qs <- use $ activePlayerState . playerActivePlotQuests
forM_ qs $ \q -> do
forM_ (q^.questPlotActions) $ \(condition, action) -> do
when (condition == StartOfRound) action
scoreFinalPoints :: Waterdeep ()
scoreFinalPoints = do

4
src/Waterdeep/Types.hs
View File

@ -216,7 +216,8 @@ data WaterdeepState =
, _gameBuildingDiscard :: [Building]
, _gameBuildersHall :: IntMap BuildingState
, _gameBuildings :: IntMap BuildingState
, _gameWaterdeepHarbor :: IntMap [PlayerID]
, _gameWaterdeepHarbor :: IntMap BuildingState
, _gameReassigningAgents :: Bool
, _gameStdGen :: StdGen
}
@ -249,7 +250,6 @@ data PlotQualifier = ActionProvides [Resource]
data PlotCondition = Immediately
| StartOfRound
| OncePerRound
| OncePerRoundWhen PlotQualifier
| Whenever PlotQualifier
deriving (Eq,Show)

26
src/Waterdeep/Util.hs
View File

@ -1,21 +1,23 @@
{-# LANGUAGE RankNTypes #-}
module Waterdeep.Util
( mrepeat
, deleteAt
( deleteAt
, on
, nubOn
, sortOn
, countOf
, singular
, mif
) where
import Lens.Family2
import Data.List
import Data.Maybe
import Data.Monoid
mrepeat :: (Monoid m) => Int -> m -> m
mrepeat n m = mconcat $ replicate n m
deleteAt :: Int -> [a] -> [a]
deleteAt n l = (take n l) ++ (drop (n + 1) l)
deleteAt n l = left ++ drop 1 right
where (left, right) = splitAt n l
on :: (b -> b -> c) -> (a -> b) -> (a -> a -> c)
(f `on` g) a b = (g a) `f` (g b)
@ -28,3 +30,15 @@ sortOn f = sortBy (compare `on` f)
countOf :: Num r => FoldLike (Sum r) a a' b b' -> (b -> Bool) -> a -> r
countOf l f = getSum . views l (\b -> if f b then Sum 1 else Sum 0)
-- |Turn a traversal into a lens. This is well-defined if and only if the traversal
-- always refers to exactly one element. With multiple elements, setting applies to
-- all and getting returns just the first value. With zero elements, setting is a
-- no-op and getting results in a runtime error.
singular :: Traversal a a' b b' -> Lens a a' b b'
singular t f b = (\a' -> b & t .~ a') `fmap` (f (unJust (firstOf t b)))
where unJust (Just x) = x
unJust Nothing = error "singular: empty traversal"
mif :: Monoid m => Bool -> m -> m
mif c m = if c then m else mempty