diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for hanabi-dealer + ## 0.3.1.0 -- 2020-01-14 + + * introduce StrategyDict, dictionary-style interface to Strategy + + * reflect the -p option + + * resolve the name collision against websockets-0.12.7.0 + ## 0.3.0.1 -- 2020-01-12 * fix bestPossibleRank (and thus isUseless) diff --git a/Game/Hanabi.hs b/Game/Hanabi.hs --- a/Game/Hanabi.hs +++ b/Game/Hanabi.hs @@ -5,7 +5,7 @@ prettyEndGame, isMoveValid, checkEndGame, help, -- * Datatypes -- ** The Class of Strategies - Strategies, Strategy(..), Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose, + Strategies, Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose, -- ** The Game Specification GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid, -- ** The Game State and Interaction History @@ -26,6 +26,7 @@ import Data.Maybe(fromJust) import Data.List(isPrefixOf, group) import System.IO +import Data.Dynamic import GHC.Generics hiding (K1) @@ -322,6 +323,34 @@ -- The next state can be the same as the current one unless the algorithm is learning on-line during the game. observe _pvs _moves st = return ((),st) -- The default does nothing. -} + + +-- StrategyDict should be used instead of class Strategy, maybe. + +-- | 'StrategyDict' is a dictionary implementation of class 'Strategy'. It can be used instead if you like. +data StrategyDict m s = SD{sdName :: String, sdMove :: Mover s m, sdObserve :: Observer s m, sdState :: s} +type HanabiT s m a = [PrivateView] -> [Move] -> s -> m (a, s) +type Mover s m = HanabiT s m Move +type Observer s m = [PrivateView] -> [Move] -> s -> m () +mkSD :: (Monad m, Typeable s, Strategy s m) => String -> s -> StrategyDict m s +mkSD name s = SD{sdName=name, sdMove=move, sdObserve=observe, sdState=s} +instance Monad m => Strategy (StrategyDict m s) m where + strategyName mp = do p <- mp + return $ sdName p + move pvs mvs s = sdMove s pvs mvs (sdState s) >>= \ (m, nexts) -> return (m, s{sdState=nexts}) + observe pvs mvs s = sdObserve s pvs mvs $ sdState s + + +-- Should DynamicStrategy be limited to IO? +type DynamicStrategy m = StrategyDict m Dynamic +mkDS :: (Monad m, Typeable s, Strategy s m) => String -> s -> DynamicStrategy m +mkDS name s = mkDS' $ mkSD name s +mkDS' :: (Monad m, Typeable s) => StrategyDict m s -> DynamicStrategy m +mkDS' gs = SD{sdName = sdName gs, + sdMove = \pvs mvs dyn -> fmap (\(m,p)->(m, toDyn p)) $ sdMove gs pvs mvs (fromDyn dyn (error "mkDS': impossible")), + sdObserve = \pvs mvs dyn -> sdObserve gs pvs mvs (fromDyn dyn (error "mkDS': impossible")), + sdState = toDyn $ sdState gs} + -- | The 'Strategies' class defines the list of 'Strategy's. If all the strategies have the same type, one can use the list instance. -- I (Susumu) guess that in most cases one can use 'Dynamic' in order to force the same type, but just in case, the tuple instance is also provided. (Also, the tuple instance should be more handy.) diff --git a/Game/Hanabi/Backend.lhs b/Game/Hanabi/Backend.lhs --- a/Game/Hanabi/Backend.lhs +++ b/Game/Hanabi/Backend.lhs @@ -10,7 +10,6 @@ import Game.Hanabi.Msg import Data.Maybe(fromJust, isNothing, isJust) -import Data.Dynamic import System.Random #ifdef TFRANDOM import System.Random.TF @@ -56,6 +55,7 @@ #endif import qualified Data.IntMap as IntMap +import qualified Data.Map as Map #ifdef SNAP import Network.WebSockets.Snap @@ -103,20 +103,20 @@ hPutStrLn stderr $ usageInfo ("Usage: "++progname++" [OPTION...]") cmdOpts data HowToServe = Network Int -data ServerOptions = SO {howToServe :: HowToServe} -defaultSO = SO {howToServe = Network portID} -procFlags :: [Flag] -> ServerOptions +defaultSO = Network portID + +procFlags :: [Flag] -> HowToServe procFlags = foldl procFlag defaultSO -procFlag :: ServerOptions -> Flag -> ServerOptions -procFlag st (Port i) = st{howToServe = Network i} +procFlag :: HowToServe -> Flag -> HowToServe +procFlag st (Port i) = Network i main = main' "hoge" main' :: String -> IO () main' versionString = do (flags, _args) <- readOpts - let so = procFlags flags + let Network pid = procFlags flags withSocketsDo $ do hPutStrLn stderr $ "hanabi-dealer server " ++ versionString beginCT <- getCurrentTime @@ -126,25 +126,24 @@ #else gen <- newStdGen #endif - let (g1,g2) = split gen - let stat = (versionString, so) tidToMVH <- newMVar (IntMap.empty::IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) #ifdef SNAP - httpServe (setPort portID defaultConfig) $ runWebSocketsSnap + httpServe (setPort pid defaultConfig) $ runWebSocketsSnap #else - runServer "127.0.0.1" portID + runServer "127.0.0.1" pid #endif - $ loop g1 stat tidToMVH + $ loop gen tidToMVH versionString loop :: RandomGen g => g - -> (String, ServerOptions) -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) + -> String -> PendingConnection -> IO () -loop gen stat tidToMVH socket = do +loop gen tidToMVH ver socket = do #ifdef DEBUG +-- In this case, every time this program is run, the gen is refreshed, but the same gen (and thus the same card deck) is always used. #else # ifdef TFRANDOM gen <- newTFGen @@ -153,9 +152,7 @@ # endif #endif conn <- acceptRequest socket - let (g1,g2) = split gen - withPingThread conn 30 (return ()) $ fmap (const ()) $ answerHIO g1 tidToMVH stat conn --- loop g2 stat tidToMVH socket -- Seemingly this is unnecessary. + withPingThread conn 30 (return ()) $ fmap (const ()) $ answerHIO gen tidToMVH ver conn endecodeX Nothing = endecode @@ -191,6 +188,7 @@ observe _ [] _ = return () observe (v:_) (m:_) vh = liftIO $ sendTextData (connection vh) $ endecodeX (verbVWS vh) $ WhatsUp1 v m +{- data IndexedStrategy = IxS Int Dynamic ixSConstructorMap :: IntMap.IntMap (IO IndexedStrategy) ixSConstructorMap = IntMap.fromAscList $ zipWith (\i iodyn -> (i, fmap (IxS i) iodyn)) [1..] [ @@ -209,12 +207,17 @@ move pvs mvs ixs@(IxS i dyn) = fmap (\(m,p)->(m, IxS i p)) $ (snd $ ixSMap IntMap.! (i `mod` ixSMapSize)) pvs mvs dyn -- modulo is used in order to avoid failure. observe vs ms (IxS 0 dyn) = observe vs ms (fromDyn dyn (error "Type error." :: ViaWebSocket)) observe _ _ _ = return () +-} +gsConstructorMap :: Map.Map String (IO (DynamicStrategy IO)) +gsConstructorMap = Map.fromList [ + -- ("Sontakki", return $ mkDS (Sontakki emptyDefault)) + ] answerHIO :: RandomGen g => - g -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) -> (String, ServerOptions) -> Connection -> IO () -answerHIO gen mvTIDToMVH tup@(_, _) conn = do + g -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) -> String -> Connection -> IO () +answerHIO gen mvTIDToMVH tup conn = do available Nothing mvTIDToMVH conn hPutStrLn stderr "trying to receive data" eithinp <- try $ receiveDataMessage conn @@ -231,10 +234,13 @@ answerHIO g2 mvTIDToMVH tup conn sendFullHistoryInFact = False - +wordsBy :: (a->Bool) -> [a] -> [[a]] +wordsBy pred xs = case break pred xs of (tk, []) -> [tk] + (tk,_:dr) -> tk : wordsBy pred dr +isWS = (`elem` ["0", "WS", "via WebSocket"]) interpret :: RandomGen g => - Maybe Verbosity -> String -> g -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) -> (String, ServerOptions) -> Connection -> IO () -interpret mbVerb inp gen mvTIDToMVH tup@(versionString, _) conn + Maybe Verbosity -> String -> g -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) -> String -> Connection -> IO () +interpret mbVerb inp gen mvTIDToMVH versionString conn = let sender :: String -> IO () sender = sendTextData conn . endecodeX mbVerb . Str in case lex inp of @@ -242,13 +248,13 @@ [("create", args)] -> case reads args of [(rule,rest)] | isRuleValid rule -> create rule rest _ -> create defaultRule args where create rule args = - case reads $ '[':args++"]" of - [(is,"")] | numAllies > 0 -> if numAllies >= 9 - then sender "Too many teemmates!\n" - else if any (>=ixSMapSize) is - then sender $ "Algorithm " ++ shows (maximum is) " not implemented yet.\n" - else do - pl2MVHs <- sequence [ fmap (pl,) newEmptyMVar | (pl,0) <- zip [0..] is ] :: IO [(Int, MVar ViaWebSocket)] + case wordsBy (==',') args of + is | numAllies > 0 -> if numAllies >= 9 + then sender "Too many teemmates!\n" + else case dropWhile (\s -> isWS s || s `Map.member` gsConstructorMap) is of + alg:_ -> sender $ "Algorithm " ++ shows (maximum is) " not implemented yet.\n" + [] -> do + pl2MVHs <- sequence [ fmap (pl,) newEmptyMVar | (pl,name) <- zip [0..] is, isWS name ] :: IO [(Int, MVar ViaWebSocket)] tidstr <- fmap show myThreadId let gid = case [ i | ("ThreadId", xs) <- lex tidstr, (i, ys) <- reads xs, all isSpace ys ] of [i] -> i @@ -256,13 +262,13 @@ mvFinalSituation <- newEmptyMVar :: IO (MVar (Maybe (EndGame,[State],[Move]))) modifyMVar_ mvTIDToMVH (return . IntMap.insert gid (map snd pl2MVHs, mvFinalSituation)) -- IntMap.insert replaces with the new value if the key already exists. This behavior is good here because that means the game for the threadId has either finished or been killed and the threadId is reused. sender $ "The ID of the game is " ++ show gid - let constructor :: Int -> Int -> IO IndexedStrategy - constructor plIx 0 = do vws <- readMVar $ fromJust $ lookup plIx pl2MVHs - return $ IxS 0 $ toDyn vws - constructor _ algIx = fromJust $ IntMap.lookup algIx ixSConstructorMap + let constructor :: Int -> String -> IO (DynamicStrategy IO) + constructor plIx algIx | isWS algIx = do vws <- readMVar $ fromJust $ lookup plIx pl2MVHs + return $ mkDS "via WebSocket" vws + constructor _ algIx = fromJust $ Map.lookup algIx gsConstructorMap ixSs <- sequence $ zipWith constructor [0..] is sender "starting the game\n" - eithFinalSituation <- try $ start (GS (succ numAllies) rule) (IxS 0 (toDyn $ VWS conn mbVerb sendFullHistoryInFact) : ixSs) gen + eithFinalSituation <- try $ start (GS (succ numAllies) rule) (mkDS "via WebSocket" (VWS conn mbVerb sendFullHistoryInFact) : ixSs) gen -- let finalSituation = either (\e -> const Nothing (e::ConnectionException)) (Just.(fst.fst)) eithFinalSituation finalSituation <- case eithFinalSituation of Left e -> do hPutStrLn stderr $ displayException (e::SomeException) diff --git a/hanabi-dealer.cabal b/hanabi-dealer.cabal --- a/hanabi-dealer.cabal +++ b/hanabi-dealer.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.3.0.1 +version: 0.3.1.0 -- A short (one-line) description of the package. synopsis: Hanabi card game