diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,15 @@ # Revision history for hanabi-dealer + ## 0.7.0.0 -- 2020-02-28 + + * start games locally when possible. + + * make the observation mode report interactions. + + * introduce the earlyQuit rule option, where the game is called when the best possible score (which can be below 25) is achieved. + + * introduce currentScore and achievedScore. + + * add lots of bells and whistles to the front end. ## 0.6.0.0 -- 2020-02-08 diff --git a/Game/Hanabi.hs b/Game/Hanabi.hs --- a/Game/Hanabi.hs +++ b/Game/Hanabi.hs @@ -16,10 +16,10 @@ Card(..), Color(..), Number(..), Marks, Possibilities, cardToInt, intToCard, readsColorChar, readsNumberChar, -- * Utilities -- ** Hints - isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, + isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, currentScore, achievableScore, isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, obviousChopss, definiteChopss, isDoubleDrop, -- ** Minor ones - what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, prettySt, ithPlayerFromTheLast, view, replaceNth, shuffle, showPossibilities, showColorPossibilities, showNumberPossibilities) where + what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, prettySt, ithPlayerFromTheLast, view, replaceNth, shuffle, showPossibilities, showColorPossibilities, showNumberPossibilities, showTrial) where -- module Hanabi where import qualified Data.IntMap as IM import System.Random @@ -31,7 +31,6 @@ import System.IO import Data.Dynamic import Data.Bits hiding (rotate) -import Numeric(showIntAtBase, showOct) import GHC.Generics hiding (K1) @@ -54,7 +53,9 @@ showsPrec _ (C color number) = (head (show color) :) . (show (fromEnum number) ++) instance Read Card where readsPrec _ str = [(C i k, rest) | (i, xs) <- readsColorChar str, (k, rest) <- readsNumberChar xs] +cardToInt :: Card -> Int cardToInt c = fromEnum (color c) * (succ $ fromEnum (maxBound::Number)) + fromEnum (number c) +intToCard :: Int -> Card intToCard i = case i `divMod` (succ $ fromEnum (maxBound::Number)) of (c,k) -> C (toEnum c) (toEnum k) type Index = Int -- starts from 0 @@ -65,7 +66,7 @@ instance Show Move where showsPrec _ (Drop i) = ("Drop"++) . shows i showsPrec _ (Play i) = ("Play"++) . shows i - showsPrec _ (Hint i eith) = ("Hint"++) . shows i . (either (\i -> (take 1 (show i) ++)) (\k -> tail . shows k) eith) + showsPrec _ (Hint i eith) = ("Hint"++) . shows i . (either (\c -> (take 1 (show c) ++)) (\k -> tail . shows k) eith) instance Read Move where readsPrec _ str = let (cmd,other) = span (not.isSpace) str' @@ -110,22 +111,29 @@ , funPlayerHand :: [Int] -- ^ memoized function taking the number of players; the default is [5,5,4,4,4,4,4,4,4,4,4,4,4,4] , numColors :: Int -- ^ number of colors. 5 for the normal rule, and 6 for Variant 1-3 of the rule book. , prolong :: Bool -- ^ continue even after a round after the pile is exhausted. @True@ for Variant 4 of the rule book. + , earlyQuit :: Bool -- ^ quit the game when the best possible score is achieved. , numMulticolors :: [Int] -- ^ number of each of multicolor cards. @[3,2,2,2,1]@ for Variant 1 (and Variant 3?), and @[1,1,1,1,1]@ for Variant 2. -- 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) +isRuleValid :: Rule -> Bool +isRuleValid 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 :: Rule defaultRule = R { numBlackTokens = 3 , funPlayerHand = [5,5]++take 12 (repeat 4) , numColors = 5 , prolong = False + , earlyQuit = False , numMulticolors = replicate 5 0 -- x , multicolor = False } +defaultGS :: GameSpec defaultGS = GS{numPlayers=2, rule=defaultRule} +initialPileNum :: GameSpec -> Int initialPileNum gs = sum (take (numColors $ rule gs) $ [10,10,10,10,10]++[sum (numMulticolors $ rule gs)]) - numPlayerHand gs * numPlayers gs +numPlayerHand :: GameSpec -> Int numPlayerHand gs = (funPlayerHand (rule gs) ++ repeat 4) !! (numPlayers gs - 2) data GameSpec = GS {numPlayers :: Int, rule :: Rule} deriving (Read, Show, Eq, Generic) @@ -196,7 +204,7 @@ -- This is useful only for predicting the behaviors of beginner players. isMostObviouslyPlayable :: PublicInfo -> Marks -> Bool isMostObviouslyPlayable pub (Just c, Just n) = isPlayable pub $ C c n -isMostObviouslyPlayable pub _ = False +isMostObviouslyPlayable _ _ = False -- | 'isMoreObviouslyPlayable' looks at the publicly available current info and decides if the card is surely playable. isMoreObviouslyPlayable :: PublicInfo -> Marks -> Bool @@ -218,7 +226,8 @@ [ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ] -iOP bag pub (Just c, Just n) = isPlayable pub $ C c n +iOP :: IM.IntMap Int -> PublicInfo -> (Maybe Color, Maybe Number) -> Bool +iOP _ pub (Just c, Just n) = isPlayable pub $ C c n iOP bag pub (Nothing,Just n) = all (\card -> (bag IM.! cardToInt card) == 0 || isPlayable pub card) [ C color n | color <- colors pub ] iOP _ _ _ = False @@ -227,10 +236,10 @@ isMoreObviouslyUseless pub (Just c, Just n) = isUseless pub $ C c n isMoreObviouslyUseless pub (Just c, Nothing) = bestPossibleRank pub c == achievedRank pub c isMoreObviouslyUseless pub (Nothing, Just n) = all (\c -> n <= achievedRank pub c || bestPossibleRank pub c < n) $ colors pub -isMoreObviouslyUseless pub (Nothing, Nothing) = False +isMoreObviouslyUseless _ (Nothing, Nothing) = False isObviouslyUseless :: PublicInfo -> Possibilities -> Bool -isObviouslyUseless pub (pc,pn) = all (\card@(C c n) -> n <= achievedRank pub c || bestPossibleRank pub c < n || (nonPublic pub IM.! cardToInt (C c n)) == 0 ) +isObviouslyUseless pub (pc,pn) = all (\card@(C c n) -> n <= achievedRank pub c || bestPossibleRank pub c < n || (nonPublic pub IM.! cardToInt card) == 0 ) [ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ] isDefinitelyUseless :: PrivateView -> Marks -> Possibilities -> Bool @@ -264,7 +273,14 @@ chops :: PublicInfo -> [Marks] -> [Possibilities] -> [Index] chops pub hls ps = concat $ map reverse $ obviousChopss pub hls ps -isDoubleDrop pv (Discard c) [i] (pc,pn) | isCritical (publicView pv) c = color c `elem` colorPossibilities pc && number c `elem` numberPossibilities pn && (invisibleBag pv IM.! cardToInt c) > 0 +isDoubleDrop :: PrivateView -> Result -> [Index] -> (Int, Int) -> Bool +isDoubleDrop pv@PV{publicView=pub} (Discard c@C{..}) [_i] (pc,pn) = not (any (==(Just color, Just number)) myHints) && -- This pattern captures: the last player discards B1; I have a card which is hinted as B and 1; I don't know where the third B1 is. + -- This can be improved to check whether any card other than the chop is obviously the just-dropped card or not, by looking at the Possibilities. + isCritical pub c && + color `elem` colorPossibilities pc && + number `elem` numberPossibilities pn && + (invisibleBag pv IM.! cardToInt c) > 0 + where myHints = head $ givenHints pub isDoubleDrop _pv _lastresult _chopset _ps = False colors :: PublicInfo -> [Color] @@ -279,6 +295,10 @@ #else Nothing -> Empty #endif +currentScore :: PublicInfo -> Int +currentScore pub = sum [ fromEnum $ achievedRank pub k | k <- colors pub ] +achievableScore :: PublicInfo -> Int +achievableScore pub = sum [ fromEnum $ bestPossibleRank pub k | k <- colors pub ] -- | 'Result' is the result of the last move. data Result = None -- ^ Hinted or at the beginning of the game @@ -304,6 +324,7 @@ PV pub1 hs1 _ == PV pub2 hs2 _ = (pub1,hs1) == (pub2,hs2) -- | 'mkPV' is the constructor of PrivateView. +mkPV :: PublicInfo -> [[Card]] -> PrivateView mkPV pub hs = PV pub hs $ foldr (IM.update (Just . pred)) (nonPublic pub) $ map cardToInt $ concat $ [ C c n | (Just c, Just n) <- head $ givenHints pub ] : hs prettyPV :: Verbosity -> PrivateView -> String @@ -328,7 +349,9 @@ wrap xs | markPossibilities v = " "++xs++" " | otherwise = xs chopSet = concat $ take 1 $ definiteChopss pv myHand myPos +prettySt :: (Int -> Int -> String) -> State -> String prettySt ithP st@St{publicState=pub} = prettyPI pub ++ concat (zipWith4 (prettyHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (hands st) (givenHints pub) (possibilities pub)) +verbose :: Verbosity verbose = V{warnCritical=True,markUseless=True,markPlayable=True,markObviouslyUseless=True,markObviouslyPlayable=True,markHints=True,markPossibilities=True,markChops=True,warnDoubleDrop=True} prettyHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Card] -> [Marks] -> [Possibilities] -> String prettyHand v pub ithPnumP i cards hl ps = "\n\n" ++ ithPnumP i ++ " hand:\n" @@ -359,10 +382,13 @@ showPosLines ps = concat [ ' ' : showColorPossibilities cs | (cs,_) <- ps] ++ "\n" ++ concat [ showNumberPossibilities ns ++" " | (_,ns) <- ps] +showColorPossibilities, showNumberPossibilities :: Int -> String showColorPossibilities = reverse . showPossibilities ' ' colorkeys showNumberPossibilities = reverse . showPossibilities ' ' "54321 " +colorkeys :: String colorkeys = map (head . show) [maxBound, pred maxBound .. minBound::Color] -- colorkeys == "MBGRYW", but I just prefer to make this robust to changes in the order. -showPossibilities _ [] pos = [] +showPossibilities :: a -> [a] -> Int -> [a] +showPossibilities _ [] _ = [] showPossibilities blank (x:xs) pos = (if odd pos then x else blank) : showPossibilities blank xs (pos `div` 2) colorPossibilities :: Int -> [Color] -- The result is in the reverse order but I do not care. @@ -386,6 +412,7 @@ } deriving (Read, Show, Eq, Generic) +prettyPI :: PublicInfo -> String prettyPI pub {- This was too verbose = let @@ -399,12 +426,18 @@ showDeck 1 = "Deck: 1, " showDeck n = "Deck: " ++ shows n ", " in "Turn: "++ shows (turn pub) ", " ++ showDeck (pileNum pub) ++ "Lives: " ++ shows (lives pub) ", Hints: " ++ shows (hintTokens pub) ";\n\n" - ++ "played:" ++ concat [ " " ++ concat [ show $ C c k | k <- [K1 .. achievedRank pub c]] | c <- [minBound .. Multicolor] ] + ++ "played (" ++ shows (currentScore pub) " / " ++ shows (achievableScore pub) "):" + ++ concat [ " " ++ concat ( [ show $ C c k | k <- [K1 .. achievedRank pub c] ] ++ replicate (possible - fromEnum playedMax) "__" ++ replicate (5 - possible) "XX") + | c <- colors pub + , let playedMax = achievedRank pub c + possible = fromEnum $ bestPossibleRank pub c + ] ++ "\ndropped: " ++ concat [ '|' : concat (replicate n $ show $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ] ++"|\n" view :: State -> PrivateView view st = mkPV (publicState st) (tail $ hands st) +main :: IO () main = selfplay defaultGS -- | 'selfplay' starts selfplay with yourself:) @@ -414,6 +447,7 @@ -- > selfplay defaultGS{numPlayers=n} -- -- (where 1 IO () selfplay gs = do g <- newStdGen ((finalSituation,_),_) <- start gs [] [stdio] g @@ -428,13 +462,17 @@ replicate 80 '!' : map (surround $ replicate 38 ' ' ++"!!") (lines $ prettySt ithPlayerFromTheLast st) ++ [ replicate 80 '!' ] +surround :: [a] -> [a] -> [a] surround ys xs = let len = length xs len2 =len `div` 2 in reverse (drop len2 ys) ++ xs ++ drop (len - len2) ys -type Peeker m = State -> m () +type Peeker m = State -> [Move] -> m () peek :: Peeker IO -peek = putStrLn . prettySt ithPlayerFromTheLast +peek st [] = putStrLn $ prettySt ithPlayerFromTheLast st +peek st (mv:_) = putStrLn $ replicate 20 '-' ++ '\n' : + showTrial (const "") undefined (view st) mv ++ '\n' : + replicate 20 '-' ++ '\n' : prettySt ithPlayerFromTheLast st -- | 'start' creates and runs a game. This is just the composition of 'createGame' and 'run'. start :: (RandomGen g, Monad m, Strategies ps m) => @@ -444,7 +482,7 @@ in fmap (\e -> (e,g)) $ run audience [st] [] players run :: (Monad m, Strategies ps m) => [Peeker m] -> [State] -> [Move] -> ps -> m ((EndGame, [State], [Move]), ps) run audience states moves players = do - ((mbeg, sts, mvs), ps) <- runARound (\sts@(st:_) mvs -> let myOffset = turn (publicState st) in mapM_ ($ st) audience >> broadcast (zipWith rotate [-myOffset, 1-myOffset ..] sts) mvs players (myOffset `mod` numPlayers (gameSpec $ publicState st)) >> return ()) states moves players + ((mbeg, sts, mvs), ps) <- runARound (\sts@(st:_) mvs -> let myOffset = turn (publicState st) in mapM_ (\p -> p st mvs) audience >> broadcast (zipWith rotate [-myOffset, 1-myOffset ..] sts) mvs players (myOffset `mod` numPlayers (gameSpec $ publicState st)) >> return ()) states moves players case mbeg of Nothing -> run audience sts mvs ps Just eg -> return ((eg, sts, mvs), ps) @@ -469,7 +507,7 @@ -> [Move] -- ^ The history of 'Move's, new to old. -> p -- ^ The strategy's current state. This can be isomorphic to @()@ if the strategy does not have any parameter. -> m () - observe _pvs _moves st = return () -- The default does nothing. + observe _pvs _moves _st = return () -- The default does nothing. {- -> m ((), p) -- ^ 'observe' returns the next state, wrapped with monad m that is usually either IO or Identity. -- The next state can be the same as the current one unless the algorithm is learning on-line during the game. @@ -527,7 +565,7 @@ 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!" + runARound _ _ _ [] = error "It takes at least one algorithm to play Hanabi!" runARound hook states moves [p] = hook states moves >> runATurn states moves p >>= \(tup, p') -> return (tup, [p']) runARound hook states moves (p:ps) = hook states moves >> runATurn states moves p >>= \(tup@(mbeg,sts,mvs), p') -> case mbeg of Nothing -> do (tups,ps') <- runARound hook sts mvs ps @@ -552,7 +590,7 @@ instance (Strategy p m, MonadIO m) => Strategy (Verbose p) m where strategyName mp = do name <- strategyName $ fmap unV mp return $ if name == "Blind" then "STDIO" else "Verbose " ++ name - move views@(v:_) moves (Verbose p verb) = let alg = move views moves p in + move views@(_:_) 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 (mv,p') <- alg @@ -561,43 +599,51 @@ observe _ [] _ = return () observe (v:_) (m:_) (Verbose _ verb) = liftIO $ putStrLn $ what'sUp1 verb v m +what'sUp :: Verbosity -> String -> [PrivateView] -> [Move] -> String what'sUp verb name views@(v:_) moves = replicate 20 '-' ++ '\n' : recentEvents ithPlayer views moves ++ '\n' : replicate 20 '-' ++ '\n' : "Algorithm: " ++ name ++ '\n' : prettyPV verb v ++ "\nYour turn.\n" +what'sUp1 :: Verbosity -> PrivateView -> Move -> String what'sUp1 verb v m = replicate 20 '-' ++ '\n' : showTrial (const "") undefined v m ++ '\n' : replicate 20 '-' ++ '\n' : prettyPV verb v +recentEvents :: (Int -> Int -> String) -> [PrivateView] -> [Move] -> String recentEvents ithP vs@(v:_) ms = unlines $ reverse $ zipWith3 (showTrial $ ithP nump) [pred nump, nump-2..0] vs ms where nump = numPlayers $ gameSpec $ publicView v +showTrial :: (Int -> String) -> Int -> PrivateView -> Move -> String showTrial ithP i v m = ithP i ++ " move: " ++ replicate (length (ithP 2) - length (ithP i)) ' ' ++ show m ++ case result $ publicView v of Discard c -> ", which revealed "++shows c "." Success c -> ", which succeeded revealing "++shows c "." Fail c -> ", which failed revealing " ++ shows c "." _ -> "." +ithPlayer :: Int -> Int -> String ithPlayer _ 0 = "My" ithPlayer _ i = "The " ++ ith i ++"next player's" +ith :: Int -> String ith 1 = "" ith 2 = "2nd " ith 3 = "3rd " ith i = shows i "th " +ithPlayerFromTheLast :: Int -> Int -> String ithPlayerFromTheLast nump j = "The " ++ ith (nump-j) ++"last player's" type STDIO = Verbose Blind +stdio :: Verbose Blind stdio = Verbose Blind verbose data Blind = Blind instance (MonadIO m) => Strategy Blind m where - strategyName p = return "Blind" + strategyName _ = return "Blind" move (v:_) _ _ = do mov <- liftIO $ repeatReadingAMoveUntilSuccess stdin stdout v return (mov, Blind) data ViaHandles = VH {hin :: Handle, hout :: Handle, verbVH :: Verbosity} instance (MonadIO m) => Strategy ViaHandles m where - strategyName p = return "via handles" + strategyName _ = return "via handles" 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) @@ -631,17 +677,21 @@ }, g) splitCons n hnds stack = case splitAt (numPlayerHand gs) stack of (tk,dr) -> splitCons (pred n) (tk:hnds) dr (shuffled, g) = shuffle (cardBag $ rule gs) gen +numAssoc :: [(Number, Int)] numAssoc = zip [K1 ..K5] [3,2,2,2,1] cardAssoc :: Rule -> [(Card,Int)] cardAssoc rule = take (5 * numColors rule) $ [ (C i k, n) | i <- [White .. pred Multicolor], (k,n) <- numAssoc ] ++ [ (C Multicolor k, n) | (k, n) <- zip [K1 ..K5] (numMulticolors rule) ] +cardBag :: Rule -> [Card] cardBag rule = concat [ replicate n c | (c,n) <- cardAssoc rule ] +cardMap :: Rule -> IM.IntMap Int cardMap rule = IM.fromList [ (cardToInt c, n) | (c,n) <- cardAssoc rule ] unknown :: GameSpec -> Possibilities unknown gs = (64 - bit (6 - numColors (rule gs)), 31) -shuffle :: RandomGen g => [c] -> g -> ([c], g) +shuffle :: RandomGen g => [a] -> g -> ([a], g) shuffle xs = shuf [] xs $ length xs +shuf :: RandomGen g => [a] -> [a] -> Int -> g -> ([a], g) shuf result _ 0 gen = (result, gen) shuf result xs n gen = let (i, g) = randomR (0, pred n) gen (nth,rest) = pickNth i xs @@ -657,8 +707,11 @@ not (null $ filter willBeHinted (tlHands !! pred hintedpl)) where willBeHinted :: Card -> Bool willBeHinted = either (\c -> (==c).color) (\k -> (==k).number) eck +pickNth :: Int -> [a] -> (a, [a]) pickNth n xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++dr) +replaceNth :: Int -> a -> [a] -> (a, [a]) replaceNth n x xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++x:dr) -- = updateNth n (const x) xs +updateNth :: Int -> (a -> a) -> [a] -> (a, [a]) updateNth n f xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++f nth:dr) -- | 'proceed' updates the state based on the current player's Move, without rotating. @@ -734,6 +787,8 @@ checkEndGame :: PublicInfo -> Maybe EndGame checkEndGame pub | lives pub == 0 = Just Failure | all (==K5) [ achievedRank pub k | k <- colors pub ] = Just Perfect - | deadline pub == Just 0 = Just $ Soso $ IM.foldr (+) 0 $ fmap fromEnum $ played pub + | deadline pub == Just 0 || + (earlyQuit (rule $ gameSpec pub) && currentScore pub == achievableScore pub) + = Just $ Soso $ IM.foldr (+) 0 $ fmap fromEnum $ played pub | hintTokens pub == 0 && null (head $ givenHints pub) = Just Failure -- No valid play is possible for the next player. This can happen when prolong==True. | otherwise = Nothing diff --git a/Game/Hanabi/Backend.lhs b/Game/Hanabi/Backend.lhs --- a/Game/Hanabi/Backend.lhs +++ b/Game/Hanabi/Backend.lhs @@ -13,7 +13,7 @@ import Game.Hanabi hiding (main) import Game.Hanabi.Msg -import Data.Maybe(fromJust, isNothing, isJust) +import Data.Maybe(fromJust, isJust) import System.Random #ifdef TFRANDOM import System.Random.TF @@ -26,7 +26,6 @@ import System.IO.Error(isEOFError) import Control.Exception import Data.Char(isSpace) --- import Data.List(isPrefixOf) import Data.Time @@ -38,9 +37,9 @@ import Control.Monad.IO.Class(MonadIO, liftIO) -import System.Timeout +-- import System.Timeout import Data.Hashable(hash) -import Data.Text(unpack, pack) +import Data.Text(Text, unpack, pack) import qualified Data.IntMap as IntMap import qualified Data.Map as Map @@ -118,8 +117,9 @@ return $ websocketsOr defaultConnectionOptions (loop params) fallbackApp #endif +type GameData = IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move]))) data Params g = Params{gen :: g, - mvTIDToMVH :: MVar (IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))), + mvTIDToMVH :: MVar GameData, conn :: Connection, versionString :: String, gsConstructorMap :: Map.Map String (IO (DynamicStrategy IO)) @@ -134,7 +134,7 @@ mkParams options = do g <- newStdGen #endif - mv <- newMVar (IntMap.empty::IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))) + mv <- newMVar (IntMap.empty::GameData) return Params{gen = g, mvTIDToMVH = mv, versionString = version options, gsConstructorMap = Map.fromList $ strategies options, conn = error "Game.Hanabi.Backend.server: should not happen"} -- Well, this is not a loop any longer.... @@ -156,9 +156,11 @@ withPingThread c 25 (return ()) $ fmap (const ()) $ answerHIO p +endecodeX :: Maybe Verbosity -> Msg -> Text endecodeX Nothing = endecode -- endecodeX Nothing = pack . show . prettyMsg verbose endecodeX (Just verb) = pack . prettyMsg verb +endecode :: Msg -> Text #ifdef AESON endecode = decodeUtf8 . toStrict . encode #else @@ -167,7 +169,7 @@ data ViaWebSocket = VWS {connection :: Connection, verbVWS :: Maybe Verbosity, sendFullHistory :: Bool} instance (MonadIO m) => Strategy ViaWebSocket m where - strategyName p = return "via WebSocket" + 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) @@ -189,7 +191,8 @@ observe (v:_) (m:_) vh = liftIO $ sendTextData (connection vh) $ endecodeX (verbVWS vh) $ WhatsUp1 v m -watch conn mbVerb st = sendTextData conn $ endecodeX mbVerb $ Watch st +watch :: Connection -> Maybe Verbosity -> State -> [Move] -> IO () +watch conn mbVerb st mvs = sendTextData conn $ endecodeX mbVerb $ Watch st $ take 1 mvs answerHIO :: RandomGen g => Params g -> IO () answerHIO params = do @@ -212,7 +215,6 @@ 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 -> Params g -> IO () @@ -227,7 +229,7 @@ is | numAllies > 0 -> if numAllies >= 9 then sender "Too many teammates!\n" else case dropWhile (\s -> isWS s || s `Map.member` gsConstructorMap params) is of - alg:_ -> sender $ "Algorithm " ++ shows (maximum is) " not implemented yet.\n" + alg:_ -> sender $ "Algorithm " ++ alg ++ " 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 @@ -281,6 +283,7 @@ 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 :: Maybe Verbosity -> MVar GameData -> Connection -> IO () available mbVerb mvTIDToMVH conn = do tidToMVH <- readMVar mvTIDToMVH -- availableGames <- IntMap.traverse filt tidToMVH @@ -291,6 +294,7 @@ emptyMVHs <- filterM isEmptyMVar mvhs return (gameid, (length emptyMVHs, length mvhs)) +commandHelp :: String 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" diff --git a/Game/Hanabi/Client.hs b/Game/Hanabi/Client.hs --- a/Game/Hanabi/Client.hs +++ b/Game/Hanabi/Client.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ExtendedDefaultRules #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric, RecordWildCards, OverloadedStrings, ExtendedDefaultRules, MultiParamTypeClasses, CPP #-} module Game.Hanabi.Client(client, #if !defined ghcjs_HOST_OS && !defined IOS clientApp, @@ -26,6 +22,15 @@ import Miso.String (MisoString) import qualified Miso.String as S +import Control.Monad.IO.Class(liftIO) + +import System.Random +#ifdef TFRANDOM +import System.Random.TF +#endif + +import Control.Concurrent + #ifdef ghcjs_HOST_OS client :: Game.Hanabi.Msg.Options -> IO () client options = clientJSM options @@ -63,9 +68,10 @@ -- https://github.com/dmjio/miso/blob/master/frontend-src/Miso/Subscription/WebSocket.hs clientJSM :: Game.Hanabi.Msg.Options -> JSM () -clientJSM options = startApp App{ - model = Model{tboxval = Message "available", players = ["via WebSocket"], from = Just 0, rule = defaultRule, received = [], fullHistory = False, showVerbosity = False, verbosity = verbose, play = True}, - update = updateModel, +clientJSM options = do mvStr <- newMVarStrategy + startApp App{ + model = Model{tboxval = Message "available", players = ["via WebSocket"], from = Just 0, rule = defaultRule, received = [], fullHistory = False, showVerbosity = False, verbosity = verbose, play = True, localStrategy = mvStr, local = False}, + update = updateModel options, view = appView strNames $ version options, subs = [ websocketSub uri protocols HandleWebSocket ], events = defaultEvents, @@ -88,26 +94,81 @@ -- 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 $ -} decodeMsg m : received model } -updateModel (SendMessage msg) model = model{fullHistory=False, showVerbosity=False} <# (-- connect uri protocols >> - send msg >> return Id) -updateModel (UpdateTBoxVal m) model = noEff model{ tboxval = Message m } -updateModel (From mbn) model = noEff model{from = mbn} -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 (UpdateVerbosity v) model = noEff model{verbosity = v} -updateModel Toggle model = noEff model{fullHistory = not $ fullHistory model} -updateModel ToggleVerbosity model = noEff model{showVerbosity = not $ showVerbosity model} -updateModel TogglePlay model | play model && length (players model) < 2 = noEff model{play = False, players = "via WebSocket" : players model} - | otherwise = noEff model{play = not $ play model} +updateModel :: Game.Hanabi.Msg.Options -> Action -> Model -> Effect Action Model +updateModel _ (HandleWebSocket (WebSocketMessage (Message m))) model + = noEff model{ received = {- take lenHistory $ -} suppressCG $ decodeMsg m : received model } +updateModel _ (SendMessage msg@(Message str)) model = model{fullHistory=False, showVerbosity=False} <# -- connect uri protocols >> + if local model + then case reads $ S.unpack str of + [(m,str)] -> do + putMVar (mvMov $ localStrategy model) m + msg <- takeMVar (mvMsg $ localStrategy model) + return $ ProcMsg msg + _ -> return $ ProcMsg $ Str "Could not parse as a Move." + else send msg >> return Id +updateModel _ (SendMove mov) model = model{fullHistory=False, showVerbosity=False} <# -- connect uri protocols >> + if local model + then do + putMVar (mvMov $ localStrategy model) mov + msg <- takeMVar (mvMsg $ localStrategy model) + return $ ProcMsg msg + else send (Message $ S.pack $ show mov) >> return Id +updateModel _ (UpdateTBoxVal m) model = noEff model{ tboxval = Message m } +updateModel _ (From mbn) model = noEff model{from = mbn} +updateModel _ IncreasePlayers model = noEff model{players = take 9 $ head (players model) : players model} +updateModel _ DecreasePlayers model = noEff model{players = case players model of + _n:ns@(_:_:_) -> ns + _n:ns@(_:_) | play model -> 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 _ (UpdateVerbosity v) model = noEff model{verbosity = v} +updateModel _ Toggle model = noEff model{fullHistory = not $ fullHistory model} +updateModel _ ToggleVerbosity model = noEff model{showVerbosity = not $ showVerbosity model} +updateModel _ TogglePlay model | play model && length (players model) < 2 = noEff model{play = False, players = head (players model) : players model} + | otherwise = noEff model{play = not $ play model} +updateModel opt ObserveLocally model = model <# liftIO (do + let constructor algIx = fromJust $ lookup algIx $ strategies opt + playerList <- mapM (constructor . S.unpack) $ reverse $ players model +#ifdef TFRANDOM + gen <- newTFGen +#else + gen <- newStdGen +#endif + let (playOrder,g) = case from model of Just n -> (dr++tk, gen) + where (tk,dr) = splitAt n playerList + Nothing -> shuffle playerList gen + finalSituation <- start (GS (length playerList) (rule model)) [] playOrder g + return $ WriteLocalResult $ fst $ fst finalSituation + ) +updateModel _ (WriteLocalResult fs@(_,sts,mvs)) model = model{received = CreateGame : PrettyEndGame (Just fs) : zipWith Watch (tail sts) (iterate (drop 1) $ drop 1 mvs) ++ received model} + <# return (SendMessage $ Message "available") +updateModel opt PlayLocally model = model{local=True} <# do + let constructor algIx = fromJust $ lookup algIx $ strategies opt + playerList <- mapM (constructor . S.unpack) $ reverse $ players model + let thePlayerList = mkDS "local strategy" (localStrategy model) : playerList +#ifdef TFRANDOM + gen <- newTFGen +#else + gen <- newStdGen +#endif + let (playOrder,g) = case from model of Just n -> (dr++tk, gen) + where (tk,dr) = splitAt n thePlayerList + Nothing -> shuffle thePlayerList gen + forkIO $ do ((fs,_),_) <- start (GS (length thePlayerList) (rule model)) [] playOrder g + putMVar (mvMsg $ localStrategy model) $ PrettyEndGame $ Just fs + msg <- takeMVar (mvMsg $ localStrategy model) + return $ ProcMsg msg +updateModel _ (ProcMsg msg@(PrettyEndGame (Just fs))) model = model{local=False, received = CreateGame : msg : received model} <# return (SendMessage $ Message "available") +updateModel _ (ProcMsg msg@(WhatsUp _ _ _)) model = noEff model{received = msg : received model} +updateModel _ (ProcMsg msg) model = model{received = msg : received model} <# do + msg <- takeMVar (mvMsg $ localStrategy model) + return $ ProcMsg msg #ifdef DEBUG -updateModel (HandleWebSocket act) model = noEff model{received = Str (show act) : received model } +updateModel _ (HandleWebSocket act) model = noEff model{received = Str (show act) : received model } #endif -updateModel _ model = noEff model +updateModel _ _ model = noEff model instance ToJSON Message instance FromJSON Message @@ -118,6 +179,7 @@ data Action = HandleWebSocket (WebSocket Message) | SendMessage Message + | SendMove Move | UpdateTBoxVal MisoString | From (Maybe Int) | IncreasePlayers @@ -128,6 +190,10 @@ | Toggle | ToggleVerbosity | TogglePlay + | ObserveLocally + | WriteLocalResult (EndGame, [State], [Move]) + | PlayLocally + | ProcMsg Msg | Id data Model = Model { @@ -140,8 +206,11 @@ , showVerbosity :: Bool , verbosity :: Verbosity , play :: Bool + , localStrategy :: MVarStrategy + , local :: Bool } deriving (Show, Eq) +lenShownHistory :: Int lenShownHistory = 10 appView :: [MisoString] -> String -> Model -> View Action appView strategies versionInfo mdl@Model{..} = div_ [] [ @@ -157,7 +226,8 @@ , span_ [style_ $ M.fromList [("clear","both"), ("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 (renderMsg strategies verbosity mdl) received) + , div_ [style_ $ M.fromList [("clear","both")]] $ if null received then renderCreateGame strategies mdl + else ((if fullHistory then id else take lenShownHistory) $ map (renderMsg strategies verbosity mdl) received) , div_ [] $ if null $ drop lenShownHistory received then [] else [ hr_ [] , input_ [ type_ "checkbox", id_ "showhist", onClick Toggle, checked_ fullHistory] @@ -216,7 +286,18 @@ renderMsg _ verb _ (WhatsUp1 p m) = renderWhatsUp1 verb p m renderMsg _ _ _ (PrettyEndGame Nothing) = pre_ [] [ text $ S.pack $ prettyMbEndGame Nothing] renderMsg _ verb _ (PrettyEndGame (Just tup)) = renderEndGame verb tup -- pre_ [] [ text $ S.pack $ prettyEndGame tup] -renderMsg _ verb _ (Watch st) = renderSt verb ithPlayerFromTheLast st +renderMsg _ verb _ (Watch st []) = div_ [] [ + hr_ [], + renderSt verb ithPlayerFromTheLast st, + hr_ [] + ] +renderMsg _ verb _ (Watch st (mv:_)) = div_ [] [ + hr_ [], + renderTrial verb (publicState st) (const "") undefined (Game.Hanabi.view st) mv, + hr_ [], + renderSt verb ithPlayerFromTheLast st, + hr_ [] + ] renderMsg strategies _ mdl (PrettyAvailable games) = div_ [style_ $ M.fromList [("overflow","auto")]] [ hr_ [], @@ -224,7 +305,13 @@ 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_ [] [ + div_ [] $ renderCreateGame strategies mdl, + hr_ [] + ] +renderMsg strategies _ mdl CreateGame = div_ [] $ renderCreateGame strategies mdl +renderCreateGame :: [MisoString] -> Model -> [View Action] +renderCreateGame strategies mdl + = [ table_ [solid] $ caption_ [textProp "text-align" "left", textProp "margin-left" "auto"] [ -- Seemingly these styles do not work. text "Players", button_ [onClick IncreasePlayers] [text $ S.pack "+"], @@ -261,16 +348,20 @@ mkTRd "Number of lives" (\n -> (rule mdl){numBlackTokens=n}) numBlackTokens [1 .. 9], mkTRd "Number of colors" (\n -> (rule mdl){numColors=n}) numColors [1 .. 6], mkTRd "Continue the game after the pile is exhausted" (\n -> (rule mdl){prolong=n}) prolong [False,True], + mkTRd "Quit the game when no more score is possible" (\n -> (rule mdl){earlyQuit=n}) earlyQuit [False,True], mkTR "numMulticolors" (\n -> (rule mdl){numMulticolors=n}) numMulticolors, mkTR "funPlayerHand" (\n -> (rule mdl){funPlayerHand=n}) funPlayerHand ], - button_ [onClick $ SendMessage $ Message $ S.pack $ (case from mdl of Just n | play mdl -> "from " ++ shows n " " + button_ [onClick $ + if all (not . isWS . S.unpack) (players mdl) + then if play mdl then PlayLocally else ObserveLocally + else SendMessage $ Message $ S.pack $ (case from mdl of Just n | play mdl -> "from " ++ shows n " " | otherwise -> "observe " ++ shows n " " Nothing | play mdl -> "shuffle " - | otherwise -> "observe ") ++ show (rule mdl) ++ concat (intersperse "," $ map S.unpack $ reverse $ players mdl)] [text $ S.pack "create a game"] + | otherwise -> "observe ") ++ show (rule mdl) ++ concat (intersperse "," $ map S.unpack $ reverse $ players mdl) + ] [text $ S.pack "create a game"] ] - ] where you = span_[][ input_ [ type_ "checkbox", id_ "you", onClick TogglePlay, checked_ $ play mdl] , label_ [for_ "you"] [if play mdl then text "You" else s_ [] [text "You"]] @@ -285,13 +376,17 @@ dropdownLiteral :: (Read a, Show a) => [a] -> (a -> Action) -> a -> View Action dropdownLiteral options action selected = dropdown (map (S.pack . show) options) (action . read . S.unpack) (S.pack $ show selected) +dropdownBool :: (Bool -> Action) -> Bool -> View Action dropdownBool = dropdownLiteral [False,True] -- but in most cases booleans should be selected by check boxes. +renderAvailable :: (Int, (Int, Int)) -> View Action 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 :: Attribute action solid = style_ $ M.fromList [("border-style","solid")] +renderWhatsUp :: Verbosity -> String -> [PrivateView] -> [Move] -> View Action renderWhatsUp verb name views@(v:_) moves = div_ [] [ hr_ [], text $ S.pack "Your turn.", @@ -335,6 +430,7 @@ , renderCardInline verb pub c , text $ S.pack "." ] +renderPI :: Verbosity -> PublicInfo -> View Action renderPI verb pub {- This was too verbose = let @@ -348,20 +444,46 @@ 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) ";", + text $ S.pack $ "Turn: "++ shows (turn pub) ", " ++ showDeck (pileNum pub) ++ "Lives: " ++ show (lives pub), + span_ [style_ $ M.fromList [("font-size","1.5em"),("color","#FF0000")]] [text $ S.pack (concat $ replicate (lives pub) "๐Ÿ’“"{-"โ™ฅ"-})], -- In html, heart is ♥ or ♥ and info is ⓘ but they show up literally when used here. + span_ [style_ $ M.fromList [("font-size","1.1em"),("color","#000000")]] [text $ S.pack (concat $ replicate (numBlackTokens (Game.Hanabi.rule $ gameSpec pub) - lives pub) "๐Ÿ’”")], + text $ S.pack $ ", Hints: " ++ show (hintTokens pub), + span_ [style_ $ M.fromList [("font-size","1.3em"),("color","#008800")]] [text $ S.pack (concat $ replicate (hintTokens pub) "โ“˜")], + s_ [style_ $ M.fromList [("font-size","1.1em"),("color","#000000")]] [text $ S.pack (concat $ replicate (8 - hintTokens pub) "โ“˜")], + text $ S.pack $ ";", div_ [] [ - text $ S.pack $ "played:", - span_ [] [ span_ [] $ text (S.pack "|") : [ renderCardInline verb pub $ C c k | k <- [K1 .. playedMax]] | c <- [White .. Multicolor], Just playedMax <- [IM.lookup (fromEnum c) (played pub)] ], + text $ S.pack $ "deck: ", + case deadline pub of -- Nothing -> span_ [style_ $ M.fromList [("width","30px"),("color","#FFFFFF"),("background-color","#000000")]] $ map (text . S.pack) $ replicate (pileNum pub) "__|" + Nothing -> span_ [style_ $ M.fromList [("width","30px")]] $ map (text . S.pack) $ replicate (pileNum pub) "๐Ÿ‚  " + Just dl -> span_ [] [ text . S.pack $ take dl "๐Ÿ•›๐Ÿ•š๐Ÿ•™๐Ÿ•˜๐Ÿ•—๐Ÿ•–๐Ÿ••๐Ÿ•”๐Ÿ•“๐Ÿ•’๐Ÿ•‘๐Ÿ•" ], + if prolong $ Game.Hanabi.rule $ gameSpec pub then span_ [] [] else + case pileNum pub of 1 -> span_ [style_ $ M.fromList [("color", "#FF0000"), ("font-weight", "bold")]] [text "โ† Bottom deck"] + n | n>1 && n <= numPlayers (gameSpec pub) -> span_ [style_ $ M.fromList [("color", "#777700"), ("font-weight", "bold")]] [text "Be ready for the bottom deck"] + | otherwise -> span_ [] [] + ], + div_ [] [ + text $ S.pack "played ", + span_ (if achievable - current >= pileNum pub then [style_ $ M.fromList [("color", "#FF0000"), ("font-weight", "bold")]] else []) + [text $ S.pack $ "(" ++ shows current " / " ++ shows achievable ")"], + text $ S.pack ": ", + span_ [style_ $ M.fromList [("font-size","0.9em")]] [ span_ [] $ text (S.pack "|") : [ renderCardInline verb pub $ C c k | k <- [K1 .. playedMax] ] ++ map (text . S.pack) (replicate (possible - fromEnum playedMax) "__" ++ replicate (5 - possible) "XX") + | c <- colors pub + , let playedMax = achievedRank pub c + possible = fromEnum $ bestPossibleRank pub c + ], text $ S.pack "|" ], div_ [] [ text $ S.pack $ "dropped: ", - span_ [] [ span_ [] $ text (S.pack "|") : (replicate n $ renderCardInline verb pub $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ], + span_ [style_ $ M.fromList [("font-size","0.9em")]] [ span_ [] $ text (S.pack "|") : (replicate n $ renderCardInline verb pub $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ], text $ S.pack "|" ] ] + where current = currentScore pub + achievable = achievableScore pub +renderCardInline :: Verbosity -> PublicInfo -> Card -> View Action renderCardInline v pub c = span_ [style_ $ M.fromList [("width","30px"),("color", colorStr $ Just $ color c),("background-color","#000000")]] [cardStr v pub 0 (Just c) (Nothing,Nothing)] renderRecentEvents :: Verbosity -> PublicInfo -> (Int -> Int -> String) -> [PrivateView] -> [Move] -> View Action @@ -382,6 +504,7 @@ ] where myHand = head (givenHints pub) +renderSt :: Verbosity -> (Int -> Int -> String) -> State -> View Action renderSt verb ithP st@St{publicState=pub} = div_ [] $ renderPI verb pub : zipWith4 (renderHand verb (Game.Hanabi.view st) (ithP $ numPlayers $ gameSpec pub)) [0..] (map (map Just) $ hands st) (givenHints pub) (possibilities pub) @@ -400,21 +523,25 @@ renderCard v pv pli hl ps i mbc tup@(mc,mk) ptup@(pc,pn) = td_ [style_ $ M.fromList [("width","4em"), ("color", colorStr $ fmap color mbc)]] [ maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'p':show i) ] [ text (S.pack "play") ]) (const $ span_[][]) mbc, - div_ [] [ + div_ [style_ $ M.fromList [("font-size","1.2em")]] [ cardStr v pub pli mbc tup ], - div_ [myStyle] [text $ S.pack $ if markHints v then maybe '_' (head . show) mc : [maybe '_' (head . show . fromEnum) mk] else "__" ], + (if useless then s_ [] . (:[]) else id) $ div_ [style_ $ M.fromList myStyle] [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, if markPossibilities v then div_ [style_ $ M.fromList [("font-size","0.8em")]] [text $ S.pack $ showColorPossibilities pc, br_[], text $ S.pack $ showNumberPossibilities pn] else span_[][] ] where pub = publicView pv - myStyle | isNothing mbc = style_ $ M.fromList [ ("background-color", if warnDoubleDrop v && isDoubleDrop pv (result pub) chopSet ptup && i `elem` chopSet then "#880000" else + (useless,myStyle) | isNothing mbc = (markObviouslyUseless v && isDefinitelyUseless pv tup ptup, + [ ("background-color", if warnDoubleDrop v && isDoubleDrop pv (result pub) chopSet ptup && i `elem` chopSet then "#880000" else if markChops v && i `elem` chopSet then "#888888" else "#000000"), - ("font-weight", if markObviouslyUseless v && isDefinitelyUseless pv tup ptup then "100" else "normal"), + ("font-weight", if useless then "100" else "normal"), ("font-style", if markObviouslyPlayable v && isDefinitelyPlayable pv tup ptup then "oblique" else "normal")] - | otherwise = style_ $ M.fromList [ ("background-color",if markChops v && i `elem` concat (take 1 $ obviousChopss pub hl ps) then "#888888" else "#000000"), - ("font-weight", if markObviouslyUseless v && isObviouslyUseless pub ptup then "100" else "normal"), + ) + | otherwise = (markObviouslyUseless v && isObviouslyUseless pub ptup, + [ ("background-color",if markChops v && i `elem` concat (take 1 $ obviousChopss pub hl ps) then "#888888" else "#000000"), + ("font-weight", if useless then "100" else "normal"), ("font-style", if markObviouslyPlayable v && isObviouslyPlayable pub ptup then "oblique" else "normal")] + ) chopSet = concat $ take 1 $ definiteChopss pv hl ps {- renderCards :: Verbosity -> PublicInfo -> [Maybe Card] -> [Marks] -> View Action @@ -435,34 +562,37 @@ ] ] -} +cardStr :: Verbosity -> PublicInfo -> Int -> Maybe Card -> (Maybe Color, Maybe Number) -> View Action -- 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_ [] [ + Just c -> (if useless then s_ else 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" + ("font-weight", if useless 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] [ + Just c -> (if useless then s_ else span_) [style] [ -- text $ S.pack $ show c - span_ [style_ $ M.fromList [("font-size","20px")], + span_ [style_ $ M.fromList [("font-size","1.3em")], 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")], + span_ [style_ $ M.fromList [("font-size","1.3em")], onClick (SendMessage $ Message $ S.pack $ shows pli $ show $ fromEnum $ number c)][text $ S.pack $ show $ fromEnum $ number c] ] where style = style_ $ M.fromList [-- ("width","30px"), - ("font-weight", if markUseless v && isUseless pub c then "100" + ("font-weight", if useless 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")] #endif + useless = markUseless v && isUseless pub c +colorStr :: Maybe Color -> MisoString colorStr Nothing = "#00FFFF" colorStr (Just White) = "#FFFFFF" colorStr (Just Yellow) = "#FFFF00" @@ -470,3 +600,20 @@ colorStr (Just Green) = "#44FF44" colorStr (Just Blue) = "#8888FF" colorStr (Just Multicolor) = "#FF00FF" + +data MVarStrategy = MVS {mvMsg :: MVar Msg, mvMov :: MVar Move} deriving Eq +instance Strategy MVarStrategy IO where + strategyName _ = return "local player" + move pvs mvs mvstr@(MVS mvmsg mvmov) = do + putMVar mvmsg $ WhatsUp "local player" pvs mvs + mov <- takeMVar mvmov + return (mov, mvstr) + observe (v:_) (m:_) (MVS mvmsg mvmov) = putMVar mvmsg $ WhatsUp1 v m + +newMVarStrategy = do + mvmsg <- newEmptyMVar + mvmov <- newEmptyMVar + return $ MVS mvmsg mvmov + +instance Show MVarStrategy where + showsPrec p _ = ("MVarStrategy "++) diff --git a/Game/Hanabi/Msg.hs b/Game/Hanabi/Msg.hs --- a/Game/Hanabi/Msg.hs +++ b/Game/Hanabi/Msg.hs @@ -33,19 +33,30 @@ #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])) | Watch State | PrettyAvailable [(Int, (Int, Int))] deriving (Show, Read, Eq, Generic) +data Msg = Str String | WhatsUp String [PrivateView] [Move] | WhatsUp1 PrivateView Move | PrettyEndGame (Maybe (EndGame, [State], [Move])) | Watch State [Move] | PrettyAvailable [(Int, (Int, Int))] | CreateGame 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 _ (Watch st) = prettySt ithPlayerFromTheLast st +prettyMsg _ (Watch st []) = prettySt ithPlayerFromTheLast st +prettyMsg _ (Watch st (mv:_)) = replicate 20 '-' ++ '\n' : + showTrial (const "") undefined (view st) mv ++ '\n' : + replicate 20 '-' ++ '\n' : prettySt ithPlayerFromTheLast st prettyMsg _ (PrettyAvailable available) = unlines $ map prettyAvailableGame available +prettyMbEndGame :: Maybe (EndGame, [State], [Move]) -> String prettyMbEndGame Nothing = "Game ended abnormally, possibly by connection failure.\n" prettyMbEndGame (Just tup) = prettyEndGame tup +prettyAvailableGame :: (Int, (Int, Int)) -> String prettyAvailableGame (gameid, (missing, total)) = "Game ID " ++ shows gameid ": available " ++ shows missing " out of " ++ shows total "." +-- Both CreateGame and PrettyAvailable have the "Create a Game" UI. Since CreateGame can work offline, sometimes CreateGame is printed before PrettyAvailable is printed. That looks redundant when online, so in such cases CreateGame is removed when PrettyAvailable is received. +suppressCG :: [Msg] -> [Msg] +suppressCG (pr@(PrettyAvailable _) : CreateGame : rest) = pr : rest +suppressCG (pr@(PrettyAvailable _) : PrettyAvailable _ : rest) = pr : rest -- this line makes the state less informative, but makes the UI more sophisticated +suppressCG xs = xs +defaultOptions :: Options defaultOptions = Opt{version = error "The verion field should be set to Game.Hanabi.VersionInfo.versionInfo", port = 8720, strategies = [] @@ -55,3 +66,6 @@ , 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. } + +isWS :: String -> Bool +isWS = (`elem` ["0", "WS", "via WebSocket"]) diff --git a/all.hs b/all.hs --- a/all.hs +++ b/all.hs @@ -3,12 +3,15 @@ import Network.HTTP.Types import Network.Wai.Handler.Warp (run) +import Game.Hanabi(mkDS, DynamicStrategy) import Game.Hanabi.Client(clientApp) -import Game.Hanabi.Backend(hanabiApp, mkDS) +import Game.Hanabi.Backend(hanabiApp) import Game.Hanabi.Msg(defaultOptions, Options(..)) import Game.Hanabi.Strategies.SimpleStrategy hiding (main) +import Game.Hanabi.Strategies.Ryunosuke hiding (main) +main :: IO () main = do putStrLn "localhost:8080" -- Seemingly other port than 8080 does not work. let opt = defaultOptions{version="hanabi-dealer quickbuilt server", strategies=strs} capp <- clientApp opt @@ -20,15 +23,9 @@ _ -> capp request respond -- _ -> respond $ responseLBS status404 [("Content-Type", "text/plain")] "404 Not found" -{- -import Game.Hanabi.Client(client) - --- main = client defaultOptions{strategies=strs, version="foo"} -main = do capp <- clientApp defaultOptions{strategies=strs, version="foo"} - run 8080 capp --} --- strs :: [(String, IO (DynamicStrategy IO))] +strs :: [(String, IO (DynamicStrategy IO))] strs = [ - ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S) + ("Stupid example strategy", return $ mkDS "Stupid example strategy" S), + ("Ryunosuke", return $ mkDS "Ryunosuke" Ry) -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault)) ] diff --git a/client.hs b/client.hs --- a/client.hs +++ b/client.hs @@ -2,11 +2,13 @@ import Game.Hanabi.Client import Game.Hanabi.Strategies.SimpleStrategy hiding (main) +import Game.Hanabi.Strategies.Ryunosuke hiding (main) main = client defOpt{strategies=strs} -- strs :: [(String, IO (DynamicStrategy IO))] strs = [ - ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S) + ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S), + ("Ryunosuke", return $ mkDS "Ryunosuke" $ Ry) -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault)) ] 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.6.0.0 +version: 0.7.0.0 -- A short (one-line) description of the package. synopsis: Hanabi card game @@ -147,7 +147,8 @@ else ghc-options: -O0 -rtsopts cpp-options: -DURI="ws://localhost:8080/ws/" -DWARP - build-depends: base >=4.12 && <4.13, containers >=0.5, random >=1.1, jsaddle-warp >=0.9, aeson, miso, websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6 && <1.9, text >=1.2, utf8-string, wai-websockets, warp, wai, http-types + build-depends: base >=4.9 && <4.13, containers >=0.5, random >=1.1, jsaddle-warp >=0.9, aeson, miso >=1.4, servant >=0.12, websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6 && <1.9, text >=1.2, utf8-string, wai-websockets, warp, wai, http-types + -- I am not sure but seemingly miso fails to build without servant. if flag(TFRANDOM) build-depends: tf-random cpp-options: -DTFRANDOM diff --git a/server.hs b/server.hs --- a/server.hs +++ b/server.hs @@ -2,11 +2,13 @@ import Game.Hanabi.VersionInfo import Game.Hanabi.Strategies.SimpleStrategy hiding (main) +import Game.Hanabi.Strategies.Ryunosuke hiding (main) main = server defOpt{strategies=strs} strs :: [(String, IO (DynamicStrategy IO))] strs = [ - ("Stupid example strategy", return $ mkDS "Stupid example strategy" S) + ("Stupid example strategy", return $ mkDS "Stupid example strategy" S), + ("Ryunosuke", return $ mkDS "Ryunosuke" $ Ry) -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault)) ]