use monadic actions for GameAction in place of pattern matching

src/ConsoleUI.hs

@@ -3,9 +3,8 @@
 {-# LANGUAGE RankNTypes      #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-import Waterdeep.Types
+module Main (main) where
-import Waterdeep.Monad
+
-import Waterdeep.Logic
 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]
+           , _questAction = \p -> do
-                         <> ReturnResources 1 [Rogue]
+                  returnResources 1 [Cleric] p
-                         <> ReturnResources 1 [Rogue]
+                  returnResources 1 [Rogue] p
-                         <> ReturnResources 1 [Wizard]
+                  returnResources 1 [Rogue] p
-                         <> ReturnResources 4 [Gold]
+                  returnResources 1 [Wizard] p
-                         <> ScorePoints 15
+                  returnResources 4 [Gold] p
-                         <> TakeResources 8 [Gold]
+                  scorePoints 15 p
+                  takeResources 8 [Gold] p
            , _questPlotActions = []
            }
 
 q2 = Quest { _questType = Skullduggery
            , _questTitle = "Rob Waterdeep Bank"
            , _questQuote = ""
-           , _questAction = ReturnResources 8 [Rogue]
+           , _questAction = \p -> do
-                         <> ScorePoints 10
+                  returnResources 8 [Rogue] p
-                         <> TakeResources 16 [Gold]
+                  scorePoints 10 p
+                  takeResources 16 [Gold] p
            , _questPlotActions = []
            }
 
 b1 = Building { _buildingCost = 6
               , _buildingTitle = "Monastary"
-              , _buildingAction = TakeResources 2 [Cleric]
+              , _buildingAction = takeResources 2 [Cleric]
-              , _buildingOwnerAction = TakeResources 1 [Cleric]
+              , _buildingOwnerAction = takeResources 1 [Cleric]
               , _buildingAccumType = NoAccumulation
               }
 
 b2 = Building { _buildingCost = 4
               , _buildingTitle = "Training Hall"
-              , _buildingAction = TakeResources 2 [Fighter]
+              , _buildingAction = takeResources 2 [Fighter]
-              , _buildingOwnerAction = TakeResources 1 [Fighter]
+              , _buildingOwnerAction = takeResources 1 [Fighter]
               , _buildingAccumType = NoAccumulation
               }
 
 b3 = Building { _buildingCost = 4
               , _buildingTitle = "Prison Yard"
-              , _buildingAction = TakeResources 2 [Rogue]
+              , _buildingAction = takeResources 2 [Rogue]
-              , _buildingOwnerAction = TakeResources 1 [Rogue]
+              , _buildingOwnerAction = takeResources 1 [Rogue]
               , _buildingAccumType = NoAccumulation
               }
 
 b4 = Building { _buildingCost = 6
               , _buildingTitle = "Wizard School"
-              , _buildingAction = TakeResources 2 [Wizard]
+              , _buildingAction = takeResources 2 [Wizard]
-              , _buildingOwnerAction = TakeResources 1 [Wizard]
+              , _buildingOwnerAction = takeResources 1 [Wizard]
               , _buildingAccumType = NoAccumulation
               }
 
 b5 = Building { _buildingCost = 4
               , _buildingTitle = "Gold Mine"
-              , _buildingAction = TakeResources 4 [Gold]
+              , _buildingAction = takeResources 4 [Gold]
-              , _buildingOwnerAction = TakeResources 2 [Gold]
+              , _buildingOwnerAction = takeResources 2 [Gold]
               , _buildingAccumType = NoAccumulation
               }
 
 i1 = IntrigueCard { _intrigueTitle  = "Graduation Day"
                   , _intrigueType   = Utility
-                  , _intrigueAction = TakeResources 2 [Wizard]
+                  , _intrigueAction = \p -> do
-                                   <> OneOpponent (TakeResources 1 [Wizard])
+                        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]
+                  , _intrigueAction = \p -> do
-                                   <> OneOpponent (TakeResources 1 [Cleric, Fighter, Rogue, Wizard])
+                        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
+   forM_ playerStates $ \p -> do
-      putStrLn ((p ^. playerName) ++ "'s State (" ++
+      printf "%s's State (%s):\n" (p ^. playerName)
-         show (p ^.  playerFaction . factionColor) ++ "):")
+         (show (p ^.  playerFaction . factionColor))
       putStrLn ("  Score:      " ++ show (p ^.  playerScore))
-      putStrLn ("  Tavern:     " ++      (p ^.  playerTavern  . to showTavern))
+      putStrLn ("  Tavern:     " ++ (p ^.  playerTavern  . to showTavern))
-      putStrLn ("  Incomplete: " ++ show (p ^.. playerIncompleteQuests . traverse . questTitle))
+      putStrLn ("  Incomplete: " ++ showItems (p ^.. playerIncompleteQuests . traverse . questTitle))
-      putStrLn ("  Complete:   " ++ show (p ^.. playerCompletedQuests  . traverse . questTitle))
+      putStrLn ("  Complete:   " ++ showItems (p ^.. playerCompletedQuests  . traverse . questTitle))
-      putStrLn ("  Intrigues:  " ++ show (p ^.. playerIntrigueCards    . traverse . intrigueTitle))
+      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
+printMenu :: [String] -> IO ()
-      forM_ (zip [1..] cs) $ \(i, (c, _)) -> menuLine i c
+printMenu cs = do
-
+   let n   = length cs
-      putStr (w ^. gamePlayer p . playerName)
+   let h   = (n `div` 3) `max` 5
-      putStr "> " >> hFlush stdout
+   let cw  = (maximum $ map length cs)
-      response <- getLine
+   let cs' = map (take cw . (++ (repeat ' '))) cs
-
+   let (c1, cs'') = splitAt h cs'
-      case reads response of
+   let (c2, c3)   = splitAt h cs''
-         (ix,""):_ | ix >= 1 && ix <= menuSize ->
+   let rows = zipWith3 (\a b c -> a ++ "  " ++ b ++ "  " ++ c)
-            blankLine >> return (snd $ cs !! (ix-1))
+                       c1 (c2 ++ repeat "") (c3 ++ repeat "")
-         _ -> redo
+   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))

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

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
+newGame players quests intrigues buildings rndgen =
-   | length players < 2 || length players > 5 =
+   WaterdeepState
-      error "This game requires 2-5 players."
+      { _gameNumberOfPlayers   = length players
-   | otherwise =
+      , _gamePlayerStates      = IM.fromAscList playerStates
-      WaterdeepState
+      , _gameFirstPlayer       = 1
-         { _gamePlayers           = IM.fromAscList playerStates
+      , _gameCurrentRound      = 0
-         , _gameFirstPlayer       = 1
+      , _gameCurrentPlayer     = noPlayerID
-         , _gameCurrentRound      = 0
+      , _gameConsecutivePasses = 0
-         , _gameCurrentPlayer     = noPlayerID
+      , _gameQuestDeck         = []
-         , _gameConsecutivePasses = 0
+      , _gameQuestDiscard      = quests
-         , _gameQuestDeck         = []
+      , _gameCliffwatchInn     = []
-         , _gameQuestDiscard      = quests
+      , _gameIntrigueDeck      = []
-         , _gameCliffwatchInn     = []
+      , _gameIntrigueDiscard   = intrigues
-         , _gameIntrigueDeck      = []
+      , _gameBuildingDeck      = []
-         , _gameIntrigueDiscard   = intrigues
+      , _gameBuildingDiscard   = buildings
-         , _gameBuildingDeck      = []
+      , _gameBuildersHall      = []
-         , _gameBuildingDiscard   = buildings
+      , _gameBuildings         = map (newBuildingState noPlayerID) basicBuildings
-         , _gameBuildersHall      = []
+      , _gameWaterdeepHarbor   = ([], [], [])
-         , _gameBuildings         = map (newBuildingState noPlayerID) basicBuildings
+      , _gameStdGen            = rndgen
-         , _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 "Aurora's Realms Shop" (takeResources 4 [Gold])
-   , basicBuilding "Blackstaff Tower" (TakeResources 1 [Wizard])
+   , basicBuilding "Blackstaff Tower" (takeResources 1 [Wizard])
-   , basicBuilding "Builder's Hall" BuyBuilding
+   , basicBuilding "Builder's Hall" buyBuilding
-   , basicBuilding "Castle Waterdeep" (BecomeFirstPlayer <> DrawIntrigue)
+   , basicBuilding "Castle Waterdeep" (\p -> becomeFirstPlayer p >> drawIntrigue p)
-   , basicBuilding "Field of Triumph" (TakeResources 2 [Fighter])
+   , basicBuilding "Field of Triumph" (takeResources 2 [Fighter])
-   , basicBuilding "The Grinning Lion Tavern" (TakeResources 2 [Rogue])
+   , basicBuilding "The Grinning Lion Tavern" (takeResources 2 [Rogue])
-   , basicBuilding "The Plinth" (TakeResources 1 [Cleric])
+   , basicBuilding "The Plinth" (takeResources 1 [Cleric])
-   , basicBuilding "Cliffwatch Inn (2 Gold)" (ChooseQuest <> TakeResources 2 [Gold])
+   , basicBuilding "Cliffwatch Inn (2 Gold)" (\p -> chooseQuest p >> takeResources 2 [Gold] p)
-   , basicBuilding "Cliffwatch Inn (Intrigue)" (ChooseQuest <> DrawIntrigue)
+   , basicBuilding "Cliffwatch Inn (Intrigue)" (\p -> chooseQuest p >> drawIntrigue p)
-   , basicBuilding "Cliffwatch Inn (Reset)" (ReplaceQuests <> ChooseQuest)
+   , 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
+   forM_ [1..np] $ \p -> do
-      replicateM_ 2 $ performAction p DrawQuest
+      replicateM_ 2 $ drawQuest p
-      replicateM_ 2 $ performAction p DrawIntrigue
+      replicateM_ 2 $ drawIntrigue p
-      performAction p $ TakeResources (3 + p) [Gold]
+      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
+         result <- filterChoices $ assignAgent p
-         case success of
+         case result of
-            True -> do
+            Just () -> do
-               filterChoices $ join $ solicitChoice p "Complete quest?" $
+               filterChoices $ join $ solicitChoice p "Complete a quest?" $
-                  [ ("Yes", performAction p CompleteQuest)
+                  [ ("Yes", completeQuest p)
-                  , ("No",  return True)
+                  , ("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
+   gameWaterdeepHarbor . each .= []
-   forM_ [1..players] $ \p -> do
+   np <- use gameNumberOfPlayers
+   forM_ [1..np] $ \p -> do
       qs <- gamePlayer p . playerUsedPlotQuests <<.= []
       gamePlayer p . playerActivePlotQuests <>= qs
-      gamePlayer p . playerAgentsInPool .= initialAgents players round
+      gamePlayer p . playerAgentsInPool .= initialAgents np round
-   notifyState
+      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
+   where startingAgents = case players of { 2 -> 4; 3 -> 3; _ -> 2 }
-
-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

src/Waterdeep/Monad.hs

@@ -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

src/Waterdeep/Types.hs

@@ -1,25 +1,30 @@
-{-# LANGUAGE RankNTypes      #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE TemplateHaskell       #-}
 
 module Waterdeep.Types 
-   ( PlayerID
+   ( AccumulationType(..)
-   , Lord(..)
-   , Faction(..)
-   , Building(..)
-   , Quest(..)
-   , IntrigueCard(..)
-   , PlayerState(..)
-   , BuildingState(..)
-   , WaterdeepState(..)
-   , Resource(..)
-   , QuestType(..)
-   , IntrigueType(..)
-   , FactionColor(..)
    , BonusType(..)
-   , AccumulationType(..)
+   , Building(..)
-   , GameAction(..)
+   , BuildingState(..)
-   , PlotQualifier(..)
+   , 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
+instance Functor Waterdeep where
-   mempty = NoAction
+   fmap f (Waterdeep m) = Waterdeep $ fmap f m
-   NoAction `mappend` x = x
+
-   x `mappend` NoAction = x
+instance Applicative Waterdeep where
-   (x `Then` y) `mappend` z = x `Then` (y `mappend` z)
+   pure = Waterdeep . pure
-   x `mappend` y = x `Then` y
+   (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

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)