rework plot actions to avoid the buggy/racy "updating" combinator
This commit is contained in:
parent
e465141017
commit
9fcbb1cf77
|
|
@ -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,8 +576,11 @@ forEachControlledBuilding m = do
|
|||
b `isControlledBy` p = b ^. buildingOwner == p
|
||||
|
||||
doPlotAction :: (PlotQualifier -> Bool) -> Waterdeep ()
|
||||
doPlotAction f = do
|
||||
updating (activePlayerState.playerPlotQuests.traverse.questPlotActions.traverse) $ \case
|
||||
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)
|
||||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue