326 lines
12 KiB
Haskell
326 lines
12 KiB
Haskell
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE NoMonomorphismRestriction #-}
|
|
|
|
module Waterdeep.Logic
|
|
( newGame
|
|
, waterdeepGame
|
|
) where
|
|
|
|
import Control.Applicative
|
|
import Control.Arrow ((&&&))
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import Control.Monad.Random
|
|
import Control.Monad.State
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.Monoid
|
|
import System.Random.Shuffle
|
|
import Text.Printf
|
|
import Waterdeep.Types
|
|
import Waterdeep.Monad
|
|
|
|
import qualified Data.IntMap as IM
|
|
import qualified Data.Map as M
|
|
|
|
newGame :: [(String,Faction,Lord)]
|
|
-> [Quest]
|
|
-> [IntrigueCard]
|
|
-> [Building]
|
|
-> StdGen
|
|
-> WaterdeepState
|
|
newGame players quests intrigues buildings rndgen
|
|
| length players < 2 || length players > 5 =
|
|
error "This game requires 2-5 players."
|
|
| otherwise =
|
|
WaterdeepState
|
|
{ _gamePlayers = IM.fromAscList playerStates
|
|
, _gameFirstPlayer = 1
|
|
, _gameCurrentRound = 0
|
|
, _gameCurrentPlayer = noPlayerID
|
|
, _gameConsecutivePasses = 0
|
|
, _gameQuestDeck = []
|
|
, _gameQuestDiscard = quests
|
|
, _gameCliffwatchInn = []
|
|
, _gameIntrigueDeck = []
|
|
, _gameIntrigueDiscard = intrigues
|
|
, _gameBuildingDeck = []
|
|
, _gameBuildingDiscard = buildings
|
|
, _gameBasicBuildings = map (newBuildingState noPlayerID) basicBuildings
|
|
, _gameBuildersHall = []
|
|
, _gameAdvancedBuildings = []
|
|
, _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 = []
|
|
|
|
waterdeepGame :: Waterdeep [PlayerID]
|
|
waterdeepGame = do
|
|
ps <- sort . IM.keys <$> use gamePlayers
|
|
restockBuildersHall
|
|
restockCliffwatchInn
|
|
forM_ ps $ \p -> do
|
|
replicateM_ 2 $ performAction p DrawQuest
|
|
replicateM_ 2 $ performAction p DrawIntrigue
|
|
replicateM_ (3 + p) $ performAction p $ TakeResource [Gold]
|
|
forM_ [1..8] $ \round -> do
|
|
beginRound round
|
|
fix $ \loop -> do
|
|
p <- use gameCurrentPlayer
|
|
success <- filterChoices $ performAction p AssignAgent
|
|
case success of
|
|
True -> do
|
|
filterChoices $ performAction p CompleteQuest
|
|
gameCurrentPlayer .= (p `mod` length ps) + 1
|
|
gameConsecutivePasses .= 0
|
|
loop
|
|
False -> do
|
|
passes <- gameConsecutivePasses <+= 1
|
|
when (passes < length ps) loop
|
|
performAction 1 $ TakeResource [Cleric, Fighter, Rogue, Wizard, Gold]
|
|
filterChoices $ performAction 1 $
|
|
ReturnResource [Wizard]
|
|
<> ReturnResource [Cleric, Fighter, Gold]
|
|
<> ReturnResource [Cleric, Fighter]
|
|
<> (ReturnResource [Cleric] `OrElse` TakeResource [Cleric])
|
|
-- performAction 2 $ ChooseQuest
|
|
scoreFinalPoints
|
|
notifyState
|
|
determineWinners
|
|
|
|
beginRound :: Int -> Waterdeep ()
|
|
beginRound round = do
|
|
gameCurrentRound .= round
|
|
gameCurrentPlayer <~ use gameFirstPlayer
|
|
gameBasicBuildings . traverse . buildingAgents .= []
|
|
gameAdvancedBuildings . traverse . buildingAgents .= []
|
|
gameBuildersHall . traverse . buildingAgents .= []
|
|
gameBuildersHall . traverse . buildingAccumulation += 1
|
|
players <- IM.size <$> use gamePlayers
|
|
forM_ [1..players] $ \p -> do
|
|
qs <- gamePlayer p . playerUsedPlotQuests <<.= []
|
|
gamePlayer p . playerActivePlotQuests %= (++ qs)
|
|
gamePlayer p . playerAgentsInPool .= initialAgents players round
|
|
notifyState
|
|
return ()
|
|
|
|
initialAgents :: Int -> Int -> Int
|
|
initialAgents players round =
|
|
if round >= 5 then startingAgents + 1 else startingAgents
|
|
where startingAgents = 6 - players
|
|
|
|
data ContWD a where
|
|
Done :: (a, WaterdeepState) -> ContWD a
|
|
Cont :: WaterdeepPrompt b -> (b -> ContWD a) -> ContWD a
|
|
|
|
-- |Permit only choices which lead to a True result.
|
|
-- Returns False if and only if no such choice exists.
|
|
-- If result is False, state remains unchanged.
|
|
filterChoices :: Waterdeep Bool -> Waterdeep Bool
|
|
filterChoices m = do
|
|
mw' <- filteredChoice [] =<< (runWaterdeepC Done Cont m <$> get)
|
|
case mw' of
|
|
Just (ps,w') -> forM_ ps forwardPrompt >> put w' >> return True
|
|
Nothing -> return False
|
|
where
|
|
tryChoice :: ContWD Bool -> Bool
|
|
tryChoice (Done a) = fst a
|
|
tryChoice (Cont (NotifyState w) cont) = tryChoice $ cont ()
|
|
tryChoice (Cont (Broadcast s) cont) = tryChoice $ cont ()
|
|
tryChoice (Cont (SolicitChoice p t cs) cont) =
|
|
or $ map (tryChoice . cont . snd) cs
|
|
filteredChoice :: [WaterdeepPrompt ()] -> ContWD Bool
|
|
-> Waterdeep (Maybe ([WaterdeepPrompt ()], WaterdeepState))
|
|
filteredChoice ps (Done (a,w)) = if a then return (Just (ps,w)) else return Nothing
|
|
filteredChoice ps (Cont p@(NotifyState w) cont) = filteredChoice (ps++[p]) $ cont ()
|
|
filteredChoice ps (Cont p@(Broadcast s) cont) = filteredChoice (ps++[p]) $ cont ()
|
|
filteredChoice ps (Cont (SolicitChoice p t cs) cont) = do
|
|
let cs' = filter (tryChoice . cont . snd) cs
|
|
if null cs'
|
|
then return Nothing
|
|
else do
|
|
forM_ ps forwardPrompt
|
|
filteredChoice [] =<< (cont <$> solicitChoice p t cs')
|
|
forwardPrompt :: WaterdeepPrompt () -> Waterdeep ()
|
|
forwardPrompt (NotifyState w) = get >>= \w0 -> put w >> notifyState >> put w0
|
|
forwardPrompt (Broadcast s) = broadcast' s
|
|
|
|
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
|
|
TakeResource rs -> do
|
|
r <- solicitChoice p "Take one item:" $ map (show &&& id) rs
|
|
gamePlayer p . playerTavern %= flip (M.unionWith (+)) (M.fromList [(r, 1)])
|
|
broadcast $ name ++ " received one " ++ show r ++ "."
|
|
return True
|
|
ReturnResource rs -> do
|
|
tavern <- use $ gamePlayer p . playerTavern
|
|
let rs' = filter ((> 0) . maybe 0 id . flip M.lookup tavern) rs
|
|
if null rs'
|
|
then return False
|
|
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
|
|
broadcast $ name ++ " returned one " ++ show r ++ " to the supply."
|
|
return True
|
|
ChooseQuest -> do
|
|
qs <- use gameCliffwatchInn
|
|
if null qs
|
|
then return False
|
|
else do
|
|
let names = qs ^.. traverse . questTitle
|
|
q <- solicitChoice p "Please choose a quest:" $ zip names qs
|
|
gameCliffwatchInn %= (\\ [q])
|
|
gamePlayer p . playerIncompleteQuests %= (++ [q])
|
|
broadcast $ name ++ " chose " ++ (q ^. questTitle) ++ " from Cliffwatch Inn."
|
|
restockCliffwatchInn
|
|
return True
|
|
DrawQuest -> do
|
|
mq <- drawQuest
|
|
case mq of
|
|
Nothing -> return False
|
|
Just q -> do
|
|
gamePlayer p . playerIncompleteQuests %= (++[q])
|
|
broadcast $ name ++ " drew " ++ (q ^. questTitle) ++ " from the quest deck."
|
|
return True
|
|
DrawIntrigue -> do
|
|
mi <- drawIntrigue
|
|
case mi of
|
|
Nothing -> return False
|
|
Just i -> do
|
|
gamePlayer p . playerIntrigueCards %= (++[i])
|
|
return True
|
|
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
|
|
_ -> return False
|
|
|
|
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 gameAdvancedBuildings
|
|
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
|