From 4a23b5f41963db8bf5c8103ead044df762e09d94 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sun, 13 Apr 2014 22:39:32 -0500 Subject: [PATCH] add a new prompt to send informational broadcasts to all players --- src/Test.hs | 82 ++++++++++++++--------- src/Waterdeep/Logic.hs | 146 +++++++++++++++++++++++++---------------- src/Waterdeep/Monad.hs | 22 +++++-- 3 files changed, 158 insertions(+), 92 deletions(-) diff --git a/src/Test.hs b/src/Test.hs index 129aa6f..df7f473 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# 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: " ++ - (w ^. gamePlayers . singular (ix (w ^. gameCurrentPlayer)) . playerName)) + let p = w ^. gameCurrentPlayer + 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 -menuPrompt prm@(NotifyState w) = printWaterdeep w -menuPrompt prm@(SolicitChoice w p t cs) = do +drawState :: IORef DisplayState -> IO () +drawState ref = 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 - printWaterdeep w - putStrLn ("ERROR: Expected a number between 1 and " ++ show menuSize ++ ".") - blankLine - menuPrompt prm + fix $ \doMenu -> do + let redo = do + redraw + putStrLn ("ERROR: Expected a number between 1 and " ++ show menuSize ++ ".") + blankLine + doMenu - putStrLn t - forM_ (zip [1..] cs) $ \(i, (c, _)) -> menuLine i c + putStrLn t + forM_ (zip [1..] cs) $ \(i, (c, _)) -> menuLine i c - putStr (w ^. gamePlayer p . playerName) - putStr "> " >> hFlush stdout - response <- getLine + putStr (w ^. gamePlayer p . playerName) + putStr "> " >> hFlush stdout + response <- getLine - case reads response of - (ix,""):_ | ix >= 1 && ix <= menuSize -> - blankLine >> return (snd $ cs !! (ix-1)) - _ -> redo + case reads response of + (ix,""):_ | ix >= 1 && ix <= menuSize -> + blankLine >> return (snd $ cs !! (ix-1)) + _ -> redo main :: IO () main = do - g <- getSplit - let w = newGame [p1, p2] [q1, q2] [] [b1, b2, b3, b4, b5] g - let gamePlayerName n = w ^. gamePlayer n . playerName - (winners, w') <- runWaterdeepM menuPrompt waterdeepGame w + w0 <- newGame [p1, p2] [q1, q2] [] [b1, b2, b3, b4, b5] <$> getSplit + ref <- newIORef (DisplayState { _gameState = w0, _gameMessages = [] }) + let gamePlayerName n = w0 ^. gamePlayer n . playerName + (winners, w') <- runWaterdeepM (menuPrompt ref (drawState ref)) waterdeepGame w0 putStrLn ("Winner(s): " ++ intercalate ", " (winners ^.. traverse . to gamePlayerName)) diff --git a/src/Waterdeep/Logic.hs b/src/Waterdeep/Logic.hs index 687fee0..a557d2c 100644 --- a/src/Waterdeep/Logic.hs +++ b/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 - Nothing -> return False + Just (ps,w') -> forM_ ps forwardPrompt >> put w' >> return True + 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 (Done (a,w)) = if a then return (Just w) else return Nothing - filteredChoice (Cont (NotifyState w) cont) = filteredChoice $ cont () - filteredChoice (Cont (SolicitChoice w p t cs) cont) = do + filteredChoice :: [WaterdeepPrompt ()] -> ContWD Bool + -> Waterdeep (Maybe ([WaterdeepPrompt ()], WaterdeepState)) + filteredChoice ps (Done (a,w)) = if a then return (Just (ps,w)) else return Nothing + 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 - NoAction -> return True - ScorePoints n -> do - gamePlayer p . playerScore += n - return True - TakeResource rs -> do - r <- solicitChoice p "Take one item:" $ map (show &&& id) rs - gamePlayer p . playerTavern %= flip (M.unionWith (+)) (M.fromList [(r, 1)]) - return True - ReturnResource rs -> do - tavern <- use $ gamePlayer p . playerTavern - let rs' = filter ((> 0) . maybe 0 id . flip M.lookup tavern) rs - if null rs' - then return False - else do - r <- solicitChoice p "Return one item:" $ map (show &&& id) rs' - let removeOne x = if x > 1 then Just (x-1) else Nothing - gamePlayer p . playerTavern %= M.update removeOne r - return True - ChooseQuest -> do - qs <- use gameCliffwatchInn - if null qs - then return False - else do - let names = qs ^.. traverse . questTitle - q <- solicitChoice p "Please choose a quest:" $ zip names qs - gameCliffwatchInn %= (\\ [q]) - gamePlayer p . playerIncompleteQuests %= (++ [q]) - restockCliffwatchInn - return True - DrawQuest -> do - mq <- drawQuest - case mq of - Nothing -> return False - Just q -> do - gamePlayer p . playerIncompleteQuests %= (++[q]) - return True - DrawIntrigue -> do - mi <- drawIntrigue - 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 - _ -> return False +performAction p a = do + name <- use $ gamePlayer p . playerName + case a of + NoAction -> return True + ScorePoints n -> do + gamePlayer p . playerScore += n + broadcast $ name ++ " scored " ++ show n ++ "points." + return True + TakeResource rs -> do + r <- solicitChoice p "Take one item:" $ map (show &&& id) rs + gamePlayer p . playerTavern %= flip (M.unionWith (+)) (M.fromList [(r, 1)]) + broadcast $ name ++ " received one " ++ show r ++ "." + return True + ReturnResource rs -> do + tavern <- use $ gamePlayer p . playerTavern + let rs' = filter ((> 0) . maybe 0 id . flip M.lookup tavern) rs + if null rs' + then return False + else do + r <- solicitChoice p "Return one item:" $ map (show &&& id) rs' + let removeOne x = if x > 1 then Just (x-1) else Nothing + gamePlayer p . playerTavern %= M.update removeOne r + broadcast $ name ++ " returned one " ++ show r ++ " to the supply." + return True + ChooseQuest -> do + qs <- use gameCliffwatchInn + if null qs + then return False + else do + let names = qs ^.. traverse . questTitle + q <- solicitChoice p "Please choose a quest:" $ zip names qs + gameCliffwatchInn %= (\\ [q]) + gamePlayer p . playerIncompleteQuests %= (++ [q]) + broadcast $ name ++ " chose " ++ (q ^. questTitle) ++ " from Cliffwatch Inn." + restockCliffwatchInn + return True + DrawQuest -> do + mq <- drawQuest + case mq of + Nothing -> return False + Just q -> do + gamePlayer p . playerIncompleteQuests %= (++[q]) + broadcast $ name ++ " drew " ++ (q ^. questTitle) ++ " from the quest deck." + return True + DrawIntrigue -> do + mi <- drawIntrigue + 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 diff --git a/src/Waterdeep/Monad.hs b/src/Waterdeep/Monad.hs index 36f0f0e..d4b08c7 100644 --- a/src/Waterdeep/Monad.hs +++ b/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 - notifyState - w <- get - Waterdeep $ lift $ prompt (SolicitChoice w p t cs) +solicitChoice p t cs = notifyState >> Waterdeep (lift (prompt (SolicitChoice 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