From 0646087080922f734522ca2e2150dc8f5c1ea078 Mon Sep 17 00:00:00 2001 From: Simon Marechal Date: Wed, 17 Jan 2018 22:04:23 +0100 Subject: [PATCH] Explicit use of opportunity --- Backends/Common.hs | 4 ++-- Backends/GenericHub.hs | 12 ++++++------ Backends/Hub.hs | 6 +++--- Startups/Game.hs | 24 +++++++++++++++--------- Startups/GameTypes.hs | 12 ++++++------ Startups/Interpreter.hs | 4 ++-- Strategies/Bot1.hs | 2 +- Strategies/Random.hs | 2 +- src/Console.hs | 3 +-- tests/tests.hs | 28 +++++++++++++++++++++++----- 10 files changed, 60 insertions(+), 37 deletions(-) diff --git a/Backends/Common.hs b/Backends/Common.hs index e41fbbe..11e9be9 100644 --- a/Backends/Common.hs +++ b/Backends/Common.hs @@ -90,8 +90,8 @@ quicksituation age turn stt = hdr situationRecap stt where hdr = "Age" <+> pe age <+> ", turn" <+> numerical turn -displayActions :: M.Map PlayerId PlayerState -> M.Map PlayerId (PlayerAction, Exchange) -> PrettyDoc -displayActions pmap actionmap = vcat [ showPlayerId pid <+> playerActionDesc Public pid pmap (pa, exch, Nothing) | (pid, (pa, exch)) <- M.toList actionmap ] +displayActions :: M.Map PlayerId PlayerState -> M.Map PlayerId (PlayerAction, Exchange, Maybe SpecialInformation) -> PrettyDoc +displayActions pmap actionmap = vcat [ showPlayerId pid <+> playerActionDesc Public pid pmap fullAction | (pid, fullAction) <- M.toList actionmap ] displayVictory :: M.Map PlayerId (M.Map VictoryType VictoryPoint) -> PrettyDoc displayVictory = vcat . map displayLine . itoList diff --git a/Backends/GenericHub.hs b/Backends/GenericHub.hs index fbcbe66..4557091 100644 --- a/Backends/GenericHub.hs +++ b/Backends/GenericHub.hs @@ -64,18 +64,18 @@ data GP = GP { _gpPlayers :: M.Map PlayerId PlayerMessages , _gpMaxprom :: PromiseId , _gpBlocking :: BlockingOn , _gpCardProm :: M.Map (Promise Card) Card - , _gpActProm :: M.Map (Promise (PlayerAction, Exchange)) (PlayerAction, Exchange) + , _gpActProm :: M.Map (Promise (PlayerAction, Exchange, Maybe SpecialInformation)) (PlayerAction, Exchange, Maybe SpecialInformation) , _gpGS :: GameState } data BlockingOn = NotBlocked | BlockingOnCard GameState (Promise Card) (Card -> GameMonad Promise GameResult) - | BlockingOnAction GameState (Promise (PlayerAction, Exchange)) ((PlayerAction, Exchange) -> GameMonad Promise GameResult) + | BlockingOnAction GameState (Promise (PlayerAction, Exchange, Maybe SpecialInformation)) ((PlayerAction, Exchange, Maybe SpecialInformation) -> GameMonad Promise GameResult) data AP = AP Age Turn PlayerId (NonEmpty Card) GameState data AC = AC Age PlayerId (NonEmpty Card) GameState Message -data Com = CAP AP (Promise (PlayerAction, Exchange)) +data Com = CAP AP (Promise (PlayerAction, Exchange, Maybe SpecialInformation)) | CAC AC (Promise Card) data PlayerMessages = PlayerMessages { _curBlocking :: Maybe Com @@ -251,8 +251,8 @@ toggleReady gid pid = do playCard :: (MonadError PlayerError m, HubMonad m, MonadState HubState m) => Card -> GameId -> PlayerId -> m () playCard = genPlay _BlockingOnCard gpCardProm (_CAC . _2) -playAction :: (MonadError PlayerError m, HubMonad m, MonadState HubState m) => PlayerAction -> Exchange -> GameId -> PlayerId -> m () -playAction pa e = genPlay _BlockingOnAction gpActProm (_CAP . _2) (pa, e) +playAction :: (MonadError PlayerError m, HubMonad m, MonadState HubState m) => PlayerAction -> Exchange -> Maybe SpecialInformation -> GameId -> PlayerId -> m () +playAction pa e mspecial = genPlay _BlockingOnAction gpActProm (_CAP . _2) (pa, e, mspecial) genPlay :: (MonadError PlayerError m, HubMonad m, MonadState HubState m) => Prism' BlockingOn (GameState, Promise toplay, toplay -> GameMonad Promise GameResult) @@ -287,7 +287,7 @@ advanceGame gid gp gs act = do GPA gp' gs' prom a -> GamePlaying (gp' & gpBlocking .~ BlockingOnAction gs' prom a) GPC gp' gs' prom a -> GamePlaying (gp' & gpBlocking .~ BlockingOnCard gs' prom a) -data StepResult a = GPA GP GameState (Promise (PlayerAction, Exchange)) ((PlayerAction, Exchange) -> GameMonad Promise a) +data StepResult a = GPA GP GameState (Promise (PlayerAction, Exchange, Maybe SpecialInformation)) ((PlayerAction, Exchange, Maybe SpecialInformation) -> GameMonad Promise a) | GPC GP GameState (Promise Card) (Card -> GameMonad Promise a) | Fin a | Failed Message diff --git a/Backends/Hub.hs b/Backends/Hub.hs index c24559d..d299526 100644 --- a/Backends/Hub.hs +++ b/Backends/Hub.hs @@ -52,7 +52,7 @@ data PlayerInput = NumericChoice Int data IAskingAction = IAskingAction PlayerId Age (NonEmpty Card) GameState Turn data IAskingCard = IAskingCard PlayerId Age (NonEmpty Card) GameState Message -data IAsk = AskingAction IAskingAction (PubFPM (PlayerAction, Exchange)) +data IAsk = AskingAction IAskingAction (PubFPM (PlayerAction, Exchange, Maybe SpecialInformation)) | AskingCard IAskingCard (PubFPM Card) $(deriveToJSON baseOptions ''IAskingAction) @@ -101,7 +101,8 @@ data VOutput = SpawnGame GameId [PlayerId] | TellPlayer PlayerId Message | Broadcast Message | FailAsk Message IAsk -- used when the player is not in the proper state - | SucceedAskingAction (PlayerAction, Exchange) (PubFPM (PlayerAction, Exchange)) + | SucceedAskingAction (PlayerAction, Exchange, Maybe SpecialInformation) + (PubFPM (PlayerAction, Exchange, Maybe SpecialInformation)) | SucceedAskingCard Card (PubFPM Card) | OCustom T.Text -- ^ Custom backend communication @@ -225,7 +226,6 @@ hub = asPipe (loop h) notifySuccess a gs necards (`SucceedAskingCard` pub) Just a@(AskingAction (IAskingAction _ age necards gs _) pub) -> do let allowable = allowableActions age pid necards (gs ^. playermap) - & traverse %~ (\(x,y,_) -> (x,y)) notifySuccess a gs allowable (`SucceedAskingAction` pub) -- Go is only acceptable when the player is in Joined state Go -> let hgid gameid = do diff --git a/Startups/Game.hs b/Startups/Game.hs index 3e61d3e..d254865 100644 --- a/Startups/Game.hs +++ b/Startups/Game.hs @@ -116,15 +116,21 @@ resolveExchange pid exch = mconcat . M.elems <$> itraverse resolveExchange' (ge -- | Try to play a card, with some extra resources, provided that the -- player has enough. -playCard :: NonInteractive m => Age -> PlayerId -> MS.MultiSet Resource -> Card -> m () -playCard age pid extraResources card = do +playCard :: NonInteractive m + => Age + -> PlayerId + -> MS.MultiSet Resource + -> Bool -- ^ use opportunity + -> Card + -> m () +playCard age pid extraResources useOpportunity card = do -- compute available resources playerState <- getPlayerState pid -- remove the chosen card from the card list, and remove the money from -- the player account let Cost _ fundCost = card ^. cCost let -- this tests whether a player has the opportunity capability ready - hasOpportunity = has (cardEffects . _Opportunity . ix age) playerState && has cType card + hasOpportunity = has (cardEffects . _Opportunity . ix age) playerState && has cType card && useOpportunity -- checks if a player has enough resources to play a card enoughResources = fundCost <= playerState ^. pFunds && isAffordable playerState extraResources card -- checks if a card is free (owns another card that permits free @@ -134,9 +140,9 @@ playCard age pid extraResources card = do Nothing -> False -- checks if a player can build a given card. This is in the 'let' -- part to take advantage of guards. - checkPrice | enoughResources = playermap . ix pid . pFunds -= fundCost - | isFree = return () + checkPrice | isFree = return () | hasOpportunity = playermap . ix pid . cardEffects . _Opportunity . at age .= Nothing + | enoughResources = playermap . ix pid . pFunds -= fundCost | otherwise = throwError (showPlayerId pid <+> "tried to play a card he did not have the resources for.") checkPrice -- add the card to the player hand @@ -152,8 +158,8 @@ playCard age pid extraResources card = do -- -- The reason it is done that way is that card payouts must be computed -- after all other actions have been performed. -resolveAction :: NonInteractive m => Age -> PlayerId -> ([Card], (PlayerAction, Exchange)) -> m ([Card], AddMap PlayerId Funding, Maybe Card) -resolveAction age pid (hand, (PlayerAction actiontype card, exch)) = do +resolveAction :: NonInteractive m => Age -> PlayerId -> ([Card], (PlayerAction, Exchange, Maybe SpecialInformation)) -> m ([Card], AddMap PlayerId Funding, Maybe Card) +resolveAction age pid (hand, (PlayerAction actiontype card, exch, mspecial)) = do -- check that the player didn't cheat unless (card `elem` hand) (throwError (showPlayerId pid <+> "tried to play a card that was not in his hand:" <+> shortCard card)) -- resolve the exchanges @@ -162,7 +168,7 @@ resolveAction age pid (hand, (PlayerAction actiontype card, exch)) = do let newhand = filter (/= card) hand (cardp, extrapay) <- case actiontype of Drop -> discardpile %= (card :) >> return (Nothing, 3) - Play -> playCard age pid extraResources card >> return (Just card, 0) + Play -> (Just card, 0) <$ playCard age pid extraResources (mspecial == Just UseOpportunity) card BuildCompany -> do stt <- getPlayerState pid let profile = stt ^. pCompany @@ -172,7 +178,7 @@ resolveAction age pid (hand, (PlayerAction actiontype card, exch)) = do ccard = getResourceCard profile nextstage when (curstage == maxstage) (throwError (showPlayerId pid <+> "tried to increase the company stage beyond the limit.")) playermap . ix pid . pCompanyStage %= succ - playCard age pid extraResources ccard + playCard age pid extraResources False ccard -- can't use opportunity to build company cards return (Just ccard, 0) return (newhand, payout <> AddMap (M.singleton pid extrapay), cardp) diff --git a/Startups/GameTypes.hs b/Startups/GameTypes.hs index e2510a1..c0cb34a 100644 --- a/Startups/GameTypes.hs +++ b/Startups/GameTypes.hs @@ -83,13 +83,13 @@ data CommunicationType = PlayerCom PlayerId Communication | BroadcastCom Communication data Communication = RawMessage PrettyDoc - | ActionRecapMsg Age Turn GameState (M.Map PlayerId (PlayerAction, Exchange)) + | ActionRecapMsg Age Turn GameState (M.Map PlayerId (PlayerAction, Exchange, Maybe SpecialInformation)) data GameInstr p a where - PlayerDecision :: Age -> Turn -> PlayerId -> NonEmpty Card -> GameInstr p (p (PlayerAction, Exchange)) + PlayerDecision :: Age -> Turn -> PlayerId -> NonEmpty Card -> GameInstr p (p (PlayerAction, Exchange, Maybe SpecialInformation)) AskCard :: Age -> PlayerId -> NonEmpty Card -> Message -> GameInstr p (p Card) GetPromiseCard :: p Card -> GameInstr p Card - GetPromiseAct :: p (PlayerAction, Exchange) -> GameInstr p (PlayerAction, Exchange) + GetPromiseAct :: p (PlayerAction, Exchange, Maybe SpecialInformation) -> GameInstr p (PlayerAction, Exchange, Maybe SpecialInformation) Message :: CommunicationType -> GameInstr p () ThrowError :: Message -> GameInstr p a -- ^ Used for the error instance CatchError :: GameMonad p a -> (Message -> GameMonad p a) -> GameInstr p a @@ -97,7 +97,7 @@ data GameInstr p a where type GameMonad p = ProgramT (GameInstr p) (State GameState) -- | Ask the player which card he would like to play. -playerDecision :: Age -> Turn -> PlayerId -> NonEmpty Card -> GameMonad p (p (PlayerAction, Exchange)) +playerDecision :: Age -> Turn -> PlayerId -> NonEmpty Card -> GameMonad p (p (PlayerAction, Exchange, Maybe SpecialInformation)) playerDecision a t p c = singleton (PlayerDecision a t p c) -- | Tell some information to a specific player @@ -113,11 +113,11 @@ getPromiseCard :: p Card -> GameMonad p Card getPromiseCard = singleton . GetPromiseCard -- | Awaits an "action" promise -getPromiseAction :: p (PlayerAction, Exchange) -> GameMonad p (PlayerAction, Exchange) +getPromiseAction :: p (PlayerAction, Exchange, Maybe SpecialInformation) -> GameMonad p (PlayerAction, Exchange, Maybe SpecialInformation) getPromiseAction = singleton . GetPromiseAct -- | Gives a quick rundown of all actions -actionRecap :: Age -> Turn -> M.Map PlayerId (PlayerAction, Exchange) -> GameMonad p () +actionRecap :: Age -> Turn -> M.Map PlayerId (PlayerAction, Exchange, Maybe SpecialInformation) -> GameMonad p () actionRecap age turn mm = get >>= \s -> singleton . Message . BroadcastCom $ ActionRecapMsg age turn s mm instance MonadError PrettyDoc (ProgramT (GameInstr p) (State GameState)) where diff --git a/Startups/Interpreter.hs b/Startups/Interpreter.hs index 090b9c0..9f3a1b8 100644 --- a/Startups/Interpreter.hs +++ b/Startups/Interpreter.hs @@ -11,7 +11,7 @@ import Control.Monad.Operational import Control.Monad.State.Strict import Data.List.NonEmpty -data Strategy p m = Strategy { _doPlayerDecision :: Age -> Turn -> PlayerId -> NonEmpty Card -> GameState -> m (p (PlayerAction, Exchange)) +data Strategy p m = Strategy { _doPlayerDecision :: Age -> Turn -> PlayerId -> NonEmpty Card -> GameState -> m (p (PlayerAction, Exchange, Maybe SpecialInformation)) , _doAskCard :: Age -> PlayerId -> NonEmpty Card -> GameState -> Message -> m (p Card) } @@ -21,7 +21,7 @@ data OperationDict p m = OperationDict { _strat :: Strategy p m } data OperationDict' p m = OperationDict' { _strat' :: Strategy p m - , _doGetPromiseAct :: p (PlayerAction, Exchange) -> m (Either Message (PlayerAction, Exchange)) + , _doGetPromiseAct :: p (PlayerAction, Exchange, Maybe SpecialInformation) -> m (Either Message (PlayerAction, Exchange, Maybe SpecialInformation)) , _doGetPromiseCard :: p Card -> m (Either Message Card) , _doMessage' :: GameState -> CommunicationType -> m () } diff --git a/Strategies/Bot1.hs b/Strategies/Bot1.hs index 79f10a9..3550fac 100644 --- a/Strategies/Bot1.hs +++ b/Strategies/Bot1.hs @@ -77,7 +77,7 @@ bot1 mkPromise = Strategy pd ac priofunc <- priority age let s = priofunc act exch special pid stt r <- s ^.. folded - return (r, (act, exch)) + return (r, (act, exch, special)) in return $ mkPromise $ snd $ head a diff --git a/Strategies/Random.hs b/Strategies/Random.hs index 7edcafe..8392f72 100644 --- a/Strategies/Random.hs +++ b/Strategies/Random.hs @@ -20,7 +20,7 @@ randStrategy roll = Strategy pd ac allactions = NE.toList $ allowableActions age pid necards pm nodrops = filter (\(PlayerAction actiontype _,_,_) -> actiontype /= Drop) allactions actions = if null nodrops then allactions else nodrops - return . (\(pa,e,_) -> (pa,e)) . (actions !!) <$> roll 0 (length actions - 1) + return . (actions !!) <$> roll 0 (length actions - 1) ac _ _ necards _ _ = do let cards = _NonEmpty # necards (return . (cards !!)) <$> roll 0 (length cards - 1) diff --git a/src/Console.hs b/src/Console.hs index 41e617e..0ba21be 100644 --- a/src/Console.hs +++ b/src/Console.hs @@ -35,8 +35,7 @@ playerStrat = Strategy pd ac print (PP.pretty (playerActionsDialog pid pm necards x)) r <- readNumber if r >= 0 && r < NE.length x - then let (pa,e,_) = x NE.!! r - in return (return (pa, e)) + then return (return (x NE.!! r)) else pd age turn pid necards stt ac turn pid necards stt m = do let cards = _NonEmpty # necards diff --git a/tests/tests.hs b/tests/tests.hs index 4e454b8..f3170fe 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -22,9 +22,8 @@ import System.Random import Test.QuickCheck import Data.Monoid import Control.Monad -import Control.Monad.Writer -import Control.Monad.Trans.Except import Data.Maybe (fromJust) +import Data.List.NonEmpty (NonEmpty(..)) getCard :: T.Text -> Card getCard n = case filter (\c -> c ^? cName == Just n) allcards of @@ -81,6 +80,25 @@ main = hspec $ do expected = S.fromList (map getResCost reslist) actual = S.fromList $ availableResources OwnRes (fromJust (testState ^? playermap . ix pid)) in it ("Is correct for " <> T.unpack pid) $ actual `shouldBe` expected + describe "Opportunity" $ do + let cny = CompanyProfile Yahoo A + heldCards = map (getResourceCard cny) [Project .. Stage3] + p1s = PlayerState cny Stage3 heldCards 10 ("p3","p2") [] + p2s = p1s & pNeighborhood .~ ("p1","p3") + p3s = p1s & pNeighborhood .~ ("p2","p1") + market = getCard "Marketroid" + lavish = getCard "Lavish Headquarters" + devops = getCard "Devops Team" + pmap = M.fromList (zip ["p1","p2","p3"] [p1s,p2s,p3s]) + it "Should only give the option to play marketroid in the first test" $ + allowableActions Age1 "p1" (market :| []) pmap `shouldBe` + (PlayerAction Play market, mempty, Nothing) :| [ (PlayerAction Drop market, mempty, Nothing) ] + it "Should only give the option to play the lavish headquarters with opportunity" $ + allowableActions Age1 "p1" (lavish :| []) pmap `shouldBe` + (PlayerAction Play lavish, mempty, Just UseOpportunity) :| [ (PlayerAction Drop lavish, mempty, Nothing) ] + it "Should only give the option to play the devops team with or without cost" $ + allowableActions Age1 "p1" (devops :| []) pmap `shouldBe` + (PlayerAction Play devops, mempty, Nothing) :| [ (PlayerAction Play devops, mempty, Just UseOpportunity), (PlayerAction Drop devops, mempty, Nothing) ] describe "random games" $ do let gs = do seed <- arbitrary @@ -148,9 +166,9 @@ main = hspec $ do InGame _ _ (TodoAction _ _ _ cardsBob _) _ <- return (playerStatus hs3 "bob") InGame _ _ (TodoAction _ _ _ cardsGarry _) _ <- return (playerStatus hs3 "garry") InGame _ _ (TodoAction _ _ _ cardsJohn _) _ <- return (playerStatus hs3 "john") - playAction (PlayerAction Drop (head cardsBob ^. _1)) mempty 0 "bob" - playAction (PlayerAction Drop (head cardsGarry ^. _1)) mempty 0 "garry" - playAction (PlayerAction Drop (head cardsJohn ^. _1)) mempty 0 "john" + playAction (PlayerAction Drop (head cardsBob ^. _1)) mempty Nothing 0 "bob" + playAction (PlayerAction Drop (head cardsGarry ^. _1)) mempty Nothing 0 "garry" + playAction (PlayerAction Drop (head cardsJohn ^. _1)) mempty Nothing 0 "john" Right (_, hs4, _) = res4 it "Should be possible to play" $ do let InGame gid' _ todo messages = playerStatus hs4 "bob"