From e465141017c47e06d5bda0d339191c3b93d3d412 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Mon, 1 Sep 2014 18:12:43 -0500 Subject: [PATCH] implement the remaining forms of plot quest action --- src/Waterdeep/Actions.hs | 27 +++++++++++++++++++---- src/Waterdeep/Intrigues.hs | 2 +- src/Waterdeep/Logic.hs | 41 ++++++++++++++++++----------------- src/Waterdeep/Quests.hs | 32 +++++++++++++-------------- src/Waterdeep/Types.hs | 44 +++++++++++++++++++++++++------------- src/Waterdeep/Util.hs | 8 ++++++- waterdeep.cabal | 3 ++- 7 files changed, 99 insertions(+), 58 deletions(-) diff --git a/src/Waterdeep/Actions.hs b/src/Waterdeep/Actions.hs index 67a24ef..a120394 100644 --- a/src/Waterdeep/Actions.hs +++ b/src/Waterdeep/Actions.hs @@ -44,6 +44,7 @@ module Waterdeep.Actions , restockCliffwatchInn , restockBuildersHall , getOpponents + , doPlotAction , mandatoryQuestCard ) where @@ -53,6 +54,7 @@ import Control.Monad (when, unless, guard, join, replicateM, replicateM_) import Control.Monad.Random import Control.Monad.State (get) import Control.Monad.Trans.Writer +import Data.Char import Data.Function import Data.List import Data.Maybe @@ -200,15 +202,17 @@ completeQuest' quest = do guard $ ((quest ^. questCost) `MS.isSubsetOf` tavern) activePlayerState . playerTavern %= (`MS.difference` (quest ^. questCost)) name <- use activePlayerName - broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest." + broadcast $ name ++ " completed the \"" ++ (quest^.questTitle) ++ "\" " + ++ map toLower (show (quest^.questType)) ++ " quest." delimitAction $ do quest ^. questReward - forM_ (filter ((==Immediately) . fst) (quest^.questPlotActions)) $ snd + forM_ (filter (\(s,c,a) -> c == Immediately) (quest^.questPlotActions)) $ \(s,c,a) -> a if (quest ^. questType == Mandatory) then gameIntrigueDiscard <>= [mandatoryQuestCard quest] else if null (quest ^. questPlotActions) - then activePlayerState . playerCompletedQuests <>= [quest] - else activePlayerState . playerActivePlotQuests <>= [quest] + then activePlayerState . playerCompletedQuests <>= [quest] + else activePlayerState . playerPlotQuests <>= [quest] + doPlotAction (== CompletesQuest (quest^.questType)) discardUncompletedQuest :: GameAction discardUncompletedQuest = do @@ -244,6 +248,7 @@ buyBuilding = do gameBuildings %= IM.insert newKey newState broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ "." scorePoints (b ^. buildingAccumulation) + doPlotAction (== BuysBuilding) restockBuildersHall chooseFreeBuilding :: GameAction @@ -298,6 +303,7 @@ playIntrigue = do intrigue ^. intrigueAction unless (intrigue ^. intrigueType == MandatoryQuest) $ gameIntrigueDiscard <>= [intrigue] + doPlotAction (== PlaysIntrigue) return () returnAgent :: GameAction @@ -572,6 +578,19 @@ forEachControlledBuilding m = do where b `isControlledBy` p = b ^. buildingOwner == p +doPlotAction :: (PlotQualifier -> Bool) -> Waterdeep () +doPlotAction f = do + updating (activePlayerState.playerPlotQuests.traverse.questPlotActions.traverse) $ \case + (Active, cond@(Whenever qual), action) | f qual -> do + filterChoices action + return (Active,cond,action) + -- TODO: Let player choose when (or if) to use once-per-round actions + (Active, cond@(OncePerRoundWhen qual), action) | f qual -> do + filterChoices action >>= \case + Nothing -> return (Active,cond,action) -- action can't be completed now + Just _ -> return (Used,cond,action) -- action is used up for this round + x -> return x + mandatoryQuestCard :: Quest -> IntrigueCard mandatoryQuestCard q = IntrigueCard diff --git a/src/Waterdeep/Intrigues.hs b/src/Waterdeep/Intrigues.hs index e56b12f..96690e1 100644 --- a/src/Waterdeep/Intrigues.hs +++ b/src/Waterdeep/Intrigues.hs @@ -137,7 +137,7 @@ defaultIntrigueDeck = concat $ map (uncurry replicate) $ , (1, IntrigueCard { _intrigueTitle = "Change of Plans" , _intrigueType = Utility , _intrigueAction = do - discardUncompletedQuest + discardUncompletedQuest scorePoints 6 forEachOpponent $ do join . solicitChoice "Discard uncompleted quest for 3 points?" $ diff --git a/src/Waterdeep/Logic.hs b/src/Waterdeep/Logic.hs index 2456a2d..d7c6c9d 100644 --- a/src/Waterdeep/Logic.hs +++ b/src/Waterdeep/Logic.hs @@ -11,18 +11,19 @@ module Waterdeep.Logic import Control.Applicative import Control.Arrow ((&&&)) -import Control.Monad +import Control.Monad hiding (forM_, mapM_) import Control.Monad.Random -import Control.Monad.State +import Control.Monad.State hiding (forM_, mapM_) import Control.Monad.Trans.Writer import Data.List -import Data.Foldable (toList) +import Data.Foldable (toList, foldMap, forM_, mapM_) import Data.Maybe import Data.Monoid -import Data.Traversable (traverse) +import Data.Traversable (traverse, for, forM, mapM) import Lens.Family2 import Lens.Family2.State import Lens.Family2.Stock +import Prelude hiding (forM, mapM) import Text.Printf import Waterdeep.Actions import Waterdeep.Buildings (basicBuildings) @@ -77,6 +78,12 @@ newHarborState i = newBuildingState noPlayerID $ , _buildingAccumType = NoAccumulation } +doActionProvided :: ResourceSet -> Waterdeep () +doActionProvided provided = when (not . Set.null $ provided) $ do + broadcast $ "Action provided " ++ joinStrings (map show $ toList provided) ++ "." + forM_ provided $ \r -> do + doPlotAction (== ActionProvides r) + waterdeepGame :: Waterdeep [PlayerID] waterdeepGame = do np <- use gameNumberOfPlayers @@ -94,16 +101,12 @@ waterdeepGame = do let p = head $ IM.keys ambassadorIM withActivePlayer p $ do provided <- snd <$> delimitAction assignAmbassador - when (not . Set.null $ provided) $ - broadcast $ "Action provided " ++ joinStrings (map show $ toList provided) ++ "." - -- TODO: Plot quests based on provided resources + doActionProvided provided fix $ \loop -> do assign gameActivePlayer =<< use gameCurrentPlayer filterChoices (delimitAction assignAgent) >>= \case Just (_, provided) -> do - when (not . Set.null $ provided) $ - broadcast $ "Action provided " ++ joinStrings (map show $ toList provided) ++ "." - -- TODO: Plot quests based on provided resources + doActionProvided provided filterChoices $ join $ solicitChoice "Complete a quest?" $ [ ("Yes", completeQuest) , ("No", return ()) @@ -139,18 +142,17 @@ beginRound round = do np <- use gameNumberOfPlayers let agents = initialAgents np round forM_ [1..np] $ \p -> withActivePlayer p $ do - qs <- use $ activePlayerState . playerUsedPlotQuests - activePlayerState . playerUsedPlotQuests .= [] - activePlayerState . playerActivePlotQuests <>= qs - activePlayerState . playerAgentsInPool .= agents + activePlayerState . playerPlotQuests . traverse + . questPlotActions . traverse . plotActionState .= Active + activePlayerState . playerAgentsInPool .= agents use (activePlayerState . playerHasLieutenant) >>= \case True -> activePlayerState . playerAgentsInPool += 1 >> return () False -> return () 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 + updating (activePlayerState.playerPlotQuests.traverse.questPlotActions.traverse) $ \(s,c,a) -> do + case c of + StartOfRound -> a >> return (Used,c,a) + _ -> return (s,c,a) scoreFinalPoints :: Waterdeep () scoreFinalPoints = do @@ -166,8 +168,7 @@ scoreFinalPoints = do QuestBonus types pts -> do quests <- concat <$> sequence [ use $ activePlayerState . playerCompletedQuests - , use $ activePlayerState . playerActivePlotQuests - , use $ activePlayerState . playerUsedPlotQuests + , use $ activePlayerState . playerPlotQuests ] let matches = length . filter ((`elem` types) . (view questType)) $ quests activePlayerState . playerScore += matches * pts diff --git a/src/Waterdeep/Quests.hs b/src/Waterdeep/Quests.hs index 10d084a..835e0a3 100644 --- a/src/Waterdeep/Quests.hs +++ b/src/Waterdeep/Quests.hs @@ -37,7 +37,7 @@ defaultQuestDeck = , _questReward = do takeResources 1 [Cleric,Fighter,Rogue,Wizard] , _questPlotActions = - [(StartOfRound, takeResources 1 [Cleric,Fighter,Rogue,Wizard])] + [(Active, StartOfRound, takeResources 1 [Cleric,Fighter,Rogue,Wizard])] } , Quest { _questType = Piety , _questTitle = "Protect the House of Wonder" @@ -46,7 +46,7 @@ defaultQuestDeck = , _questReward = do scorePoints 8 , _questPlotActions = - [(Whenever (CompletesQuest [Piety]), scorePoints 2)] + [(Active, Whenever (CompletesQuest Piety), scorePoints 2)] } , Quest { _questType = Piety , _questTitle = "Produce a Miracle for the Masses" @@ -55,7 +55,8 @@ defaultQuestDeck = , _questReward = do scorePoints 5 , _questPlotActions = - [( OncePerRoundWhen (ActionProvides [Cleric]) + [( Active + , OncePerRoundWhen (ActionProvides Cleric) , do { returnResources 1 [Fighter, Rogue, Wizard] ; takeResources 1 [Cleric] })] @@ -164,7 +165,7 @@ defaultQuestDeck = , _questReward = do noAction , _questPlotActions = - [(Immediately, gainLieutenant)] + [(Active, Immediately, gainLieutenant)] } , Quest { _questType = Warfare , _questTitle = "Train Bladesingers" @@ -192,8 +193,7 @@ defaultQuestDeck = , _questReward = do scorePoints 6 , _questPlotActions = - [(Whenever (ActionProvides [Fighter]) - , takeResources 1 [Fighter])] + [(Active, Whenever (ActionProvides Fighter), takeResources 1 [Fighter])] } , Quest { _questType = Warfare , _questTitle = "Deliver an Ultimatum" @@ -221,7 +221,7 @@ defaultQuestDeck = scorePoints 8 takeResources 4 [Gold] , _questPlotActions = - [(Whenever (CompletesQuest [Warfare]), scorePoints 2)] + [(Active, Whenever (CompletesQuest Warfare), scorePoints 2)] } , Quest { _questType = Warfare , _questTitle = "Confront the Xanathar" @@ -248,7 +248,7 @@ defaultQuestDeck = , _questReward = do noAction , _questPlotActions = - [(Whenever PlaysIntrigue, scorePoints 2)] + [(Active, Whenever PlaysIntrigue, scorePoints 2)] } , Quest { _questType = Skullduggery , _questTitle = "Establish Shadow Thieves' Guild" @@ -274,7 +274,7 @@ defaultQuestDeck = , _questReward = do scorePoints 6 , _questPlotActions = - [(Whenever (ActionProvides [Rogue]), takeResources 2 [Gold])] + [(Active, Whenever (ActionProvides Rogue), takeResources 2 [Gold])] } , Quest { _questType = Skullduggery , _questTitle = "Raid on Undermountain" @@ -350,7 +350,7 @@ defaultQuestDeck = , _questReward = do scorePoints 8 , _questPlotActions = - [(Whenever (CompletesQuest [Skullduggery]), scorePoints 2)] + [(Active, Whenever (CompletesQuest Skullduggery), scorePoints 2)] } , Quest { _questType = Arcana , _questTitle = "Expose Red Wizards' Spies" @@ -407,7 +407,7 @@ defaultQuestDeck = scorePoints 6 enableAssignOnceToOpponentsSpace , _questPlotActions = - [(StartOfRound, enableAssignOnceToOpponentsSpace)] + [(Active, StartOfRound, enableAssignOnceToOpponentsSpace)] } , Quest { _questType = Arcana , _questTitle = "Study the Illusk Arch" @@ -416,7 +416,7 @@ defaultQuestDeck = , _questReward = do scorePoints 8 , _questPlotActions = - [(Whenever (CompletesQuest [Arcana]), scorePoints 2)] + [(Active, Whenever (CompletesQuest Arcana), scorePoints 2)] } , Quest { _questType = Arcana , _questTitle = "Explore Ahghairon's Tower" @@ -425,7 +425,7 @@ defaultQuestDeck = , _questReward = do scorePoints 6 , _questPlotActions = - [(Whenever (ActionProvides [Wizard]), drawIntrigue)] + [(Active, Whenever (ActionProvides Wizard), drawIntrigue)] } , Quest { _questType = Arcana , _questTitle = "Infiltrate Halaster's Circle" @@ -471,7 +471,7 @@ defaultQuestDeck = , _questReward = do scorePoints 6 , _questPlotActions = - [(Whenever BuysBuilding, scorePoints 4)] + [(Active, Whenever BuysBuilding, scorePoints 4)] } , Quest { _questType = Commerce , _questTitle = "Loot the Crypt of Chauntea" @@ -518,7 +518,7 @@ defaultQuestDeck = , _questReward = do scorePoints 10 , _questPlotActions = - [(Whenever (ActionProvides [Gold]), takeResources 1 [Rogue])] + [(Active, Whenever (ActionProvides Gold), takeResources 1 [Rogue])] } , Quest { _questType = Commerce , _questTitle = "Lure Artisans of Mirabar" @@ -545,7 +545,7 @@ defaultQuestDeck = , _questReward = do scorePoints 8 , _questPlotActions = - [(Whenever (CompletesQuest [Commerce]), scorePoints 2)] + [(Active, Whenever (CompletesQuest Commerce), scorePoints 2)] } , Quest { _questType = Commerce , _questTitle = "Send Aid to the Harpers" diff --git a/src/Waterdeep/Types.hs b/src/Waterdeep/Types.hs index f9ef475..c6a3858 100644 --- a/src/Waterdeep/Types.hs +++ b/src/Waterdeep/Types.hs @@ -4,8 +4,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} -module Waterdeep.Types +module Waterdeep.Types ( AccumulationType(..) , BonusType(..) , Building(..) @@ -18,6 +19,7 @@ module Waterdeep.Types , Lord(..) , PlayerID , PlayerState(..) + , PlotState(..) , PlotCondition(..) , PlotQualifier(..) , Quest(..) @@ -55,8 +57,7 @@ module Waterdeep.Types , playerTavern , playerIncompleteQuests , playerCompletedQuests - , playerActivePlotQuests - , playerUsedPlotQuests + , playerPlotQuests , playerIntrigueCards , playerAgentsInPool , playerHasLieutenant @@ -84,6 +85,9 @@ module Waterdeep.Types , gameBuildings , gameWaterdeepHarbor , gameStdGen + , plotActionState + , plotCondition + , plotAction , gamePlayerState , gamePlayerName , activePlayerState @@ -162,9 +166,9 @@ data Quest = { _questType :: QuestType , _questTitle :: String , _questQuote :: String - , _questCost :: MS.MultiSet Resource + , _questCost :: ResourceBag , _questReward :: GameAction - , _questPlotActions :: [(PlotCondition, GameAction)] + , _questPlotActions :: [(PlotState, PlotCondition, GameAction)] } data IntrigueCard = @@ -182,11 +186,10 @@ data PlayerState = , _playerFaction :: Faction , _playerLord :: Lord , _playerScore :: Int - , _playerTavern :: MS.MultiSet Resource + , _playerTavern :: ResourceBag , _playerIncompleteQuests :: [Quest] , _playerCompletedQuests :: [Quest] - , _playerActivePlotQuests :: [Quest] - , _playerUsedPlotQuests :: [Quest] + , _playerPlotQuests :: [Quest] , _playerIntrigueCards :: [IntrigueCard] , _playerAgentsInPool :: Int , _playerHasLieutenant :: Bool @@ -228,6 +231,9 @@ data WaterdeepState = data Resource = Cleric | Fighter | Rogue | Wizard | Gold deriving (Eq,Ord,Enum,Bounded,Show) +type ResourceSet = Set.Set Resource +type ResourceBag = MS.MultiSet Resource + data QuestType = Piety | Warfare | Skullduggery | Arcana | Commerce | Mandatory deriving (Eq,Ord,Enum,Bounded,Show) @@ -246,8 +252,10 @@ data AccumulationType = NoAccumulation | AccumulateResource Resource Int deriving (Eq,Show) -data PlotQualifier = ActionProvides [Resource] - | CompletesQuest [QuestType] +data PlotState = Active | Used deriving (Eq,Show) + +data PlotQualifier = ActionProvides Resource + | CompletesQuest QuestType | PlaysIntrigue | BuysBuilding deriving (Eq,Show) @@ -263,8 +271,6 @@ data WaterdeepPrompt a where Broadcast :: String -> WaterdeepPrompt () SolicitChoice :: PlayerID -> String -> [(String, a)] -> WaterdeepPrompt a -type ResourceSet = Set.Set Resource - data Waterdeep a = Waterdeep { unWaterdeep :: WriterT ResourceSet (StateT WaterdeepState @@ -320,7 +326,16 @@ instance MonadRandom Waterdeep where getRandomRs r = randomRs r <$> (gameStdGen %%= R.split) instance MonadSplit StdGen Waterdeep where - getSplit = gameStdGen %%= R.split + getSplit = gameStdGen %%= R.split + +plotActionState :: Lens' (PlotState, PlotCondition, GameAction) PlotState +plotActionState f (s,c,a) = fmap (,c,a) $ f s + +plotCondition :: Lens' (PlotState, PlotCondition, GameAction) PlotCondition +plotCondition f (s,c,a) = fmap (s,,a) $ f c + +plotAction :: Lens' (PlotState, PlotCondition, GameAction) GameAction +plotAction f (s,c,a) = fmap (s,c,) $ f a gamePlayerState :: PlayerID -> Lens' WaterdeepState PlayerState gamePlayerState n = lens @@ -363,8 +378,7 @@ newPlayerState i (name, faction, lord) = , _playerTavern = mempty , _playerIncompleteQuests = [] , _playerCompletedQuests = [] - , _playerActivePlotQuests = [] - , _playerUsedPlotQuests = [] + , _playerPlotQuests = [] , _playerIntrigueCards = [] , _playerAgentsInPool = 0 , _playerHasLieutenant = False diff --git a/src/Waterdeep/Util.hs b/src/Waterdeep/Util.hs index b8717d0..320f4c2 100644 --- a/src/Waterdeep/Util.hs +++ b/src/Waterdeep/Util.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes #-} -module Waterdeep.Util +module Waterdeep.Util ( deleteAt , on , nubOn @@ -10,13 +10,16 @@ module Waterdeep.Util , mif , joinStrings , (<$$>) + , updating ) where import Control.Applicative +import Control.Monad.State import Data.List import Data.Maybe import Data.Monoid import Lens.Family2 +import Lens.Family2.State deleteAt :: Int -> [a] -> [a] deleteAt n l = left ++ drop 1 right @@ -57,3 +60,6 @@ joinStrings (x:xs) = x ++ ", " ++ joinStrings xs (<$$>) :: Applicative f => (a -> b) -> f a -> f b (<$$>) = (<$>) infixr 0 <$$> + +updating :: (Functor m, MonadState a m) => LensLike m a a b b -> (b -> m b) -> m () +updating l f = put =<< l f =<< get diff --git a/waterdeep.cabal b/waterdeep.cabal index 289ff00..f48a459 100644 --- a/waterdeep.cabal +++ b/waterdeep.cabal @@ -23,7 +23,8 @@ executable waterdeep MultiWayIf, NoMonomorphismRestriction, RankNTypes, - TemplateHaskell + TemplateHaskell, + TupleSections build-depends: base >=4.6 && <4.7, MonadPrompt >=1.0 && <1.1, MonadRandom >=0.1 && <0.2,