459 lines
17 KiB
Haskell
459 lines
17 KiB
Haskell
{-# 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
|
|
) 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
|
|
import qualified Data.MultiSet as MS
|
|
|
|
noAction :: GameAction
|
|
noAction = return ()
|
|
|
|
scorePoints :: Int -> GameAction
|
|
scorePoints n = do
|
|
activePlayerState . playerScore += n
|
|
name <- use activePlayerName
|
|
broadcast $ printf "%s scored %d points." name n
|
|
|
|
takeResources :: Int -> [Resource] -> GameAction
|
|
takeResources n rs = do
|
|
received <- map (head &&& length) . group . sort <$$> replicateM n $ do
|
|
r <- solicitChoice "Take one item:" $ map (show &&& id) rs
|
|
activePlayerState . playerTavern <>= MS.singleton r
|
|
return r
|
|
let items = joinStrings $ map (\(r,n) -> show n ++ " " ++ show r) received
|
|
name <- use $ activePlayerName
|
|
broadcast $ printf "%s received %s." name items
|
|
|
|
returnResources :: Int -> [Resource] -> GameAction
|
|
returnResources n rs = do
|
|
returned <- replicateM n $ do
|
|
r <- solicitChoice "Return one item:" $ map (show &&& id) rs
|
|
guard . (r `MS.member`) =<< use (activePlayerState . playerTavern)
|
|
activePlayerState . playerTavern %= (`MS.difference` MS.singleton r)
|
|
return r
|
|
let groups = map (head &&& length) $ group returned
|
|
let items = joinStrings $ map (\(r,n) -> show n ++ " " ++ show r) groups
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " returned " ++ items ++ " to the supply."
|
|
|
|
chooseQuest' :: Waterdeep Quest
|
|
chooseQuest' = do
|
|
choices <- zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] <$> use gameCliffwatchInn
|
|
(i, quest) <- solicitChoice "Choose one quest:" $ nubOn fst choices
|
|
gameCliffwatchInn %= deleteAt i
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " chose " ++ (quest ^. questTitle) ++ " from Cliffwatch Inn."
|
|
restockCliffwatchInn
|
|
return quest
|
|
|
|
chooseQuest :: GameAction
|
|
chooseQuest = do
|
|
quest <- chooseQuest'
|
|
activePlayerState . playerIncompleteQuests <>= [quest]
|
|
return ()
|
|
|
|
replaceQuests :: GameAction
|
|
replaceQuests = do
|
|
quests <- gameCliffwatchInn <<.= []
|
|
gameQuestDiscard <>= quests
|
|
restockCliffwatchInn
|
|
|
|
drawQuest :: GameAction
|
|
drawQuest = do
|
|
Just q <- drawQuest'
|
|
name <- use $ activePlayerName
|
|
activePlayerState . playerIncompleteQuests <>= [q]
|
|
broadcast $ printf "%s drew %s from the quest deck." name (q ^. questTitle)
|
|
|
|
drawNamedQuestType :: GameAction
|
|
drawNamedQuestType = do
|
|
let qtypes = [Piety, Warfare, Skullduggery, Arcana, Commerce]
|
|
qtype <- solicitChoice "Choose a quest type:" $ map (show &&& id) qtypes
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " chose the " ++ (show qtype) ++ " quest type."
|
|
flip fix [] $ \loop discards -> do
|
|
mq <- drawQuest'
|
|
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
|
|
activePlayerState . playerIncompleteQuests <>= [q]
|
|
return ()
|
|
|
|
distributeQuests :: GameAction
|
|
distributeQuests = do
|
|
let distribute remQuests = unless (null remQuests) $ do
|
|
let choices = zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] remQuests
|
|
(i, quest) <- solicitChoice "Choose a quest:" $ nubOn fst choices
|
|
activePlayerState . playerIncompleteQuests <>= [quest]
|
|
name <- use $ activePlayerName
|
|
broadcast $ printf "%s chose the %s quest." name (quest ^. questTitle)
|
|
p' <- getNextPlayer =<< use gameActivePlayer
|
|
withActivePlayer p' $ distribute (deleteAt i remQuests)
|
|
distribute =<< catMaybes <$> (flip replicateM drawQuest' =<< use gameNumberOfPlayers)
|
|
|
|
completeQuest :: GameAction
|
|
completeQuest = do
|
|
quests <- zip [0..] <$> use (activePlayerState . playerIncompleteQuests)
|
|
let mandatoryQuests = filter ((== Mandatory) . view questType . snd) quests
|
|
let availQuests = if null mandatoryQuests then quests else mandatoryQuests
|
|
let choices = map (\(i,q) -> (q ^. questTitle, (i, q))) availQuests
|
|
(i, quest) <- solicitChoice "Complete one quest:" $ nubOn fst choices
|
|
activePlayerState . playerIncompleteQuests %= deleteAt i
|
|
quest ^. questAction
|
|
if null (quest ^. questPlotActions)
|
|
then activePlayerState . playerCompletedQuests <>= [quest]
|
|
else activePlayerState . playerActivePlotQuests <>= [quest]
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest."
|
|
|
|
chooseAndCompleteQuest :: GameAction -> GameAction
|
|
chooseAndCompleteQuest bonusAction = do
|
|
quest <- chooseQuest'
|
|
doQuest <- solicitChoice "Complete this quest immediately?"
|
|
[("Yes", True), ("No", False)]
|
|
case doQuest of
|
|
True -> do
|
|
incompleteQuests <- use (activePlayerState . playerIncompleteQuests)
|
|
guard . not . or $ map ((== Mandatory) . view questType) incompleteQuests
|
|
quest ^. questAction
|
|
if null (quest ^. questPlotActions)
|
|
then activePlayerState . playerCompletedQuests <>= [quest]
|
|
else activePlayerState . playerActivePlotQuests <>= [quest]
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " completed the " ++ (quest ^. questTitle) ++ " quest."
|
|
bonusAction
|
|
False -> do
|
|
activePlayerState . playerIncompleteQuests <>= [quest]
|
|
return ()
|
|
|
|
discardUncompletedQuest :: GameAction
|
|
discardUncompletedQuest = do
|
|
choices <- zipWith (\i q -> (q ^. questTitle, (i, q))) [0..] <$>
|
|
use (activePlayerState . playerIncompleteQuests)
|
|
(i, quest) <- solicitChoice "Choose a quest to discard:" $ nubOn fst choices
|
|
activePlayerState . playerIncompleteQuests %= deleteAt i
|
|
gameQuestDiscard <>= [quest]
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " discarded the " ++ (quest ^. questTitle) ++ " quest."
|
|
|
|
buyBuilding :: GameAction
|
|
buyBuilding = do
|
|
let label b = printf "%s (%d Gold, %d Points)"
|
|
(b ^. building . buildingTitle)
|
|
(b ^. building . buildingCost)
|
|
(b ^. buildingAccumulation)
|
|
choices <- zipWith (\i b -> (label b, (i, b))) [0..] <$> use gameBuildersHall
|
|
(i, b) <- solicitChoice "Choose a building from Builder's Hall:" $ nubOn fst choices
|
|
let cost = b ^. building . buildingCost
|
|
returnResources cost [Gold]
|
|
scorePoints (b ^. buildingAccumulation)
|
|
gameBuildersHall %= deleteAt i
|
|
p <- use gameActivePlayer
|
|
gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0]
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ "."
|
|
restockBuildersHall
|
|
|
|
chooseFreeBuilding :: GameAction
|
|
chooseFreeBuilding = do
|
|
let label b = printf "%s (%d Points)"
|
|
(b ^. building . buildingTitle)
|
|
(b ^. buildingAccumulation)
|
|
choices <- zipWith (\i b -> (label b, (i, b))) [0..] <$> use gameBuildersHall
|
|
(i, b) <- solicitChoice "Choose a building from Builder's Hall:" $ nubOn fst choices
|
|
scorePoints (b ^. buildingAccumulation)
|
|
gameBuildersHall %= deleteAt i
|
|
p <- use gameActivePlayer
|
|
gameBuildings <>= [b & buildingOwner .~ p & buildingAccumulation .~ 0]
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " built the " ++ (b ^. building . buildingTitle) ++ " for free."
|
|
restockBuildersHall
|
|
|
|
drawFreeBuilding :: GameAction
|
|
drawFreeBuilding = do
|
|
Just b <- drawBuilding'
|
|
p <- use gameActivePlayer
|
|
gameBuildings <>= [newBuildingState p b]
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " built the " ++ (b ^. buildingTitle) ++ " for free."
|
|
|
|
discardUnoccupiedBuilding :: GameAction
|
|
discardUnoccupiedBuilding = do
|
|
allBuildings <- zip [0..] <$> use gameBuildings
|
|
p <- use gameActivePlayer
|
|
let ownedBuildings = filter ((== p) . view buildingOwner . snd) allBuildings
|
|
let emptyBuildings = filter (null . view buildingAgents . snd) ownedBuildings
|
|
let choices = map (\(i,b) -> (b ^. building . buildingTitle, (i, b))) emptyBuildings
|
|
(i, b) <- solicitChoice "Choose a building to discard:" $ nubOn fst choices
|
|
gameBuildings %= deleteAt i
|
|
gameBuildingDiscard <>= [b ^. building]
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " discarded the " ++ (b ^. building . buildingTitle) ++ "."
|
|
|
|
drawIntrigue :: GameAction
|
|
drawIntrigue = do
|
|
Just ic <- drawIntrigue'
|
|
activePlayerState . playerIntrigueCards <>= [ic]
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " drew an Intrigue card."
|
|
|
|
playIntrigue :: GameAction
|
|
playIntrigue = do
|
|
choices <- zipWith (\i ic -> (ic ^. intrigueTitle, (i, ic))) [0..] <$>
|
|
use (activePlayerState . playerIntrigueCards)
|
|
(i, intrigue) <- solicitChoice "Play one intrigue card:" $ nubOn fst choices
|
|
activePlayerState . playerIntrigueCards %= deleteAt i
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " played the " ++ (intrigue ^. intrigueTitle) ++ " Intrigue card."
|
|
intrigue ^. intrigueAction
|
|
gameIntrigueDiscard <>= [intrigue]
|
|
return ()
|
|
|
|
returnAgent :: GameAction
|
|
returnAgent = return () -- TODO
|
|
|
|
returnAgentFromHarbor :: GameAction
|
|
returnAgentFromHarbor = return () -- TODO
|
|
|
|
assignAgentToBuilding :: Lens' WaterdeepState BuildingState -> Waterdeep ()
|
|
assignAgentToBuilding bl = do
|
|
activePlayerState . playerAgentsInPool -= 1
|
|
p <- use gameActivePlayer
|
|
bl . buildingAgents <>= [p]
|
|
name <- use $ activePlayerName
|
|
bName <- use (bl . building . buildingTitle)
|
|
broadcast $ name ++ " assigned an agent to " ++ bName ++ "."
|
|
owner <- use (bl . buildingOwner)
|
|
when (owner `notElem` [noPlayerID, p]) $
|
|
withActivePlayer owner =<< use (bl . building . buildingOwnerAction)
|
|
join $ use (bl . building . buildingAction)
|
|
|
|
assignAgentToHarbor :: Lens' ([PlayerID], [PlayerID], [PlayerID]) [PlayerID] -> Waterdeep ()
|
|
assignAgentToHarbor l = do
|
|
activePlayerState . playerAgentsInPool -= 1
|
|
p <- use gameActivePlayer
|
|
gameWaterdeepHarbor . l <>= [p]
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " assigned an agent to Waterdeep Harbor."
|
|
playIntrigue
|
|
|
|
assignAgent :: GameAction
|
|
assignAgent = do
|
|
agents <- use (activePlayerState . 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)]
|
|
case w ^. gameWaterdeepHarbor of
|
|
([], _, _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _1)]
|
|
(_, [], _) -> tell [("Waterdeep Harbor", assignAgentToHarbor _2)]
|
|
(_, _, []) -> tell [("Waterdeep Harbor", assignAgentToHarbor _3)]
|
|
_ -> return ()
|
|
join $ solicitChoice "Assign one agent to:" $ nubOn fst buildings
|
|
|
|
assignAgentToBuildersHall :: GameAction
|
|
assignAgentToBuildersHall = return () -- TODO
|
|
|
|
assignAgentToOpponentsSpace :: GameAction
|
|
assignAgentToOpponentsSpace = return () -- TODO
|
|
|
|
useOpponentsSpace :: GameAction
|
|
useOpponentsSpace = return () -- TODO
|
|
|
|
gainLieutenant :: GameAction
|
|
gainLieutenant = do
|
|
activePlayerState . playerHasLieutenant .= True
|
|
activePlayerState . playerAgentsInPool += 1
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " gained the Lieutenant."
|
|
return ()
|
|
|
|
gainAmbassador :: GameAction
|
|
gainAmbassador = do
|
|
guard . not . or . toListOf (traverse . playerHasAmbassador) =<< use gamePlayerStates
|
|
gameBuildings . each . buildingAgents %= (\\ [noPlayerID])
|
|
gameWaterdeepHarbor . each %= (\\ [noPlayerID])
|
|
activePlayerState . playerHasAmbassador .= True
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " gained the Ambassador."
|
|
|
|
assignMandatoryQuest :: Quest -> GameAction
|
|
assignMandatoryQuest quest = do
|
|
name <- use $ activePlayerName
|
|
opponents <- getOpponents
|
|
let choices = map (view playerName &&& (view playerNumber &&& view playerName)) opponents
|
|
(opID, opName) <- solicitChoice "Choose one opponent:" choices
|
|
gamePlayerState opID . playerIncompleteQuests <>= [quest]
|
|
broadcast $ name ++ " assigned " ++ opName ++ " a mandatory quest."
|
|
|
|
becomeFirstPlayer :: GameAction
|
|
becomeFirstPlayer = do
|
|
gameFirstPlayer <~ use gameActivePlayer
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " is now the first player."
|
|
|
|
forOneOpponent :: GameAction -> GameAction
|
|
forOneOpponent a1 = do
|
|
opponents <- getOpponents
|
|
let choices = map (view playerName &&& (view playerNumber &&& view playerName)) opponents
|
|
(opID, opName) <- solicitChoice "Choose one opponent:" choices
|
|
name <- use $ activePlayerName
|
|
broadcast $ name ++ " chose " ++ opName ++ "."
|
|
withActivePlayer opID a1
|
|
|
|
forEachOpponent :: GameAction -> GameAction
|
|
forEachOpponent a1 = do
|
|
opponents <- getOpponents
|
|
forM_ opponents $ \op -> withActivePlayer (op ^. playerNumber) a1
|
|
|
|
forCurrentPlayer :: GameAction -> GameAction
|
|
forCurrentPlayer a1 = do
|
|
p <- use gameCurrentPlayer
|
|
withActivePlayer p a1
|
|
|
|
-- Like (<$>), but with the same fixity and precedence as ($)
|
|
(<$$>) :: Applicative f => (a -> b) -> f a -> f b
|
|
(<$$>) = (<$>)
|
|
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 :: Waterdeep [PlayerState]
|
|
getOpponents = do
|
|
p <- use gameActivePlayer
|
|
filter (\p1 -> (p1 ^. playerNumber) /= p) . toListOf traverse <$> use gamePlayerStates
|
|
|
|
getNumberOfBuildings :: Waterdeep Int
|
|
getNumberOfBuildings =
|
|
length . filter (\b -> b ^. buildingOwner /= noPlayerID) <$> use gameBuildings
|
|
|
|
getNumberOfControlledBuildings :: Waterdeep Int
|
|
getNumberOfControlledBuildings = do
|
|
p <- use gameActivePlayer
|
|
length . filter (\b -> b ^. buildingOwner == p) <$> use gameBuildings
|