From 14e622a846b391b902d141caa9c281ee038088f5 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sun, 18 May 2014 23:34:19 -0500 Subject: [PATCH] implement remaining actions; still missing conditional plot actions --- src/Waterdeep/Actions.hs | 219 +++++++++++++++++++++++++++------------ src/Waterdeep/Logic.hs | 28 ++++- src/Waterdeep/Types.hs | 4 +- src/Waterdeep/Util.hs | 26 +++-- 4 files changed, 196 insertions(+), 81 deletions(-) diff --git a/src/Waterdeep/Actions.hs b/src/Waterdeep/Actions.hs index d236dee..8bb34d6 100644 --- a/src/Waterdeep/Actions.hs +++ b/src/Waterdeep/Actions.hs @@ -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] - name <- use $ activePlayerName - broadcast $ name ++ " assigned an agent to Waterdeep Harbor." - playIntrigue +assignAgentToBuilding :: PlayerID -> Lens' WaterdeepState BuildingState -> Waterdeep () +assignAgentToBuilding agent bl = do + when (agent /= noPlayerID) $ + gamePlayerState agent . playerAgentsInPool -= 1 + bl.buildingAgents <>= [agent] + name <- use $ activePlayerName + 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 @@ -369,8 +451,9 @@ gainLieutenant = do gainAmbassador :: GameAction gainAmbassador = do guard . not . or . toListOf (traverse . playerHasAmbassador) =<< use gamePlayerStates - gameBuildings . traverse . buildingAgents %= (\\ [noPlayerID]) - gameWaterdeepHarbor . traverse %= (\\ [noPlayerID]) + gameBuildings . traverse . buildingAgents %= (\\ [noPlayerID]) + gameWaterdeepHarbor . traverse . buildingAgents %= (\\ [noPlayerID]) + gameBuildersHall . traverse . buildingAgents %= (\\ [noPlayerID]) activePlayerState . playerHasAmbassador .= True name <- use $ activePlayerName broadcast $ name ++ " gained the Ambassador." diff --git a/src/Waterdeep/Logic.hs b/src/Waterdeep/Logic.hs index 74425ca..df0bd52 100644 --- a/src/Waterdeep/Logic.hs +++ b/src/Waterdeep/Logic.hs @@ -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 diff --git a/src/Waterdeep/Types.hs b/src/Waterdeep/Types.hs index 0940c35..b92937a 100644 --- a/src/Waterdeep/Types.hs +++ b/src/Waterdeep/Types.hs @@ -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) diff --git a/src/Waterdeep/Util.hs b/src/Waterdeep/Util.hs index 2d4acba..eacf936 100644 --- a/src/Waterdeep/Util.hs +++ b/src/Waterdeep/Util.hs @@ -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