From e8b6f03be731d6de28696307b86df1cb552911a7 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Sat, 3 May 2014 18:05:55 -0500 Subject: [PATCH] use monadic actions for GameAction in place of pattern matching --- src/{Test.hs => ConsoleUI.hs} | 128 ++++--- src/Waterdeep/Actions.hs | 492 +++++++++++++++++++++++++ src/Waterdeep/Logic.hs | 658 +++++----------------------------- src/Waterdeep/Monad.hs | 87 ----- src/Waterdeep/Types.hs | 249 ++++++++----- src/Waterdeep/Util.hs | 13 + 6 files changed, 840 insertions(+), 787 deletions(-) rename src/{Test.hs => ConsoleUI.hs} (60%) create mode 100644 src/Waterdeep/Actions.hs delete mode 100644 src/Waterdeep/Monad.hs diff --git a/src/Test.hs b/src/ConsoleUI.hs similarity index 60% rename from src/Test.hs rename to src/ConsoleUI.hs index 502d845..faa8305 100755 --- a/src/Test.hs +++ b/src/ConsoleUI.hs @@ -3,9 +3,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} -import Waterdeep.Types -import Waterdeep.Monad -import Waterdeep.Logic +module Main (main) where + import Control.Applicative import Control.Lens import Control.Monad @@ -15,10 +14,14 @@ import Control.Monad.State import Data.IORef import Data.List import Data.Monoid -import Text.Printf import System.IO import System.Random import System.Random.Shuffle +import Text.Printf +import Waterdeep.Actions +import Waterdeep.Logic +import Waterdeep.Types +import Waterdeep.Util import qualified Data.IntMap as IM import qualified Data.Map as M @@ -41,71 +44,75 @@ p2 = ("Ned", f2, l2) q1 = Quest { _questType = Arcana , _questTitle = "Research Palantirs" , _questQuote = "" - , _questAction = ReturnResources 1 [Cleric] - <> ReturnResources 1 [Rogue] - <> ReturnResources 1 [Rogue] - <> ReturnResources 1 [Wizard] - <> ReturnResources 4 [Gold] - <> ScorePoints 15 - <> TakeResources 8 [Gold] + , _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 , _questPlotActions = [] } q2 = Quest { _questType = Skullduggery , _questTitle = "Rob Waterdeep Bank" , _questQuote = "" - , _questAction = ReturnResources 8 [Rogue] - <> ScorePoints 10 - <> TakeResources 16 [Gold] + , _questAction = \p -> do + returnResources 8 [Rogue] p + scorePoints 10 p + takeResources 16 [Gold] p , _questPlotActions = [] } b1 = Building { _buildingCost = 6 , _buildingTitle = "Monastary" - , _buildingAction = TakeResources 2 [Cleric] - , _buildingOwnerAction = TakeResources 1 [Cleric] + , _buildingAction = takeResources 2 [Cleric] + , _buildingOwnerAction = takeResources 1 [Cleric] , _buildingAccumType = NoAccumulation } b2 = Building { _buildingCost = 4 , _buildingTitle = "Training Hall" - , _buildingAction = TakeResources 2 [Fighter] - , _buildingOwnerAction = TakeResources 1 [Fighter] + , _buildingAction = takeResources 2 [Fighter] + , _buildingOwnerAction = takeResources 1 [Fighter] , _buildingAccumType = NoAccumulation } b3 = Building { _buildingCost = 4 , _buildingTitle = "Prison Yard" - , _buildingAction = TakeResources 2 [Rogue] - , _buildingOwnerAction = TakeResources 1 [Rogue] + , _buildingAction = takeResources 2 [Rogue] + , _buildingOwnerAction = takeResources 1 [Rogue] , _buildingAccumType = NoAccumulation } b4 = Building { _buildingCost = 6 , _buildingTitle = "Wizard School" - , _buildingAction = TakeResources 2 [Wizard] - , _buildingOwnerAction = TakeResources 1 [Wizard] + , _buildingAction = takeResources 2 [Wizard] + , _buildingOwnerAction = takeResources 1 [Wizard] , _buildingAccumType = NoAccumulation } b5 = Building { _buildingCost = 4 , _buildingTitle = "Gold Mine" - , _buildingAction = TakeResources 4 [Gold] - , _buildingOwnerAction = TakeResources 2 [Gold] + , _buildingAction = takeResources 4 [Gold] + , _buildingOwnerAction = takeResources 2 [Gold] , _buildingAccumType = NoAccumulation } i1 = IntrigueCard { _intrigueTitle = "Graduation Day" , _intrigueType = Utility - , _intrigueAction = TakeResources 2 [Wizard] - <> OneOpponent (TakeResources 1 [Wizard]) + , _intrigueAction = \p -> do + takeResources 2 [Wizard] p + forOneOpponent (takeResources 1 [Wizard]) p , _intrigueQuote = "" } i2 = IntrigueCard { _intrigueTitle = "Call for Adventurers" , _intrigueType = Utility - , _intrigueAction = TakeResources 2 [Cleric, Fighter, Rogue, Wizard] - <> OneOpponent (TakeResources 1 [Cleric, Fighter, Rogue, Wizard]) + , _intrigueAction = \p -> do + takeResources 2 [Cleric, Fighter, Rogue, Wizard] p + forOneOpponent (takeResources 1 [Cleric, Fighter, Rogue, Wizard]) p , _intrigueQuote = "" } @@ -118,9 +125,9 @@ showTavern = intercalate ", " . map showResource . M.toAscList printWaterdeep :: WaterdeepState -> IO () printWaterdeep w = do - let ps = map snd $ w ^. gamePlayers . to IM.toAscList + let playerStates = map snd $ IM.toAscList $ w ^. gamePlayerStates clearScreen - putStrLn ("Players: " ++ intercalate ", " (map (^. playerName) ps)) + putStrLn ("Players: " ++ intercalate ", " (map (^. playerName) playerStates)) putStrLn ("First Player: " ++ (w ^. gamePlayer (w ^. gameFirstPlayer) . playerName)) putStrLn ("Current Round: " ++ show (w ^. gameCurrentRound)) @@ -139,17 +146,24 @@ printWaterdeep w = do (b ^. building . buildingCost) (b ^. buildingAccumulation) putStrLn "" - forM_ ps $ \p -> do - putStrLn ((p ^. playerName) ++ "'s State (" ++ - show (p ^. playerFaction . factionColor) ++ "):") + forM_ playerStates $ \p -> do + printf "%s's State (%s):\n" (p ^. playerName) + (show (p ^. playerFaction . factionColor)) putStrLn (" Score: " ++ show (p ^. playerScore)) - putStrLn (" Tavern: " ++ (p ^. playerTavern . to showTavern)) - putStrLn (" Incomplete: " ++ show (p ^.. playerIncompleteQuests . traverse . questTitle)) - putStrLn (" Complete: " ++ show (p ^.. playerCompletedQuests . traverse . questTitle)) - putStrLn (" Intrigues: " ++ show (p ^.. playerIntrigueCards . traverse . intrigueTitle)) + putStrLn (" Tavern: " ++ (p ^. playerTavern . to showTavern)) + putStrLn (" Incomplete: " ++ showItems (p ^.. playerIncompleteQuests . traverse . questTitle)) + putStrLn (" Complete: " ++ showItems (p ^.. playerCompletedQuests . traverse . questTitle)) + putStrLn (" Intrigues: " ++ showItems (p ^.. playerIntrigueCards . traverse . intrigueTitle)) putStrLn (" Agent Pool: " ++ show (p ^. playerAgentsInPool)) putStrLn "" +showItems :: [String] -> String +showItems ss = intercalate ", " groups + where + groups = map withCount $ group $ sort ss + withCount [x] = x + withCount xs@(x:_) = x ++ " (x" ++ show (length xs) ++ ")" + drawState :: IORef DisplayState -> IO () drawState ref = do ds <- readIORef ref @@ -166,33 +180,43 @@ menuPrompt ref redraw (Broadcast s) = do redraw menuPrompt ref redraw prm@(SolicitChoice p t cs) = do let menuSize = length cs - let menuLine n t = putStrLn (show n ++ ") " ++ t) let blankLine = putStrLn "" w <- view gameState <$> readIORef ref fix $ \doMenu -> do - let redo = do + putStrLn t + printMenu $ zipWith (\i c -> show i ++ ") " ++ fst c) [1..] cs + + putStr (w ^. gamePlayer p . playerName) + putStr "> " >> hFlush stdout + response <- getLine + --response <- show <$> getRandomR (1, menuSize) + + case reads response of + (ix,""):_ | ix >= 1 && ix <= menuSize -> + blankLine >> return (snd $ cs !! (ix-1)) + _ -> do redraw putStrLn ("ERROR: Expected a number between 1 and " ++ show menuSize ++ ".") blankLine doMenu - putStrLn t - forM_ (zip [1..] cs) $ \(i, (c, _)) -> menuLine i c - - putStr (w ^. gamePlayer p . playerName) - putStr "> " >> hFlush stdout - response <- getLine - - case reads response of - (ix,""):_ | ix >= 1 && ix <= menuSize -> - blankLine >> return (snd $ cs !! (ix-1)) - _ -> redo +printMenu :: [String] -> IO () +printMenu cs = do + let n = length cs + let h = (n `div` 3) `max` 5 + let cw = (maximum $ map length cs) + let cs' = map (take cw . (++ (repeat ' '))) cs + let (c1, cs'') = splitAt h cs' + let (c2, c3) = splitAt h cs'' + let rows = zipWith3 (\a b c -> a ++ " " ++ b ++ " " ++ c) + c1 (c2 ++ repeat "") (c3 ++ repeat "") + mapM_ putStrLn rows main :: IO () main = do - w0 <- newGame [p1, p2] [q1, q2] [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 = [] }) let gamePlayerName n = w0 ^. gamePlayer n . playerName - (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)) diff --git a/src/Waterdeep/Actions.hs b/src/Waterdeep/Actions.hs new file mode 100644 index 0000000..f2bee61 --- /dev/null +++ b/src/Waterdeep/Actions.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Waterdeep.Actions + ( noAction + , scorePoints + , takeResources + , returnResources + , chooseQuest + , replaceQuests + , drawQuest + , drawNamedQuestType + , distributeQuests + , completeQuest + , chooseAndCompleteQuest + , discardUncompletedQuest + , buyBuilding + , chooseFreeBuilding + , drawFreeBuilding + , discardUnoccupiedBuilding + , drawIntrigue + , playIntrigue + , returnAgent + , returnAgentFromHarbor + , assignAgent + , assignAgentToBuildersHall + , assignAgentToOpponentsSpace + , useOpponentsSpace + , gainLieutenant + , gainAmbassador + , assignMandatoryQuest + , becomeFirstPlayer + , forOneOpponent + , forEachOpponent + , forCurrentPlayer + , restockCliffwatchInn + , restockBuildersHall + , getOpponents + , getNumberOfBuildings + , getNumberOfControlledBuildings + , filterChoices + , canPerformAction + ) where + +import Control.Applicative +import Control.Arrow ((&&&)) +import Control.Lens +import Control.Monad +import Control.Monad.Random +import Control.Monad.State +import Control.Monad.Trans.Writer +import Data.List +import Data.Maybe +import Data.Monoid +import System.Random.Shuffle +import Text.Printf +import Waterdeep.Types +import Waterdeep.Util + +import qualified Data.IntMap as IM +import qualified Data.Map as M + +noAction :: GameAction +noAction _ = return () + +scorePoints :: Int -> GameAction +scorePoints n p = do + gamePlayer p . playerScore += n + name <- use $ gamePlayerName p + broadcast $ printf "%s scored %d points." name n + +takeResources :: Int -> [Resource] -> GameAction +takeResources n rs p = 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 + return r + let items = joinStrings $ map (\(r,n) -> show n ++ " " ++ show r) received + name <- use $ gamePlayerName p + broadcast $ printf "%s received %s." name items + +returnResources :: Int -> [Resource] -> GameAction +returnResources n rs p = do + returned <- replicateM n $ do + tavern <- use $ gamePlayer p . playerTavern + let rs' = filter ((>= 1) . maybe 0 id . flip M.lookup tavern) rs + r <- solicitChoice p "Return one item:" $ map (show &&& id) rs' + let removeOne x = if x > 1 then Just (x-1) else Nothing + gamePlayer p . playerTavern %= M.update removeOne r + return r + let groups = map (head &&& length) $ group returned + let items = joinStrings $ map (\(r,n) -> show n ++ " " ++ show r) groups + name <- use $ gamePlayerName p + broadcast $ name ++ " returned " ++ items ++ " to the supply." + +chooseQuest' :: PlayerID -> Waterdeep Quest +chooseQuest' p = do + choices <- zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] <$> use gameCliffwatchInn + (i, quest) <- solicitChoice p "Choose one quest:" $ nubOn fst choices + gameCliffwatchInn %= deleteAt i + name <- use $ gamePlayerName p + broadcast $ name ++ " chose " ++ (quest ^. questTitle) ++ " from Cliffwatch Inn." + restockCliffwatchInn + return quest + +chooseQuest :: GameAction +chooseQuest p = do + quest <- chooseQuest' p + gamePlayer p . playerIncompleteQuests <>= [quest] + return () + +replaceQuests :: GameAction +replaceQuests _ = do + quests <- gameCliffwatchInn <<.= [] + gameQuestDiscard <>= quests + restockCliffwatchInn + +drawQuest :: GameAction +drawQuest p = do + Just q <- drawQuest' + name <- use $ gamePlayerName p + gamePlayer p . playerIncompleteQuests <>= [q] + broadcast $ printf "%s drew %s from the quest deck." name (q ^. questTitle) + +drawNamedQuestType :: GameAction +drawNamedQuestType p = do + let qtypes = [Piety, Warfare, Skullduggery, Arcana, Commerce] + qtype <- solicitChoice p "Choose a quest type:" $ map (show &&& id) qtypes + name <- use $ gamePlayerName p + broadcast $ name ++ " chose the " ++ (show qtype) ++ " quest type." + flip fix [] $ \loop discards -> do + mq <- drawQuest' + case mq of + Nothing -> do + broadcast $ "There were no " ++ show qtype ++ " quests available." + gameQuestDiscard <>= discards + return () + Just q -> do + broadcast $ printf "%s drew the %s quest %s." + name (show (q ^. questType)) (q ^. questTitle) + if (q ^. questType /= qtype) + then loop (q : discards) + else do + gameQuestDiscard <>= discards + gamePlayer p . playerIncompleteQuests <>= [q] + return () + +distributeQuests :: GameAction +distributeQuests p = do + np <- use gameNumberOfPlayers + let loop p' 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' + broadcast $ printf "%s chose the %s quest." name (quest ^. questTitle) + flip loop (deleteAt i remQuests) =<< getNextPlayer p' + loop p =<< return . catMaybes =<< replicateM np drawQuest' + +completeQuest :: GameAction +completeQuest p = do + quests <- zip [0..] <$> use (gamePlayer p . 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 + if null (quest ^. questPlotActions) + then gamePlayer p . playerCompletedQuests <>= [quest] + else gamePlayer p . playerActivePlotQuests <>= [quest] + name <- use $ gamePlayerName p + broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest." + +chooseAndCompleteQuest :: GameAction -> GameAction +chooseAndCompleteQuest bonusAction p = do + quest <- chooseQuest' p + doQuest <- solicitChoice p "Complete this quest immediately?" + [("Yes", True), ("No", False)] + case doQuest of + True -> do + incompleteQuests <- use (gamePlayer p . playerIncompleteQuests) + guard . not . or $ map ((== Mandatory) . view questType) incompleteQuests + (quest ^. questAction) p + if null (quest ^. questPlotActions) + then gamePlayer p . playerCompletedQuests <>= [quest] + else gamePlayer p . playerActivePlotQuests <>= [quest] + name <- use $ gamePlayerName p + broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest." + bonusAction p + False -> do + gamePlayer p . playerIncompleteQuests <>= [quest] + return () + +discardUncompletedQuest :: GameAction +discardUncompletedQuest p = 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 + gameQuestDiscard <>= [quest] + name <- use $ gamePlayerName p + broadcast $ name ++ " discarded the " ++ (quest ^. questTitle) ++ " quest." + +buyBuilding :: GameAction +buyBuilding p = 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 + let cost = b ^. building . buildingCost + returnResources cost [Gold] p + scorePoints (b ^. buildingAccumulation) p + gameBuildersHall %= deleteAt i + gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0] + name <- use $ gamePlayerName p + broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ "." + restockBuildersHall + +chooseFreeBuilding :: GameAction +chooseFreeBuilding p = 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 + gameBuildersHall %= deleteAt i + gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0] + name <- use $ gamePlayerName p + broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ " for free." + restockBuildersHall + +drawFreeBuilding :: GameAction +drawFreeBuilding p = do + Just b <- drawBuilding' + gameBuildings <>= [newBuildingState p b] + name <- use $ gamePlayerName p + broadcast $ name ++ " built the " ++ (b ^. buildingTitle) ++ " for free." + +discardUnoccupiedBuilding :: GameAction +discardUnoccupiedBuilding p = do + allBuildings <- zip [0..] <$> use gameBuildings + 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 + gameBuildings %= deleteAt i + gameBuildingDiscard <>= [b ^. building] + name <- use $ gamePlayerName p + broadcast $ name ++ " discarded the " ++ (b ^. building . buildingTitle) ++ "." + +drawIntrigue :: GameAction +drawIntrigue p = do + Just ic <- drawIntrigue' + gamePlayer p . playerIntrigueCards <>= [ic] + name <- use $ gamePlayerName p + broadcast $ name ++ " drew an Intrigue card." + +playIntrigue :: GameAction +playIntrigue p = 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 + broadcast $ name ++ " played the " ++ (intrigue ^. intrigueTitle) ++ " Intrigue card." + (intrigue ^. intrigueAction) p + gameIntrigueDiscard <>= [intrigue] + return () + +returnAgent :: GameAction +returnAgent p = return () -- TODO + +returnAgentFromHarbor :: GameAction +returnAgentFromHarbor p = return () -- TODO + +assignAgentToBuilding :: Lens' WaterdeepState BuildingState -> PlayerID -> Waterdeep () +assignAgentToBuilding bl p = do + gamePlayer p . playerAgentsInPool -= 1 + bl . buildingAgents <>= [p] + name <- use $ gamePlayerName p + 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) + +assignAgentToHarbor :: Lens' ([PlayerID], [PlayerID], [PlayerID]) [PlayerID] + -> PlayerID -> Waterdeep () +assignAgentToHarbor l p = do + gamePlayer p . playerAgentsInPool -= 1 + gameWaterdeepHarbor . l <>= [p] + name <- use $ gamePlayerName p + broadcast $ name ++ " assigned an agent to Waterdeep Harbor." + playIntrigue p + +assignAgent :: GameAction +assignAgent p = do + agents <- use (gamePlayer p . playerAgentsInPool) + guard (agents > 0) + w <- get + let buildings = execWriter $ do + forM_ [0 .. length (w ^. gameBuildings) - 1] $ \i -> 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)] + case w ^. gameWaterdeepHarbor of + ([], _, _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _1 p)] + (_, [], _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _2 p)] + (_, _, []) -> tell [("Waterdeep Harbor", assignAgentToHarbor _3 p)] + _ -> return () + join $ solicitChoice p "Assign one agent to:" $ nubOn fst buildings + +assignAgentToBuildersHall :: GameAction +assignAgentToBuildersHall p = return () -- TODO + +assignAgentToOpponentsSpace :: GameAction +assignAgentToOpponentsSpace p = return () -- TODO + +useOpponentsSpace :: GameAction +useOpponentsSpace p = return () -- TODO + +gainLieutenant :: GameAction +gainLieutenant p = do + gamePlayer p . playerHasLieutenant .= True + gamePlayer p . playerAgentsInPool += 1 + name <- use $ gamePlayerName p + broadcast $ name ++ " gained the Lieutenant." + return () + +gainAmbassador :: GameAction +gainAmbassador p = do + guard . not . or . toListOf (traverse . playerHasAmbassador) =<< use gamePlayerStates + gameBuildings . each . buildingAgents %= (\\ [noPlayerID]) + gameWaterdeepHarbor . each %= (\\ [noPlayerID]) + gamePlayer p . playerHasAmbassador .= True + name <- use $ gamePlayerName p + broadcast $ name ++ " gained the Ambassador." + +assignMandatoryQuest :: Quest -> GameAction +assignMandatoryQuest quest p = do + name <- use $ gamePlayerName p + opponents <- getOpponents p + let choices = map (view playerName &&& (view playerNumber &&& view playerName)) opponents + (opID, opName) <- solicitChoice p "Choose one opponent:" choices + gamePlayer opID . playerIncompleteQuests <>= [quest] + broadcast $ name ++ " assigned " ++ opName ++ " a mandatory quest." + +becomeFirstPlayer :: GameAction +becomeFirstPlayer p = do + gameFirstPlayer .= p + name <- use $ gamePlayerName p + broadcast $ name ++ " is now the first player." + +forOneOpponent :: GameAction -> GameAction +forOneOpponent a1 p = do + opponents <- getOpponents p + let choices = map (view playerName &&& (view playerNumber &&& view playerName)) opponents + (opID, opName) <- solicitChoice p "Choose one opponent:" choices + name <- use $ gamePlayerName p + broadcast $ name ++ " chose " ++ opName ++ "." + a1 opID + +forEachOpponent :: GameAction -> GameAction +forEachOpponent a1 p = mapM_ (\op -> a1 (op ^. playerNumber)) =<< getOpponents p + +forCurrentPlayer :: GameAction -> GameAction +forCurrentPlayer a1 _ = a1 =<< use gameCurrentPlayer + +-- Like (<$>), but with the same fixity and precedence as ($) +(<$$>) :: Applicative f => (a -> b) -> f a -> f b +(<$$>) = (<$>) +infixr 0 <$$> + +joinStrings :: [String] -> String +joinStrings [] = "nothing" +joinStrings [x] = x +joinStrings [x,y] = x ++ " and " ++ y +joinStrings [x,y,z] = x ++ ", " ++ y ++ ", and " ++ z +joinStrings (x:xs) = x ++ ", " ++ joinStrings xs + +shufflePiles :: Lens WaterdeepState WaterdeepState [a] [a] + -> Lens WaterdeepState WaterdeepState [a] [a] + -> Waterdeep () +shufflePiles deck discard = do + xs <- (++) <$> use discard <*> use deck + xs' <- shuffleM xs + deck .= xs' + discard .= [] + return () + +shuffleQuests = shufflePiles gameQuestDeck gameQuestDiscard +shuffleIntrigues = shufflePiles gameIntrigueDeck gameIntrigueDiscard +shuffleBuildings = shufflePiles gameBuildingDeck gameBuildingDiscard + +draw :: Lens WaterdeepState WaterdeepState [a] [a] + -> Lens WaterdeepState WaterdeepState [a] [a] + -> Waterdeep (Maybe a) +draw deck discard = do + out <- null <$> use deck + when out $ shufflePiles deck discard + listToMaybe <$> (deck %%= splitAt 1) + +drawQuest' = draw gameQuestDeck gameQuestDiscard +drawIntrigue' = draw gameIntrigueDeck gameIntrigueDiscard +drawBuilding' = draw gameBuildingDeck gameBuildingDiscard + +restockCliffwatchInn :: Waterdeep () +restockCliffwatchInn = do + num <- length <$> use gameCliffwatchInn + when (num < 4) $ do + mq <- drawQuest' + case mq of + Nothing -> return () + Just q -> do + gameCliffwatchInn <>= [q] + broadcast $ "Added " ++ (q ^. questTitle) ++ " to Cliffwatch Inn." + restockCliffwatchInn + +restockBuildersHall :: Waterdeep () +restockBuildersHall = do + num <- length <$> use gameBuildersHall + when (num < 3) $ do + mb <- drawBuilding' + case mb of + Nothing -> return () + Just b -> do + gameBuildersHall <>= [newBuildingState noPlayerID b] + broadcast $ "Added " ++ (b ^. buildingTitle) ++ " to Builder's Hall." + restockBuildersHall + + +getOpponents :: PlayerID -> Waterdeep [PlayerState] +getOpponents p = + 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 = + 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 9f3f8f1..0a79f7e 100644 --- a/src/Waterdeep/Logic.hs +++ b/src/Waterdeep/Logic.hs @@ -20,8 +20,8 @@ import Data.Maybe import Data.Monoid import System.Random.Shuffle import Text.Printf +import Waterdeep.Actions import Waterdeep.Types -import Waterdeep.Monad import Waterdeep.Util import qualified Data.IntMap as IM @@ -33,71 +33,41 @@ newGame :: [(String,Faction,Lord)] -> [Building] -> StdGen -> WaterdeepState -newGame players quests intrigues buildings rndgen - | length players < 2 || length players > 5 = - error "This game requires 2-5 players." - | otherwise = - WaterdeepState - { _gamePlayers = IM.fromAscList playerStates - , _gameFirstPlayer = 1 - , _gameCurrentRound = 0 - , _gameCurrentPlayer = noPlayerID - , _gameConsecutivePasses = 0 - , _gameQuestDeck = [] - , _gameQuestDiscard = quests - , _gameCliffwatchInn = [] - , _gameIntrigueDeck = [] - , _gameIntrigueDiscard = intrigues - , _gameBuildingDeck = [] - , _gameBuildingDiscard = buildings - , _gameBuildersHall = [] - , _gameBuildings = map (newBuildingState noPlayerID) basicBuildings - , _gameWaterdeepHarbor = ([], [], []) - , _gameStdGen = rndgen - } +newGame players quests intrigues buildings rndgen = + WaterdeepState + { _gameNumberOfPlayers = length players + , _gamePlayerStates = IM.fromAscList playerStates + , _gameFirstPlayer = 1 + , _gameCurrentRound = 0 + , _gameCurrentPlayer = noPlayerID + , _gameConsecutivePasses = 0 + , _gameQuestDeck = [] + , _gameQuestDiscard = quests + , _gameCliffwatchInn = [] + , _gameIntrigueDeck = [] + , _gameIntrigueDiscard = intrigues + , _gameBuildingDeck = [] + , _gameBuildingDiscard = buildings + , _gameBuildersHall = [] + , _gameBuildings = map (newBuildingState noPlayerID) basicBuildings + , _gameWaterdeepHarbor = ([], [], []) + , _gameStdGen = rndgen + } where playerStates = [ (i, newPlayerState i p) | (i, p) <- zip [1..] players ] -newPlayerState :: PlayerID -> (String, Faction, Lord) -> PlayerState -newPlayerState i (name, faction, lord) = - PlayerState - { _playerNumber = i - , _playerName = name - , _playerFaction = faction - , _playerLord = lord - , _playerScore = 0 - , _playerTavern = M.empty - , _playerIncompleteQuests = [] - , _playerCompletedQuests = [] - , _playerActivePlotQuests = [] - , _playerUsedPlotQuests = [] - , _playerIntrigueCards = [] - , _playerAgentsInPool = 0 - , _playerHasLieutenant = False - , _playerHasAmbassador = False - } - -newBuildingState :: PlayerID -> Building -> BuildingState -newBuildingState p b = - BuildingState - { _building = b - , _buildingOwner = p - , _buildingAgents = [] - , _buildingAccumulation = 0 - } - basicBuildings :: [Building] basicBuildings = - [ basicBuilding "Aurora's Realms Shop" (TakeResources 4 [Gold]) - , basicBuilding "Blackstaff Tower" (TakeResources 1 [Wizard]) - , basicBuilding "Builder's Hall" BuyBuilding - , 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)" (ChooseQuest <> TakeResources 2 [Gold]) - , basicBuilding "Cliffwatch Inn (Intrigue)" (ChooseQuest <> DrawIntrigue) - , basicBuilding "Cliffwatch Inn (Reset)" (ReplaceQuests <> ChooseQuest) + [ 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 "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 :: String -> GameAction -> Building @@ -106,541 +76,99 @@ basicBuilding title action = { _buildingCost = 0 , _buildingTitle = title , _buildingAction = action - , _buildingOwnerAction = NoAction + , _buildingOwnerAction = noAction , _buildingAccumType = NoAccumulation } waterdeepGame :: Waterdeep [PlayerID] waterdeepGame = do - ps <- sort . IM.keys <$> use gamePlayers + np <- use gameNumberOfPlayers + guard (np >= 2 && np <= 5) restockBuildersHall restockCliffwatchInn - forM_ ps $ \p -> do - replicateM_ 2 $ performAction p DrawQuest - replicateM_ 2 $ performAction p DrawIntrigue - performAction p $ TakeResources (3 + p) [Gold] + forM_ [1..np] $ \p -> do + replicateM_ 2 $ drawQuest p + replicateM_ 2 $ drawIntrigue p + takeResources (3 + p) [Gold] p forM_ [1..8] $ \round -> do beginRound round -- TODO: Assign ambassador (if in play) fix $ \loop -> do p <- use gameCurrentPlayer - success <- filterChoices $ performAction p AssignAgent - case success of - True -> do - filterChoices $ join $ solicitChoice p "Complete quest?" $ - [ ("Yes", performAction p CompleteQuest) - , ("No", return True) + result <- filterChoices $ assignAgent p + case result of + Just () -> do + filterChoices $ join $ solicitChoice p "Complete a quest?" $ + [ ("Yes", completeQuest p) + , ("No", return ()) ] - gameCurrentPlayer .= (p `mod` length ps) + 1 + gameCurrentPlayer <~ getNextPlayer p gameConsecutivePasses .= 0 loop - False -> do + Nothing -> do passes <- gameConsecutivePasses <+= 1 - when (passes < length ps) loop + when (passes < np) loop scoreFinalPoints notifyState determineWinners beginRound :: Int -> Waterdeep () beginRound round = do + broadcast $ "Starting round " ++ show round ++ "." gameCurrentRound .= round gameCurrentPlayer <~ use gameFirstPlayer gameBuildings . traverse . buildingAgents .= [] gameBuildersHall . traverse . buildingAgents .= [] gameBuildersHall . traverse . buildingAccumulation += 1 - players <- IM.size <$> use gamePlayers - forM_ [1..players] $ \p -> do + gameWaterdeepHarbor . each .= [] + np <- use gameNumberOfPlayers + forM_ [1..np] $ \p -> do qs <- gamePlayer p . playerUsedPlotQuests <<.= [] gamePlayer p . playerActivePlotQuests <>= qs - gamePlayer p . playerAgentsInPool .= initialAgents players round - notifyState + gamePlayer p . playerAgentsInPool .= initialAgents np round + extra <- use (gamePlayer p . playerHasLieutenant) + when extra $ gamePlayer p . playerAgentsInPool += 1 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_ 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 + 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)) + 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 + +determineWinners :: Waterdeep [PlayerID] +determineWinners = do + playerStates <- toListOf traverse <$> use gamePlayerStates + let bestScore = maximum $ map (view playerScore) playerStates + let winners1 = filter ((== bestScore) . view playerScore) playerStates + let bestGold = maximum $ map playerGold winners1 + let winners2 = filter ((== bestGold) . playerGold) winners1 + return (winners2 ^.. each . playerNumber) + where + playerGold = maybe 0 id . M.lookup Gold . view playerTavern + initialAgents :: Int -> Int -> Int initialAgents players round = if round >= 5 then startingAgents + 1 else startingAgents - where startingAgents = 6 - players - -data ContWD a where - Done :: (a, WaterdeepState) -> ContWD a - Cont :: WaterdeepPrompt b -> (b -> ContWD a) -> ContWD a - --- |Permit only choices which lead to a True result. --- Returns False if and only if no such choice exists. --- If result is False, state remains unchanged. -filterChoices :: Waterdeep Bool -> Waterdeep Bool -filterChoices m = do - mw' <- filteredChoice [] =<< (runWaterdeepC Done Cont m <$> get) - case mw' of - Just (ps,w') -> forM_ ps forwardPrompt >> put w' >> return True - Nothing -> return False - where - tryChoice :: ContWD Bool -> Bool - tryChoice (Done a) = fst a - tryChoice (Cont (NotifyState w) cont) = tryChoice $ cont () - tryChoice (Cont (Broadcast s) cont) = tryChoice $ cont () - tryChoice (Cont (SolicitChoice p t cs) cont) = - or $ map (tryChoice . cont . snd) cs - filteredChoice :: [WaterdeepPrompt ()] -> ContWD Bool - -> Waterdeep (Maybe ([WaterdeepPrompt ()], WaterdeepState)) - filteredChoice ps (Done (a,w)) = if a then return (Just (ps,w)) else return Nothing - filteredChoice ps (Cont p@(NotifyState w) cont) = filteredChoice (ps++[p]) $ cont () - filteredChoice ps (Cont p@(Broadcast s) cont) = filteredChoice (ps++[p]) $ cont () - filteredChoice ps (Cont (SolicitChoice p t cs) cont) = do - let cs' = filter (tryChoice . cont . snd) cs - if null cs' - then return Nothing - else do - forM_ ps forwardPrompt - filteredChoice [] =<< (cont <$> solicitChoice p t cs') - forwardPrompt :: WaterdeepPrompt () -> Waterdeep () - forwardPrompt (NotifyState w) = get >>= \w0 -> put w >> notifyState >> put w0 - forwardPrompt (Broadcast s) = broadcast' s - --- Returns True if there exists some sequence of choices --- which would make the action succeed, or False otherwise. -canPerformAction :: PlayerID -> GameAction -> Waterdeep Bool -canPerformAction p a = do - return . tryChoice . runWaterdeepC Done Cont (performAction p a) =<< get - where - tryChoice :: ContWD Bool -> Bool - tryChoice (Done a) = fst a - 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 - --- Like (<$>), but with the same fixity and precedence as ($) -(<$$>) :: Applicative f => (a -> b) -> f a -> f b -(<$$>) = (<$>) -infixr 0 <$$> - -joinStrings :: [String] -> String -joinStrings [] = "nothing" -joinStrings [x] = x -joinStrings [x,y] = x ++ " and " ++ y -joinStrings [x,y,z] = x ++ ", " ++ y ++ ", and " ++ z -joinStrings (x:xs) = x ++ ", " ++ joinStrings xs - -performAction :: PlayerID -> GameAction -> Waterdeep Bool -performAction p a = do - name <- use $ gamePlayer p . playerName - case a of - NoAction -> return True - ScorePoints n -> do - gamePlayer p . playerScore += n - broadcast $ name ++ " scored " ++ show n ++ " points." - return True - 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 - return r - let items = joinStrings $ map (\(r,n) -> show n ++ " " ++ show r) received - broadcast $ name ++ " received " ++ items ++ "." - return True - ReturnResources n rs -> do - maybeReturned <- replicateM n $ do - tavern <- use $ gamePlayer p . playerTavern - let rs' = filter ((>= 1) . maybe 0 id . flip M.lookup tavern) rs - if null rs' - then return Nothing - else do - r <- solicitChoice p "Return one item:" $ map (show &&& id) rs' - let removeOne x = if x > 1 then Just (x-1) else Nothing - gamePlayer p . playerTavern %= M.update removeOne r - return (Just r) - let success = and . map isJust $ maybeReturned - let returned = map (head &&& length) . group . catMaybes $ maybeReturned - let items = joinStrings $ map (\(r,n) -> show n ++ " " ++ show r) $ returned - broadcast $ name ++ " returned " ++ items ++ " to the supply." - return success - ChooseQuest -> do - quests <- use gameCliffwatchInn - if null quests - then return False - else do - let titles = quests ^.. traverse . questTitle - i <- solicitChoice p "Choose one quest:" $ zip titles [0..] - let quest = quests !! i - gameCliffwatchInn %= deleteAt i - gamePlayer p . playerIncompleteQuests <>= [quest] - broadcast $ name ++ " chose " ++ (quest ^. questTitle) ++ " from Cliffwatch Inn." - restockCliffwatchInn - return True - ReplaceQuests -> do - quests <- gameCliffwatchInn <<.= [] - gameQuestDiscard <>= quests - restockCliffwatchInn - return True - DrawQuest -> do - mq <- drawQuest - case mq of - Nothing -> do - broadcast $ name ++ " failed to draw a quest because the quest deck is empty." - return False - Just q -> do - gamePlayer p . playerIncompleteQuests <>= [q] - broadcast $ name ++ " drew " ++ (q ^. questTitle) ++ " from the quest deck." - return True - DrawNamedQuestType -> do - let qtypes = [Piety, Warfare, Skullduggery, Arcana, Commerce] - qtype <- solicitChoice p "Choose a quest type:" $ map (show &&& id) qtypes - broadcast $ name ++ " chose the " ++ show qtype ++ " quest type." - flip fix [] $ \loop discards -> do - mq <- drawQuest - case mq of - Nothing -> do - broadcast $ "There were no " ++ show qtype ++ " quests available." - gameQuestDiscard <>= discards - return False - Just q -> do - broadcast $ printf "%s drew the %s quest %s." - name (show (q ^. questType)) (q ^. questTitle) - if (q ^. questType /= qtype) - then loop (q : discards) >> return True - else do - gameQuestDiscard <>= discards - gamePlayer p . playerIncompleteQuests <>= [q] - return True - DistributeQuests -> do - np <- IM.size <$> use gamePlayers - let loop p' remQuests = do - unless (null remQuests) $ do - i <- solicitChoice p' "Choose a quest:" $ - zip (map (view questTitle) remQuests) [0..] - gamePlayer p' . playerIncompleteQuests <>= [remQuests !! i] - loop ((p' `mod` np) + 1) (deleteAt i remQuests) - loop p =<< return . catMaybes =<< replicateM np drawQuest - return True - CompleteQuest -> do - quests <- use (gamePlayer p . playerIncompleteQuests) - if null quests - then return False - else filterChoices $ do - let choices = zip (map (view questTitle) quests) [0..] - i <- solicitChoice p "Complete one quest:" choices - let quest = quests !! i - if (quest ^. questType /= Mandatory && - or (map (\q -> q ^. questType == Mandatory) quests)) - then return False - else do - gamePlayer p . playerIncompleteQuests %= deleteAt i - success <- performAction p (quest ^. questAction) - if null (quest ^. questPlotActions) - then gamePlayer p . playerCompletedQuests <>= [quest] - else gamePlayer p . playerActivePlotQuests <>= [quest] - broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest." - return success - ChooseAndCompleteQuest bonusAction -> do - quests <- use gameCliffwatchInn - if null quests - then return False - else filterChoices $ do - let titles = quests ^.. traverse . questTitle - i <- solicitChoice p "Choose one quest:" $ zip titles [0..] - let quest = quests !! i - if (quest ^. questType /= Mandatory && - or (map (\q -> q ^. questType == Mandatory) quests)) - then return False - else do - gameCliffwatchInn %= deleteAt i - broadcast $ name ++ " chose " ++ (quest ^. questTitle) ++ " from Cliffwatch Inn." - restockCliffwatchInn - doQuest <- solicitChoice p "Complete this quest immediately?" - [("Yes", True), ("No", False)] - case doQuest of - True -> do - questSuccess <- performAction p (quest ^. questAction) - bonusSuccess <- performAction p bonusAction - if null (quest ^. questPlotActions) - then gamePlayer p . playerCompletedQuests <>= [quest] - else gamePlayer p . playerActivePlotQuests <>= [quest] - broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest." - return (questSuccess && bonusSuccess) - False -> do - gamePlayer p . playerIncompleteQuests <>= [quest] - return True - DiscardUncompletedQuest -> do - quests <- use (gamePlayer p . playerIncompleteQuests) - if null quests - then return False - else do - i <- solicitChoice p "Choose a quest to discard:" $ - zip (map (view questTitle) quests) [0..] - let quest = quests !! i - gamePlayer p . playerIncompleteQuests %= deleteAt i - gameQuestDiscard <>= [quest] - broadcast $ name ++ " discarded the " ++ (quest ^. questTitle) ++ " quest." - return True - BuyBuilding -> do - buildings <- use gameBuildersHall - if null buildings - then return False - else do - let labels = flip map buildings $ \b -> printf "%s (%d Gold, %d Points)" - (b ^. building . buildingTitle) - (b ^. building . buildingCost) - (b ^. buildingAccumulation) - filterChoices $ do - i <- solicitChoice p "Choose a building from Builder's Hall:" $ - zip labels [0..] - let b = buildings !! i - let cost = b ^. building . buildingCost - paid <- performAction p $ ReturnResources cost [Gold] - performAction p $ ScorePoints (b ^. buildingAccumulation) - gameBuildersHall %= deleteAt i - gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0] - broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ "." - restockBuildersHall - return paid - ChooseFreeBuilding -> do - buildings <- use gameBuildersHall - if null buildings - then return False - else do - let labels = flip map buildings $ \b -> printf "%s (%d Points)" - (b ^. building . buildingTitle) - (b ^. buildingAccumulation) - i <- solicitChoice p "Choose a building from Builder's Hall:" $ - zip labels [0..] - let b = buildings !! i - performAction p $ ScorePoints (b ^. buildingAccumulation) - gameBuildersHall %= deleteAt i - gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0] - broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ " for free." - restockBuildersHall - return True - DrawFreeBuilding -> do - mb <- drawBuilding - case mb of - Nothing -> return False - Just b -> do - gameBuildings <>= [newBuildingState p b] - broadcast $ name ++ " built the " ++ (b ^. buildingTitle) ++ " for free." - return True - DiscardUnoccupiedBuilding -> do - allBuildings <- use gameBuildings - let choices = flip mapMaybe (zip allBuildings [0..]) $ \(b, i) -> - case b ^. buildingOwner == p of - True -> Just (b ^. building . buildingTitle, i) - False -> Nothing - if null choices - then return False - else do - i <- solicitChoice p "Choose a building to discard:" choices - let b = allBuildings !! i - gameBuildings %= deleteAt i - gameBuildingDiscard <>= [b ^. building] - broadcast $ name ++ " discarded the " ++ (b ^. building . buildingTitle) ++ "." - return True - DrawIntrigue -> do - mi <- drawIntrigue - case mi of - Nothing -> return False - Just i -> do - gamePlayer p . playerIntrigueCards <>= [i] - broadcast $ name ++ " drew an Intrigue card." - return True - PlayIntrigue -> do - intrigues <- use (gamePlayer p . playerIntrigueCards) - if null intrigues - then return False - else do - let sameTitle a b = fst a == fst b - let choices = nubBy sameTitle $ zip (map (view intrigueTitle) intrigues) [0..] - i <- solicitChoice p "Play one intrigue card:" choices - let intrigue = intrigues !! i - filterChoices $ do - gamePlayer p . playerIntrigueCards %= deleteAt i - broadcast $ name ++ " played the " ++ (intrigue ^. intrigueTitle) ++ " Intrigue card." - success <- performAction p (intrigue ^. intrigueAction) - gameIntrigueDiscard <>= [intrigue] - return success - ReturnAgent -> return False -- TODO - ReturnAgentFromHarbor -> return False -- TODO - AssignAgent -> do - agents <- use (gamePlayer p . playerAgentsInPool) - if agents <= 0 - then return False - else do - let assignToBuilding :: Lens' WaterdeepState BuildingState -> Waterdeep Bool - assignToBuilding bl = do - gamePlayer p . playerAgentsInPool -= 1 - bl . buildingAgents <>= [p] - bName <- use (bl . building . buildingTitle) - broadcast $ name ++ " assigned an agent to " ++ bName ++ "." - owner <- use (bl . buildingOwner) - when (owner `notElem` [noPlayerID, p]) $ - void . performAction owner =<< use (bl . building . buildingOwnerAction) - performAction p =<< use (bl . building . buildingAction) - let assignToHarbor l = do - gamePlayer p . playerAgentsInPool -= 1 - gameWaterdeepHarbor . l <>= [p] - broadcast $ name ++ " assigned an agent to Waterdeep Harbor." - performAction p PlayIntrigue - buildings <- execWriterT $ do - w <- get - forM_ [0 .. length (w ^. gameBuildings) - 1] $ \i -> do - let l :: Lens' WaterdeepState BuildingState - l = gameBuildings . singular (ix i) - when (null (w ^. l . buildingAgents)) $ do - tell [(w ^. l . building . buildingTitle, assignToBuilding l)] - case w ^. gameWaterdeepHarbor of - ([], _, _) -> tell [("Waterdeep Harbor", assignToHarbor _1)] - (_, [], _) -> tell [("Waterdeep Harbor", assignToHarbor _2)] - (_, _, []) -> tell [("Waterdeep Harbor", assignToHarbor _3)] - _ -> return () - if null buildings - then return False - else do - join $ solicitChoice p "Assign one agent to:" buildings - AssignAgentToBuildersHall -> return False -- TODO - AssignAgentToOpponentsSpace -> return False -- TODO - UseOpponentsSpace -> return False -- TODO - GainLieutenant -> do - gamePlayer p . playerHasLieutenant .= True - gamePlayer p . playerAgentsInPool += 1 - broadcast $ name ++ " gained the Lieutenant." - return True - GainAmbassador -> do - unavail <- or . toListOf (traverse . playerHasAmbassador) <$> use gamePlayers - if unavail - then return False - else do - gameBuildings . each . buildingAgents %= (\\ [noPlayerID]) - gameWaterdeepHarbor . each %= (\\ [noPlayerID]) - gamePlayer p . playerHasAmbassador .= True - broadcast $ name ++ " gained the Ambassador." - return True - TakeAccumulated -> - return True - AssignMandatoryQuest quest -> do - players <- toListOf traverse <$> use gamePlayers - let opponents = filter (\player -> (player ^. playerNumber) /= p) players - let choices = map (\p -> (p ^. playerName, p ^. playerNumber)) opponents - opID <- solicitChoice p "Choose one opponent:" choices - opName <- use (gamePlayer opID . playerName) - gamePlayer opID . playerIncompleteQuests <>= [quest] - broadcast $ name ++ " assigned " ++ opName ++ " a mandatory quest." - return True - BecomeFirstPlayer -> do - gameFirstPlayer .= p - broadcast $ name ++ " is now the first player." - return True - ChooseOne as -> do - a1 <- solicitChoice p "Choose one:" $ map (show &&& id) as - performAction p a1 - a1 `Then` a2 -> do - (&&) <$> performAction p a1 <*> performAction p a2 - a1 `OrElse` a2 -> do - r1 <- filterChoices (performAction p a1) - case r1 of - True -> return True - False -> performAction p a2 - ForEachBuilding a1 -> do - nb <- length . filter (\b -> b ^. buildingOwner /= noPlayerID) <$> use gameBuildings - and <$> replicateM nb (performAction p a1) - ForEachControlledBuilding a1 -> do - nb <- length . filter (\b -> b ^. buildingOwner == p) <$> use gameBuildings - and <$> replicateM nb (performAction p a1) - OneOpponent a1 -> do - players <- toListOf traverse <$> use gamePlayers - let opponents = filter (\player -> (player ^. playerNumber) /= p) players - let choices = map (\p -> (p ^. playerName, p ^. playerNumber)) opponents - opID <- solicitChoice p "Choose one opponent:" choices - opName <- use (gamePlayer opID . playerName) - broadcast $ name ++ " chose " ++ opName ++ "." - performAction opID a1 - EachOpponent a1 -> do - players <- toListOf traverse <$> use gamePlayers - let opponents = filter (\player -> (player ^. playerNumber) /= p) players - forM_ opponents $ \op -> do - performAction (op ^. playerNumber) a1 - return True - CurrentPlayer a1 -> - flip performAction a1 =<< use gameCurrentPlayer - -scoreFinalPoints :: Waterdeep () -scoreFinalPoints = do - ps <- toListOf traverse <$> use gamePlayers - forM_ ps $ \p -> do - let rs = p ^. playerTavern . to M.toAscList - forM_ rs $ \(r, n) -> do - let pts = case r of { Gold -> n `div` 2; _ -> n; } - gamePlayer (p ^. playerNumber) . playerScore += pts - broadcast $ printf "%s scored %d points for having %d %ss." - (p ^. playerName) pts n (show r) - case p ^. playerLord . lordBonus of - QuestBonus types pts -> do - let (cqs, apqs, upqs) = (p ^. playerCompletedQuests, p ^. playerActivePlotQuests, p ^. playerUsedPlotQuests) - let matches = length $ filter ((`elem` types) . (view questType)) (cqs ++ apqs ++ upqs) - gamePlayer (p ^. playerNumber) . playerScore += matches * pts - when (matches > 0) $ - broadcast $ printf "%s scored %d points for completing %d %s and/or %s quests." - (p ^. playerName) (matches * pts) matches - (show (types !! 0)) (show (types !! 1)) - BuildingBonus pts -> do - ownedBuildings <- length <$> filter ((== (p ^. playerNumber)) . (view buildingOwner)) <$> use gameBuildings - gamePlayer (p ^. playerNumber) . playerScore += ownedBuildings * pts - when (ownedBuildings > 0) $ - broadcast $ printf "%s scored %d points for controlling %d buildings." - (p ^. playerName) (ownedBuildings * pts) ownedBuildings - -determineWinners :: Waterdeep [PlayerID] -determineWinners = do - -- TODO: Implement tie-breaker(s) - let compareScores a b = (b^.playerScore) `compare` (a^.playerScore) - ps <- sortBy compareScores <$> toListOf traverse <$> use gamePlayers - let bestScore = (head ps) ^. playerScore - return $ map (^.playerNumber) $ takeWhile (\x -> (x^.playerScore) == bestScore) ps - -shufflePiles :: Lens WaterdeepState WaterdeepState [a] [a] - -> Lens WaterdeepState WaterdeepState [a] [a] - -> Waterdeep () -shufflePiles deck discard = do - xs <- (++) <$> use discard <*> use deck - xs' <- shuffleM xs - deck .= xs' - discard .= [] - return () - -shuffleQuests = shufflePiles gameQuestDeck gameQuestDiscard -shuffleIntrigues = shufflePiles gameIntrigueDeck gameIntrigueDiscard -shuffleBuildings = shufflePiles gameBuildingDeck gameBuildingDiscard - -draw :: Lens WaterdeepState WaterdeepState [a] [a] - -> Lens WaterdeepState WaterdeepState [a] [a] - -> Waterdeep (Maybe a) -draw deck discard = do - out <- null <$> use deck - when out $ shufflePiles deck discard - listToMaybe <$> (deck %%= splitAt 1) - -drawQuest = draw gameQuestDeck gameQuestDiscard -drawIntrigue = draw gameIntrigueDeck gameIntrigueDiscard -drawBuilding = draw gameBuildingDeck gameBuildingDiscard - -restockCliffwatchInn :: Waterdeep () -restockCliffwatchInn = do - num <- length <$> use gameCliffwatchInn - when (num < 4) $ do - mq <- drawQuest - case mq of - Nothing -> return () - Just q -> do - gameCliffwatchInn <>= [q] - broadcast $ "Added " ++ (q ^. questTitle) ++ " to Cliffwatch Inn." - restockCliffwatchInn - -restockBuildersHall :: Waterdeep () -restockBuildersHall = do - num <- length <$> use gameBuildersHall - when (num < 3) $ do - mb <- drawBuilding - case mb of - Nothing -> return () - Just b -> do - gameBuildersHall <>= [newBuildingState noPlayerID b] - broadcast $ "Added " ++ (b ^. buildingTitle) ++ " to Builder's Hall." - restockBuildersHall + where startingAgents = case players of { 2 -> 4; 3 -> 3; _ -> 2 } diff --git a/src/Waterdeep/Monad.hs b/src/Waterdeep/Monad.hs deleted file mode 100644 index d4b08c7..0000000 --- a/src/Waterdeep/Monad.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Waterdeep.Monad - ( WaterdeepPrompt(..) - , Waterdeep - , notifyState - , broadcast - , broadcast' - , solicitChoice - , solicitChoice' - , runWaterdeepC - , runWaterdeep - , runWaterdeepM - ) where - -import Waterdeep.Types -import Control.Lens -import Control.Applicative -import Control.Monad -import Control.Monad.Prompt -import Control.Monad.Random -import Control.Monad.State -import Control.Monad.State.Class -import Control.Monad.Trans -import Control.Monad.Trans.State (StateT, runStateT) -import System.Random as R - -data WaterdeepPrompt a where - NotifyState :: WaterdeepState -> WaterdeepPrompt () - Broadcast :: String -> WaterdeepPrompt () - SolicitChoice :: PlayerID -> String -> [(String, a)] -> WaterdeepPrompt a - -newtype Waterdeep a = Waterdeep { runWaterdeep' :: StateT WaterdeepState (Prompt WaterdeepPrompt) a } - -instance Functor Waterdeep where - fmap f (Waterdeep m) = Waterdeep $ fmap f m - -instance Applicative Waterdeep where - pure = Waterdeep . pure - (Waterdeep f) <*> (Waterdeep a) = Waterdeep (f <*> a) - -instance Monad Waterdeep where - return = Waterdeep . return - (Waterdeep m) >>= f = Waterdeep (m >>= runWaterdeep' . f) - -instance MonadState WaterdeepState Waterdeep where - state = Waterdeep . state - -instance MonadRandom Waterdeep where - getRandom = gameStdGen %%= random - getRandomR r = gameStdGen %%= randomR r - getRandoms = randoms <$> (gameStdGen %%= R.split) - getRandomRs r = randomRs r <$> (gameStdGen %%= R.split) - -instance MonadSplit StdGen Waterdeep where - getSplit = gameStdGen %%= R.split - -notifyState :: Waterdeep () -notifyState = get >>= Waterdeep . lift . prompt . NotifyState - -broadcast' :: String -> Waterdeep () -broadcast' s = Waterdeep (lift (prompt (Broadcast s))) - -broadcast :: String -> Waterdeep () -broadcast s = notifyState >> broadcast' s - -solicitChoice' :: PlayerID -> String -> [(String, a)] -> Waterdeep a -solicitChoice' _ _ [] = error "There must be at least one option to choose." -solicitChoice' _ _ [c] = return (snd c) -- only one option, don't bother asking -solicitChoice' p t cs = Waterdeep (lift (prompt (SolicitChoice p t cs))) - -solicitChoice :: PlayerID -> String -> [(String, a)] -> Waterdeep a -solicitChoice _ _ [] = error "There must be at least one option to choose." -solicitChoice _ _ [c] = return (snd c) -- only one option, don't bother asking -solicitChoice p t cs = notifyState >> Waterdeep (lift (prompt (SolicitChoice p t cs))) - -runWaterdeepC :: ((r, WaterdeepState) -> b) -> (forall a. WaterdeepPrompt a -> (a -> b) -> b) -> Waterdeep r -> WaterdeepState -> b -runWaterdeepC r p (Waterdeep m) s = runPromptC r p $ runStateT m s - -runWaterdeep :: (forall a. WaterdeepPrompt a -> a) -> Waterdeep r -> WaterdeepState -> (r, WaterdeepState) -runWaterdeep p (Waterdeep m) s = runPrompt p $ runStateT m s - -runWaterdeepM :: (Monad m) => (forall a. WaterdeepPrompt a -> m a) -> Waterdeep r -> WaterdeepState -> m (r, WaterdeepState) -runWaterdeepM p (Waterdeep m) s = runPromptM p $ runStateT m s diff --git a/src/Waterdeep/Types.hs b/src/Waterdeep/Types.hs index 6f855da..6a754ba 100644 --- a/src/Waterdeep/Types.hs +++ b/src/Waterdeep/Types.hs @@ -1,25 +1,30 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} module Waterdeep.Types - ( PlayerID - , Lord(..) - , Faction(..) - , Building(..) - , Quest(..) - , IntrigueCard(..) - , PlayerState(..) - , BuildingState(..) - , WaterdeepState(..) - , Resource(..) - , QuestType(..) - , IntrigueType(..) - , FactionColor(..) + ( AccumulationType(..) , BonusType(..) - , AccumulationType(..) - , GameAction(..) - , PlotQualifier(..) + , Building(..) + , BuildingState(..) + , Faction(..) + , FactionColor(..) + , GameAction + , IntrigueCard(..) + , IntrigueType(..) + , Lord(..) + , PlayerID + , PlayerState(..) , PlotCondition(..) + , PlotQualifier(..) + , Quest(..) + , QuestType(..) + , Resource(..) + , Waterdeep + , WaterdeepPrompt(..) + , WaterdeepState(..) , lordName , lordQuote , lordBonus @@ -57,7 +62,8 @@ module Waterdeep.Types , buildingAgents , buildingOwner , buildingAccumulation - , gamePlayers + , gameNumberOfPlayers + , gamePlayerStates , gameFirstPlayer , gameCurrentRound , gameCurrentPlayer @@ -74,29 +80,56 @@ module Waterdeep.Types , gameWaterdeepHarbor , gameStdGen , gamePlayer + , gamePlayerName , noPlayerID + , getNextPlayer + , newPlayerState + , newBuildingState + , notifyState + , broadcast + , broadcast' + , solicitChoice + , solicitChoice' + , runWaterdeepC + , runWaterdeep + , runWaterdeepM ) where +import Control.Applicative import Control.Lens +import Control.Monad +import Control.Monad.Prompt +import Control.Monad.Random +import Control.Monad.State +import Control.Monad.State.Class +import Control.Monad.Trans +import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) +import Control.Monad.Trans.State (StateT, runStateT) import Data.IntMap (IntMap) import Data.Map (Map) import Data.Monoid import System.Random (StdGen) +import qualified Data.IntMap as IM +import qualified Data.Map as M +import qualified System.Random as R + type PlayerID = Int +type GameAction = PlayerID -> Waterdeep () + data Lord = Lord { _lordName :: String , _lordQuote :: String , _lordBonus :: BonusType - } deriving (Show) + } data Faction = Faction { _factionName :: String , _factionColor :: FactionColor - } deriving (Show) + } data Building = Building @@ -105,7 +138,7 @@ data Building = , _buildingAction :: GameAction , _buildingOwnerAction :: GameAction , _buildingAccumType :: AccumulationType - } deriving (Show) + } data Quest = Quest @@ -114,7 +147,7 @@ data Quest = , _questQuote :: String , _questAction :: GameAction , _questPlotActions :: [(PlotCondition, GameAction)] - } deriving (Show) + } data IntrigueCard = IntrigueCard @@ -122,7 +155,7 @@ data IntrigueCard = , _intrigueType :: IntrigueType , _intrigueAction :: GameAction , _intrigueQuote :: String - } deriving (Show) + } data PlayerState = PlayerState @@ -140,7 +173,7 @@ data PlayerState = , _playerAgentsInPool :: Int , _playerHasLieutenant :: Bool , _playerHasAmbassador :: Bool - } deriving (Show) + } data BuildingState = BuildingState @@ -148,11 +181,12 @@ data BuildingState = , _buildingAgents :: [PlayerID] , _buildingOwner :: PlayerID , _buildingAccumulation :: Int - } deriving (Show) + } data WaterdeepState = WaterdeepState - { _gamePlayers :: IntMap PlayerState + { _gamePlayerStates :: IntMap PlayerState + , _gameNumberOfPlayers :: Int , _gameFirstPlayer :: PlayerID , _gameCurrentRound :: Int , _gameCurrentPlayer :: PlayerID @@ -168,7 +202,7 @@ data WaterdeepState = , _gameBuildings :: [BuildingState] , _gameWaterdeepHarbor :: ([PlayerID], [PlayerID], [PlayerID]) , _gameStdGen :: StdGen - } deriving (Show) + } data Resource = Cleric | Fighter | Rogue | Wizard | Gold deriving (Eq,Ord,Enum,Bounded,Show) @@ -191,48 +225,6 @@ data AccumulationType = NoAccumulation | AccumulateResource Resource Int deriving (Eq,Show) -data GameAction = NoAction - | ScorePoints Int - | TakeResources Int [Resource] - | ReturnResources Int [Resource] - | GiveResources Int [Resource] - | ChooseQuest - | ReplaceQuests - | DrawQuest - | DrawNamedQuestType - | DistributeQuests - | CompleteQuest - | ChooseAndCompleteQuest GameAction - | DiscardUncompletedQuest - | BuyBuilding - | ChooseFreeBuilding - | DrawFreeBuilding - | DiscardUnoccupiedBuilding - | DrawIntrigue - | PlayIntrigue - | ReturnAgent - | ReturnAgentFromHarbor - | AssignAgent - | AssignAgentToBuildersHall - | AssignAgentToOpponentsSpace - | UseOpponentsSpace - | GainLieutenant - | GainAmbassador - | TakeAccumulated - | AssignMandatoryQuest Quest - | BecomeFirstPlayer - | ChooseOne [GameAction] - | Then GameAction GameAction - | OrElse GameAction GameAction - | ForEachBuilding GameAction - | ForEachControlledBuilding GameAction - | OneOpponent GameAction - | EachOpponent GameAction - | CurrentPlayer GameAction - deriving (Show) -infixr 7 `Then` -infixr 3 `OrElse` - data PlotQualifier = ActionProvides [Resource] | CompletesQuest [QuestType] | PlaysIntrigue @@ -245,6 +237,13 @@ data PlotCondition = StartOfRound | Whenever PlotQualifier deriving (Eq,Show) +data WaterdeepPrompt a where + NotifyState :: WaterdeepState -> WaterdeepPrompt () + Broadcast :: String -> WaterdeepPrompt () + SolicitChoice :: PlayerID -> String -> [(String, a)] -> WaterdeepPrompt a + +newtype Waterdeep a = Waterdeep { runWaterdeep' :: StateT WaterdeepState (MaybeT (Prompt WaterdeepPrompt)) a } + makeLenses ''Lord makeLenses ''Faction makeLenses ''Building @@ -254,13 +253,6 @@ makeLenses ''PlayerState makeLenses ''BuildingState makeLenses ''WaterdeepState -gamePlayer :: PlayerID -> Lens' WaterdeepState PlayerState -gamePlayer n = lens (\w -> w ^. gamePlayers.singular (ix n)) - (\w p -> w & gamePlayers.singular (ix n) .~ p) - -noPlayerID :: PlayerID -noPlayerID = 0 - instance Eq Faction where a == b = a^.factionColor == b^.factionColor @@ -276,9 +268,100 @@ instance Eq Building where instance Eq IntrigueCard where a == b = a^.intrigueTitle == b^.intrigueTitle -instance Monoid GameAction where - mempty = NoAction - NoAction `mappend` x = x - x `mappend` NoAction = x - (x `Then` y) `mappend` z = x `Then` (y `mappend` z) - x `mappend` y = x `Then` y +instance Functor Waterdeep where + fmap f (Waterdeep m) = Waterdeep $ fmap f m + +instance Applicative Waterdeep where + pure = Waterdeep . pure + (Waterdeep f) <*> (Waterdeep a) = Waterdeep (f <*> a) + +instance Monad Waterdeep where + return = Waterdeep . return + (Waterdeep m) >>= f = Waterdeep (m >>= runWaterdeep' . f) + fail = Waterdeep . fail + +instance MonadPlus Waterdeep where + mzero = Waterdeep mzero + (Waterdeep m) `mplus` (Waterdeep n) = Waterdeep (m `mplus` n) + +instance MonadState WaterdeepState Waterdeep where + state = Waterdeep . state + +instance MonadRandom Waterdeep where + getRandom = gameStdGen %%= random + getRandomR r = gameStdGen %%= randomR r + getRandoms = randoms <$> (gameStdGen %%= R.split) + getRandomRs r = randomRs r <$> (gameStdGen %%= R.split) + +instance MonadSplit StdGen Waterdeep where + getSplit = gameStdGen %%= R.split + +gamePlayer :: PlayerID -> Lens' WaterdeepState PlayerState +gamePlayer n = gamePlayerStates . singular (ix n) + +gamePlayerName :: PlayerID -> Lens' WaterdeepState String +gamePlayerName n = gamePlayer n . playerName + +getNextPlayer :: PlayerID -> Waterdeep PlayerID +getNextPlayer p = do + np <- use gameNumberOfPlayers + return $ (p `mod` np) + 1 + +noPlayerID :: PlayerID +noPlayerID = 0 + +newPlayerState :: PlayerID -> (String, Faction, Lord) -> PlayerState +newPlayerState i (name, faction, lord) = + PlayerState + { _playerNumber = i + , _playerName = name + , _playerFaction = faction + , _playerLord = lord + , _playerScore = 0 + , _playerTavern = M.empty + , _playerIncompleteQuests = [] + , _playerCompletedQuests = [] + , _playerActivePlotQuests = [] + , _playerUsedPlotQuests = [] + , _playerIntrigueCards = [] + , _playerAgentsInPool = 0 + , _playerHasLieutenant = False + , _playerHasAmbassador = False + } + +newBuildingState :: PlayerID -> Building -> BuildingState +newBuildingState p b = + BuildingState + { _building = b + , _buildingOwner = p + , _buildingAgents = [] + , _buildingAccumulation = 0 + } + +notifyState :: Waterdeep () +notifyState = get >>= Waterdeep . lift . lift . prompt . NotifyState + +broadcast' :: String -> Waterdeep () +broadcast' s = Waterdeep (lift (lift (prompt (Broadcast s)))) + +broadcast :: String -> Waterdeep () +broadcast s = notifyState >> 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)))) + +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 + +runWaterdeep :: (forall a. WaterdeepPrompt a -> a) -> Waterdeep r -> WaterdeepState -> Maybe (r, WaterdeepState) +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 diff --git a/src/Waterdeep/Util.hs b/src/Waterdeep/Util.hs index dcc5d8c..4f91c79 100644 --- a/src/Waterdeep/Util.hs +++ b/src/Waterdeep/Util.hs @@ -1,8 +1,12 @@ module Waterdeep.Util ( mrepeat , deleteAt + , on + , nubOn + , sortOn ) where +import Data.List import Data.Monoid mrepeat :: (Monoid m) => Int -> m -> m @@ -10,3 +14,12 @@ mrepeat n m = mconcat $ replicate n m deleteAt :: Int -> [a] -> [a] deleteAt n l = (take n l) ++ (drop (n + 1) l) + +on :: (b -> b -> c) -> (a -> b) -> (a -> a -> c) +(f `on` g) a b = (g a) `f` (g b) + +nubOn :: Eq b => (a -> b) -> [a] -> [a] +nubOn f = nubBy ((==) `on` f) + +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = sortBy (compare `on` f)