diff --git a/src/ConsoleUI.hs b/src/ConsoleUI.hs index faa8305..786f489 100755 --- a/src/ConsoleUI.hs +++ b/src/ConsoleUI.hs @@ -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)) diff --git a/src/Waterdeep/Actions.hs b/src/Waterdeep/Actions.hs index f2bee61..61590f7 100644 --- a/src/Waterdeep/Actions.hs +++ b/src/Waterdeep/Actions.hs @@ -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 diff --git a/src/Waterdeep/Logic.hs b/src/Waterdeep/Logic.hs index 0a79f7e..53546ac 100644 --- a/src/Waterdeep/Logic.hs +++ b/src/Waterdeep/Logic.hs @@ -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 diff --git a/src/Waterdeep/Types.hs b/src/Waterdeep/Types.hs index 6a754ba..29369ed 100644 --- a/src/Waterdeep/Types.hs +++ b/src/Waterdeep/Types.hs @@ -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