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.2.0 -- 2020-01-16 + + * make the server and the client parts of the library + + * make other strategies selectable from the client, and make SimpleStrategy the first of such strategies + + * roll back memoization to fix some problem + ## 0.3.1.0 -- 2020-01-14 * introduce StrategyDict, dictionary-style interface to Strategy diff --git a/Game/Hanabi.hs b/Game/Hanabi.hs --- a/Game/Hanabi.hs +++ b/Game/Hanabi.hs @@ -16,7 +16,7 @@ -- ** Hints isCritical, isUseless, bestPossibleRank, isPlayable, invisibleBag, -- ** Minor ones - what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, ithPlayerFromTheLast, view) where + what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, ithPlayerFromTheLast, view, replaceNth) where -- module Hanabi where import qualified Data.IntMap as IM import System.Random @@ -329,8 +329,7 @@ -- | '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 Mover s m = [PrivateView] -> [Move] -> s -> m (Move, s) 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} diff --git a/Game/Hanabi/Backend.lhs b/Game/Hanabi/Backend.lhs --- a/Game/Hanabi/Backend.lhs +++ b/Game/Hanabi/Backend.lhs @@ -4,7 +4,7 @@ -- -- x #define SNAP -module Game.Hanabi.Backend(main') where +module Game.Hanabi.Backend(server, Options(..), defaultOptions, module Game.Hanabi) where import Game.Hanabi hiding (main) import Game.Hanabi.Msg @@ -32,28 +32,12 @@ import Control.Monad --- These are for reporting resource usage. -#if __GLASGOW_HASKELL__ >= 700 -import GHC.Stats -#endif - --- import Control.Monad.Par.Class --- import Control.Monad.Par.IO import Control.Monad.IO.Class(MonadIO, liftIO) import System.Timeout import Data.Hashable(hash) import Data.Text(unpack, pack) --- import Control.Concurrent.ParallelIO(stopGlobalPool) - --- import Data.Map - -#ifdef UNIX --- as suggested by /usr/share/doc/libghc6-network-doc/html/Network.html -import System.Posix hiding (Default) -#endif - import qualified Data.IntMap as IntMap import qualified Data.Map as Map @@ -70,18 +54,6 @@ import Data.Aeson #endif - -portID = 8720 - -{- -trusted "localhost" = True -trusted "127.0.0.1" = True -trusted hostname = "133.54." `isPrefixOf` hostname - -deadlineTO = 30 * minutes -minutes = 60*1000000 --} - data Flag = Port Int -- x | Socket FilePath | Interactive cmdOpts :: [OptDescr Flag] @@ -102,57 +74,59 @@ usage = do progname <- getProgName hPutStrLn stderr $ usageInfo ("Usage: "++progname++" [OPTION...]") cmdOpts -data HowToServe = Network Int +procFlags :: Options -> [Flag] -> Options +procFlags = foldl procFlag +procFlag :: Options -> Flag -> Options +procFlag opt (Port i) = opt{port=i} -defaultSO = Network portID -procFlags :: [Flag] -> HowToServe -procFlags = foldl procFlag defaultSO -procFlag :: HowToServe -> Flag -> HowToServe -procFlag st (Port i) = Network i - -main = main' "hoge" - -main' :: String -> IO () -main' versionString = do +server :: Options -> IO () +server opt = do (flags, _args) <- readOpts - let Network pid = procFlags flags + let options = procFlags opt flags withSocketsDo $ do - hPutStrLn stderr $ "hanabi-dealer server " ++ versionString + hPutStrLn stderr $ "hanabi-dealer server " ++ version options beginCT <- getCurrentTime hPutStrLn stderr ("started at " ++ show beginCT) #ifdef TFRANDOM - gen <- newTFGen + g <- newTFGen #else - gen <- newStdGen + g <- newStdGen #endif - tidToMVH <- newMVar (IntMap.empty::IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) + mv <- newMVar (IntMap.empty::IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) + let params = Params{gen = g, mvTIDToMVH = mv, versionString = version options, gsConstructorMap = Map.fromList $ strategies options, conn = error "Game.Hanabi.Backend.server: should not happen"} #ifdef SNAP - httpServe (setPort pid defaultConfig) $ runWebSocketsSnap + httpServe (setPort (port options) defaultConfig) $ runWebSocketsSnap #else - runServer "127.0.0.1" pid + runServer "127.0.0.1" (port options) #endif - $ loop gen tidToMVH versionString + $ loop params +data Params g = Params{gen :: g, + mvTIDToMVH :: MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))), + conn :: Connection, + versionString :: String, + gsConstructorMap :: Map.Map String (IO (DynamicStrategy IO)) + } + +-- Well, this is not a loop any longer.... loop :: RandomGen g => - g - -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) - -> String - -> PendingConnection - -> IO () -loop gen tidToMVH ver socket = do + Params g -> PendingConnection -> IO () +loop params socket = do + c <- acceptRequest socket #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. + let p = params{conn = c} #else # ifdef TFRANDOM - gen <- newTFGen + g <- newTFGen # else - gen <- newStdGen + g <- newStdGen # endif + let p = params{gen = g, conn = c} #endif - conn <- acceptRequest socket - withPingThread conn 30 (return ()) $ fmap (const ()) $ answerHIO gen tidToMVH ver conn + withPingThread c 30 (return ()) $ fmap (const ()) $ answerHIO p endecodeX Nothing = endecode @@ -171,7 +145,6 @@ let truncate = if sendFullHistory vh then id else take $ numPlayers $ gameSpec $ publicView v msg = WhatsUp "via WebSocket" (truncate views) (truncate moves) sendTextData (connection vh) $ endecodeX (verbVWS vh) msg --- sendTextData (connection vh) $ endecodeX (verbVWS vh) $ Str "Your turn.\n" mov <- repeatReadingAMoveUntilSuccess (connection vh) v return (mov, vh) where repeatReadingAMoveUntilSuccess :: Connection -> PrivateView -> IO Move @@ -188,70 +161,44 @@ 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..] [ --- return $ toDyn $ Sontakki emptyDefault - ] -ixSMap :: (MonadIO m) => IntMap.IntMap (m String, [PrivateView] -> [Move] -> Dynamic -> m (Move, Dynamic)) -ixSMap = IntMap.fromAscList $ zip [0..] [ (return "Via WebSocket", \pvs mvs dyn -> fmap (\(m,p)->(m, toDyn p)) $ move pvs mvs (fromDyn dyn (error "Type error." :: ViaWebSocket))) --- , (return "Sontakki", \pvs mvs (IxS i dyn) -> fmap (\(m,p)->(m, IxS i $ toDyn p)) $ move pvs mvs (fromDyn dyn (Sontakki emptyDefault))) --- , ... - ] -ixSMapSize :: Int -ixSMapSize = IntMap.size (ixSMap :: IntMap.IntMap (IO String, [PrivateView] -> [Move] -> Dynamic -> IO (Move, Dynamic))) -instance (MonadIO m) => Strategy IndexedStrategy m where - strategyName mp = do IxS i _dyn <- mp - fst $ ixSMap IntMap.! (i `mod` ixSMapSize) -- "Array of Strategies" - 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 -> Connection -> IO () -answerHIO gen mvTIDToMVH tup conn = do - available Nothing mvTIDToMVH conn +answerHIO :: RandomGen g => Params g -> IO () +answerHIO params = do + available Nothing (mvTIDToMVH params) (conn params) hPutStrLn stderr "trying to receive data" - eithinp <- try $ receiveDataMessage conn + eithinp <- try $ receiveDataMessage $ conn params hPutStrLn stderr $ "received " ++ show eithinp - let (g1,g2) = split gen + let (g1,g2) = split $ gen params case eithinp of Left e | isEOFError e -> hPutStrLn stderr $ show e | otherwise -> hPutStrLn stderr $ show e Right input -> do let inp = unpack $ fromDataMessage input hPutStrLn stderr inp - case reads inp of [(cmdl, _)] -> interpret Nothing cmdl g1 mvTIDToMVH tup conn - _ -> interpret (Just verbose) inp g1 mvTIDToMVH tup conn - answerHIO g2 mvTIDToMVH tup conn + case reads inp of [(cmdl, _)] -> interpret Nothing cmdl params{gen=g1} + _ -> interpret (Just verbose) inp params{gen=g1} + answerHIO params{gen=g2} 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 -> Connection -> IO () -interpret mbVerb inp gen mvTIDToMVH versionString conn + Maybe Verbosity -> String -> Params g -> IO () +interpret mbVerb inp params = let sender :: String -> IO () - sender = sendTextData conn . endecodeX mbVerb . Str + sender = sendTextData (conn params) . endecodeX mbVerb . Str in case lex inp of - [("version", _)] -> sender $ "hanabi-dealer server "++versionString + [("version", _)] -> sender $ "hanabi-dealer server " ++ versionString params [("create", args)] -> case reads args of [(rule,rest)] | isRuleValid rule -> create rule rest _ -> create defaultRule args where create rule args = 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 + else case dropWhile (\s -> isWS s || s `Map.member` gsConstructorMap params) 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)] @@ -260,37 +207,36 @@ [i] -> i _ -> hash tidstr -- Just for future compatibility. 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. + modifyMVar_ (mvTIDToMVH params) (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 -> 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 + constructor _ algIx = fromJust $ Map.lookup algIx $ gsConstructorMap params ixSs <- sequence $ zipWith constructor [0..] is sender "starting the game\n" - 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 + eithFinalSituation <- try $ start (GS (succ numAllies) rule) (mkDS "via WebSocket" (VWS (conn params) mbVerb sendFullHistoryInFact) : ixSs) $ gen params finalSituation <- case eithFinalSituation of Left e -> do hPutStrLn stderr $ displayException (e::SomeException) return Nothing Right ((fs@(eg,sts,mvs),_),_) -> return $ Just $ if sendFullHistoryInFact then fs else (eg, truncate sts, truncate mvs) where truncate = take $ numPlayers $ gameSpec $ publicState $ head sts - sendTextData conn $ endecodeX mbVerb $ PrettyEndGame finalSituation + sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame finalSituation putMVar mvFinalSituation finalSituation where numAllies = length is _ -> sender "The arguments of the `create' command could not be parsed." - [("available", s)] | all isSpace s -> when (isJust mbVerb) $ available mbVerb mvTIDToMVH conn + [("available", s)] | all isSpace s -> when (isJust mbVerb) $ available mbVerb (mvTIDToMVH params) (conn params) [("attend", arg)] -> case reads arg of - [(gid, s)] | all isSpace s -> do tidToMVH <- readMVar mvTIDToMVH + [(gid, s)] | all isSpace s -> do tidToMVH <- readMVar $ mvTIDToMVH params case IntMap.lookup gid tidToMVH of Nothing -> sender $ "Could not find the game ID " ++ show gid Just (mvhs, mvFinalSituation) -> do emptyMVHs <- fmap (map fst . filter snd . zip mvhs) $ mapM isEmptyMVar mvhs case emptyMVHs of - emvh:_ -> putMVar emvh (VWS conn mbVerb sendFullHistoryInFact) >> sender "Successfully registered to the game.\n" + emvh:_ -> putMVar emvh (VWS (conn params) mbVerb sendFullHistoryInFact) >> sender "Successfully registered to the game.\n" [] -> sender "The game already has enough number of players.\n" finalSituation <- readMVar mvFinalSituation - sendTextData conn $ endecodeX mbVerb $ PrettyEndGame finalSituation -- This could be from the viewpoint of this player. + sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame finalSituation -- This could be from the viewpoint of this player. _ -> sender "The arguments of the `attend' command could not be parsed." _ -> sender $ inp ++ " : command unknown\n" ++ commandHelp available mbVerb mvTIDToMVH conn = do diff --git a/Game/Hanabi/Client.hs b/Game/Hanabi/Client.hs --- a/Game/Hanabi/Client.hs +++ b/Game/Hanabi/Client.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE CPP #-} -module Game.Hanabi.Client where +module Game.Hanabi.Client(client, Game.Hanabi.Msg.Options(..), Game.Hanabi.Msg.defaultOptions, mkDS) where import Game.Hanabi hiding (main, rule) import Game.Hanabi.Msg @@ -14,6 +14,7 @@ import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Maybe(fromJust) +import Data.List(intersperse) import Miso hiding (Fail) import Miso.String (MisoString) @@ -34,16 +35,17 @@ -- Miso's implementation of WebSockets uses global IORef. -- https://github.com/dmjio/miso/blob/master/frontend-src/Miso/Subscription/WebSocket.hs -main' :: String -> IO () -main' versionInfo = runApp $ startApp App{ - model = Model{tboxval = Message "available", players = [0], rule = defaultRule, received = [], fullHistory = False}, +client :: Game.Hanabi.Msg.Options -> IO () +client options = runApp $ startApp App{ + model = Model{tboxval = Message "available", players = ["via WebSocket"], rule = defaultRule, received = [], fullHistory = False}, update = updateModel, - view = appView versionInfo, + view = appView strNames $ version options, subs = [ websocketSub uri protocols HandleWebSocket ], events = defaultEvents, initialAction = Id, -- initialAction = SendMessage $ Message "available", -- Seemingly sending as initialAction does not work, even if connect is executed before send. mountPoint = Nothing} + where strNames = "via WebSocket" : [ S.pack name | (name, _) <- strategies options ] #ifdef URI uri = URL URI #else @@ -61,16 +63,17 @@ -} updateModel :: Action -> Model -> Effect Action Model updateModel (HandleWebSocket (WebSocketMessage (Message m))) model - = noEff model{ received = {- take lenHistory $ -} memoMsg verbose model (decodeMsg m) : received model } + = noEff model{ received = {- take lenHistory $ -} decodeMsg m : received model } updateModel (SendMessage msg) model = model{fullHistory=False} <# (-- connect uri protocols >> send msg >> return Id) updateModel (UpdateTBoxVal m) model = noEff model{ tboxval = Message m } -updateModel IncreasePlayers model = noEff model{players = take 9 $ 0 : players model} +updateModel IncreasePlayers model = noEff model{players = take 9 $ "via WebSocket" : players model} updateModel DecreasePlayers model = noEff model{players = case players model of {n:ns@(_:_) -> ns; ns -> ns}} +updateModel (UpdatePlayer ix pl) model = noEff model{players = snd $ replaceNth ix pl $ players model} updateModel (UpdateRule r) model | isRuleValid r = noEff model{rule=r} updateModel Toggle model = noEff model{fullHistory = not $ fullHistory model} #ifdef DEBUG -updateModel (HandleWebSocket act) model = noEff model{received = memoMsg verbose model (Str (show act)) : received model } +updateModel (HandleWebSocket act) model = noEff model{received = Str (show act) : received model } #endif updateModel _ model = noEff model @@ -86,35 +89,28 @@ | UpdateTBoxVal MisoString | IncreasePlayers | DecreasePlayers + | UpdatePlayer Int MisoString | UpdateRule Rule | Toggle | Id data Model = Model { tboxval :: Message - , players :: [Int] + , players :: [MisoString] , rule :: Rule - , received :: [MsgView] + , received :: [Msg] , fullHistory :: Bool } deriving (Show, Eq) --- MsgView memoizes the view of its Msg. -data MsgView = MV{theMsg :: Msg, viewMsg :: View Action} -instance Eq MsgView where - MV m1 _ == MV m2 _ = m1 == m2 -instance Show MsgView where - showsPrec _ (MV m _) = ("(MV "++) . shows m . (')':) - -- Also, toHtml could be used for showing viewMsg. - lenShownHistory = 10 -appView :: String -> Model -> View Action -appView versionInfo mdl@Model{..} = div_ [] [ +appView :: [MisoString] -> String -> Model -> View Action +appView strategies versionInfo mdl@Model{..} = div_ [] [ input_ [ type_ "text", placeholder_ "You can also use your keyboard.", size_ "25", onInput UpdateTBoxVal, onEnter (SendMessage tboxval) ] , button_ [ onClick (SendMessage tboxval) ] [ text (S.pack "Send to the server") ] -- x , span_ [style_ $ M.fromList [("font-size","10px")]] [text $ S.pack "(Use this line if you prefer the keyboard interface.)"] , span_ [style_ $ M.fromList [("font-size","10px"), ("float","right")]] [text $ S.pack $ "hanabi-dealer client "++versionInfo] -- , hr_ [] - , div_ [style_ $ M.fromList [("clear","both")]] ((if fullHistory then id else take lenShownHistory) $ map viewMsg received) + , div_ [style_ $ M.fromList [("clear","both")]] ((if fullHistory then id else take lenShownHistory) $ map (renderMsg strategies verbose mdl) received) , div_ [] $ if null $ drop lenShownHistory received then [] else [ hr_ [] , input_ [ type_ "checkbox", id_ "showhist", onClick Toggle, checked_ fullHistory] @@ -148,16 +144,13 @@ [(msg,_)] -> msg #endif -memoMsg :: Verbosity -> Model -> Msg -> MsgView -memoMsg v mdl msg = MV msg $ renderMsg v mdl msg - -renderMsg :: Verbosity -> Model -> Msg -> View Action -renderMsg _ _ (Str xs) = div_ [] [hr_ [], pre_ [] [ text $ S.pack xs ]] -renderMsg verb _ (WhatsUp name ps ms) = renderWhatsUp verb name ps ms -renderMsg verb _ (WhatsUp1 p m) = renderWhatsUp1 verb p m -renderMsg _ _ (PrettyEndGame Nothing) = pre_ [] [ text $ S.pack $ prettyMbEndGame Nothing] -renderMsg _ _ (PrettyEndGame (Just tup)) = renderEndGame tup -- pre_ [] [ text $ S.pack $ prettyEndGame tup] -renderMsg _ mdl (PrettyAvailable games) +renderMsg :: [MisoString] -> Verbosity -> Model -> Msg -> View Action +renderMsg _ _ _ (Str xs) = div_ [] [hr_ [], pre_ [] [ text $ S.pack xs ]] +renderMsg _ verb _ (WhatsUp name ps ms) = renderWhatsUp verb name ps ms +renderMsg _ verb _ (WhatsUp1 p m) = renderWhatsUp1 verb p m +renderMsg _ _ _ (PrettyEndGame Nothing) = pre_ [] [ text $ S.pack $ prettyMbEndGame Nothing] +renderMsg _ _ _ (PrettyEndGame (Just tup)) = renderEndGame tup -- pre_ [] [ text $ S.pack $ prettyEndGame tup] +renderMsg strategies _ mdl (PrettyAvailable games) = div_ [style_ $ M.fromList [("overflow","auto")]] [ hr_ [], table_ [style_ $ M.fromList [("border-style","solid"), ("clear","both"), ("float","right")]] $ @@ -169,11 +162,16 @@ div_ [] [ button_ [onClick IncreasePlayers] [text $ S.pack "+"], button_ [onClick DecreasePlayers] [text $ S.pack "-"], - text $ S.pack $ show $ players mdl, - button_ [onClick $ SendMessage $ Message $ S.pack $ "create " ++ show (rule mdl) ++ tail (init $ show $ players mdl)] [text $ S.pack "create a game"] + span_ [] $ intersperse (text ",") $ zipWith (renderPlayer strategies) [0..] $ players mdl, + button_ [onClick $ SendMessage $ Message $ S.pack $ "create " ++ show (rule mdl) ++ concat (intersperse "," $ map S.unpack $ players mdl)] [text $ S.pack "create a game"] ] ] ] +renderPlayer :: [MisoString] -> Int -> MisoString -> View Action +--renderPlayer _ i p = text p +renderPlayer strategies i p = select_ [onChange $ UpdatePlayer i] [ option_ [value_ p', selected_ $ p==p'] [text p'] | p' <- strategies ] + + renderAvailable (gameid, (missing, total)) = tr_ [onClick $ SendMessage $ Message $ S.pack $ "attend "++show gameid] [ td_ [solid] [text $ S.pack str] | str <- [show gameid, show missing, show total] ] solid = style_ $ M.fromList [("border-style","solid")] diff --git a/Game/Hanabi/Msg.hs b/Game/Hanabi/Msg.hs --- a/Game/Hanabi/Msg.hs +++ b/Game/Hanabi/Msg.hs @@ -43,3 +43,14 @@ prettyMbEndGame Nothing = "Game ended abnormally, possibly by connection failure.\n" prettyMbEndGame (Just tup) = prettyEndGame tup prettyAvailableGame (gameid, (missing, total)) = "Game ID " ++ shows gameid ": available " ++ shows missing " out of " ++ shows total "." + + +defaultOptions = Opt{version = error "The verion field should be set to Game.Hanabi.VersionInfo.versionInfo", + port = 8720, + strategies = [] + } +data Options = Opt{ version :: String -- ^ the version string to be shown by the `version' command. + -- This is supposed to be set to 'versionInfo', but can just be @""@ + , port :: Int -- ^ the port number. This can be overridden by `-p' option. + , strategies :: [(String, IO (DynamicStrategy IO))] -- ^ the association list of the tuples of the strategy name and (the constructor for) the strategy. + } diff --git a/Game/Hanabi/Strategies/SimpleStrategy.hs b/Game/Hanabi/Strategies/SimpleStrategy.hs new file mode 100644 --- /dev/null +++ b/Game/Hanabi/Strategies/SimpleStrategy.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +module Game.Hanabi.Strategies.SimpleStrategy where +import Game.Hanabi hiding (main) +import System.Random + +-- An example of a simple and stupid strategy. +data Simple = S () + +instance Monad m => Strategy Simple m where + strategyName ms = return "Stupid example strategy" + move (pv:_) _mvs s = let pub = publicView pv + numHand = length $ head $ givenHints pub + mov | hintTokens pub == 8 = Play 0 -- Play the newest card if there are the max number of hint tokens. + | otherwise = Drop (numHand-1) -- Otherwise, drop the oldest card. + in return (mov, s) + +main = do g <- newStdGen + ((eg,_),_) <- start defaultGS ([S ()],[stdio]) g -- Play it with standard I/O (human player). + putStrLn $ prettyEndGame eg diff --git a/Game/Hanabi/VersionInfo.hs b/Game/Hanabi/VersionInfo.hs --- a/Game/Hanabi/VersionInfo.hs +++ b/Game/Hanabi/VersionInfo.hs @@ -10,14 +10,15 @@ import Language.Haskell.TH #endif #ifdef CABAL -import Paths_hanabi_dealer(version) +import qualified Paths_hanabi_dealer(version) import Data.Version(showVersion) #endif +import Game.Hanabi.Msg(defaultOptions, Options(..)) versionInfo, mhVersion, ghcVersion, now :: String versionInfo = mhVersion ++ compiler ++ ghcVersion ++ now #ifdef CABAL -mhVersion = showVersion version +mhVersion = showVersion Paths_hanabi_dealer.version #else mhVersion = "" #endif @@ -32,3 +33,5 @@ #else now = "" #endif + +defOpt = defaultOptions{version=versionInfo} diff --git a/client.hs b/client.hs --- a/client.hs +++ b/client.hs @@ -1,3 +1,12 @@ import Game.Hanabi.VersionInfo import Game.Hanabi.Client -main = main' versionInfo + +import Game.Hanabi.Strategies.SimpleStrategy hiding (main) + +main = client defOpt{strategies=strs} + +-- strs :: [(String, IO (DynamicStrategy IO))] +strs = [ + ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S ()) + -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault)) + ] diff --git a/examples/SimpleStrategy.hs b/examples/SimpleStrategy.hs deleted file mode 100644 --- a/examples/SimpleStrategy.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -module SimpleStrategy where -import Game.Hanabi hiding (main) -import System.Random - --- An example of a simple and stupid strategy. -data Simple = S () - -instance Monad m => Strategy Simple m where - strategyName ms = return "Simple" - move (pv:_) _mvs s = let pub = publicView pv - numHand = length $ head $ givenHints pub - mov | hintTokens pub == 8 = Play 0 -- Play the newest card if there are the max number of hint tokens. - | otherwise = Drop (numHand-1) -- Otherwise, drop the oldest card. - in return (mov, s) - -main = do g <- newStdGen - ((eg,_),_) <- start defaultGS ([S ()],[stdio]) g -- Play it with standard I/O (human player). - putStrLn $ prettyEndGame eg 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.1.0 +version: 0.3.2.0 -- A short (one-line) description of the package. synopsis: Hanabi card game @@ -43,7 +43,8 @@ -- Extra files to be distributed with the package, such as examples or a -- README. -extra-source-files: ChangeLog.md, examples/SimpleStrategy.hs +extra-source-files: ChangeLog.md +-- , examples/SimpleStrategy.hs -- This is moved to Game.Hanabi.Strategies.SimpleStrategy -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.10 @@ -53,7 +54,7 @@ location: https://hub.darcs.net/susumu/hanabi-dealer Flag server - Description: Build the server program in addition to the library. + Description: Build the server program and library in addition to the minimal library. Default: False Flag SNAP Description: Use Snap instead of runServer. @@ -63,6 +64,7 @@ Default: True FLAG official Description: The client connects to the official server URI instead of localhost. + (NB: Currently the official server is behind our firewall and is being tested internally.) Default: False FLAG TH Description: Use template-haskell just for obtaining the compilation time. @@ -71,17 +73,16 @@ library -- Modules exported by the library. exposed-modules: Game.Hanabi - -- , Game.Hanabi.Backend + -- Other library packages from which modules are imported. + build-depends: base >=4.8 && <4.14, containers >=0.5, random >=1.1 + -- Modules included in this library but not exported. -- other-modules: -- LANGUAGE extensions used by modules in this package. other-extensions: MultiParamTypeClasses, FlexibleInstances, Safe - -- , CPP, TupleSections, NoOverlappingInstances - -- Other library packages from which modules are imported. - build-depends: base >=4.8 && <4.14, containers >=0.5, random >=1.1 -- Directories containing source files. -- hs-source-dirs: @@ -89,9 +90,39 @@ -- Base language which the package is written in. default-language: Haskell2010 + if impl(ghcjs) || flag(server) + exposed-modules: Game.Hanabi.VersionInfo + other-modules: Game.Hanabi.Msg + + if !impl(ghcjs) && flag(server) + ghc-options: -O2 + -- Not sure if -O2 is worthy, but this should be OK because the server is not built by default. + exposed-modules: Game.Hanabi.Backend + build-depends: websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6 && <1.9, text >=1.2, utf8-string + -- cpp-options: -DCABAL + -- -DCABAL is used for detecting the version of hanabi-dealer, which is impossible when building as the library. + if flag(TH) + build-depends: template-haskell + if flag(TFRANDOM) + build-depends: tf-random + cpp-options: -DTFRANDOM + if flag(SNAP) + build-depends: unix >=2.7 && <2.8, websockets-snap >=0.10 && <0.11, snap-server >=1.1 && <1.2, abstract-par >=0.3 && <0.4, monad-par >=0.3 && <0.4 + cpp-options: -DSNAP + if impl(ghcjs) + exposed-modules: Game.Hanabi.Client + ghcjs-options: -dedupe -O + -- cpp-options: -DCABAL + build-depends: base >=4.12 && <4.13, jsaddle-warp >=0.9, aeson, miso, time + default-language: Haskell2010 + if flag(official) + cpp-options: -DURI="ws://133.54.228.39:8720" + if flag(TH) + build-depends: template-haskell + executable server main-is: server.hs - other-modules: Game.Hanabi.Backend, Game.Hanabi.Msg, Game.Hanabi.VersionInfo + other-modules: Game.Hanabi.Backend, Game.Hanabi.Msg, Game.Hanabi.VersionInfo, Game.Hanabi.Strategies.SimpleStrategy if impl(ghcjs) || !flag(server) buildable: False else @@ -111,7 +142,7 @@ executable client main-is: client.hs - other-modules: Game.Hanabi.Msg, Game.Hanabi.Client, Game.Hanabi.VersionInfo + other-modules: Game.Hanabi.Msg, Game.Hanabi.Client, Game.Hanabi.VersionInfo, Game.Hanabi.Strategies.SimpleStrategy if !impl(ghcjs) buildable: False else diff --git a/server.hs b/server.hs --- a/server.hs +++ b/server.hs @@ -1,3 +1,12 @@ import Game.Hanabi.Backend import Game.Hanabi.VersionInfo -main = main' versionInfo + +import Game.Hanabi.Strategies.SimpleStrategy hiding (main) + +main = server defOpt{strategies=strs} + +strs :: [(String, IO (DynamicStrategy IO))] +strs = [ + ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S ()) + -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault)) + ]