hanabi-dealer 0.2.1.0 → 0.3.0.0
raw patch · 10 files changed
+854/−35 lines, 10 filesdep +abstract-pardep +aesondep +hanabi-dealerdep ~basenew-component:exe:clientnew-component:exe:serverPVP ok
version bump matches the API change (PVP)
Dependencies added: abstract-par, aeson, hanabi-dealer, hashable, jsaddle-warp, miso, monad-par, network, snap-server, template-haskell, text, tf-random, time, unix, utf8-string, websockets, websockets-snap
Dependency ranges changed: base
API changes (from Hackage documentation)
- Game.Hanabi: [invisibleBag] :: PrivateView -> IntMap Int
+ Game.Hanabi: invisibleBag :: PrivateView -> IntMap Int
+ Game.Hanabi: isRuleValid :: Rule -> Bool
- Game.Hanabi: PV :: PublicInfo -> [[Card]] -> IntMap Int -> PrivateView
+ Game.Hanabi: PV :: PublicInfo -> [[Card]] -> PrivateView
Files
- ChangeLog.md +20/−8
- Game/Hanabi.hs +22/−19
- Game/Hanabi/Backend.lhs +306/−0
- Game/Hanabi/Client.hs +347/−0
- Game/Hanabi/Msg.hs +45/−0
- Game/Hanabi/VersionInfo.hs +34/−0
- client.hs +3/−0
- examples/SimpleStrategy.hs +19/−0
- hanabi-dealer.cabal +55/−8
- server.hs +3/−0
ChangeLog.md view
@@ -1,17 +1,29 @@ # Revision history for hanabi-dealer -## 0.2.1.0 -- 2020-01-04+ ## 0.3.0.0 -- 2020-01-12 -* introduce isPlayable+ * playable client/server system via WebSocket -* fix several misfeatures+ * GUI using GHCJS and Miso -## 0.2.0.0 -- 2019-12-20+ * separate invisibleBag from PrivateView -* define the Verbosity option+ * surpress redundant broadcasting of the observation to the current player -* confirm running with base-4.13 compiled by GHC-8.8.1.+ * add SimpleStrategy example -## 0.1.0.0 -- 2019-12-18+ ## 0.2.1.0 -- 2020-01-04 -* First version. Released on an unsuspecting world.+ * introduce isPlayable++ * fix several misfeatures++ ## 0.2.0.0 -- 2019-12-20++ * define the Verbosity option++ * confirm running with base-4.13 compiled by GHC-8.8.1.++ ## 0.1.0.0 -- 2019-12-18++ * First version. Released on an unsuspecting world.
Game/Hanabi.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, Safe, DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, Safe, DeriveGeneric, RecordWildCards #-} module Game.Hanabi( -- * Functions for Dealing Games main, selfplay, start, createGame, run,@@ -7,19 +7,20 @@ -- ** The Class of Strategies Strategies, Strategy(..), Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose, -- ** The Game Specification- GameSpec(..), defaultGS, Rule(..), defaultRule,+ GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid, -- ** The Game State and Interaction History Move(..), Index, State(..), PrivateView(..), PublicInfo(..), Result(..), EndGame(..), -- ** The Cards Card(..), Color(..), Number(..), cardToInt, intToCard, readsColorChar, readsNumberChar, -- * Utilities -- ** Hints- isCritical, isUseless, bestPossibleRank, isPlayable,+ isCritical, isUseless, bestPossibleRank, isPlayable, invisibleBag, -- ** Minor ones what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, ithPlayerFromTheLast, view) where -- module Hanabi where import qualified Data.IntMap as IM import System.Random+import Control.Monad(when) import Control.Monad.IO.Class(MonadIO, liftIO) import Data.Char(isSpace, isAlpha, isAlphaNum, toLower, toUpper) import Data.Maybe(fromJust)@@ -107,7 +108,7 @@ -- x , multicolor :: Bool -- ^ multicolor play, or Variant 3 } deriving (Show, Read, Eq, Generic)-+isRuleValid rule@R{..} = numBlackTokens > 0 && all (>0) funPlayerHand && numColors>0 && numColors <=6 && (numColors < 6 || all (>0) numMulticolors) -- | @defaultRule@ is the normal rule from the rule book of the original card game Hanabi. defaultRule = R { numBlackTokens = 3 , funPlayerHand = [5,5]++take 12 (repeat 4)@@ -119,7 +120,7 @@ defaultGS = GS{numPlayers=2, rule=defaultRule} initialPileNum gs = sum (take (numColors $ rule gs) $ [10,10,10,10,10]++[sum (numMulticolors $ rule gs)]) - numPlayerHand gs * numPlayers gs-numPlayerHand gs = funPlayerHand (rule gs) !! (numPlayers gs - 2)+numPlayerHand gs = (funPlayerHand (rule gs) ++ repeat 4) !! (numPlayers gs - 2) data GameSpec = GS {numPlayers :: Int, rule :: Rule} deriving (Read, Show, Eq, Generic) -- | State consists of all the information of the current game state, including public info, private info, and the hidden deck.@@ -194,9 +195,12 @@ , handsPV :: [[Card]] -- ^ Other players' hands. [next player's hand, second next player's hand, ...] -- This is based on the viewer's viewpoint (unlike 'hands' which is based on the current player's viewpoint), -- and the view history @[PrivateView]@ must be from the same player's viewpoint (as the matter of course).- , invisibleBag :: IM.IntMap Int -- ^ @'Card' -> Int@. This represents the bag of unknown cards (which are either in the pile or in the player's hand).- -- This can be computed from publicView and handsSV. } deriving (Read, Show, Eq, Generic)+-- | 'invisibleBag' returns the bag of unknown cards (which are either in the pile or in the player's hand).+invisibleBag :: PrivateView+ -> IM.IntMap Int -- ^ @'Card' -> Int@+invisibleBag pv = foldr (IM.update (Just . pred)) (nonPublic $ publicView pv) $ map cardToInt $ concat $ handsPV pv + prettyPV :: Verbosity -> PrivateView -> String prettyPV v pv@PV{publicView=pub} = prettyPI pub ++ "\nMy hand:\n" ++ concat (replicate (length myHand) " __") ++ "\n"@@ -251,8 +255,7 @@ view :: State -> PrivateView view st = PV {publicView = publicState st,- handsPV = tail $ hands st,- invisibleBag = foldr (IM.update (Just . pred)) (nonPublic $ publicState st) $ map cardToInt $ concat $ tail $ hands st}+ handsPV = tail $ hands st} main = selfplay defaultGS @@ -288,7 +291,7 @@ (st, g) = createGame gs gen in fmap (\e -> (e,g)) $ run [st] [] players run :: (Monad m, Strategies ps m) => [State] -> [Move] -> ps -> m ((EndGame, [State], [Move]), ps)-run states moves players = do ((mbeg, sts, mvs), ps) <- runARound (\sts@(st:_) mvs -> let myOffset = turn (publicState st) in broadcast (zipWith rotate [-myOffset, 1-myOffset ..] sts) mvs players >> return ()) states moves players+run states moves players = do ((mbeg, sts, mvs), ps) <- runARound (\sts@(st:_) mvs -> let myOffset = turn (publicState st) in broadcast (zipWith rotate [-myOffset, 1-myOffset ..] sts) mvs players (myOffset `mod` numPlayers (gameSpec $ publicState st)) >> return ()) states moves players case mbeg of Nothing -> run sts mvs ps Just eg -> return ((eg, sts, mvs), ps) @@ -330,7 +333,7 @@ -- If there are twice as many strategies as 'numPlayers', the game will be "Pair Hanabi", like "Pair Go" or "Pair Golf" or whatever. (Maybe this is also interesting.) class Strategies ps m where runARound :: ([State] -> [Move] -> m ()) -> [State] -> [Move] -> ps -> m ((Maybe EndGame, [State], [Move]), ps)- broadcast :: [State] -> [Move] -> ps -> m [State]+ broadcast :: [State] -> [Move] -> ps -> Int -> m ([State], Int) {- Abolished in order to avoid confusion due to overlapping instances. When necessary, use a singleton list instead. instance {-# OVERLAPS #-} (Strategy p1 m, Monad m) => Strategies p1 m where runARound states moves p = runATurn states moves p@@ -340,8 +343,8 @@ Nothing -> do (tups,ps') <- runARound hook sts mvs ps return (tups, (p',ps')) _ -> return (tup, (p',ps))- broadcast states moves (p1,p2) = do sts <- broadcast states moves p1- broadcast sts moves p2+ broadcast states moves (p1,p2) offset = do (sts, ofs) <- broadcast states moves p1 offset+ broadcast sts moves p2 ofs instance (Strategy p m, Monad m) => Strategies [p] m where -- runARound hook states moves [] = return ((Nothing, states, moves), []) runARound hook states moves [] = error "It takes at least one algorithm to play Hanabi!"@@ -350,9 +353,9 @@ Nothing -> do (tups,ps') <- runARound hook sts mvs ps return (tups, (p':ps')) _ -> return (tup, (p':ps))- broadcast _ _ [] = error "It takes at least one algorithm to play Hanabi!"- broadcast states moves [p] = observe (map view states) moves p >> return (map (rotate 1) states)- broadcast states moves (p:ps) = observe (map view states) moves p >> broadcast (map (rotate 1) states) moves ps+ broadcast _ _ [] _ = error "It takes at least one algorithm to play Hanabi!"+ broadcast states moves [p] ofs = when (ofs/=0) (observe (map view states) moves p) >> return (map (rotate 1) states, pred ofs)+ broadcast states moves (p:ps) ofs = when (ofs/=0) (observe (map view states) moves p) >> broadcast (map (rotate 1) states) moves ps (pred ofs) runATurn :: (Strategy p m, Monad m) => [State] -> [Move] -> p -> m ((Maybe EndGame, [State], [Move]), p) runATurn states moves p = let alg = move (map view $ zipWith rotate [0..] states) moves p in@@ -371,7 +374,7 @@ return $ if name == "Blind" then "STDIO" else "Verbose " ++ name move views@(v:_) moves (Verbose p verb) = let alg = move views moves p in do name <- strategyName (fmap (\a -> Verbose (snd a) verb) alg)- liftIO $ putStrLn $ what'sUp verb name views moves ++ "Your turn.\n"+ liftIO $ putStrLn $ what'sUp verb name views moves (mv,p') <- alg -- liftIO $ putStrLn $ "Move is " ++ show mv -- This is redundant because of echo back. return (mv, Verbose p' verb)@@ -382,7 +385,7 @@ recentEvents ithPlayer views moves ++ '\n' : replicate 20 '-' ++ '\n' : "Algorithm: " ++ name ++ '\n' :- prettyPV verb v ++ "\n"+ prettyPV verb v ++ "\nYour turn.\n" what'sUp1 verb v m = replicate 20 '-' ++ '\n' : showTrial (const "") undefined v m ++ '\n' : replicate 20 '-' ++ '\n' :@@ -415,7 +418,7 @@ data ViaHandles = VH {hin :: Handle, hout :: Handle, verbVH :: Verbosity} instance (MonadIO m) => Strategy ViaHandles m where strategyName p = return "via handles"- move views@(v:_) moves vh = liftIO $ do hPutStrLn (hout vh) $ what'sUp (verbVH vh) "via handles" views moves ++ "Your turn.\n"+ move views@(v:_) moves vh = liftIO $ do hPutStrLn (hout vh) $ what'sUp (verbVH vh) "via handles" views moves mov <- repeatReadingAMoveUntilSuccess (hin vh) (hout vh) v return (mov, vh)
+ Game/Hanabi/Backend.lhs view
@@ -0,0 +1,306 @@+\begin{code}+{-# LANGUAGE CPP, TupleSections, MultiParamTypeClasses, FlexibleInstances #-}+-- Do not forget -threaded!+--++-- x #define SNAP+module Game.Hanabi.Backend(main') where++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+#endif++import Control.Concurrent+import Network.Socket+import Network.WebSockets+import System.IO+import System.IO.Error(isEOFError)+import Control.Exception+import Data.Char(isSpace)+-- import Data.List(isPrefixOf)++import Data.Time++import System.Console.GetOpt+import System.Environment+import System.Exit++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++#ifdef SNAP+import Network.WebSockets.Snap+import Snap.Http.Server.Config+import Snap.Http.Server+import Data.ByteString.UTF8(fromString)+#endif++#ifdef AESON+import Data.Text.Encoding(decodeUtf8)+import Data.ByteString.Lazy(toStrict)+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]+cmdOpts = [ Option ['p'] ["port-number"] (ReqArg (Port . toEnum . readOrErr msgp) "PORT_NUMBER") "use port number PORT_NUMBER"+ ]+ where readOrErr msg xs = case reads xs of [(i,"")] | i>=0 -> i+ _ -> error msg+ msgp = "--port-number (or -p) takes a non-negative integral value specifying the port number."++readOpts :: IO ([Flag], [String])+readOpts = do argv <- getArgs+ case (getOpt Permute cmdOpts argv) of+ (o,n,[] ) -> return (o,n)+ (_,_,errs) -> do hPutStrLn stderr (concat errs)+ usage+ exitFailure+usage :: IO ()+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+procFlags = foldl procFlag defaultSO+procFlag :: ServerOptions -> Flag -> ServerOptions+procFlag st (Port i) = st{howToServe = Network i}++main = main' "hoge"++main' :: String -> IO ()+main' versionString = do+ (flags, _args) <- readOpts+ let so = procFlags flags+ withSocketsDo $ do+ hPutStrLn stderr $ "hanabi-dealer server " ++ versionString+ beginCT <- getCurrentTime+ hPutStrLn stderr ("started at " ++ show beginCT)+#ifdef TFRANDOM+ gen <- newTFGen+#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+#else+ runServer "127.0.0.1" portID+#endif+ $ loop g1 stat tidToMVH++loop :: RandomGen g =>+ g+ -> (String, ServerOptions)+ -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move]))))+ -> PendingConnection+ -> IO ()+loop gen stat tidToMVH socket = do+#ifdef DEBUG+#else+# ifdef TFRANDOM+ gen <- newTFGen+# else+ gen <- newStdGen+# 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.+++endecodeX Nothing = endecode+-- endecodeX Nothing = pack . show . prettyMsg verbose+endecodeX (Just verb) = pack . prettyMsg verb+#ifdef AESON+endecode = decodeUtf8 . toStrict . encode+#else+endecode = pack . show . show+#endif++data ViaWebSocket = VWS {connection :: Connection, verbVWS :: Maybe Verbosity, sendFullHistory :: Bool}+instance (MonadIO m) => Strategy ViaWebSocket m where+ strategyName p = return "via WebSocket"+ move views@(v:_) moves vh = liftIO $ do+ 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+ repeatReadingAMoveUntilSuccess conn v = do+ str <- fmap unpack $ receiveData conn+ let mvstr = case reads str of+ [(mvs,rest)] | all isSpace rest -> mvs+ _ -> str+ case reads mvstr of+ [(mv, rest)] | all isSpace rest -> if isMoveValid v mv then return mv else do sender conn "Invalid Move"+ repeatReadingAMoveUntilSuccess conn v+ _ -> sender conn ("Parse error.\n"++help) >> repeatReadingAMoveUntilSuccess conn v+ sender conn = sendTextData conn . endecodeX (verbVWS vh) . Str+ 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 ()++++answerHIO :: RandomGen g =>+ g -> MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) -> (String, ServerOptions) -> Connection -> IO ()+answerHIO gen mvTIDToMVH tup@(_, _) conn = do+ available Nothing mvTIDToMVH conn+ hPutStrLn stderr "trying to receive data"+ eithinp <- try $ receiveDataMessage conn+ hPutStrLn stderr $ "received " ++ show eithinp+ let (g1,g2) = split gen+ 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++sendFullHistoryInFact = False++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+ = let sender :: String -> IO ()+ sender = sendTextData conn . endecodeX mbVerb . Str+ in case lex inp of+ [("version", _)] -> sender $ "hanabi-dealer server "++versionString+ [("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)]+ tidstr <- fmap show myThreadId+ let gid = case [ i | ("ThreadId", xs) <- lex tidstr, (i, ys) <- reads xs, all isSpace ys ] of+ [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.+ 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+ 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+-- let finalSituation = either (\e -> const Nothing (e::ConnectionException)) (Just.(fst.fst)) eithFinalSituation+ 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+ 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+ [("attend", arg)] -> case reads arg of+ [(gid, s)] | all isSpace s -> do tidToMVH <- readMVar mvTIDToMVH+ 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"+ [] -> 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.+ _ -> sender "The arguments of the `attend' command could not be parsed."+ _ -> sender $ inp ++ " : command unknown\n" ++ commandHelp+available mbVerb mvTIDToMVH conn = do+ tidToMVH <- readMVar mvTIDToMVH+-- availableGames <- IntMap.traverse filt tidToMVH+ games <- mapM fun $ IntMap.toAscList $ fmap fst tidToMVH+ let availableGames = filter (\(_,(n,_)) -> n/=0) games+ sendTextData conn $ endecodeX mbVerb $ PrettyAvailable availableGames+ where fun (gameid, mvhs) = do+ emptyMVHs <- filterM isEmptyMVar mvhs+ return (gameid, (length emptyMVHs, length mvhs))++commandHelp = "`create 0' : create a two-player game, call for a player, then start the game. The game ID will be printed.\n"+ ++ "`create 0,0' : create a three-player game, call for two players, then start the game. The game ID will be printed.\n"+ ++ " etc. up to nine-player game.\n"+ ++ " (`0' means a human player. We plan to add various algorithmic players.)\n"+ ++ "`attend <<game ID>>' : attend the game identified by the game ID.\n"+ ++ "'available' : request the list of games calling for players.\n"+\end{code}
+ Game/Hanabi/Client.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE CPP #-}+module Game.Hanabi.Client where++import Game.Hanabi hiding (main, rule)+import Game.Hanabi.Msg++import Data.Aeson hiding (Success)+import GHC.Generics hiding (K1)+import Data.Bool+import qualified Data.Map as M+import qualified Data.IntMap as IM+import Data.Maybe(fromJust)++import Miso hiding (Fail)+import Miso.String (MisoString)+import qualified Miso.String as S++#ifdef IOS+import Language.Javascript.JSaddle.WKWebView as JSaddle++runApp :: JSM () -> IO ()+runApp = JSaddle.run+#else+import Language.Javascript.JSaddle.Warp as JSaddle++runApp :: JSM () -> IO ()+runApp = JSaddle.run 8080 -- 8720+#endif++-- 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},+ update = updateModel,+ view = appView versionInfo,+ 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}+#ifdef URI+uri = URL URI+#else+-- uri = URL "ws://133.54.228.39:8720"+uri = URL "ws://localhost:8720"+#endif+protocols = Protocols []++{- At last, I chose to hide the history by default.+lenHistory = 400+-- A better approach might be+-- 1. to send the history to a separate frame after the endgame+-- 2. to memoize renderMsg+-- Also, `observe' should not send to the current player.+-}+updateModel :: Action -> Model -> Effect Action Model+updateModel (HandleWebSocket (WebSocketMessage (Message m))) model+ = noEff model{ received = {- take lenHistory $ -} memoMsg verbose model (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 DecreasePlayers model = noEff model{players = case players model of {n:ns@(_:_) -> ns; ns -> ns}}+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 }+#endif+updateModel _ model = noEff model++instance ToJSON Message+instance FromJSON Message++newtype Message = Message MisoString+ deriving (Eq, Show, Generic)++data Action+ = HandleWebSocket (WebSocket Message)+ | SendMessage Message+ | UpdateTBoxVal MisoString+ | IncreasePlayers+ | DecreasePlayers+ | UpdateRule Rule+ | Toggle+ | Id++data Model = Model {+ tboxval :: Message+ , players :: [Int]+ , rule :: Rule+ , received :: [MsgView]+ , 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_ [] [+ 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_ [] $ if null $ drop lenShownHistory received then [] else [+ hr_ []+ , input_ [ type_ "checkbox", id_ "showhist", onClick Toggle, checked_ fullHistory]+ , label_ [for_ "showhist"] [text "Show full history"]+ ]+ ]++onEnter :: Action -> Attribute Action+onEnter action = onKeyDown $ bool Id action . (== KeyCode 13)+{-+#ifdef AESON+prettyDecode :: MisoString -> MisoString+prettyDecode str = case decode $ S.fromMisoString str of Nothing -> str+ Just msg -> S.toMisoString $ encode $ prettyMsg verbose msg+#else+prettyDecode :: MisoString -> MisoString+prettyDecode str = case reads $ S.fromMisoString str of [] -> str+ [(msg,_)] -> S.toMisoString $ prettyMsg verbose msg+#endif+render :: MisoString -> View Action+render str = case decode str' of Nothing -> text $ S.fromMisoString str+ Just msg -> renderMsg verbose msg+ where str' = S.fromMisoString str+-}+decodeMsg :: MisoString -> Msg+#ifdef AESON+decodeMsg str = case decode $ S.fromMisoString str of Nothing -> Str $ S.fromMisoString str+ Just msg -> msg+#else+decodeMsg str = case reads $ S.fromMisoString str of [] -> Str $ S.fromMisoString str+ [(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)+ = div_ [style_ $ M.fromList [("overflow","auto")]] [+ hr_ [],+ table_ [style_ $ M.fromList [("border-style","solid"), ("clear","both"), ("float","right")]] $+ caption_ [] [text $ S.pack "Available games", button_ [onClick $ SendMessage $ Message "available"] [text $ S.pack "refresh"]] :+ tr_ [] [ th_ [solid] [text $ S.pack str] | str <- ["Game ID", "available", "total"] ] :+ map renderAvailable games,+ div_ [] [+ input_ [type_ "text", onInput (UpdateRule . head . (++[rule mdl]) . map fst . reads . S.unpack), value_ $ S.pack $ show $ rule mdl, style_ $ M.fromList [("width","70%")]],+ 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"]+ ]+ ]+ ]+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")]++renderWhatsUp verb name views@(v:_) moves = div_ [] [+ hr_ [],+ text $ S.pack "Your turn.",+ hr_ [],+ renderRecentEvents (publicView v) ithPlayer views moves,+ hr_ [],+ text $ S.pack $ "Algorithm: " ++ name,+ renderPV verb v+ ]+renderWhatsUp1 :: Verbosity -> PrivateView -> Move -> View Action+renderWhatsUp1 verb v m = div_ [style_ $ M.fromList [("background-color","#555555"),("color","#000000")]] [+ hr_ [],+ renderTrial (publicView v) (const "") undefined v m,+ hr_ [],+ renderPV verb v+ ]++renderEndGame :: (EndGame, [State], [Move]) -> View Action+renderEndGame (eg,sts@(st:_),mvs)+ = div_ [] [+ hr_ [],+ renderRecentEvents (publicState st) ithPlayerFromTheLast (map Game.Hanabi.view sts) mvs,+ hr_ [],+ h1_ [style_ $ M.fromList [("background-color","#FF0000"),("color","#000000")]] [text $ S.pack $ show eg],+ hr_ [],+ renderSt ithPlayerFromTheLast st,+ hr_ []+ ]++renderTrial :: PublicInfo -> (Int -> String) -> Int -> PrivateView -> Move -> View Action+renderTrial pub ithP i v m = div_ [] [+ text $ S.pack $ ithP i ++ " move: " ++ {- replicate (length (ithP 2) - length (ithP i)) ' ' ++ -} show m+ , case result $ publicView v of Discard c -> showResults c ", which revealed "+ Success c -> showResults c ", which succeeded revealing "+ Fail c -> showResults c ", which failed revealing "+ _ -> text $ S.pack ""+ ]+ where showResults c xs = span_ [] [+ xs+-- , renderHand' verbose pub [Just c] [(Nothing,Nothing)]+ , renderCardInline verbose pub c+ , text $ S.pack "."+ ]+renderPI pub+{- This was too verbose+ = let+ showDeck 0 = "no card at the deck (the game will end in " ++ shows (fromJust $ deadline pub) " turn(s)), "+ showDeck 1 = "1 card at the deck, "+ showDeck n = shows n " cards at the deck, "+ in "Turn "++ shows (turn pub) ": " ++ showDeck (pileNum pub) ++ shows (lives pub) " live(s) left, " ++ shows (hintTokens pub) " hint tokens;\n\n"+-}+ = let+ showDeck 0 = "Deck: 0 (" ++ shows (fromJust $ deadline pub) " turn(s) left), "+ showDeck 1 = "Deck: 1, "+ showDeck n = "Deck: " ++ shows n ", "+ in div_ [] [+ text $ S.pack $ "Turn: "++ shows (turn pub) ", " ++ showDeck (pileNum pub) ++ "Lives: " ++ shows (lives pub) ", Hints: " ++ shows (hintTokens pub) ";",++ div_ [] [+ text $ S.pack $ "played:",+ span_ [] [ span_ [] $ text (S.pack "|") : [ renderCardInline verbose pub $ C c k | k <- [K1 .. playedMax]] | c <- [White .. Multicolor], Just playedMax <- [IM.lookup (fromEnum c) (played pub)] ],+ text $ S.pack "|"+ ],++ div_ [] [+ text $ S.pack $ "dropped: ",+ span_ [] [ span_ [] $ text (S.pack "|") : (replicate n $ renderCardInline verbose pub $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ],+ text $ S.pack "|"+ ]+ ]+renderCardInline v pub c = span_ [style_ $ M.fromList [("width","30px"),("color", colorStr $ Just $ color c),("background-color","#000000")]] [cardStr verbose pub 0 (Just c) (Nothing,Nothing)]++renderRecentEvents :: PublicInfo -> (Int -> Int -> String) -> [PrivateView] -> [Move] -> View Action+renderRecentEvents pub ithP vs@(v:_) ms = div_ [] $ reverse $ zipWith3 (renderTrial pub $ ithP nump) [pred nump, nump-2..0] vs ms+ where nump = numPlayers $ gameSpec $ publicView v+++renderPV :: Verbosity -> PrivateView -> View Action+renderPV v pv@PV{publicView=pub} = div_ [] [+ renderPI pub,+ div_ [] (+-- div_ [] [text $ S.pack $ "My hand:"] :+-- renderCards v pub [ Nothing | _ <- myHand] myHand :+ renderHand v pub (const "My") 0 [ Nothing | _ <- myHand] myHand :+-- ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ]+ (zipWith3 (renderHand v pub (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) $ tail $ givenHints pub)+ )+ ]+ where myHand = head (givenHints pub)++renderSt ithP st@St{publicState=pub} = div_ [] $+ renderPI pub :+ zipWith3 (renderHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (map (map Just) $ hands st) (givenHints pub)++renderHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action+renderHand v pub ithPnumP i mbcards hl = div_ [] [+ div_ [] [text $ S.pack $ ithPnumP i ++ " hand:"],+ renderHand' v pub i mbcards hl+-- renderCards v pub (map Just cards) hl+ ]+renderHand' :: Verbosity -> PublicInfo -> Int -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action+renderHand' v pub pli mbcards hl = + table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"), ("height","48px")]] (zipWith3 (renderCard v pub pli) [0..] mbcards hl)]++renderCard :: Verbosity -> PublicInfo -> Int -> Index -> Maybe Card -> (Maybe Color, Maybe Number) -> View Action+renderCard v pub pli i mbc tup@(mc,mk) = td_ [style_ $ M.fromList [("width","36px"),+ ("color", colorStr $ fmap color mbc)]] [+ maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'p':show i) ] [ text (S.pack "play") ]) (const $ span_[][]) mbc,+ div_ [] [+ cardStr v pub pli mbc tup+ ],+ div_ [] [text $ S.pack $ if markHints v then maybe '_' (head . show) mc : [maybe '_' (head . show . fromEnum) mk] else "__" ],+ maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'd':show i) ] [ text (S.pack "drop") ]) (const $ span_[][]) mbc+ ]+{-+renderCards :: Verbosity -> PublicInfo -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action+renderCards v pub mbcs tups = table_ [style_ $ M.fromList [("border-color","#FFFFFF"),("border-width","medium")]] [+ tr_ [style_ $ M.fromList [("background-color","#000000")]]+ [+ td_ [style_ $ M.fromList [("color", colorStr $ fmap color mbc)]] [+ cardStr v pub mbc tup+ ]+ | (mbc,tup) <- zip mbcs tups+ ],+ tr_ [style_ $ M.fromList [("background-color","#000000")]]+ [+ td_ [style_ $ M.fromList [("color", colorStr $ fmap color mbc)]] [+ text $ S.pack $ if markHints v then maybe ' ' (head . show) mc : [maybe ' ' (head . show . fromEnum) mk] else ""+ ]+ | (mbc,(mc,mk)) <- zip mbcs tups+ ]+ ]+-}+-- Not sure which style is better.+#ifdef BUTTONSONCARDS+cardStr v pub pli mbc tup = case mbc of+ Nothing -> span_ [] [text $ S.pack "??"]+ Just c -> span_ [] [+-- text $ S.pack $ show c+ button_ [onClick (SendMessage $ Message $ S.pack $ shows pli $ take 1 $ show $ color c), style] [text $ S.pack $ take 1 $ show $ color c],+ button_ [onClick (SendMessage $ Message $ S.pack $ shows pli $ show $ fromEnum $ number c), style][text $ S.pack $ show $ fromEnum $ number c]+ ]+ where style = style_ $ M.fromList [+ ("font-weight", if markUseless v && isUseless pub c then "100"+ else if warnCritical v && tup==(Nothing,Nothing) && isCritical pub c then "bold" else "normal"),+ ("font-style", if markPlayable v && isPlayable pub c then "oblique" else "normal"), ("background-color","#000000"),("color", colorStr $ fmap color mbc)]+#else+cardStr v pub pli mbc tup = case mbc of+ Nothing -> span_ [] [text $ S.pack "??"]+ Just c -> span_ [style_ $ M.fromList [-- ("width","30px"),+ ("font-weight", if markUseless v && isUseless pub c then "100"+ else if warnCritical v && tup==(Nothing,Nothing) && isCritical pub c then "bold" else "normal"),+ ("font-style", if markPlayable v && isPlayable pub c then "oblique" else "normal")]] [+-- text $ S.pack $ show c+ span_ [style_ $ M.fromList [("font-size","20px")],+ onClick (SendMessage $ Message $ S.pack $ shows pli $ take 1 $ show $ color c)] [text $ S.pack $ take 1 $ show $ color c],+ span_ [style_ $ M.fromList [("font-size","20px")],+ onClick (SendMessage $ Message $ S.pack $ shows pli $ show $ fromEnum $ number c)][text $ S.pack $ show $ fromEnum $ number c]+ ]+#endif+colorStr Nothing = "#00FFFF"+colorStr (Just White) = "#FFFFFF"+colorStr (Just Yellow) = "#FFFF00"+colorStr (Just Red) = "#FF4444"+colorStr (Just Green) = "#44FF44"+colorStr (Just Blue) = "#8888FF"+colorStr (Just Multicolor) = "#FF00FF"
+ Game/Hanabi/Msg.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveGeneric, CPP #-}+module Game.Hanabi.Msg where+import Game.Hanabi+import GHC.Generics++#ifdef AESON+import Data.Aeson++instance ToJSON Msg+instance FromJSON Msg+instance ToJSON State+instance FromJSON State+instance ToJSON PrivateView+instance FromJSON PrivateView+instance ToJSON PublicInfo+instance FromJSON PublicInfo+instance ToJSON EndGame+instance FromJSON EndGame+instance ToJSON Move+instance FromJSON Move+instance ToJSON Card+instance FromJSON Card+instance ToJSON Color+instance FromJSON Color+instance ToJSON Number+instance FromJSON Number+instance ToJSON GameSpec+instance FromJSON GameSpec+instance ToJSON Rule+instance FromJSON Rule+instance ToJSON Game.Hanabi.Result+instance FromJSON Game.Hanabi.Result+#endif++-- WhatsUp and WhatsUp1 should be minimized after better clients are implemented. 効率上はminimizeすべきだが、テスト目的ではとりあえずこのままの方がやりやすい。+data Msg = Str String | WhatsUp String [PrivateView] [Move] | WhatsUp1 PrivateView Move | PrettyEndGame (Maybe (EndGame, [State], [Move])) | PrettyAvailable [(Int, (Int, Int))] deriving (Show, Read, Eq, Generic)+prettyMsg :: Verbosity -> Msg -> String+prettyMsg _ (Str xs) = xs+prettyMsg verb (WhatsUp name ps ms) = what'sUp verb name ps ms+prettyMsg verb (WhatsUp1 p m) = what'sUp1 verb p m+prettyMsg _ (PrettyEndGame tup) = prettyMbEndGame tup+prettyMsg _ (PrettyAvailable available) = unlines $ map prettyAvailableGame available+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 "."
+ Game/Hanabi/VersionInfo.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE CPP #-}+#if MIN_VERSION_template_haskell(2,2,0)+{-# LANGUAGE TemplateHaskell #-}+#endif+{-# OPTIONS_GHC -fforce-recomp #-}+-- Recompilation is needed to obtain the correct build time.+module Game.Hanabi.VersionInfo where+import Data.Time+#if MIN_VERSION_template_haskell(2,2,0)+import Language.Haskell.TH+#endif+#ifdef CABAL+import Paths_hanabi_dealer(version)+import Data.Version(showVersion)+#endif++versionInfo, mhVersion, ghcVersion, now :: String+versionInfo = mhVersion ++ compiler ++ ghcVersion ++ now+#ifdef CABAL+mhVersion = showVersion version+#else+mhVersion = ""+#endif+#ifdef ghcjs_HOST_OS+compiler = " built with GHCJS-"+#else+compiler = " built with GHC-"+#endif+ghcVersion = case __GLASGOW_HASKELL__ `divMod` 100 of (b,s) -> shows b $ '.' : show s+#if MIN_VERSION_template_haskell(2,2,0)+now = " at " ++ $(runIO getCurrentTime >>= \t -> return (LitE $ StringL $ show t)) -- This requires the -fforce-recomp flag in order to be correct.+#else+now = ""+#endif
+ client.hs view
@@ -0,0 +1,3 @@+import Game.Hanabi.VersionInfo+import Game.Hanabi.Client+main = main' versionInfo
+ examples/SimpleStrategy.hs view
@@ -0,0 +1,19 @@+{-# 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
hanabi-dealer.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.2.1.0+version: 0.3.0.0 -- A short (one-line) description of the package. synopsis: Hanabi card game@@ -43,15 +43,31 @@ -- Extra files to be distributed with the package, such as examples or a -- README.-extra-source-files: ChangeLog.md+extra-source-files: ChangeLog.md, examples/SimpleStrategy.hs -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.10 --- Flag SNAP--- Description: Use Snap instead of runServer--- Default: True+source-repository head+ type: darcs+ location: https://hub.darcs.net/susumu/hanabi-dealer +Flag server+ Description: Build the server program in addition to the library.+ Default: False+Flag SNAP+ Description: Use Snap instead of runServer.+ Default: True+FLAG TFRANDOM+ Description: Use tf-random instead of random.+ Default: True+FLAG official+ Description: The client connects to the official server URI instead of localhost.+ Default: False+FLAG TH+ Description: Use template-haskell just for obtaining the compilation time.+ Default: True+ library -- Modules exported by the library. exposed-modules: Game.Hanabi@@ -73,6 +89,37 @@ -- Base language which the package is written in. default-language: Haskell2010 - -- if flag(SNAP)- -- build-depends: network >=3.1 && <3.2, websockets >=0.12 && <0.13, time >=1.6 && <1.7, unix >=2.7 && <2.8, websockets-snap >=0.10 && <0.11, snap-server >=1.1 && <1.2, network >=2.6 && <2.7, abstract-par >=0.3 && <0.4, monad-par >=0.3 && <0.4- -- cpp-options: -DSNAP+executable server+ main-is: server.hs+ other-modules: Game.Hanabi.Backend, Game.Hanabi.Msg, Game.Hanabi.VersionInfo+ if impl(ghcjs) || !flag(server)+ buildable: False+ else+ ghc-options: -O2 -threaded -Wall -rtsopts+ -- Not sure if -O2 is worthy, but this should be OK because the server is not built by default.+ cpp-options: -DCABAL+ build-depends: base >=4.8 && <4.14, containers >=0.5, random >=1.1, websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6 && <1.9, text >=1.2, utf8-string, hanabi-dealer+ default-language: Haskell2010+ 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++executable client+ main-is: client.hs+ other-modules: Game.Hanabi.Msg, Game.Hanabi.Client, Game.Hanabi.VersionInfo+ if !impl(ghcjs)+ buildable: False+ else+ ghcjs-options: -dedupe -O+ cpp-options: -DCABAL+ build-depends: base >=4.12 && <4.13, containers >=0.5, random >=1.1, jsaddle-warp >=0.9, aeson, miso, time, hanabi-dealer+ default-language: Haskell2010+ if flag(official)+ cpp-options: -DURI="ws://133.54.228.39:8720"+ if flag(TH)+ build-depends: template-haskell
+ server.hs view
@@ -0,0 +1,3 @@+import Game.Hanabi.Backend+import Game.Hanabi.VersionInfo+main = main' versionInfo