477 lines
15 KiB
Haskell
477 lines
15 KiB
Haskell
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Waterdeep.Types
|
|
( AccumulationType(..)
|
|
, BonusType(..)
|
|
, Building(..)
|
|
, BuildingState(..)
|
|
, Faction(..)
|
|
, FactionColor(..)
|
|
, GameAction
|
|
, IntrigueCard(..)
|
|
, IntrigueType(..)
|
|
, Lord(..)
|
|
, PlayerID
|
|
, PlayerState(..)
|
|
, PlotState(..)
|
|
, PlotCondition(..)
|
|
, PlotQualifier(..)
|
|
, Quest(..)
|
|
, QuestType(..)
|
|
, Resource(..)
|
|
, Waterdeep
|
|
, WaterdeepPrompt(..)
|
|
, WaterdeepState(..)
|
|
, ResourceSet
|
|
, lordName
|
|
, lordQuote
|
|
, lordBonus
|
|
, factionName
|
|
, factionColor
|
|
, buildingCost
|
|
, buildingTitle
|
|
, buildingAction
|
|
, buildingOwnerAction
|
|
, buildingAccumType
|
|
, questType
|
|
, questTitle
|
|
, questQuote
|
|
, questCost
|
|
, questReward
|
|
, questPlotActions
|
|
, intrigueTitle
|
|
, intrigueType
|
|
, intrigueAction
|
|
, intrigueQuote
|
|
, playerNumber
|
|
, playerName
|
|
, playerFaction
|
|
, playerLord
|
|
, playerScore
|
|
, playerTavern
|
|
, playerIncompleteQuests
|
|
, playerCompletedQuests
|
|
, playerPlotQuests
|
|
, playerIntrigueCards
|
|
, playerAgentsInPool
|
|
, playerHasLieutenant
|
|
, playerHasAmbassador
|
|
, playerCanUseOpSpace
|
|
, building
|
|
, buildingAgents
|
|
, buildingOwner
|
|
, buildingAccumulation
|
|
, gameNumberOfPlayers
|
|
, gamePlayerStates
|
|
, gameFirstPlayer
|
|
, gameCurrentRound
|
|
, gameCurrentPlayer
|
|
, gameActivePlayer
|
|
, gameConsecutivePasses
|
|
, gameQuestDeck
|
|
, gameQuestDiscard
|
|
, gameCliffwatchInn
|
|
, gameIntrigueDeck
|
|
, gameIntrigueDiscard
|
|
, gameBuildingDeck
|
|
, gameBuildingDiscard
|
|
, gameBuildersHall
|
|
, gameBuildings
|
|
, gameWaterdeepHarbor
|
|
, gameStdGen
|
|
, plotActionState
|
|
, plotCondition
|
|
, plotAction
|
|
, gamePlayerState
|
|
, gamePlayerName
|
|
, activePlayerState
|
|
, activePlayerName
|
|
, withActivePlayer
|
|
, nextPlayerID
|
|
, noPlayerID
|
|
, newPlayerState
|
|
, newBuildingState
|
|
, notifyState
|
|
, broadcast
|
|
, solicitChoice
|
|
, actionProvidedSet
|
|
, actionProvided
|
|
, delimitAction
|
|
, runWaterdeepC
|
|
, runWaterdeep
|
|
, runWaterdeepM
|
|
, canPerformAction
|
|
, filterChoices
|
|
) where
|
|
|
|
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.Writer.Class
|
|
import Control.Monad.Trans
|
|
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
|
|
import Control.Monad.Trans.State (StateT, runStateT)
|
|
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
|
|
import Data.Maybe
|
|
import Data.Monoid
|
|
import Lens.Family2
|
|
import Lens.Family2.State
|
|
import Lens.Family2.Stock
|
|
import Lens.Family2.TH
|
|
import Lens.Family2.Unchecked (lens)
|
|
import System.Random (StdGen)
|
|
|
|
import qualified Data.IntMap as IM
|
|
import qualified Data.MultiSet as MS
|
|
import qualified Data.Set as Set
|
|
import qualified System.Random as R
|
|
|
|
type PlayerID = Int
|
|
|
|
type GameAction = Waterdeep ()
|
|
|
|
data Lord =
|
|
Lord
|
|
{ _lordName :: String
|
|
, _lordQuote :: String
|
|
, _lordBonus :: BonusType
|
|
}
|
|
|
|
data Faction =
|
|
Faction
|
|
{ _factionName :: String
|
|
, _factionColor :: FactionColor
|
|
}
|
|
|
|
data Building =
|
|
Building
|
|
{ _buildingCost :: Int
|
|
, _buildingTitle :: String
|
|
, _buildingAction :: GameAction
|
|
, _buildingOwnerAction :: GameAction
|
|
, _buildingAccumType :: AccumulationType
|
|
}
|
|
|
|
data Quest =
|
|
Quest
|
|
{ _questType :: QuestType
|
|
, _questTitle :: String
|
|
, _questQuote :: String
|
|
, _questCost :: ResourceBag
|
|
, _questReward :: GameAction
|
|
, _questPlotActions :: [(PlotState, PlotCondition, GameAction)]
|
|
}
|
|
|
|
data IntrigueCard =
|
|
IntrigueCard
|
|
{ _intrigueTitle :: String
|
|
, _intrigueType :: IntrigueType
|
|
, _intrigueAction :: GameAction
|
|
, _intrigueQuote :: String
|
|
}
|
|
|
|
data PlayerState =
|
|
PlayerState
|
|
{ _playerNumber :: PlayerID
|
|
, _playerName :: String
|
|
, _playerFaction :: Faction
|
|
, _playerLord :: Lord
|
|
, _playerScore :: Int
|
|
, _playerTavern :: ResourceBag
|
|
, _playerIncompleteQuests :: [Quest]
|
|
, _playerCompletedQuests :: [Quest]
|
|
, _playerPlotQuests :: IM.IntMap Quest
|
|
, _playerIntrigueCards :: [IntrigueCard]
|
|
, _playerAgentsInPool :: Int
|
|
, _playerHasLieutenant :: Bool
|
|
, _playerHasAmbassador :: Bool
|
|
, _playerCanUseOpSpace :: Bool
|
|
}
|
|
|
|
data BuildingState =
|
|
BuildingState
|
|
{ _building :: Building
|
|
, _buildingAgents :: [PlayerID]
|
|
, _buildingOwner :: PlayerID
|
|
, _buildingAccumulation :: Int
|
|
}
|
|
|
|
data WaterdeepState =
|
|
WaterdeepState
|
|
{ _gamePlayerStates :: IM.IntMap PlayerState
|
|
, _gameNumberOfPlayers :: Int
|
|
, _gameFirstPlayer :: PlayerID
|
|
, _gameCurrentRound :: Int
|
|
, _gameCurrentPlayer :: PlayerID
|
|
, _gameActivePlayer :: PlayerID
|
|
, _gameConsecutivePasses :: Int
|
|
, _gameQuestDeck :: [Quest]
|
|
, _gameQuestDiscard :: [Quest]
|
|
, _gameCliffwatchInn :: [Quest]
|
|
, _gameIntrigueDeck :: [IntrigueCard]
|
|
, _gameIntrigueDiscard :: [IntrigueCard]
|
|
, _gameBuildingDeck :: [Building]
|
|
, _gameBuildingDiscard :: [Building]
|
|
, _gameBuildersHall :: IM.IntMap BuildingState
|
|
, _gameBuildings :: IM.IntMap BuildingState
|
|
, _gameWaterdeepHarbor :: IM.IntMap BuildingState
|
|
, _gameReassigningAgents :: Bool
|
|
, _gameStdGen :: StdGen
|
|
}
|
|
|
|
data Resource = Cleric | Fighter | Rogue | Wizard | Gold
|
|
deriving (Eq,Ord,Enum,Bounded,Show)
|
|
|
|
type ResourceSet = Set.Set Resource
|
|
type ResourceBag = MS.MultiSet Resource
|
|
|
|
data QuestType = Piety | Warfare | Skullduggery | Arcana | Commerce | Mandatory
|
|
deriving (Eq,Ord,Enum,Bounded,Show)
|
|
|
|
data IntrigueType = Utility | Attack | MandatoryQuest
|
|
deriving (Eq,Ord,Enum,Bounded,Show)
|
|
|
|
data FactionColor = Yellow | Black | Blue | Green | Red
|
|
deriving (Eq,Ord,Enum,Bounded,Show)
|
|
|
|
data BonusType = QuestBonus [QuestType] Int
|
|
| BuildingBonus Int
|
|
deriving (Eq,Show)
|
|
|
|
data AccumulationType = NoAccumulation
|
|
| AccumulatePoints Int
|
|
| AccumulateResource Resource Int
|
|
deriving (Eq,Show)
|
|
|
|
data PlotState = Active | Used deriving (Eq,Show)
|
|
|
|
data PlotQualifier = ActionProvides Resource
|
|
| CompletesQuest QuestType
|
|
| PlaysIntrigue
|
|
| BuysBuilding
|
|
deriving (Eq,Show)
|
|
|
|
data PlotCondition = Immediately
|
|
| StartOfRound
|
|
| OncePerRoundWhen PlotQualifier
|
|
| Whenever PlotQualifier
|
|
deriving (Eq,Show)
|
|
|
|
data WaterdeepPrompt a where
|
|
NotifyState :: WaterdeepState -> WaterdeepPrompt ()
|
|
Broadcast :: String -> WaterdeepPrompt ()
|
|
SolicitChoice :: PlayerID -> String -> [(String, a)] -> WaterdeepPrompt a
|
|
|
|
data Waterdeep a =
|
|
Waterdeep { unWaterdeep :: WriterT ResourceSet
|
|
(StateT WaterdeepState
|
|
(MaybeT (Prompt WaterdeepPrompt))) a }
|
|
|
|
makeLenses ''Lord
|
|
makeLenses ''Faction
|
|
makeLenses ''Building
|
|
makeLenses ''Quest
|
|
makeLenses ''IntrigueCard
|
|
makeLenses ''PlayerState
|
|
makeLenses ''BuildingState
|
|
makeLenses ''WaterdeepState
|
|
|
|
instance Eq Faction where
|
|
a == b = a^.factionColor == b^.factionColor
|
|
|
|
instance Ord Faction where
|
|
a `compare` b = (a^.factionColor) `compare` (b^.factionColor)
|
|
|
|
instance Eq Quest where
|
|
a == b = a^.questTitle == b^.questTitle
|
|
|
|
instance Eq Building where
|
|
a == b = a^.buildingTitle == b^.buildingTitle
|
|
|
|
instance Eq IntrigueCard where
|
|
a == b = a^.intrigueTitle == b^.intrigueTitle
|
|
|
|
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 >>= unWaterdeep . f)
|
|
fail = Waterdeep . fail
|
|
|
|
instance Alternative Waterdeep where
|
|
empty = Waterdeep empty
|
|
Waterdeep m <|> Waterdeep n = Waterdeep (m <|> n)
|
|
|
|
instance MonadPlus Waterdeep where
|
|
mzero = empty
|
|
mplus = (<|>)
|
|
|
|
instance MonadState WaterdeepState Waterdeep where
|
|
state = Waterdeep . lift . 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
|
|
|
|
plotActionState :: Lens' (PlotState, PlotCondition, GameAction) PlotState
|
|
plotActionState f (s,c,a) = fmap (,c,a) $ f s
|
|
|
|
plotCondition :: Lens' (PlotState, PlotCondition, GameAction) PlotCondition
|
|
plotCondition f (s,c,a) = fmap (s,,a) $ f c
|
|
|
|
plotAction :: Lens' (PlotState, PlotCondition, GameAction) GameAction
|
|
plotAction f (s,c,a) = fmap (s,c,) $ f a
|
|
|
|
gamePlayerState :: PlayerID -> Lens' WaterdeepState PlayerState
|
|
gamePlayerState n = lens
|
|
(\w -> w ^. gamePlayerStates . intAt n . to fromJust)
|
|
(\w ps' -> w & gamePlayerStates . intAt n .~ Just ps')
|
|
|
|
gamePlayerName :: PlayerID -> Lens' WaterdeepState String
|
|
gamePlayerName n = gamePlayerState n . playerName
|
|
|
|
activePlayerState :: Lens' WaterdeepState PlayerState
|
|
activePlayerState = lens
|
|
(\w -> w ^. gamePlayerState (w ^. gameActivePlayer))
|
|
(\w v -> w & gamePlayerState (w ^. gameActivePlayer) .~ v)
|
|
|
|
activePlayerName :: Lens' WaterdeepState String
|
|
activePlayerName = activePlayerState . playerName
|
|
|
|
withActivePlayer :: PlayerID -> Waterdeep a -> Waterdeep a
|
|
withActivePlayer p m = do
|
|
p0 <- use gameActivePlayer
|
|
gameActivePlayer .= p
|
|
r <- m
|
|
gameActivePlayer .= p0
|
|
return r
|
|
|
|
nextPlayerID :: PlayerID -> WaterdeepState -> PlayerID
|
|
nextPlayerID p w = (p `mod` (w ^. gameNumberOfPlayers)) + 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 = mempty
|
|
, _playerIncompleteQuests = mempty
|
|
, _playerCompletedQuests = mempty
|
|
, _playerPlotQuests = mempty
|
|
, _playerIntrigueCards = mempty
|
|
, _playerAgentsInPool = 0
|
|
, _playerHasLieutenant = False
|
|
, _playerHasAmbassador = False
|
|
, _playerCanUseOpSpace = False
|
|
}
|
|
|
|
newBuildingState :: PlayerID -> Building -> BuildingState
|
|
newBuildingState p b =
|
|
BuildingState
|
|
{ _building = b
|
|
, _buildingOwner = p
|
|
, _buildingAgents = []
|
|
, _buildingAccumulation = 0
|
|
}
|
|
|
|
waterdeepPrompt :: WaterdeepPrompt a -> Waterdeep a
|
|
waterdeepPrompt = Waterdeep . lift . lift . lift . prompt
|
|
|
|
notifyState :: Waterdeep ()
|
|
notifyState = get >>= waterdeepPrompt . NotifyState
|
|
|
|
broadcast :: String -> Waterdeep ()
|
|
broadcast s = notifyState >> waterdeepPrompt (Broadcast s)
|
|
|
|
solicitChoice :: 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 t cs = do
|
|
notifyState
|
|
p <- use gameActivePlayer
|
|
waterdeepPrompt (SolicitChoice p t cs)
|
|
|
|
actionProvidedSet :: ResourceSet -> Waterdeep ()
|
|
actionProvidedSet s = Waterdeep $ tell s
|
|
|
|
actionProvided :: Resource -> Waterdeep ()
|
|
actionProvided r = actionProvidedSet $ Set.singleton r
|
|
|
|
delimitAction :: Waterdeep a -> Waterdeep (a, ResourceSet)
|
|
delimitAction (Waterdeep m) = Waterdeep . lift $ runWriterT m
|
|
|
|
evalWriterT :: Monad m => WriterT w m a -> m a
|
|
evalWriterT m = return . fst =<< runWriterT m
|
|
|
|
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 (evalWriterT m) s
|
|
|
|
runWaterdeep :: (forall a. WaterdeepPrompt a -> a) -> Waterdeep r -> WaterdeepState -> Maybe (r, WaterdeepState)
|
|
runWaterdeep p (Waterdeep m) s = runPrompt p $ runMaybeT $ runStateT (evalWriterT 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 (evalWriterT m) s
|
|
|
|
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
|
|
|
|
-- |Permit 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 = filteredChoice [] . runWaterdeepC Done Cont m =<< get
|
|
where
|
|
filteredChoice :: [WaterdeepPrompt ()] -> ContWD a -> Waterdeep (Maybe a)
|
|
filteredChoice ps (Done Nothing) = return Nothing
|
|
filteredChoice ps (Done (Just (a,w))) = forwardPrompts ps >> put w >> return (Just a)
|
|
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) =
|
|
case filter (tryChoice . cont . snd) cs of
|
|
[] -> return Nothing
|
|
[c] -> filteredChoice ps $ cont (snd c)
|
|
cs' -> do
|
|
forwardPrompts ps
|
|
r <- waterdeepPrompt (SolicitChoice p t cs')
|
|
filteredChoice [] $ cont r
|
|
forwardPrompts :: [WaterdeepPrompt ()] -> Waterdeep ()
|
|
forwardPrompts = mapM_ waterdeepPrompt
|