diff --git a/src/Waterdeep/Actions.hs b/src/Waterdeep/Actions.hs index a120394..c3047ed 100644 --- a/src/Waterdeep/Actions.hs +++ b/src/Waterdeep/Actions.hs @@ -50,7 +50,7 @@ module Waterdeep.Actions import Control.Applicative import Control.Arrow ((&&&)) -import Control.Monad (when, unless, guard, join, replicateM, replicateM_) +import Control.Monad (when, unless, guard, join, replicateM, replicateM_, void) import Control.Monad.Random import Control.Monad.State (get) import Control.Monad.Trans.Writer @@ -211,7 +211,7 @@ completeQuest' quest = do then gameIntrigueDiscard <>= [mandatoryQuestCard quest] else if null (quest ^. questPlotActions) then activePlayerState . playerCompletedQuests <>= [quest] - else activePlayerState . playerPlotQuests <>= [quest] + else activePlayerState . playerPlotQuests . intAtNext .= Just quest doPlotAction (== CompletesQuest (quest^.questType)) discardUncompletedQuest :: GameAction @@ -243,9 +243,8 @@ buyBuilding = do p <- use gameActivePlayer name <- use activePlayerName returnResources (b ^. building . buildingCost) [Gold] - newKey <- (+1) . fst . IM.findMax <$> use gameBuildings let newState = b & buildingOwner .~ p & buildingAccumulation .~ 0 - gameBuildings %= IM.insert newKey newState + gameBuildings . intAtNext .= Just newState broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ "." scorePoints (b ^. buildingAccumulation) doPlotAction (== BuysBuilding) @@ -256,9 +255,8 @@ chooseFreeBuilding = do (i, b) <- chooseFromBuildersHall p <- use gameActivePlayer name <- use activePlayerName - newKey <- (+1) . fst . IM.findMax <$> use gameBuildings let newState = b & buildingOwner .~ p & buildingAccumulation .~ 0 - gameBuildings %= IM.insert newKey newState + gameBuildings . intAtNext .= Just newState broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ " for free." scorePoints (b ^. buildingAccumulation) restockBuildersHall @@ -267,8 +265,7 @@ drawFreeBuilding :: GameAction drawFreeBuilding = do Just b <- drawBuilding' p <- use gameActivePlayer - newKey <- (+1) . fst . IM.findMax <$> use gameBuildings - gameBuildings %= IM.insert newKey (newBuildingState p b) + gameBuildings . intAtNext .= Just (newBuildingState p b) name <- use $ activePlayerName broadcast $ name ++ " built the " ++ (b ^. buildingTitle) ++ " for free." @@ -579,17 +576,21 @@ forEachControlledBuilding m = do 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 +doPlotAction f = void $ delimitAction $ do + walkIntMap (activePlayerState . playerPlotQuests) $ \k l -> do + -- Assumption: Plot actions within the same card do not affect each other. + actions <- use $ l . singular _Just . questPlotActions + actions' <- forM actions $ \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 + l . singular _Just . questPlotActions .= actions' mandatoryQuestCard :: Quest -> IntrigueCard mandatoryQuestCard q = diff --git a/src/Waterdeep/Logic.hs b/src/Waterdeep/Logic.hs index d7c6c9d..bee952a 100644 --- a/src/Waterdeep/Logic.hs +++ b/src/Waterdeep/Logic.hs @@ -16,14 +16,14 @@ import Control.Monad.Random import Control.Monad.State hiding (forM_, mapM_) import Control.Monad.Trans.Writer import Data.List -import Data.Foldable (toList, foldMap, forM_, mapM_) +import Data.Foldable (toList, foldMap, forM_, mapM_, sequenceA_) import Data.Maybe import Data.Monoid -import Data.Traversable (traverse, for, forM, mapM) +import Data.Traversable (traverse, for, forM, mapM, sequenceA) import Lens.Family2 import Lens.Family2.State import Lens.Family2.Stock -import Prelude hiding (forM, mapM) +import Prelude hiding (forM, mapM, mapM_) import Text.Printf import Waterdeep.Actions import Waterdeep.Buildings (basicBuildings) @@ -149,10 +149,10 @@ beginRound round = do True -> activePlayerState . playerAgentsInPool += 1 >> return () False -> return () forM_ [1..np] $ \p -> withActivePlayer p $ do - updating (activePlayerState.playerPlotQuests.traverse.questPlotActions.traverse) $ \(s,c,a) -> do - case c of - StartOfRound -> a >> return (Used,c,a) - _ -> return (s,c,a) + actions <- activePlayerState.playerPlotQuests.traverse.questPlotActions.traverse %%= \case + (Active, StartOfRound, a) -> ([a], (Used, StartOfRound, a)) + x -> (mempty, x) + mapM_ filterChoices actions scoreFinalPoints :: Waterdeep () scoreFinalPoints = do @@ -166,10 +166,10 @@ scoreFinalPoints = do broadcast $ printf "%s scored %d points for having %d %ss." name pts n (show r) use (activePlayerState . playerLord . lordBonus) >>= \case QuestBonus types pts -> do - quests <- concat <$> sequence - [ use $ activePlayerState . playerCompletedQuests - , use $ activePlayerState . playerPlotQuests - ] + quests <- concat . sequenceA + [ view (activePlayerState . playerCompletedQuests) + , toListOf (activePlayerState . playerPlotQuests . traverse) + ] <$> get let matches = length . filter ((`elem` types) . (view questType)) $ quests activePlayerState . playerScore += matches * pts when (matches > 0) $ broadcast $ diff --git a/src/Waterdeep/Types.hs b/src/Waterdeep/Types.hs index c6a3858..20be86a 100644 --- a/src/Waterdeep/Types.hs +++ b/src/Waterdeep/Types.hs @@ -189,7 +189,7 @@ data PlayerState = , _playerTavern :: ResourceBag , _playerIncompleteQuests :: [Quest] , _playerCompletedQuests :: [Quest] - , _playerPlotQuests :: [Quest] + , _playerPlotQuests :: IM.IntMap Quest , _playerIntrigueCards :: [IntrigueCard] , _playerAgentsInPool :: Int , _playerHasLieutenant :: Bool @@ -376,10 +376,10 @@ newPlayerState i (name, faction, lord) = , _playerLord = lord , _playerScore = 0 , _playerTavern = mempty - , _playerIncompleteQuests = [] - , _playerCompletedQuests = [] - , _playerPlotQuests = [] - , _playerIntrigueCards = [] + , _playerIncompleteQuests = mempty + , _playerCompletedQuests = mempty + , _playerPlotQuests = mempty + , _playerIntrigueCards = mempty , _playerAgentsInPool = 0 , _playerHasLieutenant = False , _playerHasAmbassador = False diff --git a/src/Waterdeep/Util.hs b/src/Waterdeep/Util.hs index 320f4c2..a38e3e1 100644 --- a/src/Waterdeep/Util.hs +++ b/src/Waterdeep/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} module Waterdeep.Util @@ -10,24 +11,29 @@ module Waterdeep.Util , mif , joinStrings , (<$$>) - , updating + , whenM + , unlessM + , nextIntKey + , intAtNext + , walkIntMap ) where import Control.Applicative import Control.Monad.State import Data.List +import Data.Function import Data.Maybe import Data.Monoid import Lens.Family2 import Lens.Family2.State +import Lens.Family2.Stock + +import qualified Data.IntMap as IM deleteAt :: Int -> [a] -> [a] 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) - nubOn :: Eq b => (a -> b) -> [a] -> [a] nubOn f = nubBy ((==) `on` f) @@ -61,5 +67,25 @@ joinStrings (x:xs) = x ++ ", " ++ joinStrings xs (<$$>) = (<$>) 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 +-- Like when/unless, except that the condition is an action yielding a Bool +-- rather than a pure Bool. Avoids the need for spurious condition variables. +whenM, unlessM :: Monad m => m Bool -> m () -> m () +whenM mc ma = do { c <- mc; when c ma } +unlessM mc ma = do { c <- mc; unless c ma } + +-- Returns the next available key in an IntMap, starting from 1 if the map is empty. +nextIntKey :: IM.IntMap a -> IM.Key +nextIntKey im = if IM.null im then 1 else 1 + fst (IM.findMax im) + +-- This isn't really a lens since it doesn't refer to a constant location. +-- You don't get back what you put in, and setting twice has a different +-- effect than setting once. Nonetheless, I find it useful. It works like +-- intAt except that the (implied) key parameter always refers to the next +-- available key. +intAtNext :: Applicative f => (Maybe b -> f (Maybe b)) -> IM.IntMap b -> f (IM.IntMap b) +intAtNext f im = maybe im (flip (IM.insert (nextIntKey im)) im) <$> f Nothing + +walkIntMap :: MonadState a m => Lens' a (IM.IntMap b) + -> (IM.Key -> Lens' a (Maybe b) -> m r) -> m () +walkIntMap l f = use l >>= \im -> unless (IM.null im) $ go (fst $ IM.findMin im) where + go k = f k (l . intAt k) >> use l >>= maybe (return ()) (go . fst) . IM.lookupGT k