nybble
/
waterdeep
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

eliminate the explicit PlayerID parameter to the GameActions

This commit is contained in:
Jesse D. McDonald 2014-05-05 02:34:12 -05:00
parent e8b6f03be7
commit 01ab0b30db
4 changed files with 297 additions and 265 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
src/ConsoleUI.hs
View File

@ -44,24 +44,24 @@ p2 = ("Ned", f2, l2)
q1 = Quest { _questType = Arcana q1 = Quest { _questType = Arcana
, _questTitle = "Research Palantirs" , _questTitle = "Research Palantirs"
, _questQuote = "" , _questQuote = ""
, _questAction = \p -> do , _questAction = do
returnResources 1 [Cleric] p returnResources 1 [Cleric]
returnResources 1 [Rogue] p returnResources 1 [Rogue]
returnResources 1 [Rogue] p returnResources 1 [Rogue]
returnResources 1 [Wizard] p returnResources 1 [Wizard]
returnResources 4 [Gold] p returnResources 4 [Gold]
scorePoints 15 p scorePoints 15
takeResources 8 [Gold] p takeResources 8 [Gold]
, _questPlotActions = [] , _questPlotActions = []
} }
q2 = Quest { _questType = Skullduggery q2 = Quest { _questType = Skullduggery
, _questTitle = "Rob Waterdeep Bank" , _questTitle = "Rob Waterdeep Bank"
, _questQuote = "" , _questQuote = ""
, _questAction = \p -> do , _questAction = do
returnResources 8 [Rogue] p returnResources 8 [Rogue]
scorePoints 10 p scorePoints 10
takeResources 16 [Gold] p takeResources 16 [Gold]
, _questPlotActions = [] , _questPlotActions = []
} }
@ -102,17 +102,17 @@ b5 = Building { _buildingCost = 4
i1 = IntrigueCard { _intrigueTitle = "Graduation Day" i1 = IntrigueCard { _intrigueTitle = "Graduation Day"
, _intrigueType = Utility , _intrigueType = Utility
, _intrigueAction = \p -> do , _intrigueAction = do
takeResources 2 [Wizard] p takeResources 2 [Wizard]
forOneOpponent (takeResources 1 [Wizard]) p forOneOpponent (takeResources 1 [Wizard])
, _intrigueQuote = "" , _intrigueQuote = ""
} }
i2 = IntrigueCard { _intrigueTitle = "Call for Adventurers" i2 = IntrigueCard { _intrigueTitle = "Call for Adventurers"
, _intrigueType = Utility , _intrigueType = Utility
, _intrigueAction = \p -> do , _intrigueAction = do
takeResources 2 [Cleric, Fighter, Rogue, Wizard] p takeResources 2 [Cleric, Fighter, Rogue, Wizard]
forOneOpponent (takeResources 1 [Cleric, Fighter, Rogue, Wizard]) p forOneOpponent (takeResources 1 [Cleric, Fighter, Rogue, Wizard])
, _intrigueQuote = "" , _intrigueQuote = ""
} }
@ -129,11 +129,11 @@ printWaterdeep w = do
clearScreen clearScreen
putStrLn ("Players: " ++ intercalate ", " (map (^. playerName) playerStates)) putStrLn ("Players: " ++ intercalate ", " (map (^. playerName) playerStates))
putStrLn ("First Player: " ++ putStrLn ("First Player: " ++
(w ^. gamePlayer (w ^. gameFirstPlayer) . playerName)) (w ^. gamePlayerState (w ^. gameFirstPlayer) . playerName))
putStrLn ("Current Round: " ++ show (w ^. gameCurrentRound)) putStrLn ("Current Round: " ++ show (w ^. gameCurrentRound))
let p = w ^. gameCurrentPlayer let p = w ^. gameCurrentPlayer
when (p /= noPlayerID) $ when (p /= noPlayerID) $
putStrLn ("Current Player: " ++ (w ^. gamePlayer p . playerName)) putStrLn ("Current Player: " ++ (w ^. gamePlayerState p . playerName))
putStrLn "" putStrLn ""
putStrLn "Cliffwatch Inn:" putStrLn "Cliffwatch Inn:"
forM_ (w ^. gameCliffwatchInn) $ \q -> do forM_ (w ^. gameCliffwatchInn) $ \q -> do
@ -187,7 +187,7 @@ menuPrompt ref redraw prm@(SolicitChoice p t cs) = do
putStrLn t putStrLn t
printMenu $ zipWith (\i c -> show i ++ ") " ++ fst c) [1..] cs printMenu $ zipWith (\i c -> show i ++ ") " ++ fst c) [1..] cs
putStr (w ^. gamePlayer p . playerName) putStr (w ^. gamePlayerState p . playerName)
putStr "> " >> hFlush stdout putStr "> " >> hFlush stdout
response <- getLine response <- getLine
--response <- show <$> getRandomR (1, menuSize) --response <- show <$> getRandomR (1, menuSize)
@ -217,6 +217,6 @@ main :: IO ()
main = do main = do
w0 <- newGame [p1, p2] (mrepeat 4 [q1, q2]) (mrepeat 4 [i1, i2]) [b1, b2, b3, b4, b5] <$> getSplit w0 <- newGame [p1, p2] (mrepeat 4 [q1, q2]) (mrepeat 4 [i1, i2]) [b1, b2, b3, b4, b5] <$> getSplit
ref <- newIORef (DisplayState { _gameState = w0, _gameMessages = [] }) ref <- newIORef (DisplayState { _gameState = w0, _gameMessages = [] })
let gamePlayerName n = w0 ^. gamePlayer n . playerName
Just (winners, w') <- runWaterdeepM (menuPrompt ref (drawState ref)) waterdeepGame w0 Just (winners, w') <- runWaterdeepM (menuPrompt ref (drawState ref)) waterdeepGame w0
putStrLn ("Winner(s): " ++ intercalate ", " (winners ^.. traverse . to gamePlayerName)) let playerIDToName n = w0 ^. gamePlayerName n
putStrLn ("Winner(s): " ++ intercalate ", " (winners ^.. traverse . to playerIDToName))

319
src/Waterdeep/Actions.hs
View File

@ -40,8 +40,6 @@ module Waterdeep.Actions
, getOpponents , getOpponents
, getNumberOfBuildings , getNumberOfBuildings
, getNumberOfControlledBuildings , getNumberOfControlledBuildings
, filterChoices
, canPerformAction
) where ) where
import Control.Applicative import Control.Applicative
@ -63,72 +61,72 @@ import qualified Data.IntMap as IM
import qualified Data.Map as M import qualified Data.Map as M
noAction :: GameAction noAction :: GameAction
noAction _ = return () noAction = return ()
scorePoints :: Int -> GameAction scorePoints :: Int -> GameAction
scorePoints n p = do scorePoints n = do
gamePlayer p . playerScore += n activePlayerState . playerScore += n
name <- use $ gamePlayerName p name <- use activePlayerName
broadcast $ printf "%s scored %d points." name n broadcast $ printf "%s scored %d points." name n
takeResources :: Int -> [Resource] -> GameAction takeResources :: Int -> [Resource] -> GameAction
takeResources n rs p = do takeResources n rs = do
received <- map (head &&& length) . group . sort <$$> replicateM n $ do received <- map (head &&& length) . group . sort <$$> replicateM n $ do
r <- solicitChoice p "Take one item:" $ map (show &&& id) rs r <- solicitChoice "Take one item:" $ map (show &&& id) rs
gamePlayer p . playerTavern %= M.insertWith' (+) r 1 activePlayerState . playerTavern %= M.insertWith' (+) r 1
return r return r
let items = joinStrings $ map (\(r,n) -> show n ++ " " ++ show r) received let items = joinStrings $ map (\(r,n) -> show n ++ " " ++ show r) received
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ printf "%s received %s." name items broadcast $ printf "%s received %s." name items
returnResources :: Int -> [Resource] -> GameAction returnResources :: Int -> [Resource] -> GameAction
returnResources n rs p = do returnResources n rs = do
returned <- replicateM n $ do returned <- replicateM n $ do
tavern <- use $ gamePlayer p . playerTavern tavern <- use $ activePlayerState . playerTavern
let rs' = filter ((>= 1) . maybe 0 id . flip M.lookup tavern) rs let rs' = filter ((>= 1) . maybe 0 id . flip M.lookup tavern) rs
r <- solicitChoice p "Return one item:" $ map (show &&& id) rs' r <- solicitChoice "Return one item:" $ map (show &&& id) rs'
let removeOne x = if x > 1 then Just (x-1) else Nothing let removeOne x = if x > 1 then Just (x-1) else Nothing
gamePlayer p . playerTavern %= M.update removeOne r activePlayerState . playerTavern %= M.update removeOne r
return r return r
let groups = map (head &&& length) $ group returned let groups = map (head &&& length) $ group returned
let items = joinStrings $ map (\(r,n) -> show n ++ " " ++ show r) groups let items = joinStrings $ map (\(r,n) -> show n ++ " " ++ show r) groups
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " returned " ++ items ++ " to the supply." broadcast $ name ++ " returned " ++ items ++ " to the supply."
chooseQuest' :: PlayerID -> Waterdeep Quest chooseQuest' :: Waterdeep Quest
chooseQuest' p = do chooseQuest' = do
choices <- zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] <$> use gameCliffwatchInn choices <- zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] <$> use gameCliffwatchInn
(i, quest) <- solicitChoice p "Choose one quest:" $ nubOn fst choices (i, quest) <- solicitChoice "Choose one quest:" $ nubOn fst choices
gameCliffwatchInn %= deleteAt i gameCliffwatchInn %= deleteAt i
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " chose " ++ (quest ^. questTitle) ++ " from Cliffwatch Inn." broadcast $ name ++ " chose " ++ (quest ^. questTitle) ++ " from Cliffwatch Inn."
restockCliffwatchInn restockCliffwatchInn
return quest return quest
chooseQuest :: GameAction chooseQuest :: GameAction
chooseQuest p = do chooseQuest = do
quest <- chooseQuest' p quest <- chooseQuest'
gamePlayer p . playerIncompleteQuests <>= [quest] activePlayerState . playerIncompleteQuests <>= [quest]
return () return ()
replaceQuests :: GameAction replaceQuests :: GameAction
replaceQuests _ = do replaceQuests = do
quests <- gameCliffwatchInn <<.= [] quests <- gameCliffwatchInn <<.= []
gameQuestDiscard <>= quests gameQuestDiscard <>= quests
restockCliffwatchInn restockCliffwatchInn
drawQuest :: GameAction drawQuest :: GameAction
drawQuest p = do drawQuest = do
Just q <- drawQuest' Just q <- drawQuest'
name <- use $ gamePlayerName p name <- use $ activePlayerName
gamePlayer p . playerIncompleteQuests <>= [q] activePlayerState . playerIncompleteQuests <>= [q]
broadcast $ printf "%s drew %s from the quest deck." name (q ^. questTitle) broadcast $ printf "%s drew %s from the quest deck." name (q ^. questTitle)
drawNamedQuestType :: GameAction drawNamedQuestType :: GameAction
drawNamedQuestType p = do drawNamedQuestType = do
let qtypes = [Piety, Warfare, Skullduggery, Arcana, Commerce] let qtypes = [Piety, Warfare, Skullduggery, Arcana, Commerce]
qtype <- solicitChoice p "Choose a quest type:" $ map (show &&& id) qtypes qtype <- solicitChoice "Choose a quest type:" $ map (show &&& id) qtypes
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " chose the " ++ (show qtype) ++ " quest type." broadcast $ name ++ " chose the " ++ (show qtype) ++ " quest type."
flip fix [] $ \loop discards -> do flip fix [] $ \loop discards -> do
mq <- drawQuest' mq <- drawQuest'
@ -144,165 +142,170 @@ drawNamedQuestType p = do
then loop (q : discards) then loop (q : discards)
else do else do
gameQuestDiscard <>= discards gameQuestDiscard <>= discards
gamePlayer p . playerIncompleteQuests <>= [q] activePlayerState . playerIncompleteQuests <>= [q]
return () return ()
distributeQuests :: GameAction distributeQuests :: GameAction
distributeQuests p = do distributeQuests = do
np <- use gameNumberOfPlayers let distribute remQuests = unless (null remQuests) $ do
let loop p' remQuests = unless (null remQuests) $ do
let choices = zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] remQuests let choices = zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] remQuests
(i, quest) <- solicitChoice p' "Choose a quest:" $ nubOn fst choices (i, quest) <- solicitChoice "Choose a quest:" $ nubOn fst choices
gamePlayer p' . playerIncompleteQuests <>= [quest] activePlayerState . playerIncompleteQuests <>= [quest]
name <- use $ gamePlayerName p' name <- use $ activePlayerName
broadcast $ printf "%s chose the %s quest." name (quest ^. questTitle) broadcast $ printf "%s chose the %s quest." name (quest ^. questTitle)
flip loop (deleteAt i remQuests) =<< getNextPlayer p' p' <- getNextPlayer =<< use gameActivePlayer
loop p =<< return . catMaybes =<< replicateM np drawQuest' withActivePlayer p' $ distribute (deleteAt i remQuests)
distribute =<< catMaybes <$> (flip replicateM drawQuest' =<< use gameNumberOfPlayers)
completeQuest :: GameAction completeQuest :: GameAction
completeQuest p = do completeQuest = do
quests <- zip [0..] <$> use (gamePlayer p . playerIncompleteQuests) quests <- zip [0..] <$> use (activePlayerState . playerIncompleteQuests)
let mandatoryQuests = filter ((== Mandatory) . view questType . snd) quests let mandatoryQuests = filter ((== Mandatory) . view questType . snd) quests
let availQuests = if null mandatoryQuests then quests else mandatoryQuests let availQuests = if null mandatoryQuests then quests else mandatoryQuests
let choices = map (\(i,q) -> (q ^. questTitle, (i, q))) availQuests let choices = map (\(i,q) -> (q ^. questTitle, (i, q))) availQuests
(i, quest) <- solicitChoice p "Complete one quest:" $ nubOn fst choices (i, quest) <- solicitChoice "Complete one quest:" $ nubOn fst choices
gamePlayer p . playerIncompleteQuests %= deleteAt i activePlayerState . playerIncompleteQuests %= deleteAt i
(quest ^. questAction) p quest ^. questAction
if null (quest ^. questPlotActions) if null (quest ^. questPlotActions)
then gamePlayer p . playerCompletedQuests <>= [quest] then activePlayerState . playerCompletedQuests <>= [quest]
else gamePlayer p . playerActivePlotQuests <>= [quest] else activePlayerState . playerActivePlotQuests <>= [quest]
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest." broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest."
chooseAndCompleteQuest :: GameAction -> GameAction chooseAndCompleteQuest :: GameAction -> GameAction
chooseAndCompleteQuest bonusAction p = do chooseAndCompleteQuest bonusAction = do
quest <- chooseQuest' p quest <- chooseQuest'
doQuest <- solicitChoice p "Complete this quest immediately?" doQuest <- solicitChoice "Complete this quest immediately?"
[("Yes", True), ("No", False)] [("Yes", True), ("No", False)]
case doQuest of case doQuest of
True -> do True -> do
incompleteQuests <- use (gamePlayer p . playerIncompleteQuests) incompleteQuests <- use (activePlayerState . playerIncompleteQuests)
guard . not . or $ map ((== Mandatory) . view questType) incompleteQuests guard . not . or $ map ((== Mandatory) . view questType) incompleteQuests
(quest ^. questAction) p quest ^. questAction
if null (quest ^. questPlotActions) if null (quest ^. questPlotActions)
then gamePlayer p . playerCompletedQuests <>= [quest] then activePlayerState . playerCompletedQuests <>= [quest]
else gamePlayer p . playerActivePlotQuests <>= [quest] else activePlayerState . playerActivePlotQuests <>= [quest]
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest." broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest."
bonusAction p bonusAction
False -> do False -> do
gamePlayer p . playerIncompleteQuests <>= [quest] activePlayerState . playerIncompleteQuests <>= [quest]
return () return ()
discardUncompletedQuest :: GameAction discardUncompletedQuest :: GameAction
discardUncompletedQuest p = do discardUncompletedQuest = do
choices <- zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] <$> choices <- zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] <$>
use (gamePlayer p . playerIncompleteQuests) use (activePlayerState . playerIncompleteQuests)
(i, quest) <- solicitChoice p "Choose a quest to discard:" $ nubOn fst choices (i, quest) <- solicitChoice "Choose a quest to discard:" $ nubOn fst choices
gamePlayer p . playerIncompleteQuests %= deleteAt i activePlayerState . playerIncompleteQuests %= deleteAt i
gameQuestDiscard <>= [quest] gameQuestDiscard <>= [quest]
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " discarded the " ++ (quest ^. questTitle) ++ " quest." broadcast $ name ++ " discarded the " ++ (quest ^. questTitle) ++ " quest."
buyBuilding :: GameAction buyBuilding :: GameAction
buyBuilding p = do buyBuilding = do
let label b = printf "%s (%d Gold, %d Points)" let label b = printf "%s (%d Gold, %d Points)"
(b ^. building . buildingTitle) (b ^. building . buildingTitle)
(b ^. building . buildingCost) (b ^. building . buildingCost)
(b ^. buildingAccumulation) (b ^. buildingAccumulation)
choices <- zipWith (\i b -> (label b, (i, b))) [0..] <$> use gameBuildersHall choices <- zipWith (\i b -> (label b, (i, b))) [0..] <$> use gameBuildersHall
(i, b) <- solicitChoice p "Choose a building from Builder's Hall:" $ nubOn fst choices (i, b) <- solicitChoice "Choose a building from Builder's Hall:" $ nubOn fst choices
let cost = b ^. building . buildingCost let cost = b ^. building . buildingCost
returnResources cost [Gold] p returnResources cost [Gold]
scorePoints (b ^. buildingAccumulation) p scorePoints (b ^. buildingAccumulation)
gameBuildersHall %= deleteAt i gameBuildersHall %= deleteAt i
p <- use gameActivePlayer
gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0] gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0]
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ "." broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ "."
restockBuildersHall restockBuildersHall
chooseFreeBuilding :: GameAction chooseFreeBuilding :: GameAction
chooseFreeBuilding p = do chooseFreeBuilding = do
let label b = printf "%s (%d Points)" let label b = printf "%s (%d Points)"
(b ^. building . buildingTitle) (b ^. building . buildingTitle)
(b ^. buildingAccumulation) (b ^. buildingAccumulation)
choices <- zipWith (\i b -> (label b, (i, b))) [0..] <$> use gameBuildersHall choices <- zipWith (\i b -> (label b, (i, b))) [0..] <$> use gameBuildersHall
(i, b) <- solicitChoice p "Choose a building from Builder's Hall:" $ nubOn fst choices (i, b) <- solicitChoice "Choose a building from Builder's Hall:" $ nubOn fst choices
scorePoints (b ^. buildingAccumulation) p scorePoints (b ^. buildingAccumulation)
gameBuildersHall %= deleteAt i gameBuildersHall %= deleteAt i
p <- use gameActivePlayer
gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0] gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0]
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ " for free." broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ " for free."
restockBuildersHall restockBuildersHall
drawFreeBuilding :: GameAction drawFreeBuilding :: GameAction
drawFreeBuilding p = do drawFreeBuilding = do
Just b <- drawBuilding' Just b <- drawBuilding'
p <- use gameActivePlayer
gameBuildings <>= [newBuildingState p b] gameBuildings <>= [newBuildingState p b]
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " built the " ++ (b ^. buildingTitle) ++ " for free." broadcast $ name ++ " built the " ++ (b ^. buildingTitle) ++ " for free."
discardUnoccupiedBuilding :: GameAction discardUnoccupiedBuilding :: GameAction
discardUnoccupiedBuilding p = do discardUnoccupiedBuilding = do
allBuildings <- zip [0..] <$> use gameBuildings allBuildings <- zip [0..] <$> use gameBuildings
p <- use gameActivePlayer
let ownedBuildings = filter ((== p) . view buildingOwner . snd) allBuildings let ownedBuildings = filter ((== p) . view buildingOwner . snd) allBuildings
let emptyBuildings = filter (null . view buildingAgents . snd) ownedBuildings let emptyBuildings = filter (null . view buildingAgents . snd) ownedBuildings
let choices = map (\(i,b) -> (b ^. building . buildingTitle, (i, b))) emptyBuildings let choices = map (\(i,b) -> (b ^. building . buildingTitle, (i, b))) emptyBuildings
(i, b) <- solicitChoice p "Choose a building to discard:" $ nubOn fst choices (i, b) <- solicitChoice "Choose a building to discard:" $ nubOn fst choices
gameBuildings %= deleteAt i gameBuildings %= deleteAt i
gameBuildingDiscard <>= [b ^. building] gameBuildingDiscard <>= [b ^. building]
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " discarded the " ++ (b ^. building . buildingTitle) ++ "." broadcast $ name ++ " discarded the " ++ (b ^. building . buildingTitle) ++ "."
drawIntrigue :: GameAction drawIntrigue :: GameAction
drawIntrigue p = do drawIntrigue = do
Just ic <- drawIntrigue' Just ic <- drawIntrigue'
gamePlayer p . playerIntrigueCards <>= [ic] activePlayerState . playerIntrigueCards <>= [ic]
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " drew an Intrigue card." broadcast $ name ++ " drew an Intrigue card."
playIntrigue :: GameAction playIntrigue :: GameAction
playIntrigue p = do playIntrigue = do
choices <- zipWith (\i ic -> (ic ^. intrigueTitle, (i, ic))) [0..] <$> choices <- zipWith (\i ic -> (ic ^. intrigueTitle, (i, ic))) [0..] <$>
use (gamePlayer p . playerIntrigueCards) use (activePlayerState . playerIntrigueCards)
(i, intrigue) <- solicitChoice p "Play one intrigue card:" $ nubOn fst choices (i, intrigue) <- solicitChoice "Play one intrigue card:" $ nubOn fst choices
gamePlayer p . playerIntrigueCards %= deleteAt i activePlayerState . playerIntrigueCards %= deleteAt i
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " played the " ++ (intrigue ^. intrigueTitle) ++ " Intrigue card." broadcast $ name ++ " played the " ++ (intrigue ^. intrigueTitle) ++ " Intrigue card."
(intrigue ^. intrigueAction) p intrigue ^. intrigueAction
gameIntrigueDiscard <>= [intrigue] gameIntrigueDiscard <>= [intrigue]
return () return ()
returnAgent :: GameAction returnAgent :: GameAction
returnAgent p = return () -- TODO returnAgent = return () -- TODO
returnAgentFromHarbor :: GameAction returnAgentFromHarbor :: GameAction
returnAgentFromHarbor p = return () -- TODO returnAgentFromHarbor = return () -- TODO
assignAgentToBuilding :: Lens' WaterdeepState BuildingState -> PlayerID -> Waterdeep () assignAgentToBuilding :: Lens' WaterdeepState BuildingState -> Waterdeep ()
assignAgentToBuilding bl p = do assignAgentToBuilding bl = do
gamePlayer p . playerAgentsInPool -= 1 activePlayerState . playerAgentsInPool -= 1
p <- use gameActivePlayer
bl . buildingAgents <>= [p] bl . buildingAgents <>= [p]
name <- use $ gamePlayerName p name <- use $ activePlayerName
bName <- use (bl . building . buildingTitle) bName <- use (bl . building . buildingTitle)
broadcast $ name ++ " assigned an agent to " ++ bName ++ "." broadcast $ name ++ " assigned an agent to " ++ bName ++ "."
owner <- use (bl . buildingOwner) owner <- use (bl . buildingOwner)
when (owner `notElem` [noPlayerID, p]) $ when (owner `notElem` [noPlayerID, p]) $
void . ($ owner) =<< use (bl . building . buildingOwnerAction) withActivePlayer owner =<< use (bl . building . buildingOwnerAction)
($ p) =<< use (bl . building . buildingAction) join $ use (bl . building . buildingAction)
assignAgentToHarbor :: Lens' ([PlayerID], [PlayerID], [PlayerID]) [PlayerID] assignAgentToHarbor :: Lens' ([PlayerID], [PlayerID], [PlayerID]) [PlayerID] -> Waterdeep ()
-> PlayerID -> Waterdeep () assignAgentToHarbor l = do
assignAgentToHarbor l p = do activePlayerState . playerAgentsInPool -= 1
gamePlayer p . playerAgentsInPool -= 1 p <- use gameActivePlayer
gameWaterdeepHarbor . l <>= [p] gameWaterdeepHarbor . l <>= [p]
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " assigned an agent to Waterdeep Harbor." broadcast $ name ++ " assigned an agent to Waterdeep Harbor."
playIntrigue p playIntrigue
assignAgent :: GameAction assignAgent :: GameAction
assignAgent p = do assignAgent = do
agents <- use (gamePlayer p . playerAgentsInPool) agents <- use (activePlayerState . playerAgentsInPool)
guard (agents > 0) guard (agents > 0)
w <- get w <- get
let buildings = execWriter $ do let buildings = execWriter $ do
@ -310,69 +313,73 @@ assignAgent p = do
let l :: Lens' WaterdeepState BuildingState let l :: Lens' WaterdeepState BuildingState
l = gameBuildings . singular (ix i) l = gameBuildings . singular (ix i)
when (null (w ^. l . buildingAgents)) $ do when (null (w ^. l . buildingAgents)) $ do
tell [(w ^. l . building . buildingTitle, assignAgentToBuilding l p)] tell [(w ^. l . building . buildingTitle, assignAgentToBuilding l)]
case w ^. gameWaterdeepHarbor of case w ^. gameWaterdeepHarbor of
([], _, _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _1 p)] ([], _, _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _1)]
(_, [], _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _2 p)] (_, [], _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _2)]
(_, _, []) -> tell [("Waterdeep Harbor", assignAgentToHarbor _3 p)] (_, _, []) -> tell [("Waterdeep Harbor", assignAgentToHarbor _3)]
_ -> return () _ -> return ()
join $ solicitChoice p "Assign one agent to:" $ nubOn fst buildings join $ solicitChoice "Assign one agent to:" $ nubOn fst buildings
assignAgentToBuildersHall :: GameAction assignAgentToBuildersHall :: GameAction
assignAgentToBuildersHall p = return () -- TODO assignAgentToBuildersHall = return () -- TODO
assignAgentToOpponentsSpace :: GameAction assignAgentToOpponentsSpace :: GameAction
assignAgentToOpponentsSpace p = return () -- TODO assignAgentToOpponentsSpace = return () -- TODO
useOpponentsSpace :: GameAction useOpponentsSpace :: GameAction
useOpponentsSpace p = return () -- TODO useOpponentsSpace = return () -- TODO
gainLieutenant :: GameAction gainLieutenant :: GameAction
gainLieutenant p = do gainLieutenant = do
gamePlayer p . playerHasLieutenant .= True activePlayerState . playerHasLieutenant .= True
gamePlayer p . playerAgentsInPool += 1 activePlayerState . playerAgentsInPool += 1
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " gained the Lieutenant." broadcast $ name ++ " gained the Lieutenant."
return () return ()
gainAmbassador :: GameAction gainAmbassador :: GameAction
gainAmbassador p = do gainAmbassador = do
guard . not . or . toListOf (traverse . playerHasAmbassador) =<< use gamePlayerStates guard . not . or . toListOf (traverse . playerHasAmbassador) =<< use gamePlayerStates
gameBuildings . each . buildingAgents %= (\\ [noPlayerID]) gameBuildings . each . buildingAgents %= (\\ [noPlayerID])
gameWaterdeepHarbor . each %= (\\ [noPlayerID]) gameWaterdeepHarbor . each %= (\\ [noPlayerID])
gamePlayer p . playerHasAmbassador .= True activePlayerState . playerHasAmbassador .= True
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " gained the Ambassador." broadcast $ name ++ " gained the Ambassador."
assignMandatoryQuest :: Quest -> GameAction assignMandatoryQuest :: Quest -> GameAction
assignMandatoryQuest quest p = do assignMandatoryQuest quest = do
name <- use $ gamePlayerName p name <- use $ activePlayerName
opponents <- getOpponents p opponents <- getOpponents
let choices = map (view playerName &&& (view playerNumber &&& view playerName)) opponents let choices = map (view playerName &&& (view playerNumber &&& view playerName)) opponents
(opID, opName) <- solicitChoice p "Choose one opponent:" choices (opID, opName) <- solicitChoice "Choose one opponent:" choices
gamePlayer opID . playerIncompleteQuests <>= [quest] gamePlayerState opID . playerIncompleteQuests <>= [quest]
broadcast $ name ++ " assigned " ++ opName ++ " a mandatory quest." broadcast $ name ++ " assigned " ++ opName ++ " a mandatory quest."
becomeFirstPlayer :: GameAction becomeFirstPlayer :: GameAction
becomeFirstPlayer p = do becomeFirstPlayer = do
gameFirstPlayer .= p gameFirstPlayer <~ use gameActivePlayer
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " is now the first player." broadcast $ name ++ " is now the first player."
forOneOpponent :: GameAction -> GameAction forOneOpponent :: GameAction -> GameAction
forOneOpponent a1 p = do forOneOpponent a1 = do
opponents <- getOpponents p opponents <- getOpponents
let choices = map (view playerName &&& (view playerNumber &&& view playerName)) opponents let choices = map (view playerName &&& (view playerNumber &&& view playerName)) opponents
(opID, opName) <- solicitChoice p "Choose one opponent:" choices (opID, opName) <- solicitChoice "Choose one opponent:" choices
name <- use $ gamePlayerName p name <- use $ activePlayerName
broadcast $ name ++ " chose " ++ opName ++ "." broadcast $ name ++ " chose " ++ opName ++ "."
a1 opID withActivePlayer opID a1
forEachOpponent :: GameAction -> GameAction forEachOpponent :: GameAction -> GameAction
forEachOpponent a1 p = mapM_ (\op -> a1 (op ^. playerNumber)) =<< getOpponents p forEachOpponent a1 = do
opponents <- getOpponents
forM_ opponents $ \op -> withActivePlayer (op ^. playerNumber) a1
forCurrentPlayer :: GameAction -> GameAction forCurrentPlayer :: GameAction -> GameAction
forCurrentPlayer a1 _ = a1 =<< use gameCurrentPlayer forCurrentPlayer a1 = do
p <- use gameCurrentPlayer
withActivePlayer p a1
-- Like (<$>), but with the same fixity and precedence as ($) -- Like (<$>), but with the same fixity and precedence as ($)
(<$$>) :: Applicative f => (a -> b) -> f a -> f b (<$$>) :: Applicative f => (a -> b) -> f a -> f b
@ -437,56 +444,16 @@ restockBuildersHall = do
restockBuildersHall restockBuildersHall
getOpponents :: PlayerID -> Waterdeep [PlayerState] getOpponents :: Waterdeep [PlayerState]
getOpponents p = getOpponents = do
p <- use gameActivePlayer
filter (\p1 -> (p1 ^. playerNumber) /= p) . toListOf traverse <$> use gamePlayerStates filter (\p1 -> (p1 ^. playerNumber) /= p) . toListOf traverse <$> use gamePlayerStates
getNumberOfBuildings :: Waterdeep Int getNumberOfBuildings :: Waterdeep Int
getNumberOfBuildings = getNumberOfBuildings =
length . filter (\b -> b ^. buildingOwner /= noPlayerID) <$> use gameBuildings length . filter (\b -> b ^. buildingOwner /= noPlayerID) <$> use gameBuildings
getNumberOfControlledBuildings :: PlayerID -> Waterdeep Int getNumberOfControlledBuildings :: Waterdeep Int
getNumberOfControlledBuildings p = getNumberOfControlledBuildings = do
p <- use gameActivePlayer
length . filter (\b -> b ^. buildingOwner == p) <$> use gameBuildings length . filter (\b -> b ^. buildingOwner == p) <$> use gameBuildings
data ContWD a where
Done :: Maybe (a, WaterdeepState) -> ContWD a
Cont :: WaterdeepPrompt b -> (b -> ContWD a) -> ContWD a
-- |Returns true if there exists some sequence of choices leading to a successful result.
tryChoice :: ContWD a -> Bool
tryChoice (Done (Just _)) = True
tryChoice (Done Nothing) = False
tryChoice (Cont (NotifyState w) cont) = tryChoice $ cont ()
tryChoice (Cont (Broadcast s) cont) = tryChoice $ cont ()
tryChoice (Cont (SolicitChoice p t cs) cont) = or $ map (tryChoice . cont . snd) cs
-- |Returns True if there exists some sequence of choices
-- which would make the action succeed, or False otherwise.
canPerformAction :: Waterdeep a -> Waterdeep Bool
canPerformAction m = tryChoice . runWaterdeepC Done Cont m <$> get
-- |Permits only choices which lead to a successful result.
-- Returns Nothing if and only if no such choice exists.
filterChoices :: Waterdeep a -> Waterdeep (Maybe a)
filterChoices m = do
mw' <- filteredChoice [] =<< (runWaterdeepC Done Cont m <$> get)
case mw' of
Just (ps,a,w') -> forM_ ps forwardPrompt >> put w' >> return (Just a)
Nothing -> return Nothing
where
filteredChoice :: [WaterdeepPrompt ()] -> ContWD a
-> Waterdeep (Maybe ([WaterdeepPrompt ()], a, WaterdeepState))
filteredChoice ps (Done (Just (a,w))) = return (Just (ps,a,w))
filteredChoice ps (Done Nothing) = 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 do
forM_ ps forwardPrompt
filteredChoice [] =<< (cont <$> solicitChoice p t cs')
forwardPrompt :: WaterdeepPrompt () -> Waterdeep ()
forwardPrompt (NotifyState w) = put w >> notifyState
forwardPrompt (Broadcast s) = broadcast' s

93
src/Waterdeep/Logic.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE NoMonomorphismRestriction #-}
@ -39,7 +40,8 @@ newGame players quests intrigues buildings rndgen =
, _gamePlayerStates = IM.fromAscList playerStates , _gamePlayerStates = IM.fromAscList playerStates
, _gameFirstPlayer = 1 , _gameFirstPlayer = 1
, _gameCurrentRound = 0 , _gameCurrentRound = 0
, _gameCurrentPlayer = noPlayerID , _gameCurrentPlayer = 1
, _gameActivePlayer = 1
, _gameConsecutivePasses = 0 , _gameConsecutivePasses = 0
, _gameQuestDeck = [] , _gameQuestDeck = []
, _gameQuestDiscard = quests , _gameQuestDiscard = quests
@ -61,13 +63,13 @@ basicBuildings =
[ basicBuilding "Aurora's Realms Shop" (takeResources 4 [Gold]) [ basicBuilding "Aurora's Realms Shop" (takeResources 4 [Gold])
, basicBuilding "Blackstaff Tower" (takeResources 1 [Wizard]) , basicBuilding "Blackstaff Tower" (takeResources 1 [Wizard])
, basicBuilding "Builder's Hall" buyBuilding , basicBuilding "Builder's Hall" buyBuilding
, basicBuilding "Castle Waterdeep" (\p -> becomeFirstPlayer p >> drawIntrigue p) , basicBuilding "Castle Waterdeep" (becomeFirstPlayer >> drawIntrigue)
, basicBuilding "Field of Triumph" (takeResources 2 [Fighter]) , basicBuilding "Field of Triumph" (takeResources 2 [Fighter])
, basicBuilding "The Grinning Lion Tavern" (takeResources 2 [Rogue]) , basicBuilding "The Grinning Lion Tavern" (takeResources 2 [Rogue])
, basicBuilding "The Plinth" (takeResources 1 [Cleric]) , basicBuilding "The Plinth" (takeResources 1 [Cleric])
, basicBuilding "Cliffwatch Inn (2 Gold)" (\p -> chooseQuest p >> takeResources 2 [Gold] p) , basicBuilding "Cliffwatch Inn (2 Gold)" (chooseQuest >> takeResources 2 [Gold])
, basicBuilding "Cliffwatch Inn (Intrigue)" (\p -> chooseQuest p >> drawIntrigue p) , basicBuilding "Cliffwatch Inn (Intrigue)" (chooseQuest >> drawIntrigue)
, basicBuilding "Cliffwatch Inn (Reset)" (\p -> replaceQuests p >> chooseQuest p) , basicBuilding "Cliffwatch Inn (Reset)" (replaceQuests >> chooseQuest)
] ]
basicBuilding :: String -> GameAction -> Building basicBuilding :: String -> GameAction -> Building
@ -86,28 +88,29 @@ waterdeepGame = do
guard (np >= 2 && np <= 5) guard (np >= 2 && np <= 5)
restockBuildersHall restockBuildersHall
restockCliffwatchInn restockCliffwatchInn
forM_ [1..np] $ \p -> do forM_ [1..np] $ \p -> withActivePlayer p $ do
replicateM_ 2 $ drawQuest p replicateM_ 2 $ drawQuest
replicateM_ 2 $ drawIntrigue p replicateM_ 2 $ drawIntrigue
takeResources (3 + p) [Gold] p takeResources (3 + p) [Gold]
forM_ [1..8] $ \round -> do forM_ [1..8] $ \round -> do
beginRound round beginRound round
-- TODO: Assign ambassador (if in play) -- TODO: Assign ambassador (if in play)
fix $ \loop -> do fix $ \loop -> do
p <- use gameCurrentPlayer gameActivePlayer <~ use gameCurrentPlayer
result <- filterChoices $ assignAgent p filterChoices assignAgent >>= \case
case result of
Just () -> do Just () -> do
filterChoices $ join $ solicitChoice p "Complete a quest?" $ filterChoices $ join $ solicitChoice "Complete a quest?" $
[ ("Yes", completeQuest p) [ ("Yes", completeQuest)
, ("No", return ()) , ("No", return ())
] ]
gameCurrentPlayer <~ getNextPlayer p
gameConsecutivePasses .= 0 gameConsecutivePasses .= 0
gameCurrentPlayer <~ (getNextPlayer =<< use gameCurrentPlayer)
loop loop
Nothing -> do Nothing -> do
passes <- gameConsecutivePasses <+= 1 passes <- gameConsecutivePasses <+= 1
when (passes < np) loop when (passes < np) $ do
gameCurrentPlayer <~ (getNextPlayer =<< use gameCurrentPlayer)
loop
scoreFinalPoints scoreFinalPoints
notifyState notifyState
determineWinners determineWinners
@ -117,45 +120,49 @@ beginRound round = do
broadcast $ "Starting round " ++ show round ++ "." broadcast $ "Starting round " ++ show round ++ "."
gameCurrentRound .= round gameCurrentRound .= round
gameCurrentPlayer <~ use gameFirstPlayer gameCurrentPlayer <~ use gameFirstPlayer
gameActivePlayer <~ use gameFirstPlayer
gameBuildings . traverse . buildingAgents .= [] gameBuildings . traverse . buildingAgents .= []
gameBuildersHall . traverse . buildingAgents .= [] gameBuildersHall . traverse . buildingAgents .= []
gameBuildersHall . traverse . buildingAccumulation += 1 gameBuildersHall . traverse . buildingAccumulation += 1
gameWaterdeepHarbor . each .= [] gameWaterdeepHarbor . each .= []
np <- use gameNumberOfPlayers np <- use gameNumberOfPlayers
forM_ [1..np] $ \p -> do let agents = initialAgents np round
qs <- gamePlayer p . playerUsedPlotQuests <<.= [] forM_ [1..np] $ \p -> withActivePlayer p $ do
gamePlayer p . playerActivePlotQuests <>= qs qs <- activePlayerState . playerUsedPlotQuests <<.= []
gamePlayer p . playerAgentsInPool .= initialAgents np round activePlayerState . playerActivePlotQuests <>= qs
extra <- use (gamePlayer p . playerHasLieutenant) activePlayerState . playerAgentsInPool .= agents
when extra $ gamePlayer p . playerAgentsInPool += 1 use (activePlayerState . playerHasLieutenant) >>= \case
return () True -> activePlayerState . playerAgentsInPool += 1 >> return ()
False -> return ()
scoreFinalPoints :: Waterdeep () scoreFinalPoints :: Waterdeep ()
scoreFinalPoints = do scoreFinalPoints = do
np <- use gameNumberOfPlayers np <- use gameNumberOfPlayers
forM_ [1..np] $ \p -> do forM_ [1..np] $ \p -> withActivePlayer p $ do
ps <- use $ gamePlayer p rs <- M.toAscList <$> use (activePlayerState . playerTavern)
let rs = ps ^. playerTavern . to M.toAscList name <- use activePlayerName
forM_ rs $ \(r, n) -> do forM_ rs $ \(r, n) -> do
let pts = case r of { Gold -> n `div` 2; _ -> n; } let pts = case r of { Gold -> n `div` 2; _ -> n; }
gamePlayer (ps ^. playerNumber) . playerScore += pts activePlayerState . playerScore += pts
broadcast $ printf "%s scored %d points for having %d %ss." broadcast $ printf "%s scored %d points for having %d %ss." name pts n (show r)
(ps ^. playerName) pts n (show r) use (activePlayerState . playerLord . lordBonus) >>= \case
case ps ^. playerLord . lordBonus of
QuestBonus types pts -> do QuestBonus types pts -> do
let (cqs, apqs, upqs) = (ps ^. playerCompletedQuests, ps ^. playerActivePlotQuests, ps ^. playerUsedPlotQuests) quests <- concat <$> sequence
let matches = length $ filter ((`elem` types) . (view questType)) (cqs ++ apqs ++ upqs) [ use $ activePlayerState . playerCompletedQuests
gamePlayer (ps ^. playerNumber) . playerScore += matches * pts , use $ activePlayerState . playerActivePlotQuests
when (matches > 0) $ , use $ activePlayerState . playerUsedPlotQuests
broadcast $ printf "%s scored %d points for completing %d %s and/or %s quests." ]
(ps ^. playerName) (matches * pts) matches let matches = length . filter ((`elem` types) . (view questType)) $ quests
(show (types !! 0)) (show (types !! 1)) activePlayerState . playerScore += matches * pts
when (matches > 0) $ broadcast $
printf "%s scored %d points for completing %d %s and/or %s quests."
name (matches * pts) matches (show (types !! 0)) (show (types !! 1))
BuildingBonus pts -> do BuildingBonus pts -> do
ownedBuildings <- length <$> filter ((== (ps ^. playerNumber)) . (view buildingOwner)) <$> use gameBuildings owned <- length . filter ((== p) . (view buildingOwner)) <$> use gameBuildings
gamePlayer (ps ^. playerNumber) . playerScore += ownedBuildings * pts activePlayerState . playerScore += owned * pts
when (ownedBuildings > 0) $ when (owned > 0) $ broadcast $
broadcast $ printf "%s scored %d points for controlling %d buildings." printf "%s scored %d points for controlling %d buildings."
(ps ^. playerName) (ownedBuildings * pts) ownedBuildings name (owned * pts) owned
determineWinners :: Waterdeep [PlayerID] determineWinners :: Waterdeep [PlayerID]
determineWinners = do determineWinners = do

104
src/Waterdeep/Types.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
@ -67,6 +68,7 @@ module Waterdeep.Types
, gameFirstPlayer , gameFirstPlayer
, gameCurrentRound , gameCurrentRound
, gameCurrentPlayer , gameCurrentPlayer
, gameActivePlayer
, gameConsecutivePasses , gameConsecutivePasses
, gameQuestDeck , gameQuestDeck
, gameQuestDiscard , gameQuestDiscard
@ -79,20 +81,23 @@ module Waterdeep.Types
, gameBuildings , gameBuildings
, gameWaterdeepHarbor , gameWaterdeepHarbor
, gameStdGen , gameStdGen
, gamePlayer , gamePlayerState
, gamePlayerName , gamePlayerName
, activePlayerState
, activePlayerName
, withActivePlayer
, noPlayerID , noPlayerID
, getNextPlayer , getNextPlayer
, newPlayerState , newPlayerState
, newBuildingState , newBuildingState
, notifyState , notifyState
, broadcast , broadcast
, broadcast'
, solicitChoice , solicitChoice
, solicitChoice'
, runWaterdeepC , runWaterdeepC
, runWaterdeep , runWaterdeep
, runWaterdeepM , runWaterdeepM
, canPerformAction
, filterChoices
) where ) where
import Control.Applicative import Control.Applicative
@ -116,7 +121,7 @@ import qualified System.Random as R
type PlayerID = Int type PlayerID = Int
type GameAction = PlayerID -> Waterdeep () type GameAction = Waterdeep ()
data Lord = data Lord =
Lord Lord
@ -190,6 +195,7 @@ data WaterdeepState =
, _gameFirstPlayer :: PlayerID , _gameFirstPlayer :: PlayerID
, _gameCurrentRound :: Int , _gameCurrentRound :: Int
, _gameCurrentPlayer :: PlayerID , _gameCurrentPlayer :: PlayerID
, _gameActivePlayer :: PlayerID
, _gameConsecutivePasses :: Int , _gameConsecutivePasses :: Int
, _gameQuestDeck :: [Quest] , _gameQuestDeck :: [Quest]
, _gameQuestDiscard :: [Quest] , _gameQuestDiscard :: [Quest]
@ -242,7 +248,8 @@ data WaterdeepPrompt a where
Broadcast :: String -> WaterdeepPrompt () Broadcast :: String -> WaterdeepPrompt ()
SolicitChoice :: PlayerID -> String -> [(String, a)] -> WaterdeepPrompt a SolicitChoice :: PlayerID -> String -> [(String, a)] -> WaterdeepPrompt a
newtype Waterdeep a = Waterdeep { runWaterdeep' :: StateT WaterdeepState (MaybeT (Prompt WaterdeepPrompt)) a } data Waterdeep a =
Waterdeep { unWaterdeep :: StateT WaterdeepState (MaybeT (Prompt WaterdeepPrompt)) a }
makeLenses ''Lord makeLenses ''Lord
makeLenses ''Faction makeLenses ''Faction
@ -277,7 +284,7 @@ instance Applicative Waterdeep where
instance Monad Waterdeep where instance Monad Waterdeep where
return = Waterdeep . return return = Waterdeep . return
(Waterdeep m) >>= f = Waterdeep (m >>= runWaterdeep' . f) (Waterdeep m) >>= f = Waterdeep (m >>= unWaterdeep . f)
fail = Waterdeep . fail fail = Waterdeep . fail
instance MonadPlus Waterdeep where instance MonadPlus Waterdeep where
@ -296,11 +303,26 @@ instance MonadRandom Waterdeep where
instance MonadSplit StdGen Waterdeep where instance MonadSplit StdGen Waterdeep where
getSplit = gameStdGen %%= R.split getSplit = gameStdGen %%= R.split
gamePlayer :: PlayerID -> Lens' WaterdeepState PlayerState gamePlayerState :: PlayerID -> Lens' WaterdeepState PlayerState
gamePlayer n = gamePlayerStates . singular (ix n) gamePlayerState n = gamePlayerStates . singular (ix n)
gamePlayerName :: PlayerID -> Lens' WaterdeepState String gamePlayerName :: PlayerID -> Lens' WaterdeepState String
gamePlayerName n = gamePlayer n . playerName gamePlayerName n = gamePlayerState n . playerName
activePlayerState :: Lens' WaterdeepState PlayerState
activePlayerState = lens
(\w -> w ^. gamePlayerState (w ^. gameActivePlayer))
(\w v -> w & gamePlayerState (w ^. gameActivePlayer) .~ v)
activePlayerName :: Lens' WaterdeepState String
activePlayerName = activePlayerState . playerName
withActivePlayer :: PlayerID -> Waterdeep a -> Waterdeep a
withActivePlayer p m = do
p0 <- gameActivePlayer <<.= p
r <- m
gameActivePlayer .= p0
return r
getNextPlayer :: PlayerID -> Waterdeep PlayerID getNextPlayer :: PlayerID -> Waterdeep PlayerID
getNextPlayer p = do getNextPlayer p = do
@ -338,24 +360,22 @@ newBuildingState p b =
, _buildingAccumulation = 0 , _buildingAccumulation = 0
} }
notifyState :: Waterdeep () waterdeepPrompt :: WaterdeepPrompt a -> Waterdeep a
notifyState = get >>= Waterdeep . lift . lift . prompt . NotifyState waterdeepPrompt = Waterdeep . lift . lift . prompt
broadcast' :: String -> Waterdeep () notifyState :: Waterdeep ()
broadcast' s = Waterdeep (lift (lift (prompt (Broadcast s)))) notifyState = get >>= waterdeepPrompt . NotifyState
broadcast :: String -> Waterdeep () broadcast :: String -> Waterdeep ()
broadcast s = notifyState >> broadcast' s broadcast s = notifyState >> waterdeepPrompt (Broadcast s)
solicitChoice' :: PlayerID -> String -> [(String, a)] -> Waterdeep a solicitChoice :: String -> [(String, a)] -> Waterdeep a
solicitChoice' _ _ [] = fail "there must be at least one option to choose" solicitChoice _ [] = fail "there must be at least one option to choose"
solicitChoice' _ _ [c] = return (snd c) -- only one option, don't bother asking solicitChoice _ [c] = return (snd c) -- only one option, don't bother asking
solicitChoice' p t cs = Waterdeep (lift (lift (prompt (SolicitChoice p t cs)))) solicitChoice t cs = do
notifyState
solicitChoice :: PlayerID -> String -> [(String, a)] -> Waterdeep a p <- use gameActivePlayer
solicitChoice _ _ [] = fail "there must be at least one option to choose" waterdeepPrompt (SolicitChoice p t cs)
solicitChoice _ _ [c] = return (snd c) -- only one option, don't bother asking
solicitChoice p t cs = notifyState >> Waterdeep (lift (lift (prompt (SolicitChoice p t cs))))
runWaterdeepC :: (Maybe (r, WaterdeepState) -> b) -> (forall a. WaterdeepPrompt a -> (a -> b) -> b) -> Waterdeep r -> WaterdeepState -> b runWaterdeepC :: (Maybe (r, WaterdeepState) -> b) -> (forall a. WaterdeepPrompt a -> (a -> b) -> b) -> Waterdeep r -> WaterdeepState -> b
runWaterdeepC r p (Waterdeep m) s = runPromptC r p $ runMaybeT $ runStateT m s runWaterdeepC r p (Waterdeep m) s = runPromptC r p $ runMaybeT $ runStateT m s
@ -365,3 +385,41 @@ runWaterdeep p (Waterdeep m) s = runPrompt p $ runMaybeT $ runStateT m s
runWaterdeepM :: (Monad m) => (forall a. WaterdeepPrompt a -> m a) -> Waterdeep r -> WaterdeepState -> m (Maybe (r, WaterdeepState)) runWaterdeepM :: (Monad m) => (forall a. WaterdeepPrompt a -> m a) -> Waterdeep r -> WaterdeepState -> m (Maybe (r, WaterdeepState))
runWaterdeepM p (Waterdeep m) s = runPromptM p $ runMaybeT $ runStateT m s runWaterdeepM p (Waterdeep m) s = runPromptM p $ runMaybeT $ runStateT m s
data ContWD a where
Done :: Maybe (a, WaterdeepState) -> ContWD a
Cont :: WaterdeepPrompt b -> (b -> ContWD a) -> ContWD a
-- |Returns true if there exists some sequence of choices leading to a successful result.
tryChoice :: ContWD a -> Bool
tryChoice (Done (Just _)) = True
tryChoice (Done Nothing) = False
tryChoice (Cont (NotifyState w) cont) = tryChoice $ cont ()
tryChoice (Cont (Broadcast s) cont) = tryChoice $ cont ()
tryChoice (Cont (SolicitChoice p t cs) cont) = or $ map (tryChoice . cont . snd) cs
-- |Returns True if there exists some sequence of choices
-- which would make the action succeed, or False otherwise.
canPerformAction :: Waterdeep a -> Waterdeep Bool
canPerformAction m = tryChoice . runWaterdeepC Done Cont m <$> get
-- |Permit only choices which lead to a successful result.
-- Returns Nothing if and only if no such choice exists.
filterChoices :: Waterdeep a -> Waterdeep (Maybe a)
filterChoices m = filteredChoice [] . runWaterdeepC Done Cont m =<< get
where
filteredChoice :: [WaterdeepPrompt ()] -> ContWD a -> Waterdeep (Maybe a)
filteredChoice ps (Done Nothing) = return Nothing
filteredChoice ps (Done (Just (a,w))) = forwardPrompts ps >> put w >> return (Just a)
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) =
case filter (tryChoice . cont . snd) cs of
[] -> return Nothing
[c] -> filteredChoice ps $ cont (snd c)
cs' -> do
forwardPrompts ps
r <- waterdeepPrompt (SolicitChoice p t cs')
filteredChoice [] $ cont r
forwardPrompts :: [WaterdeepPrompt ()] -> Waterdeep ()
forwardPrompts = mapM_ waterdeepPrompt