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