rework plot actions to avoid the buggy/racy "updating" combinator

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 . intAtNext .= Just (newBuildingState p b)
-   gameBuildings %= IM.insert newKey (newBuildingState p b)
    name <- use $ activePlayerName
    broadcast $ name ++ " built the " ++ (b ^. buildingTitle) ++ " for free."
 
@@ -579,8 +576,11 @@ forEachControlledBuilding m = do
       b `isControlledBy` p = b ^. buildingOwner == p
 
 doPlotAction :: (PlotQualifier -> Bool) -> Waterdeep ()
-doPlotAction f = do
+doPlotAction f = void $ delimitAction $ do
-   updating (activePlayerState.playerPlotQuests.traverse.questPlotActions.traverse) $ \case
+   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)
@@ -590,6 +590,7 @@ doPlotAction f = do
                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 =

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
+      actions <- activePlayerState.playerPlotQuests.traverse.questPlotActions.traverse %%= \case
-         case c of
+         (Active, StartOfRound, a) -> ([a], (Used, StartOfRound, a))
-            StartOfRound -> a >> return (Used,c,a)
+         x                         -> (mempty, x)
-            _            -> return (s,c,a)
+      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
+            quests <- concat . sequenceA
-               [ use $ activePlayerState . playerCompletedQuests
+               [ view     (activePlayerState . playerCompletedQuests)
-               , use $ activePlayerState . playerPlotQuests
+               , toListOf (activePlayerState . playerPlotQuests . traverse)
-               ]
+               ] <$> get
             let matches = length . filter ((`elem` types) . (view questType)) $ quests
             activePlayerState . playerScore += matches * pts
             when (matches > 0) $ broadcast $

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 = []
+      , _playerIncompleteQuests = mempty
-      , _playerCompletedQuests  = []
+      , _playerCompletedQuests  = mempty
-      , _playerPlotQuests       = []
+      , _playerPlotQuests       = mempty
-      , _playerIntrigueCards    = []
+      , _playerIntrigueCards    = mempty
       , _playerAgentsInPool     = 0
       , _playerHasLieutenant    = False
       , _playerHasAmbassador    = False

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 ()
+-- Like when/unless, except that the condition is an action yielding a Bool
-updating l f = put =<< l f =<< get
+-- 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