diff --git a/7startups.cabal b/7startups.cabal index 760309e..caab283 100644 --- a/7startups.cabal +++ b/7startups.cabal @@ -26,10 +26,12 @@ library Startups.PrettyPrint, Startups.Interpreter, Startups.Json, + Startups.Exported, Backends.Pure, Backends.Common, Backends.Coroutine, Backends.Hub, + Backends.GenericHub, Strategies.Random, Strategies.Compose, Strategies.Bot1 @@ -56,7 +58,7 @@ library directory == 1.2.*, ansi-wl-pprint == 0.6.*, transformers == 0.4.*, - aeson + hspec -- hs-source-dirs: default-language: Haskell2010 @@ -65,7 +67,7 @@ Test-Suite tests type: exitcode-stdio-1.0 ghc-options: -Wall other-extensions: OverloadedStrings - build-depends: 7startups, base, containers, hspec, QuickCheck, lens, text, random + build-depends: 7startups, base, containers, hspec, QuickCheck, lens, text, random, mtl, transformers main-is: tests.hs default-language: Haskell2010 diff --git a/Backends/Coroutine.hs b/Backends/Coroutine.hs index 70ed944..fe04b34 100644 --- a/Backends/Coroutine.hs +++ b/Backends/Coroutine.hs @@ -51,19 +51,21 @@ data Com p = CAP AP (p (PlayerAction, Exchange)) | CAC AC (p Card) | MSG GameState CommunicationType -runCR :: Monad m => (forall x. p x -> m x) - -> (forall x. m (p x)) +runCR :: Monad m => (p Card -> m Card) + -> (p (PlayerAction, Exchange) -> m (PlayerAction, Exchange)) + -> (m (p Card)) + -> (m (p (PlayerAction, Exchange))) -> GameState -> GameMonad p a -> Coroutine (Com p) m (GameState, Either Message a) -runCR getp mkp = runInterpreter dict +runCR gpc gpa mkc mka = runInterpreter' dict where - dict = OperationDict (Strategy pa ac) (fmap Right . lift . getp) (\gs -> yield . MSG gs) + dict = OperationDict' (Strategy pa ac) (fmap Right . lift . gpa) (fmap Right . lift . gpc) (\gs -> yield . MSG gs) pa age turn pid clist gs = do - p <- lift mkp + p <- lift mka yield (CAP (AP age turn pid clist gs) p) return p ac age pid cards gs msg = do - p <- lift mkp + p <- lift mkc yield (CAC (AC age pid cards gs msg) p) return p diff --git a/Backends/GenericHub.hs b/Backends/GenericHub.hs new file mode 100644 index 0000000..4af18a4 --- /dev/null +++ b/Backends/GenericHub.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GADTs #-} +module Backends.GenericHub + ( GameId + , PromiseId + , HubState + , HubMonad(..) + , GameS + , initialHubstate + , extractGameSummary + , games + , game + , playerStatus + , newGame + , joinGame + , toggleReady + , playCard + , playAction + ) where + +import Startups.Base +import Startups.Cards +import Startups.Game hiding (playCard) +import Startups.GameTypes +import Startups.Utils +import Startups.Exported + +import Data.Aeson hiding ((.=)) +import Control.Monad.State.Strict +import Control.Monad.Trans.Except +import Control.Monad.Operational +import Data.List.NonEmpty +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import System.Random +import Control.Lens + +type GameResult = M.Map PlayerId (M.Map VictoryType VictoryPoint) + +newtype PromiseId = PromiseId { _getPromiseId :: Integer } + deriving (Show, Eq, Ord, Enum, Num, FromJSON, ToJSON) + +newtype Promise x = Promise { _getPromise :: PromiseId } + deriving (Show, Eq, Ord, Enum, Num, FromJSON, ToJSON) + +newtype HubState = HubState { getHubState :: M.Map GameId GameS } + +data GameS = GameJoining (M.Map PlayerId PlayerJoining) + | GameOver (Either Message GameResult) + | GamePlaying GP + +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) + , _gpGS :: GameState + } + +data BlockingOn = NotBlocked + | BlockingOnCard GameState (Promise Card) (Card -> GameMonad Promise GameResult) + | BlockingOnAction GameState (Promise (PlayerAction, Exchange)) ((PlayerAction, Exchange) -> 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)) + | CAC AC (Promise Card) + +data PlayerMessages = PlayerMessages { _curBlocking :: Maybe Com + , _playerLog :: [Message] + } + +class Monad m => HubMonad m where + getRand :: m StdGen + tellEvent :: GameId -> GameEvent -> m () + +defPlayerMessages :: PlayerMessages +defPlayerMessages = PlayerMessages Nothing [] + +makePrisms ''GameS +makePrisms ''Com +makePrisms ''BlockingOn +makeLenses ''GP +makeLenses ''PlayerMessages + +type GTrav x = Traversal' (M.Map GameId GameS) x + +zoomHub :: HubMonad m => GTrav a -> HubState -> PlayerError -> (a -> ExceptT PlayerError m a) -> ExceptT PlayerError m HubState +zoomHub trav (HubState hs) rr a = + case hs ^? trav of + Nothing -> throwE rr + Just x -> do + x' <- a x + return (HubState (hs & trav .~ x')) + +withGame :: HubMonad m => HubState -> GameId -> (GameS -> ExceptT PlayerError m GameS) -> ExceptT PlayerError m HubState +withGame hs gid = zoomHub (ix gid) hs CantPlayNow + +_GamePlayers :: Traversal' GameS (S.Set PlayerId) +_GamePlayers f s = case s of + GameJoining m -> fmap (GameJoining . rebuildMap Joined m) (f (M.keysSet m)) + GamePlaying gp -> let m = gp ^. gpPlayers + in fmap (\st -> GamePlaying (gp & gpPlayers .~ rebuildMap defPlayerMessages m st)) (f (M.keysSet m)) + GameOver _ -> pure s + where + rebuildMap :: a -> M.Map PlayerId a -> S.Set PlayerId -> M.Map PlayerId a + rebuildMap def mp userset = M.filterWithKey (\k _ -> k `S.member` userset) mp `M.union` M.fromSet (const def) userset + +convertMCom :: Maybe Com -> Todo +convertMCom mc = case mc of + Nothing -> TodoNothing + Just (CAP (AP age turn pid cards _) _) -> TodoAction age turn pid (toList cards) + Just (CAC (AC age pid cards _ msg) _) -> TodoCard age pid (toList cards) msg + +extractGameSummary :: GameS -> GameSummary +extractGameSummary gs = case gs of + GameJoining m -> Joining m + GameOver o -> Finished (fmap (fmap VictoryMap) o) + GamePlaying (GP pm _ _ _ _ gs') -> Started (exportGameState gs') $ do + (pid, PlayerMessages blk msgs) <- itoList pm + let activity = maybe Waiting (const Playing) blk + return (pid, activity, msgs) + +initialHubstate :: HubState +initialHubstate = HubState mempty + +games :: HubState -> M.Map GameId GameSummary +games = fmap extractGameSummary . getHubState + +game :: HubState -> GameId -> Maybe GameSummary +game (HubState hs) gid = fmap extractGameSummary (M.lookup gid hs) + +playerGame :: HubState -> PlayerId -> Maybe (GameId, GameSummary) +playerGame (HubState hs) pid = case M.toList (M.filter (has (_GamePlayers . ix pid)) hs) of + (x : _) -> Just (fmap extractGameSummary x) + _ -> Nothing + +playerStatus :: HubState -> PlayerId -> PlayerStatus +playerStatus (HubState hs) pid = + case M.toList (M.filter (has (_GamePlayers . ix pid)) hs) of + ( (gid, gameS) : _ ) -> + let (todo, messages) = case gameS ^? _GamePlaying . gpPlayers . ix pid of + Nothing -> (TodoNothing, []) + Just (PlayerMessages mcom msgs) -> (convertMCom mcom, msgs) + in InGame gid (extractGameSummary gameS) todo messages + [] -> Inactive + +newGame :: HubMonad m => HubState -> PlayerId -> m (GameId, HubState) +newGame (HubState hs) pid = do + let gid = maybe 0 (succ . fst . fst) (M.maxViewWithKey hs) + tellEvent gid GameCreated + return (gid, HubState (hs & at gid ?~ GameJoining (M.singleton pid Joined))) + +joinGame :: HubMonad m => HubState -> PlayerId -> GameId -> ExceptT PlayerError m HubState +joinGame nhs@(HubState hs) pid gid = do + case playerGame nhs pid of + Nothing -> return () + Just _ -> throwE AlreadyPlaying + case hs ^? ix gid of + Nothing -> throwE GameNotFound + Just GamePlaying{} -> throwE GameAlreadyStarted + Just (GameOver _) -> throwE GameFinished + Just (GameJoining _) -> lift $ do + tellEvent gid (PlayerJoinedGame pid) + checkGameStart (HubState (hs & ix gid . _GameJoining . at pid ?~ Joined)) gid + +checkGameStart :: HubMonad m => HubState -> GameId -> m HubState +checkGameStart nhs@(HubState hs) gid = + case hs ^? ix gid . _GameJoining of + Nothing -> return nhs + Just mp -> if M.size mp >= 7 || (all (== Ready) mp && M.size mp > 1) + then startGame nhs gid (M.keysSet mp) + else return nhs + +startGame :: HubMonad m => HubState -> GameId -> S.Set PlayerId -> m HubState +startGame (HubState hs) gid players = do + tellEvent gid (GameStarted (S.toList players)) + rgen <- getRand + let gs = initialGameState rgen (S.toList players) + gp = GP (M.fromSet (const defPlayerMessages) players) 1 NotBlocked M.empty M.empty gs + gameS <- advanceGame gid gp gs playGame + return $ HubState (hs & at gid ?~ gameS) + +toggleReady :: HubMonad m => HubState -> GameId -> PlayerId -> ExceptT PlayerError m (PlayerJoining, HubState) +toggleReady (HubState hs) gid pid = + case hs ^? ix gid of + Nothing -> throwE PlayerNotInGame + Just (GameJoining mp) -> do + let toggle s = lift $ do + tellEvent gid (PlayerReady pid s) + let hs' = hs & ix gid . _GameJoining . ix pid .~ s + return (s, HubState hs') + case mp ^? ix pid of + Nothing -> throwE PlayerNotInGame -- should not happen + Just Ready -> toggle Joined + Just Joined -> do + (pj, nhs) <- toggle Ready + fmap (pj,) (lift (checkGameStart nhs gid)) + Just GamePlaying{} -> throwE GameAlreadyStarted + Just (GameOver _) -> throwE GameFinished + +playCard :: HubMonad m => Card -> HubState -> GameId -> PlayerId -> ExceptT PlayerError m HubState +playCard = genPlay _BlockingOnCard gpCardProm (_CAC . _2) + +playAction :: HubMonad m => PlayerAction -> Exchange -> HubState -> GameId -> PlayerId -> ExceptT PlayerError m HubState +playAction pa e = genPlay _BlockingOnAction gpActProm (_CAP . _2) (pa, e) + +genPlay :: HubMonad m + => Prism' BlockingOn (GameState, Promise toplay, toplay -> GameMonad Promise GameResult) + -> Lens' GP (M.Map (Promise toplay) toplay) + -> Traversal' Com (Promise toplay) + -> toplay + -> HubState + -> GameId + -> PlayerId + -> ExceptT PlayerError m HubState +genPlay blockPrism promMap comPrism toplay hs gid pid = withGame hs gid $ \gameS -> + case gameS ^? _GamePlaying of + Nothing -> throwE CantPlayNow + Just gp -> case gp ^? gpPlayers . ix pid . curBlocking . _Just . comPrism of + Just prom -> do + let gp' = gp & gpPlayers . ix pid . curBlocking .~ Nothing + pass = return $ GamePlaying $ gp' & promMap . at prom ?~ toplay + case gp' ^? gpBlocking . blockPrism of + Just (gs, prom', act) -> + if prom' == prom + then lift $ advanceGame gid gp' gs (act toplay) + else pass + _ -> pass + _ -> throwE CantPlayNow + +-- | The entry point to run the game and update its state +advanceGame :: HubMonad m => GameId -> GP -> GameState -> GameMonad Promise GameResult -> m GameS +advanceGame gid gp gs act = do + s <- step gid gp gs act + return $ case s of + Fin x -> GameOver (Right x) + Failed rr -> GameOver (Left rr) + 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) + | GPC GP GameState (Promise Card) (Card -> GameMonad Promise a) + | Fin a + | Failed Message + +step :: HubMonad m => GameId -> GP -> GameState -> GameMonad Promise a -> m (StepResult a) +step gid initialgp gs act = case r of + Return x -> return $ Fin x + a :>>= f -> tst a f + where + (r, gs') = runState (viewT act) gs + tst :: HubMonad m => GameInstr Promise b -> (b -> ProgramT (GameInstr Promise) (StateT GameState Identity) a) -> m (StepResult a) + tst a f = + let mkpromise :: (PromiseId, GP) + mkpromise = gp & gpMaxprom <%~ succ + gp = initialgp & gpGS .~ gs' + in case a of + GetPromiseCard pc -> case gp ^? gpCardProm . ix pc of + Just card -> step gid gp gs' (f card) + Nothing -> return $ GPC gp gs' pc f + GetPromiseAct pa -> case gp ^? gpActProm . ix pa of + Just action -> step gid gp gs' (f action) + Nothing -> return $ GPA gp gs' pa f + PlayerDecision age turn pid clist -> do + let apa = AP age turn pid clist gs' + (promid, gp') = mkpromise + prom = Promise promid + gp'' = gp' & gpPlayers . ix pid . curBlocking ?~ CAP apa prom + tellEvent gid (PlayerMustPlay pid) + step gid gp'' gs' (f prom) + AskCard age pid cards msg -> do + let apc = AC age pid cards gs' msg + (promid, gp') = mkpromise + prom = Promise promid + gp'' = gp' & gpPlayers . ix pid . curBlocking ?~ CAC apc prom + tellEvent gid (PlayerMustPlay pid) + step gid gp'' gs' (f prom) + Message com -> do + gp' <- case com of + PlayerCom pid (RawMessage msg) -> do + tellEvent gid (PCom pid msg) + return $ gp & gpPlayers . ix pid . playerLog %~ (msg :) + BroadcastCom (RawMessage msg) -> do + tellEvent gid (BCom msg) + return $ gp & gpPlayers . traverse . playerLog %~ (msg :) + _ -> return gp + step gid gp' gs' (f ()) + ThrowError err -> return $ Failed err + CatchError n handler -> step gid gp gs' n >>= \y -> case y of + Failed rr -> step gid gp gs' (handler rr >>= f) + Fin x -> step gid gp gs' (f x) + GPA _ _ _ _ -> return $ Failed "Can't catch error when asking for a promise in the middle" + GPC _ _ _ _ -> return $ Failed "Can't catch error when asking for a promise in the middle" diff --git a/Startups/Exported.hs b/Startups/Exported.hs new file mode 100644 index 0000000..1dd08ee --- /dev/null +++ b/Startups/Exported.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | Useful for safely exporting data without exposing hidden information +module Startups.Exported where + +import qualified Data.Map.Strict as M +import Data.Aeson +import Data.Aeson.TH +import Data.Aeson.Types (Parser) +import Data.Text (Text) +import Control.Lens + +import Startups.Json +import Startups.Base +import Startups.Cards +import Startups.GameTypes + +data ExportedPlayerState = ExportedPlayerState { _eCompany :: CompanyProfile + , _eCompanyStage :: CompanyStage + , _eCardsCount :: Int + , _eFunds :: Funding + , _eNeighborhood :: Neighborhood + , _ePoachingResults :: [PoachingOutcome] + } deriving (Eq, Show) + +data ExportedGameState = ExportedGameState { _eplayermap :: M.Map PlayerId ExportedPlayerState + , _ediscardSize :: Int + } deriving (Eq, Show) + +newtype GameId = GameId { _getGameId :: Integer } + deriving (Show, Eq, Ord, Enum, Num, FromJSON, ToJSON) + +data PlayerStatus = Inactive + | InGame GameId GameSummary Todo [Message] + deriving (Show, Eq) + +data Todo = TodoAction Age Turn PlayerId [Card] + | TodoCard Age PlayerId [Card] Message + | TodoNothing + deriving (Show, Eq) + +exportGameState :: GameState -> ExportedGameState +exportGameState gs = ExportedGameState (fmap exportPlayerState (_playermap gs)) (length (_discardpile gs)) + where + exportPlayerState pm = ExportedPlayerState (_pCompany pm) + (_pCompanyStage pm) + (length (_pCards pm)) + (_pFunds pm) + (_pNeighborhood pm) + (_pPoachingResults pm) + +newtype VictoryMap = VictoryMap { getVictoryMap :: M.Map VictoryType VictoryPoint } + deriving (Eq, Show) + +instance ToJSON VictoryMap where + toJSON = toJSON . M.fromList . (traverse . _1 %~ show) . M.toList . getVictoryMap + +instance FromJSON VictoryMap where + parseJSON = withObject "VictoryMap" (fmap (VictoryMap . M.fromList) . mapM readKey . itoList) + where + readKey :: (Text, Value) -> Parser (VictoryType, VictoryPoint) + readKey (k,v) = (,) <$> parseJSON (String k) <*> parseJSON v + +data PlayerJoining = Joined | Ready + deriving (Show, Eq, Enum, Bounded) + +data GameSummary = Joining (M.Map PlayerId PlayerJoining) + | Zombie [PlayerId] + | Started ExportedGameState [(PlayerId, PlayerActivity, [Message])] + | Finished (Either Message (M.Map PlayerId VictoryMap)) + deriving (Eq, Show) + +data PlayerActivity = Waiting | Playing + deriving (Show, Eq, Enum, Bounded) + +data PlayerError = AlreadyPlaying + | GameAlreadyStarted + | GameFinished + | GameNotFound + | PlayerNotInGame + | CantPlayNow + deriving (Show, Eq, Read, Enum, Ord, Bounded) + +data GameEvent = PlayerJoinedGame PlayerId + | GameCreated + | GameStarted [PlayerId] + | PlayerMustPlay PlayerId + | PlayerReady PlayerId PlayerJoining + | PCom PlayerId Message + | BCom Message + deriving (Show, Eq) + +makePrisms ''GameSummary +makePrisms ''PlayerStatus +makePrisms ''Todo +makeLenses ''ExportedGameState +makeLenses ''ExportedPlayerState +$(deriveJSON baseOptions ''PlayerStatus) +$(deriveJSON baseOptions ''Todo) +$(deriveJSON baseOptions ''GameSummary) +$(deriveJSON baseOptions ''PlayerJoining) +$(deriveJSON baseOptions ''PlayerActivity) +$(deriveJSON baseOptions ''PlayerError) +$(deriveJSON baseOptions ''GameEvent) +$(deriveJSON (dropOptions 2) ''ExportedGameState) +$(deriveJSON (dropOptions 2) ''ExportedPlayerState) + diff --git a/Startups/Game.hs b/Startups/Game.hs index d241ce4..e301eb0 100644 --- a/Startups/Game.hs +++ b/Startups/Game.hs @@ -211,7 +211,7 @@ playTurn age turn rawcardmap = do -- first gather all decisions promises pdecisions <- ifor cardmap $ \pid crds -> (crds,) <$> (convertCards crds >>= playerDecision age turn pid) -- then await on all promised - decisions <- traverse (\(crds,p) -> (,) <$> pure crds <*> getPromise p) pdecisions + decisions <- traverse (\(crds,p) -> (,) <$> pure crds <*> getPromiseAction p) pdecisions results <- itraverse (resolveAction age) decisions -- first add the money gained from exchanges ifor_ (results ^. traverse . _2) $ \pid payout -> diff --git a/Startups/GameTypes.hs b/Startups/GameTypes.hs index 47796b9..435b855 100644 --- a/Startups/GameTypes.hs +++ b/Startups/GameTypes.hs @@ -83,7 +83,8 @@ data Communication = RawMessage PrettyDoc data GameInstr p a where PlayerDecision :: Age -> Turn -> PlayerId -> NonEmpty Card -> GameInstr p (p (PlayerAction, Exchange)) AskCard :: Age -> PlayerId -> NonEmpty Card -> Message -> GameInstr p (p Card) - GetPromise :: p a -> GameInstr p a + GetPromiseCard :: p Card -> GameInstr p Card + GetPromiseAct :: p (PlayerAction, Exchange) -> GameInstr p (PlayerAction, Exchange) 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 @@ -102,9 +103,13 @@ tellPlayer p = singleton . Message . PlayerCom p . RawMessage generalMessage :: Message -> GameMonad p () generalMessage = singleton . Message . BroadcastCom . RawMessage --- | Awaits a promise -getPromise :: p a -> GameMonad p a -getPromise = singleton . GetPromise +-- | Awaits a "card" promise +getPromiseCard :: p Card -> GameMonad p Card +getPromiseCard = singleton . GetPromiseCard + +-- | Awaits an "action" promise +getPromiseAction :: p (PlayerAction, Exchange) -> GameMonad p (PlayerAction, Exchange) +getPromiseAction = singleton . GetPromiseAct -- | Gives a quick rundown of all actions actionRecap :: Age -> Turn -> M.Map PlayerId (PlayerAction, Exchange) -> GameMonad p () @@ -120,7 +125,7 @@ instance MonadError PrettyDoc (ProgramT (GameInstr p) (State GameState)) where -- player doesn't introduce a new card in the game. askCardSafe :: Age -> PlayerId -> NonEmpty Card -> Message -> GameMonad p Card askCardSafe a p cl m = do - card <- singleton (AskCard a p cl m) >>= getPromise + card <- singleton (AskCard a p cl m) >>= getPromiseCard when (card `notElem` (cl ^. re _NonEmpty)) (throwError (showPlayerId p <+> "tried to play a non proposed card")) return card diff --git a/Startups/Interpreter.hs b/Startups/Interpreter.hs index a21b98f..090b9c0 100644 --- a/Startups/Interpreter.hs +++ b/Startups/Interpreter.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Startups.Interpreter where import Startups.Base @@ -14,40 +15,59 @@ data Strategy p m = Strategy { _doPlayerDecision :: Age -> Turn -> PlayerId -> N , _doAskCard :: Age -> PlayerId -> NonEmpty Card -> GameState -> Message -> m (p Card) } -data OperationDict p m = OperationDict { _strat :: Strategy p m - , _doGetPromise :: forall a. p a -> m (Either Message a) - , _doMessage :: GameState -> CommunicationType -> m () +data OperationDict p m = OperationDict { _strat :: Strategy p m + , _doGetPromise :: forall a. p a -> m (Either Message a) + , _doMessage :: GameState -> CommunicationType -> m () } +data OperationDict' p m = OperationDict' { _strat' :: Strategy p m + , _doGetPromiseAct :: p (PlayerAction, Exchange) -> m (Either Message (PlayerAction, Exchange)) + , _doGetPromiseCard :: p Card -> m (Either Message Card) + , _doMessage' :: GameState -> CommunicationType -> m () + } runInterpreter :: Monad m => OperationDict p m -> GameState -> GameMonad p a -> m (GameState, Either Message a) -runInterpreter dico gamestate m = +runInterpreter dico = runInterpreter' dico' + where + dico' = OperationDict' (_strat dico) (_doGetPromise dico) (_doGetPromise dico) (_doMessage dico) + +runInterpreter' :: Monad m + => OperationDict' p m + -> GameState + -> GameMonad p a + -> m (GameState, Either Message a) +runInterpreter' dico gamestate m = case runState (viewT m) gamestate of - (a, nextstate) -> evalInstrGen dico nextstate a + (a, nextstate) -> evalInstrGen' dico nextstate a -evalInstrGen :: Monad m - => OperationDict p m - -> GameState - -> ProgramViewT (GameInstr p) (State GameState) a - -> m (GameState, Either Message a) -evalInstrGen _ gamestate (Return x) = return (gamestate, Right x) -evalInstrGen dico gamestate (a :>>= f) = - let runC a' = runInterpreter dico gamestate (f a') +evalInstrGen' :: forall p m a. Monad m + => OperationDict' p m + -> GameState + -> ProgramViewT (GameInstr p) (State GameState) a + -> m (GameState, Either Message a) +evalInstrGen' _ gamestate (Return x) = return (gamestate, Right x) +evalInstrGen' dico gamestate (a :>>= f) = + let runC a' = runInterpreter' dico gamestate (f a') in case a of - PlayerDecision age turn pid clist -> _doPlayerDecision (_strat dico) age turn pid clist gamestate >>= runC - GetPromise x -> do - o <- _doGetPromise dico x + PlayerDecision age turn pid clist -> _doPlayerDecision (_strat' dico) age turn pid clist gamestate >>= runC + GetPromiseCard x -> do + o <- _doGetPromiseCard dico x + case o of + Left rr -> return (gamestate, Left rr) + Right v -> runC v + GetPromiseAct x -> do + o <- _doGetPromiseAct dico x case o of - Left rr -> return (gamestate, Left rr) - Right v -> runC v - AskCard age pid cards msg -> _doAskCard (_strat dico) age pid cards gamestate msg >>= runC - Message com -> _doMessage dico gamestate com >>= runC + Left rr -> return (gamestate, Left rr) + Right v -> runC v + AskCard age pid cards msg -> _doAskCard (_strat' dico) age pid cards gamestate msg >>= runC + Message com -> _doMessage' dico gamestate com >>= runC ThrowError err -> return (gamestate, Left err) CatchError n handler -> do - n' <- runInterpreter dico gamestate n + n' <- runInterpreter' dico gamestate n case n' of - (gs', Left rr) -> runInterpreter dico gs' (handler rr >>= f) - (gs', Right x) -> runInterpreter dico gs' (f x) + (gs', Left rr) -> runInterpreter' dico gs' (handler rr >>= f) + (gs', Right x) -> runInterpreter' dico gs' (f x) diff --git a/tests/tests.hs b/tests/tests.hs index b2605c3..9cc44a0 100644 --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main where import Startups.Base @@ -6,6 +7,8 @@ import Startups.Cards import Startups.CardList import Startups.GameTypes import Startups.Utils +import Startups.Exported +import Backends.GenericHub import Backends.Pure import Strategies.Random @@ -19,6 +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) getCard :: T.Text -> Card @@ -58,6 +63,13 @@ testState = GameState (M.fromList players) [] (mkStdGen 5) , "Standing Desks" ] +newtype HubWriter a = HubWriter { getHubWriter :: Writer [(GameId, GameEvent)] a } + deriving (Functor, Applicative, Monad, MonadWriter [(GameId, GameEvent)]) + +instance HubMonad HubWriter where + getRand = return (mkStdGen 42) + tellEvent gid e = tell [(gid, e)] + main :: IO () main = hspec $ do describe "Cards" $ do @@ -84,3 +96,73 @@ main = hspec $ do it "end well" $ forAll gs $ \(seed, nbplayers) -> case pureGame stdGenStateStrat (mkStdGen seed) (map (T.pack . show) [1 .. nbplayers]) of (_, Right _) -> True _ -> False + + describe "Hub" $ do + let mhs = initialHubstate + runHubE :: ExceptT PlayerError HubWriter a -> (Either PlayerError a, [(GameId, GameEvent)]) + runHubE = runWriter . getHubWriter . runExceptT + runHub :: HubWriter a -> (a, [(GameId, GameEvent)]) + runHub = runWriter . getHubWriter + shouldGiveError act err = case runHubE act of + (Left rr, _) -> rr `shouldBe` err + _ -> fail "Should have failed" + it "Should start with an empty game" $ games mhs `shouldBe` mempty + it "Should not enter nonexistent games" $ joinGame mhs "bob" 12 `shouldGiveError` GameNotFound + let ((gid, hs1),msgs) = runHub (newGame mhs "bob") + it "Should create a new game" $ do + gid `shouldBe` 0 + msgs `shouldBe` [(0,GameCreated)] + games hs1 `shouldBe` M.singleton 0 (Joining (M.singleton "bob" Joined)) + let (res2, msgs2) = runHubE (joinGame hs1 "garry" 0 >>= \hs' -> joinGame hs' "john" 0) + Right hs2 = res2 + it "Should register other players" $ do + case res2 of + Left rr -> fail (show rr) + Right _ -> return () + msgs2 `shouldBe` [(0, PlayerJoinedGame "garry"), (0, PlayerJoinedGame "john")] + games hs2 `shouldBe` M.singleton 0 (Joining (M.fromList [("bob", Joined), ("garry", Joined), ("john", Joined)])) + let (res3, msgs3) = runHubE $ do + (_, hsa) <- toggleReady hs2 0 "bob" + (_, hsb) <- toggleReady hsa 0 "garry" + (_, hsc) <- toggleReady hsb 0 "john" + return hsc + Right hs3 = res3 + it "Should toggle status until game starts" $ do + msgs3 `shouldBe` [ (0, PlayerReady "bob" Ready) + , (0, PlayerReady "garry" Ready) + , (0, PlayerReady "john" Ready) + , (0, GameStarted ["bob","garry","john"]) + , (0, PlayerMustPlay "bob") + , (0, PlayerMustPlay "garry") + , (0, PlayerMustPlay "john") + ] + it "Should start the game properly" $ do + let InGame gid' _ todo messages = playerStatus hs3 "bob" + TodoAction age turn pid cards = todo + gid' `shouldBe` 0 + todo `shouldSatisfy` has _TodoAction + age `shouldBe` Age1 + turn `shouldBe` 1 + pid `shouldBe` "bob" + length cards `shouldBe` 7 + messages `shouldBe` [] + let (res4, msgs4) = runHubE $ do + InGame _ _ (TodoAction _ _ _ cardsBob) _ <- return (playerStatus hs3 "bob") + InGame _ _ (TodoAction _ _ _ cardsGarry) _ <- return (playerStatus hs3 "garry") + InGame _ _ (TodoAction _ _ _ cardsJohn) _ <- return (playerStatus hs3 "john") + hsa <- playAction (PlayerAction Drop (head cardsBob)) mempty hs3 0 "bob" + hsb <- playAction (PlayerAction Drop (head cardsGarry)) mempty hsa 0 "garry" + hsc <- playAction (PlayerAction Drop (head cardsJohn)) mempty hsb 0 "john" + return hsc + Right hs4 = res4 + it "Should be possible to play" $ do + res4 `shouldSatisfy` has _Right + let InGame gid' _ todo messages = playerStatus hs4 "bob" + TodoAction age turn pid cards = todo + gid' `shouldBe` 0 + todo `shouldSatisfy` has _TodoAction + age `shouldBe` Age1 + turn `shouldBe` 2 + pid `shouldBe` "bob" + length cards `shouldBe` 6 + messages `shouldBe` []