eliminate the explicit PlayerID parameter to the GameActions
This commit is contained in:
parent
e8b6f03be7
commit
01ab0b30db
|
|
@ -44,24 +44,24 @@ p2 = ("Ned", f2, l2)
|
|||
q1 = Quest { _questType = Arcana
|
||||
, _questTitle = "Research Palantirs"
|
||||
, _questQuote = ""
|
||||
, _questAction = \p -> do
|
||||
returnResources 1 [Cleric] p
|
||||
returnResources 1 [Rogue] p
|
||||
returnResources 1 [Rogue] p
|
||||
returnResources 1 [Wizard] p
|
||||
returnResources 4 [Gold] p
|
||||
scorePoints 15 p
|
||||
takeResources 8 [Gold] p
|
||||
, _questAction = do
|
||||
returnResources 1 [Cleric]
|
||||
returnResources 1 [Rogue]
|
||||
returnResources 1 [Rogue]
|
||||
returnResources 1 [Wizard]
|
||||
returnResources 4 [Gold]
|
||||
scorePoints 15
|
||||
takeResources 8 [Gold]
|
||||
, _questPlotActions = []
|
||||
}
|
||||
|
||||
q2 = Quest { _questType = Skullduggery
|
||||
, _questTitle = "Rob Waterdeep Bank"
|
||||
, _questQuote = ""
|
||||
, _questAction = \p -> do
|
||||
returnResources 8 [Rogue] p
|
||||
scorePoints 10 p
|
||||
takeResources 16 [Gold] p
|
||||
, _questAction = do
|
||||
returnResources 8 [Rogue]
|
||||
scorePoints 10
|
||||
takeResources 16 [Gold]
|
||||
, _questPlotActions = []
|
||||
}
|
||||
|
||||
|
|
@ -102,17 +102,17 @@ b5 = Building { _buildingCost = 4
|
|||
|
||||
i1 = IntrigueCard { _intrigueTitle = "Graduation Day"
|
||||
, _intrigueType = Utility
|
||||
, _intrigueAction = \p -> do
|
||||
takeResources 2 [Wizard] p
|
||||
forOneOpponent (takeResources 1 [Wizard]) p
|
||||
, _intrigueAction = do
|
||||
takeResources 2 [Wizard]
|
||||
forOneOpponent (takeResources 1 [Wizard])
|
||||
, _intrigueQuote = ""
|
||||
}
|
||||
|
||||
i2 = IntrigueCard { _intrigueTitle = "Call for Adventurers"
|
||||
, _intrigueType = Utility
|
||||
, _intrigueAction = \p -> do
|
||||
takeResources 2 [Cleric, Fighter, Rogue, Wizard] p
|
||||
forOneOpponent (takeResources 1 [Cleric, Fighter, Rogue, Wizard]) p
|
||||
, _intrigueAction = do
|
||||
takeResources 2 [Cleric, Fighter, Rogue, Wizard]
|
||||
forOneOpponent (takeResources 1 [Cleric, Fighter, Rogue, Wizard])
|
||||
, _intrigueQuote = ""
|
||||
}
|
||||
|
||||
|
|
@ -129,11 +129,11 @@ printWaterdeep w = do
|
|||
clearScreen
|
||||
putStrLn ("Players: " ++ intercalate ", " (map (^. playerName) playerStates))
|
||||
putStrLn ("First Player: " ++
|
||||
(w ^. gamePlayer (w ^. gameFirstPlayer) . playerName))
|
||||
(w ^. gamePlayerState (w ^. gameFirstPlayer) . playerName))
|
||||
putStrLn ("Current Round: " ++ show (w ^. gameCurrentRound))
|
||||
let p = w ^. gameCurrentPlayer
|
||||
when (p /= noPlayerID) $
|
||||
putStrLn ("Current Player: " ++ (w ^. gamePlayer p . playerName))
|
||||
putStrLn ("Current Player: " ++ (w ^. gamePlayerState p . playerName))
|
||||
putStrLn ""
|
||||
putStrLn "Cliffwatch Inn:"
|
||||
forM_ (w ^. gameCliffwatchInn) $ \q -> do
|
||||
|
|
@ -187,7 +187,7 @@ menuPrompt ref redraw prm@(SolicitChoice p t cs) = do
|
|||
putStrLn t
|
||||
printMenu $ zipWith (\i c -> show i ++ ") " ++ fst c) [1..] cs
|
||||
|
||||
putStr (w ^. gamePlayer p . playerName)
|
||||
putStr (w ^. gamePlayerState p . playerName)
|
||||
putStr "> " >> hFlush stdout
|
||||
response <- getLine
|
||||
--response <- show <$> getRandomR (1, menuSize)
|
||||
|
|
@ -217,6 +217,6 @@ main :: IO ()
|
|||
main = do
|
||||
w0 <- newGame [p1, p2] (mrepeat 4 [q1, q2]) (mrepeat 4 [i1, i2]) [b1, b2, b3, b4, b5] <$> getSplit
|
||||
ref <- newIORef (DisplayState { _gameState = w0, _gameMessages = [] })
|
||||
let gamePlayerName n = w0 ^. gamePlayer n . playerName
|
||||
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))
|
||||
|
|
|
|||
|
|
@ -40,8 +40,6 @@ module Waterdeep.Actions
|
|||
, getOpponents
|
||||
, getNumberOfBuildings
|
||||
, getNumberOfControlledBuildings
|
||||
, filterChoices
|
||||
, canPerformAction
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
|
|
@ -63,72 +61,72 @@ import qualified Data.IntMap as IM
|
|||
import qualified Data.Map as M
|
||||
|
||||
noAction :: GameAction
|
||||
noAction _ = return ()
|
||||
noAction = return ()
|
||||
|
||||
scorePoints :: Int -> GameAction
|
||||
scorePoints n p = do
|
||||
gamePlayer p . playerScore += n
|
||||
name <- use $ gamePlayerName p
|
||||
scorePoints n = do
|
||||
activePlayerState . playerScore += n
|
||||
name <- use activePlayerName
|
||||
broadcast $ printf "%s scored %d points." name n
|
||||
|
||||
takeResources :: Int -> [Resource] -> GameAction
|
||||
takeResources n rs p = do
|
||||
takeResources n rs = do
|
||||
received <- map (head &&& length) . group . sort <$$> replicateM n $ do
|
||||
r <- solicitChoice p "Take one item:" $ map (show &&& id) rs
|
||||
gamePlayer p . playerTavern %= M.insertWith' (+) r 1
|
||||
r <- solicitChoice "Take one item:" $ map (show &&& id) rs
|
||||
activePlayerState . playerTavern %= M.insertWith' (+) r 1
|
||||
return r
|
||||
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
|
||||
|
||||
returnResources :: Int -> [Resource] -> GameAction
|
||||
returnResources n rs p = do
|
||||
returnResources n rs = 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
|
||||
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
|
||||
gamePlayer p . playerTavern %= M.update removeOne r
|
||||
activePlayerState . playerTavern %= M.update removeOne r
|
||||
return r
|
||||
let groups = map (head &&& length) $ group returned
|
||||
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."
|
||||
|
||||
chooseQuest' :: PlayerID -> Waterdeep Quest
|
||||
chooseQuest' p = do
|
||||
chooseQuest' :: Waterdeep Quest
|
||||
chooseQuest' = do
|
||||
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
|
||||
name <- use $ gamePlayerName p
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " chose " ++ (quest ^. questTitle) ++ " from Cliffwatch Inn."
|
||||
restockCliffwatchInn
|
||||
return quest
|
||||
|
||||
chooseQuest :: GameAction
|
||||
chooseQuest p = do
|
||||
quest <- chooseQuest' p
|
||||
gamePlayer p . playerIncompleteQuests <>= [quest]
|
||||
chooseQuest = do
|
||||
quest <- chooseQuest'
|
||||
activePlayerState . playerIncompleteQuests <>= [quest]
|
||||
return ()
|
||||
|
||||
replaceQuests :: GameAction
|
||||
replaceQuests _ = do
|
||||
replaceQuests = do
|
||||
quests <- gameCliffwatchInn <<.= []
|
||||
gameQuestDiscard <>= quests
|
||||
restockCliffwatchInn
|
||||
|
||||
drawQuest :: GameAction
|
||||
drawQuest p = do
|
||||
drawQuest = do
|
||||
Just q <- drawQuest'
|
||||
name <- use $ gamePlayerName p
|
||||
gamePlayer p . playerIncompleteQuests <>= [q]
|
||||
name <- use $ activePlayerName
|
||||
activePlayerState . playerIncompleteQuests <>= [q]
|
||||
broadcast $ printf "%s drew %s from the quest deck." name (q ^. questTitle)
|
||||
|
||||
drawNamedQuestType :: GameAction
|
||||
drawNamedQuestType p = do
|
||||
drawNamedQuestType = do
|
||||
let qtypes = [Piety, Warfare, Skullduggery, Arcana, Commerce]
|
||||
qtype <- solicitChoice p "Choose a quest type:" $ map (show &&& id) qtypes
|
||||
name <- use $ gamePlayerName p
|
||||
qtype <- solicitChoice "Choose a quest type:" $ map (show &&& id) qtypes
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " chose the " ++ (show qtype) ++ " quest type."
|
||||
flip fix [] $ \loop discards -> do
|
||||
mq <- drawQuest'
|
||||
|
|
@ -144,165 +142,170 @@ drawNamedQuestType p = do
|
|||
then loop (q : discards)
|
||||
else do
|
||||
gameQuestDiscard <>= discards
|
||||
gamePlayer p . playerIncompleteQuests <>= [q]
|
||||
activePlayerState . playerIncompleteQuests <>= [q]
|
||||
return ()
|
||||
|
||||
distributeQuests :: GameAction
|
||||
distributeQuests p = do
|
||||
np <- use gameNumberOfPlayers
|
||||
let loop p' remQuests = unless (null remQuests) $ do
|
||||
distributeQuests = do
|
||||
let distribute remQuests = unless (null remQuests) $ do
|
||||
let choices = zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] remQuests
|
||||
(i, quest) <- solicitChoice p' "Choose a quest:" $ nubOn fst choices
|
||||
gamePlayer p' . playerIncompleteQuests <>= [quest]
|
||||
name <- use $ gamePlayerName p'
|
||||
(i, quest) <- solicitChoice "Choose a quest:" $ nubOn fst choices
|
||||
activePlayerState . playerIncompleteQuests <>= [quest]
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ printf "%s chose the %s quest." name (quest ^. questTitle)
|
||||
flip loop (deleteAt i remQuests) =<< getNextPlayer p'
|
||||
loop p =<< return . catMaybes =<< replicateM np drawQuest'
|
||||
p' <- getNextPlayer =<< use gameActivePlayer
|
||||
withActivePlayer p' $ distribute (deleteAt i remQuests)
|
||||
distribute =<< catMaybes <$> (flip replicateM drawQuest' =<< use gameNumberOfPlayers)
|
||||
|
||||
completeQuest :: GameAction
|
||||
completeQuest p = do
|
||||
quests <- zip [0..] <$> use (gamePlayer p . playerIncompleteQuests)
|
||||
completeQuest = do
|
||||
quests <- zip [0..] <$> use (activePlayerState . playerIncompleteQuests)
|
||||
let mandatoryQuests = filter ((== Mandatory) . view questType . snd) quests
|
||||
let availQuests = if null mandatoryQuests then quests else mandatoryQuests
|
||||
let choices = map (\(i,q) -> (q ^. questTitle, (i, q))) availQuests
|
||||
(i, quest) <- solicitChoice p "Complete one quest:" $ nubOn fst choices
|
||||
gamePlayer p . playerIncompleteQuests %= deleteAt i
|
||||
(quest ^. questAction) p
|
||||
(i, quest) <- solicitChoice "Complete one quest:" $ nubOn fst choices
|
||||
activePlayerState . playerIncompleteQuests %= deleteAt i
|
||||
quest ^. questAction
|
||||
if null (quest ^. questPlotActions)
|
||||
then gamePlayer p . playerCompletedQuests <>= [quest]
|
||||
else gamePlayer p . playerActivePlotQuests <>= [quest]
|
||||
name <- use $ gamePlayerName p
|
||||
then activePlayerState . playerCompletedQuests <>= [quest]
|
||||
else activePlayerState . playerActivePlotQuests <>= [quest]
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest."
|
||||
|
||||
chooseAndCompleteQuest :: GameAction -> GameAction
|
||||
chooseAndCompleteQuest bonusAction p = do
|
||||
quest <- chooseQuest' p
|
||||
doQuest <- solicitChoice p "Complete this quest immediately?"
|
||||
chooseAndCompleteQuest bonusAction = do
|
||||
quest <- chooseQuest'
|
||||
doQuest <- solicitChoice "Complete this quest immediately?"
|
||||
[("Yes", True), ("No", False)]
|
||||
case doQuest of
|
||||
True -> do
|
||||
incompleteQuests <- use (gamePlayer p . playerIncompleteQuests)
|
||||
incompleteQuests <- use (activePlayerState . playerIncompleteQuests)
|
||||
guard . not . or $ map ((== Mandatory) . view questType) incompleteQuests
|
||||
(quest ^. questAction) p
|
||||
quest ^. questAction
|
||||
if null (quest ^. questPlotActions)
|
||||
then gamePlayer p . playerCompletedQuests <>= [quest]
|
||||
else gamePlayer p . playerActivePlotQuests <>= [quest]
|
||||
name <- use $ gamePlayerName p
|
||||
then activePlayerState . playerCompletedQuests <>= [quest]
|
||||
else activePlayerState . playerActivePlotQuests <>= [quest]
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest."
|
||||
bonusAction p
|
||||
bonusAction
|
||||
False -> do
|
||||
gamePlayer p . playerIncompleteQuests <>= [quest]
|
||||
activePlayerState . playerIncompleteQuests <>= [quest]
|
||||
return ()
|
||||
|
||||
discardUncompletedQuest :: GameAction
|
||||
discardUncompletedQuest p = do
|
||||
discardUncompletedQuest = do
|
||||
choices <- zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] <$>
|
||||
use (gamePlayer p . playerIncompleteQuests)
|
||||
(i, quest) <- solicitChoice p "Choose a quest to discard:" $ nubOn fst choices
|
||||
gamePlayer p . playerIncompleteQuests %= deleteAt i
|
||||
use (activePlayerState . playerIncompleteQuests)
|
||||
(i, quest) <- solicitChoice "Choose a quest to discard:" $ nubOn fst choices
|
||||
activePlayerState . playerIncompleteQuests %= deleteAt i
|
||||
gameQuestDiscard <>= [quest]
|
||||
name <- use $ gamePlayerName p
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " discarded the " ++ (quest ^. questTitle) ++ " quest."
|
||||
|
||||
buyBuilding :: GameAction
|
||||
buyBuilding p = do
|
||||
buyBuilding = do
|
||||
let label b = printf "%s (%d Gold, %d Points)"
|
||||
(b ^. building . buildingTitle)
|
||||
(b ^. building . buildingCost)
|
||||
(b ^. buildingAccumulation)
|
||||
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
|
||||
returnResources cost [Gold] p
|
||||
scorePoints (b ^. buildingAccumulation) p
|
||||
returnResources cost [Gold]
|
||||
scorePoints (b ^. buildingAccumulation)
|
||||
gameBuildersHall %= deleteAt i
|
||||
p <- use gameActivePlayer
|
||||
gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0]
|
||||
name <- use $ gamePlayerName p
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ "."
|
||||
restockBuildersHall
|
||||
|
||||
chooseFreeBuilding :: GameAction
|
||||
chooseFreeBuilding p = do
|
||||
chooseFreeBuilding = do
|
||||
let label b = printf "%s (%d Points)"
|
||||
(b ^. building . buildingTitle)
|
||||
(b ^. buildingAccumulation)
|
||||
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
|
||||
scorePoints (b ^. buildingAccumulation) p
|
||||
(i, b) <- solicitChoice "Choose a building from Builder's Hall:" $ nubOn fst choices
|
||||
scorePoints (b ^. buildingAccumulation)
|
||||
gameBuildersHall %= deleteAt i
|
||||
p <- use gameActivePlayer
|
||||
gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0]
|
||||
name <- use $ gamePlayerName p
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ " for free."
|
||||
restockBuildersHall
|
||||
|
||||
drawFreeBuilding :: GameAction
|
||||
drawFreeBuilding p = do
|
||||
drawFreeBuilding = do
|
||||
Just b <- drawBuilding'
|
||||
p <- use gameActivePlayer
|
||||
gameBuildings <>= [newBuildingState p b]
|
||||
name <- use $ gamePlayerName p
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " built the " ++ (b ^. buildingTitle) ++ " for free."
|
||||
|
||||
discardUnoccupiedBuilding :: GameAction
|
||||
discardUnoccupiedBuilding p = do
|
||||
discardUnoccupiedBuilding = do
|
||||
allBuildings <- zip [0..] <$> use gameBuildings
|
||||
p <- use gameActivePlayer
|
||||
let ownedBuildings = filter ((== p) . view buildingOwner . snd) allBuildings
|
||||
let emptyBuildings = filter (null . view buildingAgents . snd) ownedBuildings
|
||||
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
|
||||
gameBuildingDiscard <>= [b ^. building]
|
||||
name <- use $ gamePlayerName p
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " discarded the " ++ (b ^. building . buildingTitle) ++ "."
|
||||
|
||||
drawIntrigue :: GameAction
|
||||
drawIntrigue p = do
|
||||
drawIntrigue = do
|
||||
Just ic <- drawIntrigue'
|
||||
gamePlayer p . playerIntrigueCards <>= [ic]
|
||||
name <- use $ gamePlayerName p
|
||||
activePlayerState . playerIntrigueCards <>= [ic]
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " drew an Intrigue card."
|
||||
|
||||
playIntrigue :: GameAction
|
||||
playIntrigue p = do
|
||||
playIntrigue = do
|
||||
choices <- zipWith (\i ic -> (ic ^. intrigueTitle, (i, ic))) [0..] <$>
|
||||
use (gamePlayer p . playerIntrigueCards)
|
||||
(i, intrigue) <- solicitChoice p "Play one intrigue card:" $ nubOn fst choices
|
||||
gamePlayer p . playerIntrigueCards %= deleteAt i
|
||||
name <- use $ gamePlayerName p
|
||||
use (activePlayerState . playerIntrigueCards)
|
||||
(i, intrigue) <- solicitChoice "Play one intrigue card:" $ nubOn fst choices
|
||||
activePlayerState . playerIntrigueCards %= deleteAt i
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " played the " ++ (intrigue ^. intrigueTitle) ++ " Intrigue card."
|
||||
(intrigue ^. intrigueAction) p
|
||||
intrigue ^. intrigueAction
|
||||
gameIntrigueDiscard <>= [intrigue]
|
||||
return ()
|
||||
|
||||
returnAgent :: GameAction
|
||||
returnAgent p = return () -- TODO
|
||||
returnAgent = return () -- TODO
|
||||
|
||||
returnAgentFromHarbor :: GameAction
|
||||
returnAgentFromHarbor p = return () -- TODO
|
||||
returnAgentFromHarbor = return () -- TODO
|
||||
|
||||
assignAgentToBuilding :: Lens' WaterdeepState BuildingState -> PlayerID -> Waterdeep ()
|
||||
assignAgentToBuilding bl p = do
|
||||
gamePlayer p . playerAgentsInPool -= 1
|
||||
assignAgentToBuilding :: Lens' WaterdeepState BuildingState -> Waterdeep ()
|
||||
assignAgentToBuilding bl = do
|
||||
activePlayerState . playerAgentsInPool -= 1
|
||||
p <- use gameActivePlayer
|
||||
bl . buildingAgents <>= [p]
|
||||
name <- use $ gamePlayerName p
|
||||
name <- use $ activePlayerName
|
||||
bName <- use (bl . building . buildingTitle)
|
||||
broadcast $ name ++ " assigned an agent to " ++ bName ++ "."
|
||||
owner <- use (bl . buildingOwner)
|
||||
when (owner `notElem` [noPlayerID, p]) $
|
||||
void . ($ owner) =<< use (bl . building . buildingOwnerAction)
|
||||
($ p) =<< use (bl . building . buildingAction)
|
||||
withActivePlayer owner =<< use (bl . building . buildingOwnerAction)
|
||||
join $ use (bl . building . buildingAction)
|
||||
|
||||
assignAgentToHarbor :: Lens' ([PlayerID], [PlayerID], [PlayerID]) [PlayerID]
|
||||
-> PlayerID -> Waterdeep ()
|
||||
assignAgentToHarbor l p = do
|
||||
gamePlayer p . playerAgentsInPool -= 1
|
||||
assignAgentToHarbor :: Lens' ([PlayerID], [PlayerID], [PlayerID]) [PlayerID] -> Waterdeep ()
|
||||
assignAgentToHarbor l = do
|
||||
activePlayerState . playerAgentsInPool -= 1
|
||||
p <- use gameActivePlayer
|
||||
gameWaterdeepHarbor . l <>= [p]
|
||||
name <- use $ gamePlayerName p
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " assigned an agent to Waterdeep Harbor."
|
||||
playIntrigue p
|
||||
playIntrigue
|
||||
|
||||
assignAgent :: GameAction
|
||||
assignAgent p = do
|
||||
agents <- use (gamePlayer p . playerAgentsInPool)
|
||||
assignAgent = do
|
||||
agents <- use (activePlayerState . playerAgentsInPool)
|
||||
guard (agents > 0)
|
||||
w <- get
|
||||
let buildings = execWriter $ do
|
||||
|
|
@ -310,69 +313,73 @@ assignAgent p = do
|
|||
let l :: Lens' WaterdeepState BuildingState
|
||||
l = gameBuildings . singular (ix i)
|
||||
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
|
||||
([], _, _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _1 p)]
|
||||
(_, [], _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _2 p)]
|
||||
(_, _, []) -> tell [("Waterdeep Harbor", assignAgentToHarbor _3 p)]
|
||||
([], _, _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _1)]
|
||||
(_, [], _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _2)]
|
||||
(_, _, []) -> tell [("Waterdeep Harbor", assignAgentToHarbor _3)]
|
||||
_ -> return ()
|
||||
join $ solicitChoice p "Assign one agent to:" $ nubOn fst buildings
|
||||
join $ solicitChoice "Assign one agent to:" $ nubOn fst buildings
|
||||
|
||||
assignAgentToBuildersHall :: GameAction
|
||||
assignAgentToBuildersHall p = return () -- TODO
|
||||
assignAgentToBuildersHall = return () -- TODO
|
||||
|
||||
assignAgentToOpponentsSpace :: GameAction
|
||||
assignAgentToOpponentsSpace p = return () -- TODO
|
||||
assignAgentToOpponentsSpace = return () -- TODO
|
||||
|
||||
useOpponentsSpace :: GameAction
|
||||
useOpponentsSpace p = return () -- TODO
|
||||
useOpponentsSpace = return () -- TODO
|
||||
|
||||
gainLieutenant :: GameAction
|
||||
gainLieutenant p = do
|
||||
gamePlayer p . playerHasLieutenant .= True
|
||||
gamePlayer p . playerAgentsInPool += 1
|
||||
name <- use $ gamePlayerName p
|
||||
gainLieutenant = do
|
||||
activePlayerState . playerHasLieutenant .= True
|
||||
activePlayerState . playerAgentsInPool += 1
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " gained the Lieutenant."
|
||||
return ()
|
||||
|
||||
gainAmbassador :: GameAction
|
||||
gainAmbassador p = do
|
||||
gainAmbassador = do
|
||||
guard . not . or . toListOf (traverse . playerHasAmbassador) =<< use gamePlayerStates
|
||||
gameBuildings . each . buildingAgents %= (\\ [noPlayerID])
|
||||
gameWaterdeepHarbor . each %= (\\ [noPlayerID])
|
||||
gamePlayer p . playerHasAmbassador .= True
|
||||
name <- use $ gamePlayerName p
|
||||
activePlayerState . playerHasAmbassador .= True
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " gained the Ambassador."
|
||||
|
||||
assignMandatoryQuest :: Quest -> GameAction
|
||||
assignMandatoryQuest quest p = do
|
||||
name <- use $ gamePlayerName p
|
||||
opponents <- getOpponents p
|
||||
assignMandatoryQuest quest = do
|
||||
name <- use $ activePlayerName
|
||||
opponents <- getOpponents
|
||||
let choices = map (view playerName &&& (view playerNumber &&& view playerName)) opponents
|
||||
(opID, opName) <- solicitChoice p "Choose one opponent:" choices
|
||||
gamePlayer opID . playerIncompleteQuests <>= [quest]
|
||||
(opID, opName) <- solicitChoice "Choose one opponent:" choices
|
||||
gamePlayerState opID . playerIncompleteQuests <>= [quest]
|
||||
broadcast $ name ++ " assigned " ++ opName ++ " a mandatory quest."
|
||||
|
||||
becomeFirstPlayer :: GameAction
|
||||
becomeFirstPlayer p = do
|
||||
gameFirstPlayer .= p
|
||||
name <- use $ gamePlayerName p
|
||||
becomeFirstPlayer = do
|
||||
gameFirstPlayer <~ use gameActivePlayer
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " is now the first player."
|
||||
|
||||
forOneOpponent :: GameAction -> GameAction
|
||||
forOneOpponent a1 p = do
|
||||
opponents <- getOpponents p
|
||||
forOneOpponent a1 = do
|
||||
opponents <- getOpponents
|
||||
let choices = map (view playerName &&& (view playerNumber &&& view playerName)) opponents
|
||||
(opID, opName) <- solicitChoice p "Choose one opponent:" choices
|
||||
name <- use $ gamePlayerName p
|
||||
(opID, opName) <- solicitChoice "Choose one opponent:" choices
|
||||
name <- use $ activePlayerName
|
||||
broadcast $ name ++ " chose " ++ opName ++ "."
|
||||
a1 opID
|
||||
withActivePlayer opID a1
|
||||
|
||||
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 a1 _ = a1 =<< use gameCurrentPlayer
|
||||
forCurrentPlayer a1 = do
|
||||
p <- use gameCurrentPlayer
|
||||
withActivePlayer p a1
|
||||
|
||||
-- Like (<$>), but with the same fixity and precedence as ($)
|
||||
(<$$>) :: Applicative f => (a -> b) -> f a -> f b
|
||||
|
|
@ -437,56 +444,16 @@ restockBuildersHall = do
|
|||
restockBuildersHall
|
||||
|
||||
|
||||
getOpponents :: PlayerID -> Waterdeep [PlayerState]
|
||||
getOpponents p =
|
||||
getOpponents :: Waterdeep [PlayerState]
|
||||
getOpponents = do
|
||||
p <- use gameActivePlayer
|
||||
filter (\p1 -> (p1 ^. playerNumber) /= p) . toListOf traverse <$> use gamePlayerStates
|
||||
|
||||
getNumberOfBuildings :: Waterdeep Int
|
||||
getNumberOfBuildings =
|
||||
length . filter (\b -> b ^. buildingOwner /= noPlayerID) <$> use gameBuildings
|
||||
|
||||
getNumberOfControlledBuildings :: PlayerID -> Waterdeep Int
|
||||
getNumberOfControlledBuildings p =
|
||||
getNumberOfControlledBuildings :: Waterdeep Int
|
||||
getNumberOfControlledBuildings = do
|
||||
p <- use gameActivePlayer
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE NoMonomorphismRestriction #-}
|
||||
|
||||
|
|
@ -39,7 +40,8 @@ newGame players quests intrigues buildings rndgen =
|
|||
, _gamePlayerStates = IM.fromAscList playerStates
|
||||
, _gameFirstPlayer = 1
|
||||
, _gameCurrentRound = 0
|
||||
, _gameCurrentPlayer = noPlayerID
|
||||
, _gameCurrentPlayer = 1
|
||||
, _gameActivePlayer = 1
|
||||
, _gameConsecutivePasses = 0
|
||||
, _gameQuestDeck = []
|
||||
, _gameQuestDiscard = quests
|
||||
|
|
@ -61,13 +63,13 @@ basicBuildings =
|
|||
[ basicBuilding "Aurora's Realms Shop" (takeResources 4 [Gold])
|
||||
, basicBuilding "Blackstaff Tower" (takeResources 1 [Wizard])
|
||||
, 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 "The Grinning Lion Tavern" (takeResources 2 [Rogue])
|
||||
, basicBuilding "The Plinth" (takeResources 1 [Cleric])
|
||||
, basicBuilding "Cliffwatch Inn (2 Gold)" (\p -> chooseQuest p >> takeResources 2 [Gold] p)
|
||||
, basicBuilding "Cliffwatch Inn (Intrigue)" (\p -> chooseQuest p >> drawIntrigue p)
|
||||
, basicBuilding "Cliffwatch Inn (Reset)" (\p -> replaceQuests p >> chooseQuest p)
|
||||
, basicBuilding "Cliffwatch Inn (2 Gold)" (chooseQuest >> takeResources 2 [Gold])
|
||||
, basicBuilding "Cliffwatch Inn (Intrigue)" (chooseQuest >> drawIntrigue)
|
||||
, basicBuilding "Cliffwatch Inn (Reset)" (replaceQuests >> chooseQuest)
|
||||
]
|
||||
|
||||
basicBuilding :: String -> GameAction -> Building
|
||||
|
|
@ -86,28 +88,29 @@ waterdeepGame = do
|
|||
guard (np >= 2 && np <= 5)
|
||||
restockBuildersHall
|
||||
restockCliffwatchInn
|
||||
forM_ [1..np] $ \p -> do
|
||||
replicateM_ 2 $ drawQuest p
|
||||
replicateM_ 2 $ drawIntrigue p
|
||||
takeResources (3 + p) [Gold] p
|
||||
forM_ [1..np] $ \p -> withActivePlayer p $ do
|
||||
replicateM_ 2 $ drawQuest
|
||||
replicateM_ 2 $ drawIntrigue
|
||||
takeResources (3 + p) [Gold]
|
||||
forM_ [1..8] $ \round -> do
|
||||
beginRound round
|
||||
-- TODO: Assign ambassador (if in play)
|
||||
fix $ \loop -> do
|
||||
p <- use gameCurrentPlayer
|
||||
result <- filterChoices $ assignAgent p
|
||||
case result of
|
||||
gameActivePlayer <~ use gameCurrentPlayer
|
||||
filterChoices assignAgent >>= \case
|
||||
Just () -> do
|
||||
filterChoices $ join $ solicitChoice p "Complete a quest?" $
|
||||
[ ("Yes", completeQuest p)
|
||||
filterChoices $ join $ solicitChoice "Complete a quest?" $
|
||||
[ ("Yes", completeQuest)
|
||||
, ("No", return ())
|
||||
]
|
||||
gameCurrentPlayer <~ getNextPlayer p
|
||||
gameConsecutivePasses .= 0
|
||||
gameCurrentPlayer <~ (getNextPlayer =<< use gameCurrentPlayer)
|
||||
loop
|
||||
Nothing -> do
|
||||
passes <- gameConsecutivePasses <+= 1
|
||||
when (passes < np) loop
|
||||
when (passes < np) $ do
|
||||
gameCurrentPlayer <~ (getNextPlayer =<< use gameCurrentPlayer)
|
||||
loop
|
||||
scoreFinalPoints
|
||||
notifyState
|
||||
determineWinners
|
||||
|
|
@ -117,45 +120,49 @@ beginRound round = do
|
|||
broadcast $ "Starting round " ++ show round ++ "."
|
||||
gameCurrentRound .= round
|
||||
gameCurrentPlayer <~ use gameFirstPlayer
|
||||
gameActivePlayer <~ use gameFirstPlayer
|
||||
gameBuildings . traverse . buildingAgents .= []
|
||||
gameBuildersHall . traverse . buildingAgents .= []
|
||||
gameBuildersHall . traverse . buildingAccumulation += 1
|
||||
gameWaterdeepHarbor . each .= []
|
||||
np <- use gameNumberOfPlayers
|
||||
forM_ [1..np] $ \p -> do
|
||||
qs <- gamePlayer p . playerUsedPlotQuests <<.= []
|
||||
gamePlayer p . playerActivePlotQuests <>= qs
|
||||
gamePlayer p . playerAgentsInPool .= initialAgents np round
|
||||
extra <- use (gamePlayer p . playerHasLieutenant)
|
||||
when extra $ gamePlayer p . playerAgentsInPool += 1
|
||||
return ()
|
||||
let agents = initialAgents np round
|
||||
forM_ [1..np] $ \p -> withActivePlayer p $ do
|
||||
qs <- activePlayerState . playerUsedPlotQuests <<.= []
|
||||
activePlayerState . playerActivePlotQuests <>= qs
|
||||
activePlayerState . playerAgentsInPool .= agents
|
||||
use (activePlayerState . playerHasLieutenant) >>= \case
|
||||
True -> activePlayerState . playerAgentsInPool += 1 >> return ()
|
||||
False -> return ()
|
||||
|
||||
scoreFinalPoints :: Waterdeep ()
|
||||
scoreFinalPoints = do
|
||||
np <- use gameNumberOfPlayers
|
||||
forM_ [1..np] $ \p -> do
|
||||
ps <- use $ gamePlayer p
|
||||
let rs = ps ^. playerTavern . to M.toAscList
|
||||
forM_ [1..np] $ \p -> withActivePlayer p $ do
|
||||
rs <- M.toAscList <$> use (activePlayerState . playerTavern)
|
||||
name <- use activePlayerName
|
||||
forM_ rs $ \(r, n) -> do
|
||||
let pts = case r of { Gold -> n `div` 2; _ -> n; }
|
||||
gamePlayer (ps ^. playerNumber) . playerScore += pts
|
||||
broadcast $ printf "%s scored %d points for having %d %ss."
|
||||
(ps ^. playerName) pts n (show r)
|
||||
case ps ^. playerLord . lordBonus of
|
||||
activePlayerState . playerScore += pts
|
||||
broadcast $ printf "%s scored %d points for having %d %ss." name pts n (show r)
|
||||
use (activePlayerState . playerLord . lordBonus) >>= \case
|
||||
QuestBonus types pts -> do
|
||||
let (cqs, apqs, upqs) = (ps ^. playerCompletedQuests, ps ^. playerActivePlotQuests, ps ^. playerUsedPlotQuests)
|
||||
let matches = length $ filter ((`elem` types) . (view questType)) (cqs ++ apqs ++ upqs)
|
||||
gamePlayer (ps ^. playerNumber) . playerScore += matches * pts
|
||||
when (matches > 0) $
|
||||
broadcast $ printf "%s scored %d points for completing %d %s and/or %s quests."
|
||||
(ps ^. playerName) (matches * pts) matches
|
||||
(show (types !! 0)) (show (types !! 1))
|
||||
quests <- concat <$> sequence
|
||||
[ use $ activePlayerState . playerCompletedQuests
|
||||
, use $ activePlayerState . playerActivePlotQuests
|
||||
, use $ activePlayerState . playerUsedPlotQuests
|
||||
]
|
||||
let matches = length . filter ((`elem` types) . (view questType)) $ quests
|
||||
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
|
||||
ownedBuildings <- length <$> filter ((== (ps ^. playerNumber)) . (view buildingOwner)) <$> use gameBuildings
|
||||
gamePlayer (ps ^. playerNumber) . playerScore += ownedBuildings * pts
|
||||
when (ownedBuildings > 0) $
|
||||
broadcast $ printf "%s scored %d points for controlling %d buildings."
|
||||
(ps ^. playerName) (ownedBuildings * pts) ownedBuildings
|
||||
owned <- length . filter ((== p) . (view buildingOwner)) <$> use gameBuildings
|
||||
activePlayerState . playerScore += owned * pts
|
||||
when (owned > 0) $ broadcast $
|
||||
printf "%s scored %d points for controlling %d buildings."
|
||||
name (owned * pts) owned
|
||||
|
||||
determineWinners :: Waterdeep [PlayerID]
|
||||
determineWinners = do
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
|
@ -67,6 +68,7 @@ module Waterdeep.Types
|
|||
, gameFirstPlayer
|
||||
, gameCurrentRound
|
||||
, gameCurrentPlayer
|
||||
, gameActivePlayer
|
||||
, gameConsecutivePasses
|
||||
, gameQuestDeck
|
||||
, gameQuestDiscard
|
||||
|
|
@ -79,20 +81,23 @@ module Waterdeep.Types
|
|||
, gameBuildings
|
||||
, gameWaterdeepHarbor
|
||||
, gameStdGen
|
||||
, gamePlayer
|
||||
, gamePlayerState
|
||||
, gamePlayerName
|
||||
, activePlayerState
|
||||
, activePlayerName
|
||||
, withActivePlayer
|
||||
, noPlayerID
|
||||
, getNextPlayer
|
||||
, newPlayerState
|
||||
, newBuildingState
|
||||
, notifyState
|
||||
, broadcast
|
||||
, broadcast'
|
||||
, solicitChoice
|
||||
, solicitChoice'
|
||||
, runWaterdeepC
|
||||
, runWaterdeep
|
||||
, runWaterdeepM
|
||||
, canPerformAction
|
||||
, filterChoices
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
|
|
@ -116,7 +121,7 @@ import qualified System.Random as R
|
|||
|
||||
type PlayerID = Int
|
||||
|
||||
type GameAction = PlayerID -> Waterdeep ()
|
||||
type GameAction = Waterdeep ()
|
||||
|
||||
data Lord =
|
||||
Lord
|
||||
|
|
@ -190,6 +195,7 @@ data WaterdeepState =
|
|||
, _gameFirstPlayer :: PlayerID
|
||||
, _gameCurrentRound :: Int
|
||||
, _gameCurrentPlayer :: PlayerID
|
||||
, _gameActivePlayer :: PlayerID
|
||||
, _gameConsecutivePasses :: Int
|
||||
, _gameQuestDeck :: [Quest]
|
||||
, _gameQuestDiscard :: [Quest]
|
||||
|
|
@ -242,7 +248,8 @@ data WaterdeepPrompt a where
|
|||
Broadcast :: String -> WaterdeepPrompt ()
|
||||
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 ''Faction
|
||||
|
|
@ -277,7 +284,7 @@ instance Applicative Waterdeep where
|
|||
|
||||
instance Monad Waterdeep where
|
||||
return = Waterdeep . return
|
||||
(Waterdeep m) >>= f = Waterdeep (m >>= runWaterdeep' . f)
|
||||
(Waterdeep m) >>= f = Waterdeep (m >>= unWaterdeep . f)
|
||||
fail = Waterdeep . fail
|
||||
|
||||
instance MonadPlus Waterdeep where
|
||||
|
|
@ -296,11 +303,26 @@ instance MonadRandom Waterdeep where
|
|||
instance MonadSplit StdGen Waterdeep where
|
||||
getSplit = gameStdGen %%= R.split
|
||||
|
||||
gamePlayer :: PlayerID -> Lens' WaterdeepState PlayerState
|
||||
gamePlayer n = gamePlayerStates . singular (ix n)
|
||||
gamePlayerState :: PlayerID -> Lens' WaterdeepState PlayerState
|
||||
gamePlayerState n = gamePlayerStates . singular (ix n)
|
||||
|
||||
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 p = do
|
||||
|
|
@ -338,24 +360,22 @@ newBuildingState p b =
|
|||
, _buildingAccumulation = 0
|
||||
}
|
||||
|
||||
notifyState :: Waterdeep ()
|
||||
notifyState = get >>= Waterdeep . lift . lift . prompt . NotifyState
|
||||
waterdeepPrompt :: WaterdeepPrompt a -> Waterdeep a
|
||||
waterdeepPrompt = Waterdeep . lift . lift . prompt
|
||||
|
||||
broadcast' :: String -> Waterdeep ()
|
||||
broadcast' s = Waterdeep (lift (lift (prompt (Broadcast s))))
|
||||
notifyState :: Waterdeep ()
|
||||
notifyState = get >>= waterdeepPrompt . NotifyState
|
||||
|
||||
broadcast :: String -> Waterdeep ()
|
||||
broadcast s = notifyState >> broadcast' s
|
||||
broadcast s = notifyState >> waterdeepPrompt (Broadcast s)
|
||||
|
||||
solicitChoice' :: PlayerID -> String -> [(String, a)] -> Waterdeep a
|
||||
solicitChoice' _ _ [] = fail "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 (lift (prompt (SolicitChoice p t cs))))
|
||||
|
||||
solicitChoice :: PlayerID -> String -> [(String, a)] -> Waterdeep a
|
||||
solicitChoice _ _ [] = fail "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 = notifyState >> Waterdeep (lift (lift (prompt (SolicitChoice p t cs))))
|
||||
solicitChoice :: String -> [(String, a)] -> Waterdeep a
|
||||
solicitChoice _ [] = fail "there must be at least one option to choose"
|
||||
solicitChoice _ [c] = return (snd c) -- only one option, don't bother asking
|
||||
solicitChoice t cs = do
|
||||
notifyState
|
||||
p <- use gameActivePlayer
|
||||
waterdeepPrompt (SolicitChoice p t cs)
|
||||
|
||||
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
|
||||
|
|
@ -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 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue