summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xChangeLog.md8
-rw-r--r--Game/Hanabi.hs31
-rw-r--r--Game/Hanabi/Backend.lhs74
-rw-r--r--hanabi-dealer.cabal2
4 files changed, 79 insertions, 36 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index 4dd0754..1082470 100755
--- 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
index cb779d8..89da39f 100644
--- a/Game/Hanabi.hs
+++ b/Game/Hanabi.hs
@@ -5,7 +5,7 @@ module Game.Hanabi(
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.Char(isSpace, isAlpha, isAlphaNum, toLower, toUpper)
import Data.Maybe(fromJust)
import Data.List(isPrefixOf, group)
import System.IO
+import Data.Dynamic
import GHC.Generics hiding (K1)
@@ -323,6 +324,34 @@ class Monad m => Strategy p m where
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
index 6282c3d..33df97d 100644
--- a/Game/Hanabi/Backend.lhs
+++ b/Game/Hanabi/Backend.lhs
@@ -10,7 +10,6 @@ import Game.Hanabi hiding (main)
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 @@ import System.Posix hiding (Default)
#endif
import qualified Data.IntMap as IntMap
+import qualified Data.Map as Map
#ifdef SNAP
import Network.WebSockets.Snap
@@ -103,20 +103,20 @@ usage = do progname <- getProgName
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 @@ main' versionString = do
#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 @@ loop gen stat tidToMVH socket = do
# 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 @@ instance (MonadIO m) => Strategy ViaWebSocket m where
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 @@ instance (MonadIO m) => Strategy IndexedStrategy m where
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 gen mvTIDToMVH tup@(_, _) conn = do
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 @@ interpret mbVerb inp gen mvTIDToMVH tup@(versionString, _) conn
[("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 @@ interpret mbVerb inp gen mvTIDToMVH tup@(versionString, _) conn
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
index c315c4f..2ab0128 100644
--- a/hanabi-dealer.cabal
+++ b/hanabi-dealer.cabal
@@ -10,7 +10,7 @@ name: hanabi-dealer
-- 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