Explicit use of opportunity

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

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

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

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)
 

Startups/GameTypes.hs

@@ -83,21 +83,21 @@ 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
 
 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

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 ()
                                          }

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
 
 

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)

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

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"