add a new prompt to send informational broadcasts to all players
This commit is contained in:
parent
2810c0ea4b
commit
4a23b5f419
82
src/Test.hs
82
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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue