implement remaining actions; still missing conditional plot actions

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 ()
+foldMapBuildings ::
-assignAgentToBuilding bt = do
+   (Monoid m) => (Bool -> Lens' WaterdeepState BuildingState -> m) -> WaterdeepState -> m
-   activePlayerState.playerAgentsInPool -= 1
+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]
+   owner <- use $ bl.buildingOwner
-   name  <- use $ activePlayerName
-   bName <- fromJust . firstOf (bt.building.buildingTitle) <$> get
-   broadcast $ name ++ " assigned an agent to " ++ bName ++ "."
-   owner <- fromJust . firstOf (bt.buildingOwner) <$> get
    when (owner `notElem` [noPlayerID, p]) $
-      withActivePlayer owner . fromJust . firstOf (bt.building.buildingOwnerAction) =<< get
+      withActivePlayer owner =<< use (bl.building.buildingOwnerAction)
-   fromJust . firstOf (bt.building.buildingAction) =<< get
+   join . use $ bl.building.buildingAction
 
-assignAgentToHarbor :: Traversal' WaterdeepState [PlayerID] -> Waterdeep ()
+assignAgentToBuilding :: PlayerID -> Lens' WaterdeepState BuildingState -> Waterdeep ()
-assignAgentToHarbor t = do
+assignAgentToBuilding agent bl = do
-   activePlayerState.playerAgentsInPool -= 1
+   when (agent /= noPlayerID) $
-   p <- use gameActivePlayer
+      gamePlayerState agent . playerAgentsInPool -= 1
-   t <>= [p]
+   bl.buildingAgents <>= [agent]
    name  <- use $ activePlayerName
-   broadcast $ name ++ " assigned an agent to Waterdeep Harbor."
+   bName <- use $ bl.building.buildingTitle
-   playIntrigue
+   broadcast $ name ++ " assigned an agent to " ++ bName ++ "."
+   useBuilding bl
 
-findAssignableBuildings :: WaterdeepState -> [(String, Waterdeep ())]
+assignAmbassador :: GameAction
-findAssignableBuildings w = execWriter $ do
+assignAmbassador = do
-   forM_ (w ^. gameBuildings . to IM.keys) $ \i -> do
+   w <- get
-      let t :: Traversal' WaterdeepState BuildingState
+   let p = w^.gameActivePlayer
-          t = gameBuildings . intAt i . traverse
+   let opponents = (w^..gamePlayerStates.traverse.playerNumber) \\ [p]
-      let b = fromJust $ firstOf t w
+   let includesOpponent = any (`elem` opponents)
-      tell [(b ^. building . buildingTitle, assignAgentToBuilding t)]
+   let usedOpSpace = (activePlayerState . playerCanUseOpSpace .= False)
-   let harbor = getFirst $ flip F.foldMap [1,2,3] $ \i -> First $
+   let canUseOpSpace = w ^. activePlayerState . playerCanUseOpSpace
-         let t :: Traversal' WaterdeepState [PlayerID]
+   let buildings = flip foldMapBuildings w $ \inHall bl ->
-             t = gameWaterdeepHarbor . intAt i . traverse
+         let agents = w^.bl.buildingAgents
-             agents = fromJust $ firstOf t w
+             title  = w^.bl.building.buildingTitle
-         in if null agents then Just (assignAgentToHarbor t) else Nothing
+         in if | canUseOpSpace && includesOpponent agents ->
-   case harbor of
+                  [(title, usedOpSpace >> assignAgentToBuilding noPlayerID bl)]
-      Just f  -> tell [("Waterdeep Harbor", f)]
+               | null agents && not inHall ->
-      Nothing -> return ()
+                  [(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
+   w <- get
-   join $ solicitChoice "Assign one agent to:" $ nubOn fst buildings
+   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
@@ -370,7 +452,8 @@ gainAmbassador :: GameAction
 gainAmbassador = do
    guard . not . or . toListOf (traverse . playerHasAmbassador) =<< use gamePlayerStates
    gameBuildings       . traverse . buildingAgents %= (\\ [noPlayerID])
-   gameWaterdeepHarbor . traverse %= (\\ [noPlayerID])
+   gameWaterdeepHarbor . traverse . buildingAgents %= (\\ [noPlayerID])
+   gameBuildersHall    . traverse . buildingAgents %= (\\ [noPlayerID])
    activePlayerState . playerHasAmbassador .= True
    name <- use $ activePlayerName
    broadcast $ name ++ " gained the Ambassador."

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

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)

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