hanabi-dealer 0.6.0.0 → 0.7.0.0

raw patch · 9 files changed

+329/−96 lines, 9 filesdep +servantdep ~basedep ~misoPVP ok

version bump matches the API change (PVP)

Dependencies added: servant

Dependency ranges changed: base, miso

API changes (from Hackage documentation)

Files

• ChangeLog.md +11/−0
• Game/Hanabi.hs +77/−22
• Game/Hanabi/Backend.lhs +14/−10
• Game/Hanabi/Client.hs +195/−48
• Game/Hanabi/Msg.hs +16/−2
• all.hs +7/−10
• client.hs +3/−1
• hanabi-dealer.cabal +3/−2
• server.hs +3/−1

@@ -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 

@@ -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<n<10) starts selfplay with youselves:D+selfplay :: GameSpec -> 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

@@ -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"

@@ -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 &hearts; or &#9829; and info is &#9432; 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 "++)

@@ -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"])

@@ -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))   ]

@@ -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))   ]

@@ -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

@@ -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))   ]