commit 899912894709a9b7704fa6d730040bea4f64e5fb Author: Jesse McDonald Date: Mon Mar 31 17:34:51 2014 -0500 Lords of Waterdeep simulation -- initial commit. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..65ad62d --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +*.swp +*.swo +*.hi +*.o diff --git a/src/.gitignore b/src/.gitignore new file mode 100644 index 0000000..345e6ae --- /dev/null +++ b/src/.gitignore @@ -0,0 +1 @@ +Test diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 index 0000000..e48d760 --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +import Waterdeep.Types +import Waterdeep.Monad +import Waterdeep.Logic +import Control.Applicative +import Control.Lens +import Control.Monad +import Control.Monad.Prompt +import Control.Monad.State +import Data.List +import Text.Printf +import System.IO +import System.Random +import System.Random.Shuffle + +import qualified Data.IntMap as IM + +f1 = Faction "Jesters" Blue +l1 = Lord "Prince Henry XXX" "" (QuestBonus [Skullduggery, Commerce] 4) +p1 = ("Harry", f1, l1) + +f2 = Faction "Pilots" Green +l2 = Lord "Princess Anastasia" "" (QuestBonus [Arcana, Warfare] 4) +p2 = ("Ned", f2, l2) + +b1 = Building { _buildingCost = 6 + , _buildingTitle = "Monastary" + , _buildingAction = Group [TakeResource [Cleric], TakeResource [Cleric]] + , _buildingOwnerAction = TakeResource [Cleric] + , _buildingAccumulation = NoAccumulation + } + +b2 = Building { _buildingCost = 4 + , _buildingTitle = "Training Hall" + , _buildingAction = Group [TakeResource [Fighter], TakeResource [Fighter]] + , _buildingOwnerAction = TakeResource [Fighter] + , _buildingAccumulation = NoAccumulation + } + +b3 = Building { _buildingCost = 4 + , _buildingTitle = "Prison Yard" + , _buildingAction = Group [TakeResource [Rogue], TakeResource [Rogue]] + , _buildingOwnerAction = TakeResource [Rogue] + , _buildingAccumulation = NoAccumulation + } + +b4 = Building { _buildingCost = 6 + , _buildingTitle = "Wizard School" + , _buildingAction = Group [TakeResource [Wizard], TakeResource [Wizard]] + , _buildingOwnerAction = TakeResource [Wizard] + , _buildingAccumulation = NoAccumulation + } + +b5 = Building { _buildingCost = 4 + , _buildingTitle = "Gold Mine" + , _buildingAction = Group $ replicate 4 $ TakeResource [Gold] + , _buildingOwnerAction = Group $ replicate 2 $ TakeResource [Gold] + , _buildingAccumulation = NoAccumulation + } + +printWaterdeep :: WaterdeepState -> IO () +printWaterdeep w = do + let ps = map snd $ w ^. gamePlayers . to IM.toAscList + putStrLn ("Players: " ++ intercalate ", " (map (^. playerName) ps)) + putStrLn ("First Player: " ++ + (w ^. gamePlayers . singular (ix (w ^. gameFirstPlayer)) . playerName)) + putStrLn ("Current Round: " ++ show (w ^. gameCurrentRound)) + putStrLn ("Current Player: " ++ + (w ^. gamePlayers . singular (ix (w ^. gameCurrentPlayer)) . playerName)) + putStrLn "" + putStrLn "Cliffwatch Inn:" + forM_ (w ^. gameCliffwatchInn) $ \q -> do + putStrLn (" " ++ (q ^. questTitle)) + putStrLn "" + putStrLn "Builder's Hall:" + forM_ (w ^. gameBuildersHall) $ \(b,agents,pts) -> do + printf " %s (%d gold -> %d points)\n" (b ^. buildingTitle) (b ^. buildingCost) pts + putStrLn "" + forM_ ps $ \p -> do + putStrLn ((p ^. playerName) ++ "'s State:") + putStrLn (" Score: " ++ show (p ^. playerScore)) + putStrLn (" Tavern: " ++ show (p ^. playerTavern)) + putStrLn (" Color: " ++ show (p ^. playerFaction . factionColor)) + putStrLn (" Lord: " ++ (p ^. playerLord . lordName)) + putStrLn (" Faction: " ++ (p ^. playerFaction . factionName)) + putStrLn (" Incomplete: " ++ show (p ^. playerIncompleteQuests . to length)) + putStrLn (" Complete: " ++ show (p ^. playerCompletedQuests . to length)) + putStrLn (" Intrigues: " ++ show (p ^. playerIntrigueCards . to length)) + putStrLn (" Agent Pool: " ++ show (p ^. playerAgentsInPool)) + putStrLn "" + +dummyPrompt :: WaterdeepPrompt a -> IO a +dummyPrompt prm@(NotifyState w) = return () +dummyPrompt prm@(SolicitChoice w p t cs) = do + let menuSize = length cs + let menuLine n t = putStrLn (show n ++ ") " ++ t) + let blankLine = putStrLn "" + let redo why = putStrLn ("ERROR: " ++ why) >> blankLine >> dummyPrompt prm + + printWaterdeep w + + putStrLn t + forM_ (zip [1::Int ..] cs) $ \(i, (c, _)) -> menuLine i c + + putStr (w ^. gamePlayer p . playerName) + putStr "> " >> hFlush stdout + response <- getLine + + case reads response of + (ix,""):_ -> if ix >= 1 && ix <= menuSize + then blankLine >> return (snd $ cs !! (ix-1)) + else redo "Invalid choice." + _ -> redo "Expected a number." + +main :: IO () +main = do + w <- newGame [p1, p2] [] [] [b1,b2,b3,b4,b5] + winners <- fst <$> runWaterdeepM dummyPrompt waterdeepGame w + let gamePlayerName n = w ^. gamePlayer n . playerName + putStrLn ("Winner(s): " ++ intercalate ", " (toListOf (traverse . to gamePlayerName) winners)) diff --git a/src/Waterdeep/Logic.hs b/src/Waterdeep/Logic.hs new file mode 100644 index 0000000..4161459 --- /dev/null +++ b/src/Waterdeep/Logic.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module Waterdeep.Logic + ( newGame + , waterdeepGame + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad +import Control.Monad.Random +import Control.Monad.State +import Data.List +import Data.Maybe +import System.Random.Shuffle +import Waterdeep.Types +import Waterdeep.Monad + +import qualified Data.IntMap as IM + +newGame :: (MonadRandom m, MonadSplit StdGen m) + => [(String,Faction,Lord)] + -> [Quest] + -> [IntrigueCard] + -> [Building] + -> m WaterdeepState +newGame players quests intrigues buildings + | length players < 2 || length players > 5 = error "This game requires 2-5 players." + | otherwise = do + let playerStates = IM.fromList $ flip map (zip [1..] players) $ + \(i,(n,f,l)) -> (i, newPlayerState i n f l) + quests' <- shuffleM quests + intrigues' <- shuffleM intrigues + buildings' <- shuffleM buildings + splitGen <- getSplit + return $ snd $ runWaterdeep batchMode setupGame $ WaterdeepState + { _gamePlayers = playerStates + , _gameFirstPlayer = 1 + , _gameCurrentRound = 0 + , _gameCurrentPlayer = 1 + , _gameConsecutivePasses = 0 + , _gameQuestDeck = quests' + , _gameQuestDiscard = [] + , _gameCliffwatchInn = [] + , _gameIntrigueDeck = intrigues' + , _gameIntrigueDiscard = [] + , _gameBuildingDeck = buildings' + , _gameBuildingDiscard = [] + , _gameBasicBuildings = map (\b -> (b, [])) basicBuildings + , _gameBuildersHall = [] + , _gameAdvancedBuildings = [] + , _gameWaterdeepHarbor = ([], [], []) + , _gameStdGen = splitGen + } + where + batchMode :: WaterdeepPrompt a -> a + batchMode (NotifyState _) = () + batchMode (SolicitChoice _ _ _ _) = error "No choices during setup." + + setupGame :: Waterdeep () + setupGame = do + restockBuildersHall + restockCliffwatchInn + let ps = [1 .. length players] + forM_ (zip ps [4..]) $ \(p, g) -> do + replicateM_ 2 $ performAction p DrawQuest + replicateM_ 2 $ performAction p DrawIntrigue + replicateM_ g $ performAction p $ TakeResource [Gold] + return () + +newPlayerState :: PlayerID -> String -> Faction -> Lord -> PlayerState +newPlayerState i name faction lord = + PlayerState + { _playerNumber = i + , _playerName = name + , _playerFaction = faction + , _playerLord = lord + , _playerScore = 0 + , _playerTavern = [] + , _playerIncompleteQuests = [] + , _playerCompletedQuests = [] + , _playerActivePlotQuests = [] + , _playerUsedPlotQuests = [] + , _playerIntrigueCards = [] + , _playerAgentsInPool = 0 + , _playerHasLieutenant = False + , _playerHasAmbassador = False + } + +basicBuildings :: [Building] +basicBuildings = [] + +waterdeepGame :: Waterdeep [PlayerID] +waterdeepGame = do + forM_ [1..8] $ \round -> do + beginRound round + void $ solicitChoice 1 "Choose one" [("Option A", ()), ("Option B", ())] + notifyState + determineWinners + +beginRound :: Int -> Waterdeep () +beginRound round = do + gameCurrentRound .= round + notifyState + return () + +performAction :: PlayerID -> GameAction -> Waterdeep Bool +performAction p a = case a of + DrawQuest -> do + mq <- drawQuest + case mq of + Nothing -> return False + Just q -> do + gamePlayers . singular (ix p) . playerIncompleteQuests %= (++[q]) + return True + _ -> return False + +determineWinners :: Waterdeep [PlayerID] +determineWinners = do + 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]) + restockCliffwatchInn + +restockBuildersHall :: Waterdeep () +restockBuildersHall = do + num <- length <$> use gameBuildersHall + when (num < 3) $ do + mb <- drawBuilding + case mb of + Nothing -> return () + Just b -> do + gameBuildersHall %= (++ [(b, [], 0)]) + restockBuildersHall diff --git a/src/Waterdeep/Monad.hs b/src/Waterdeep/Monad.hs new file mode 100644 index 0000000..00bc657 --- /dev/null +++ b/src/Waterdeep/Monad.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Waterdeep.Monad + ( WaterdeepPrompt(..) + , Waterdeep + , notifyState + , 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 () + SolicitChoice :: WaterdeepState -> 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 f = Waterdeep $ do + s <- get + let (a, s') = f s + put s' + lift $ prompt $ NotifyState s' + return a + +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 + +solicitChoice :: PlayerID -> String -> [(String, a)] -> Waterdeep a +solicitChoice p t cs = do + notifyState + w <- get + Waterdeep $ lift $ prompt (SolicitChoice w 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 diff --git a/src/Waterdeep/Types.hs b/src/Waterdeep/Types.hs new file mode 100644 index 0000000..743f8bb --- /dev/null +++ b/src/Waterdeep/Types.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Waterdeep.Types + ( PlayerID + , Lord(..) + , Faction(..) + , Building(..) + , Quest(..) + , IntrigueCard(..) + , PlayerState(..) + , WaterdeepState(..) + , Resource(..) + , QuestType(..) + , IntrigueType(..) + , FactionColor(..) + , BonusType(..) + , AccumulationType(..) + , GameAction(..) + , PlotQualifier(..) + , PlotCondition(..) + , lordName + , lordQuote + , lordBonus + , factionName + , factionColor + , buildingCost + , buildingTitle + , buildingAction + , buildingOwnerAction + , buildingAccumulation + , questType + , questTitle + , questQuote + , questAction + , questPlotActions + , intrigueTitle + , intrigueType + , intrigueAction + , intrigueQuote + , playerNumber + , playerName + , playerFaction + , playerLord + , playerScore + , playerTavern + , playerIncompleteQuests + , playerCompletedQuests + , playerActivePlotQuests + , playerUsedPlotQuests + , playerIntrigueCards + , playerAgentsInPool + , playerHasLieutenant + , playerHasAmbassador + , gamePlayers + , gameFirstPlayer + , gameCurrentRound + , gameCurrentPlayer + , gameConsecutivePasses + , gameQuestDeck + , gameQuestDiscard + , gameCliffwatchInn + , gameIntrigueDeck + , gameIntrigueDiscard + , gameBuildingDeck + , gameBuildingDiscard + , gameBasicBuildings + , gameBuildersHall + , gameAdvancedBuildings + , gameWaterdeepHarbor + , gameStdGen + , gamePlayer + ) where + +import Control.Lens +import Data.IntMap (IntMap) +import System.Random (StdGen) + +type PlayerID = Int + +data Lord = + Lord + { _lordName :: String + , _lordQuote :: String + , _lordBonus :: BonusType + } deriving (Show) + +data Faction = + Faction + { _factionName :: String + , _factionColor :: FactionColor + } deriving (Show) + +data Building = + Building + { _buildingCost :: Int + , _buildingTitle :: String + , _buildingAction :: GameAction + , _buildingOwnerAction :: GameAction + , _buildingAccumulation :: AccumulationType + } deriving (Show) + +data Quest = + Quest + { _questType :: QuestType + , _questTitle :: String + , _questQuote :: String + , _questAction :: GameAction + , _questPlotActions :: [(PlotCondition, GameAction)] + } deriving (Show) + +data IntrigueCard = + IntrigueCard + { _intrigueTitle :: String + , _intrigueType :: IntrigueType + , _intrigueAction :: GameAction + , _intrigueQuote :: String + } deriving (Show) + +data PlayerState = + PlayerState + { _playerNumber :: PlayerID + , _playerName :: String + , _playerFaction :: Faction + , _playerLord :: Lord + , _playerScore :: Int + , _playerTavern :: [(Int,Resource)] + , _playerIncompleteQuests :: [Quest] + , _playerCompletedQuests :: [Quest] + , _playerActivePlotQuests :: [Quest] + , _playerUsedPlotQuests :: [Quest] + , _playerIntrigueCards :: [IntrigueCard] + , _playerAgentsInPool :: Int + , _playerHasLieutenant :: Bool + , _playerHasAmbassador :: Bool + } deriving (Show) + +data WaterdeepState = + WaterdeepState + { _gamePlayers :: IntMap PlayerState + , _gameFirstPlayer :: PlayerID + , _gameCurrentRound :: Int + , _gameCurrentPlayer :: PlayerID + , _gameConsecutivePasses :: Int + , _gameQuestDeck :: [Quest] + , _gameQuestDiscard :: [Quest] + , _gameCliffwatchInn :: [Quest] + , _gameIntrigueDeck :: [IntrigueCard] + , _gameIntrigueDiscard :: [IntrigueCard] + , _gameBuildingDeck :: [Building] + , _gameBuildingDiscard :: [Building] + , _gameBasicBuildings :: [(Building, [PlayerID])] + , _gameBuildersHall :: [(Building, [PlayerID], Int)] + , _gameAdvancedBuildings :: [(Building, [PlayerID], Int, Int)] + , _gameWaterdeepHarbor :: ([PlayerID], [PlayerID], [PlayerID]) + , _gameStdGen :: StdGen + } deriving (Show) + +data Resource = Cleric | Fighter | Rogue | Wizard | Gold + deriving (Eq,Ord,Enum,Bounded,Show) + +data QuestType = Piety | Warfare | Skullduggery | Arcana | Commerce | Mandatory + deriving (Eq,Ord,Enum,Bounded,Show) + +data IntrigueType = Utility | Attack + deriving (Eq,Ord,Enum,Bounded,Show) + +data FactionColor = Red | Yellow | Green | Blue | Black + 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 GameAction = ScorePoints Int + | TakeResource [Resource] + | ReturnResource [Resource] + | GiveResource [Resource] + | ChooseQuest + | ReplaceQuests + | DrawQuest + | DrawNamedQuestType + | DistributeQuests + | ChooseAndCompleteQuest + | DiscardUncompletedQuest + | BuyBuilding + | ChooseFreeBuilding + | DrawFreeBuilding + | DiscardUnoccupiedBuilding + | DrawIntrigue + | PlayIntrigue + | ReturnAgent + | ReturnAgentFromHarbor + | AssignAgent + | AssignAgentToBuildersHall + | AssignAgentToOpponentsSpace + | UseOpponentsSpace + | GainLieutenant + | GainAmbassador + | TakeAccumulated + | TakeResourceFromOpponent [Resource] + | AssignMandatoryQuest Quest + | Group [GameAction] + | Optional GameAction + | ChooseFrom [GameAction] + | Transaction [GameAction] + | Repeat Int GameAction + | IfThenElse GameAction GameAction GameAction + | ForEachBuilding GameAction + | ForEachControlledBuilding GameAction + | OneOpponent GameAction + | EachOpponent GameAction + | CurrentPlayer GameAction + deriving (Show) + +data PlotQualifier = ActionProvides [Resource] + | CompletesQuest [QuestType] + | PlaysIntrigue + | BuysBuilding + deriving (Eq,Show) + +data PlotCondition = StartOfRound + | OncePerRound + | OncePerRoundWhen PlotQualifier + | Whenever PlotQualifier + deriving (Eq,Show) + +makeLenses ''Lord +makeLenses ''Faction +makeLenses ''Building +makeLenses ''Quest +makeLenses ''IntrigueCard +makeLenses ''PlayerState +makeLenses ''WaterdeepState + +gamePlayer :: PlayerID -> Lens' WaterdeepState PlayerState +gamePlayer n = lens (\w -> w ^. gamePlayers.singular (ix n)) + (\w p -> w & gamePlayers.singular (ix n) .~ p) + +instance Eq Faction where + a == b = a^.factionColor == b^.factionColor + +instance Ord Faction where + a `compare` b = (a^.factionColor) `compare` (b^.factionColor)