add a new prompt to send informational broadcasts to all players

src/Test.hs

@@ -1,5 +1,6 @@
-{-# LANGUAGE GADTs      #-}
+{-# LANGUAGE GADTs           #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes      #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 import Waterdeep.Types
 import Waterdeep.Monad
@@ -11,6 +12,7 @@ import Control.Monad
 import Control.Monad.Prompt
 import Control.Monad.Random
 import Control.Monad.State
+import Data.IORef
 import Data.List
 import Data.Monoid
 import Text.Printf
@@ -21,6 +23,13 @@ import System.Random.Shuffle
 import qualified Data.IntMap as IM
 import qualified Data.Map    as M
 
+data DisplayState =
+   DisplayState
+      { _gameState    :: WaterdeepState
+      , _gameMessages :: [String]
+      }
+makeLenses ''DisplayState
+
 f1 = Faction "Jesters" Blue
 l1 = Lord "Prince Henry XXX" "" (QuestBonus [Skullduggery, Commerce] 4)
 p1 = ("Harry", f1, l1)
@@ -99,10 +108,11 @@ printWaterdeep w = do
    clearScreen
    putStrLn ("Players: " ++ intercalate ", " (map (^. playerName) ps))
    putStrLn ("First Player: " ++
-      (w ^. gamePlayers . singular (ix (w ^. gameFirstPlayer)) . playerName))
+      (w ^. gamePlayer (w ^. gameFirstPlayer) . playerName))
    putStrLn ("Current Round: " ++ show (w ^. gameCurrentRound))
-   putStrLn ("Current Player: " ++
+   let p = w ^. gameCurrentPlayer
-      (w ^. gamePlayers . singular (ix (w ^. gameCurrentPlayer)) . playerName))
+   when (p /= noPlayerID) $
+      putStrLn ("Current Player: " ++ (w ^. gamePlayer p . playerName))
    putStrLn ""
    putStrLn "Cliffwatch Inn:"
    forM_ (w ^. gameCliffwatchInn) $ \q -> do
@@ -116,47 +126,59 @@ printWaterdeep w = do
              (b ^. buildingAccumulation)
    putStrLn ""
    forM_ ps $ \p -> do
-      putStrLn ((p ^. playerName) ++ "'s State:")
+      putStrLn ((p ^. playerName) ++ "'s State (" ++
+         show (p ^.  playerFaction . factionColor) ++ "):")
       putStrLn ("  Score:      " ++ show (p ^.  playerScore))
       putStrLn ("  Tavern:     " ++      (p ^.  playerTavern  . to showTavern))
-      putStrLn ("  Color:      " ++ show (p ^.  playerFaction . factionColor))
-      putStrLn ("  Lord:       " ++      (p ^.  playerLord    . lordName))
-      putStrLn ("  Faction:    " ++      (p ^.  playerFaction . factionName))
       putStrLn ("  Incomplete: " ++ show (p ^.. playerIncompleteQuests . traverse . questTitle))
       putStrLn ("  Complete:   " ++ show (p ^.. playerCompletedQuests  . traverse . questTitle))
       putStrLn ("  Intrigues:  " ++ show (p ^.. playerIntrigueCards    . traverse . intrigueTitle))
       putStrLn ("  Agent Pool: " ++ show (p ^.  playerAgentsInPool))
       putStrLn ""
 
-menuPrompt :: WaterdeepPrompt a -> IO a
+drawState :: IORef DisplayState -> IO ()
-menuPrompt prm@(NotifyState w) = printWaterdeep w
+drawState ref = do
-menuPrompt prm@(SolicitChoice w p t cs) = do
+   ds <- readIORef ref
+   printWaterdeep (ds ^. gameState)
+   forM_ (ds ^. gameMessages) putStrLn 
+   unless (null (ds ^. gameMessages)) $ putStrLn ""
+
+menuPrompt :: IORef DisplayState -> IO () -> WaterdeepPrompt a -> IO a
+menuPrompt ref redraw (NotifyState w) = do
+   modifyIORef ref (gameState .~ w)
+   redraw
+menuPrompt ref redraw (Broadcast s)   = do
+   modifyIORef ref (gameMessages %~ ((s:) . take 2))
+   redraw
+menuPrompt ref redraw prm@(SolicitChoice p t cs) = do
    let menuSize = length cs
    let menuLine n t = putStrLn (show n ++ ") " ++ t)
    let blankLine = putStrLn ""
+   w <- view gameState <$> readIORef ref
 
-   let redo = do
+   fix $ \doMenu -> do
-         printWaterdeep w
+      let redo = do
-         putStrLn ("ERROR: Expected a number between 1 and " ++ show menuSize ++ ".")
+            redraw
-         blankLine
+            putStrLn ("ERROR: Expected a number between 1 and " ++ show menuSize ++ ".")
-         menuPrompt prm
+            blankLine
+            doMenu
 
-   putStrLn t
+      putStrLn t
-   forM_ (zip [1..] cs) $ \(i, (c, _)) -> menuLine i c
+      forM_ (zip [1..] cs) $ \(i, (c, _)) -> menuLine i c
 
-   putStr (w ^. gamePlayer p . playerName)
+      putStr (w ^. gamePlayer p . playerName)
-   putStr "> " >> hFlush stdout
+      putStr "> " >> hFlush stdout
-   response <- getLine
+      response <- getLine
 
-   case reads response of
+      case reads response of
-      (ix,""):_ | ix >= 1 && ix <= menuSize ->
+         (ix,""):_ | ix >= 1 && ix <= menuSize ->
-         blankLine >> return (snd $ cs !! (ix-1))
+            blankLine >> return (snd $ cs !! (ix-1))
-      _ -> redo
+         _ -> redo
 
 main :: IO ()
 main = do
-   g <- getSplit
+   w0  <- newGame [p1, p2] [q1, q2] [] [b1, b2, b3, b4, b5] <$> getSplit
-   let w = newGame [p1, p2] [q1, q2] [] [b1, b2, b3, b4, b5] g
+   ref <- newIORef (DisplayState { _gameState = w0, _gameMessages = [] })
-   let gamePlayerName n = w ^. gamePlayer n . playerName
+   let gamePlayerName n = w0 ^. gamePlayer n . playerName
-   (winners, w') <- runWaterdeepM menuPrompt waterdeepGame w
+   (winners, w') <- runWaterdeepM (menuPrompt ref (drawState ref)) waterdeepGame w0
    putStrLn ("Winner(s): " ++ intercalate ", " (winners ^.. traverse . to gamePlayerName))

src/Waterdeep/Logic.hs

@@ -18,6 +18,7 @@ import Data.List
 import Data.Maybe
 import Data.Monoid
 import System.Random.Shuffle
+import Text.Printf
 import Waterdeep.Types
 import Waterdeep.Monad
 
@@ -115,7 +116,7 @@ waterdeepGame = do
             ReturnResource [Wizard]
          <> ReturnResource [Cleric, Fighter, Gold]
          <> ReturnResource [Cleric, Fighter]
-         <> ReturnResource [Cleric]
+         <> (ReturnResource [Cleric] `OrElse` TakeResource [Cleric])
       -- performAction 2 $ ChooseQuest
    scoreFinalPoints
    notifyState
@@ -151,73 +152,93 @@ data ContWD a where
 -- If result is False, state remains unchanged.
 filterChoices :: Waterdeep Bool -> Waterdeep Bool
 filterChoices m = do
-   mw' <- filteredChoice =<< (runWaterdeepC Done Cont m <$> get)
+   mw' <- filteredChoice [] =<< (runWaterdeepC Done Cont m <$> get)
    case mw' of
-      Just w' -> put w' >> return True
+      Just (ps,w') -> forM_ ps forwardPrompt >> put w' >> return True
-      Nothing -> return False
+      Nothing      -> return False
    where
       tryChoice :: ContWD Bool -> Bool
       tryChoice (Done a) = fst a
       tryChoice (Cont (NotifyState w) cont) = tryChoice $ cont ()
-      tryChoice (Cont (SolicitChoice w p t cs) cont) =
+      tryChoice (Cont (Broadcast s)   cont) = tryChoice $ cont ()
+      tryChoice (Cont (SolicitChoice p t cs) cont) =
          or $ map (tryChoice . cont . snd) cs
-      filteredChoice :: ContWD Bool -> Waterdeep (Maybe WaterdeepState)
+      filteredChoice :: [WaterdeepPrompt ()] -> ContWD Bool
-      filteredChoice (Done (a,w)) = if a then return (Just w) else return Nothing
+                     -> Waterdeep (Maybe ([WaterdeepPrompt ()], WaterdeepState))
-      filteredChoice (Cont (NotifyState w) cont) = filteredChoice $ cont ()
+      filteredChoice ps (Done (a,w)) = if a then return (Just (ps,w)) else return Nothing
-      filteredChoice (Cont (SolicitChoice w p t cs) cont) = do
+      filteredChoice ps (Cont p@(NotifyState w) cont) = filteredChoice (ps++[p]) $ cont ()
+      filteredChoice ps (Cont p@(Broadcast s)   cont) = filteredChoice (ps++[p]) $ cont ()
+      filteredChoice ps (Cont (SolicitChoice p t cs) cont) = do
          let cs' = filter (tryChoice . cont . snd) cs
          if null cs'
             then return Nothing
-            else filteredChoice =<< (cont <$> (put w >> solicitChoice p t cs'))
+            else do
+               forM_ ps forwardPrompt
+               filteredChoice [] =<< (cont <$> solicitChoice p t cs')
+      forwardPrompt :: WaterdeepPrompt () -> Waterdeep ()
+      forwardPrompt (NotifyState w) = get >>= \w0 -> put w >> notifyState >> put w0
+      forwardPrompt (Broadcast s)   = broadcast' s
 
 performAction :: PlayerID -> GameAction -> Waterdeep Bool
-performAction p a = case a of
+performAction p a = do
-   NoAction -> return True
+   name <- use $ gamePlayer p . playerName
-   ScorePoints n -> do
+   case a of
-      gamePlayer p . playerScore += n
+      NoAction -> return True
-      return True
+      ScorePoints n -> do
-   TakeResource rs -> do
+         gamePlayer p . playerScore += n
-      r <- solicitChoice p "Take one item:" $ map (show &&& id) rs
+         broadcast $ name ++ " scored " ++ show n ++ "points."
-      gamePlayer p . playerTavern %= flip (M.unionWith (+)) (M.fromList [(r, 1)])
+         return True
-      return True
+      TakeResource rs -> do
-   ReturnResource rs -> do
+         r <- solicitChoice p "Take one item:" $ map (show &&& id) rs
-      tavern <- use $ gamePlayer p . playerTavern
+         gamePlayer p . playerTavern %= flip (M.unionWith (+)) (M.fromList [(r, 1)])
-      let rs' = filter ((> 0) . maybe 0 id . flip M.lookup tavern) rs
+         broadcast $ name ++ " received one " ++ show r ++ "."
-      if null rs'
+         return True
-         then return False
+      ReturnResource rs -> do
-         else do
+         tavern <- use $ gamePlayer p . playerTavern
-            r <- solicitChoice p "Return one item:" $ map (show &&& id) rs'
+         let rs' = filter ((> 0) . maybe 0 id . flip M.lookup tavern) rs
-            let removeOne x = if x > 1 then Just (x-1) else Nothing
+         if null rs'
-            gamePlayer p . playerTavern %= M.update removeOne r
+            then return False
-            return True
+            else do
-   ChooseQuest -> do
+               r <- solicitChoice p "Return one item:" $ map (show &&& id) rs'
-      qs <- use gameCliffwatchInn
+               let removeOne x = if x > 1 then Just (x-1) else Nothing
-      if null qs
+               gamePlayer p . playerTavern %= M.update removeOne r
-         then return False
+               broadcast $ name ++ " returned one " ++ show r ++ " to the supply."
-         else do
+               return True
-            let names = qs ^.. traverse . questTitle
+      ChooseQuest -> do
-            q <- solicitChoice p "Please choose a quest:" $ zip names qs
+         qs <- use gameCliffwatchInn
-            gameCliffwatchInn %= (\\ [q])
+         if null qs
-            gamePlayer p . playerIncompleteQuests %= (++ [q])
+            then return False
-            restockCliffwatchInn
+            else do
-            return True
+               let names = qs ^.. traverse . questTitle
-   DrawQuest -> do
+               q <- solicitChoice p "Please choose a quest:" $ zip names qs
-      mq <- drawQuest
+               gameCliffwatchInn %= (\\ [q])
-      case mq of
+               gamePlayer p . playerIncompleteQuests %= (++ [q])
-         Nothing -> return False
+               broadcast $ name ++ " chose " ++ (q ^. questTitle) ++ " from Cliffwatch Inn."
-         Just q  -> do
+               restockCliffwatchInn
-            gamePlayer p . playerIncompleteQuests %= (++[q])
+               return True
-            return True
+      DrawQuest -> do
-   DrawIntrigue -> do
+         mq <- drawQuest
-      mi <- drawIntrigue
+         case mq of
-      case mi of
+            Nothing -> return False
-         Nothing -> return False
+            Just q  -> do
-         Just i  -> do
+               gamePlayer p . playerIncompleteQuests %= (++[q])
-            gamePlayer p . playerIntrigueCards %= (++[i])
+               broadcast $ name ++ " drew " ++ (q ^. questTitle) ++ " from the quest deck."
-            return True
+               return True
-   a1 `Then` a2 -> do
+      DrawIntrigue -> do
-      (&&) <$> performAction p a1 <*> performAction p a2
+         mi <- drawIntrigue
-   _ -> return False
+         case mi of
+            Nothing -> return False
+            Just i  -> do
+               gamePlayer p . playerIntrigueCards %= (++[i])
+               return True
+      a1 `Then` a2 -> do
+         (&&) <$> performAction p a1 <*> performAction p a2
+      a1 `OrElse` a2 -> do
+         r1 <- filterChoices (performAction p a1)
+         case r1 of
+            True -> return True
+            False -> performAction p a2
+      _ -> return False
 
 scoreFinalPoints :: Waterdeep ()
 scoreFinalPoints = do
@@ -227,14 +248,23 @@ scoreFinalPoints = do
       forM_ rs $ \(r, n) -> do
          let pts = case r of { Gold -> n `div` 2; _ -> n; }
          gamePlayer (p ^. playerNumber) . playerScore += pts
+         broadcast $ printf "%s scored %d points for having %d %ss."
+                            (p ^. playerName) pts n (show r)
       case p ^. playerLord . lordBonus of
          QuestBonus types pts -> do
             let (cqs, apqs, upqs) = (p ^. playerCompletedQuests, p ^. playerActivePlotQuests, p ^. playerUsedPlotQuests)
             let matches = length $ filter ((`elem` types) . (view questType)) (cqs ++ apqs ++ upqs)
             gamePlayer (p ^. playerNumber) . playerScore += matches * pts
+            when (matches > 0) $
+               broadcast $ printf "%s scored %d points for completing %d %s and/or %s quests."
+                                  (p ^. playerName) (matches * pts) matches
+                                  (show (types !! 0)) (show (types !! 1))
          BuildingBonus pts -> do
             ownedBuildings <- length <$> filter ((== (p ^. playerNumber)) . (view buildingOwner)) <$> use gameAdvancedBuildings
             gamePlayer (p ^. playerNumber) . playerScore += ownedBuildings * pts
+            when (ownedBuildings > 0) $
+               broadcast $ printf "%s scored %d points for controlling %d buildings."
+                                  (p ^. playerName) (ownedBuildings * pts) ownedBuildings
 
 determineWinners :: Waterdeep [PlayerID]
 determineWinners = do
@@ -279,6 +309,7 @@ restockCliffwatchInn = do
          Nothing -> return ()
          Just q  -> do
             gameCliffwatchInn %= (++ [q])
+            broadcast $ "Added " ++ (q ^. questTitle) ++ " to Cliffwatch Inn."
             restockCliffwatchInn
 
 restockBuildersHall :: Waterdeep ()
@@ -290,4 +321,5 @@ restockBuildersHall = do
          Nothing -> return ()
          Just b  -> do
             gameBuildersHall %= (++ [newBuildingState noPlayerID b])
+            broadcast $ "Added " ++ (b ^. buildingTitle) ++ " to Builder's Hall."
             restockBuildersHall

src/Waterdeep/Monad.hs

@@ -7,7 +7,10 @@ module Waterdeep.Monad
    ( WaterdeepPrompt(..)
    , Waterdeep
    , notifyState
+   , broadcast
+   , broadcast'
    , solicitChoice
+   , solicitChoice'
    , runWaterdeepC
    , runWaterdeep
    , runWaterdeepM
@@ -27,7 +30,8 @@ import System.Random as R
 
 data WaterdeepPrompt a where
    NotifyState   :: WaterdeepState -> WaterdeepPrompt ()
-   SolicitChoice :: WaterdeepState -> PlayerID -> String -> [(String, a)] -> WaterdeepPrompt a
+   Broadcast     :: String -> WaterdeepPrompt ()
+   SolicitChoice :: PlayerID -> String -> [(String, a)] -> WaterdeepPrompt a
 
 newtype Waterdeep a = Waterdeep { runWaterdeep' :: StateT WaterdeepState (Prompt WaterdeepPrompt) a }
 
@@ -57,13 +61,21 @@ instance MonadSplit StdGen Waterdeep where
 notifyState :: Waterdeep ()
 notifyState = get >>= Waterdeep . lift . prompt . NotifyState
 
+broadcast' :: String -> Waterdeep ()
+broadcast' s = Waterdeep (lift (prompt (Broadcast s)))
+
+broadcast :: String -> Waterdeep ()
+broadcast s = notifyState >> broadcast' s
+
+solicitChoice' :: PlayerID -> String -> [(String, a)] -> Waterdeep a
+solicitChoice' _ _ []  = error "There must be at least one option to choose."
+solicitChoice' _ _ [c] = return (snd c)  -- only one option, don't bother asking
+solicitChoice' p t cs  = Waterdeep (lift (prompt (SolicitChoice p t cs)))
+
 solicitChoice :: PlayerID -> String -> [(String, a)] -> Waterdeep a
 solicitChoice _ _ []  = error "There must be at least one option to choose."
 solicitChoice _ _ [c] = return (snd c)  -- only one option, don't bother asking
-solicitChoice p t cs  = do
+solicitChoice p t cs  = notifyState >> Waterdeep (lift (prompt (SolicitChoice p t cs)))
-   notifyState
-   w <- get
-   Waterdeep $ lift $ prompt (SolicitChoice w p t cs)
 
 runWaterdeepC :: ((r, WaterdeepState) -> b) -> (forall a. WaterdeepPrompt a -> (a -> b) -> b) -> Waterdeep r -> WaterdeepState -> b
 runWaterdeepC r p (Waterdeep m) s = runPromptC r p $ runStateT m s