hanabi-dealer 0.3.2.0 → 0.4.0.0

raw patch · 8 files changed

+221/−84 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +18/−0
• Game/Hanabi.hs +96/−34
• Game/Hanabi/Backend.lhs +15/−6
• Game/Hanabi/Client.hs +64/−28
• Game/Hanabi/Strategies/SimpleStrategy.hs +20/−4
• client.hs +1/−1
• hanabi-dealer.cabal +6/−10
• server.hs +1/−1

@@ -1,5 +1,23 @@ # Revision history for hanabi-dealer +	## 0.4.0.0 -- 2020-01-28++	* improve GUI++	* enable starting games from anyone, and shuffling the player list++	* actually implement the prolong option++	* enable finding chop cards++	* enable finding obviously-useless cards from the hints++	* enable finding obviously-playable cards from the hints++	* change the definition of invisibleBag to consider fully-hinted cards, too++	* define some other utility functions+ 	## 0.3.2.0 -- 2020-01-16  	* make the server and the client parts of the library

@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, Safe, DeriveGeneric, RecordWildCards #-}+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, Safe, DeriveGeneric, RecordWildCards #-} module Game.Hanabi(               -- * Functions for Dealing Games               main, selfplay, start, createGame, run,@@ -7,16 +7,16 @@               -- ** The Class of Strategies               Strategies, Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose,               -- ** The Game Specification-              GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid,+              GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid, colors,               -- ** The Game State and Interaction History               Move(..), Index, State(..), PrivateView(..), PublicInfo(..), Result(..), EndGame(..),               -- ** The Cards-              Card(..), Color(..), Number(..), cardToInt, intToCard, readsColorChar, readsNumberChar,+              Card(..), Color(..), Number(..), Marks, cardToInt, intToCard, readsColorChar, readsNumberChar,               -- * Utilities               -- ** Hints-              isCritical, isUseless, bestPossibleRank, isPlayable, invisibleBag,+              isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, isObviouslyUseless, isMoreObviouslyPlayable, isObviouslyPlayable, invisibleBag, chops, chopss,               -- ** Minor ones-              what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, ithPlayerFromTheLast, view, replaceNth) where+              what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, ithPlayerFromTheLast, view, replaceNth, shuffle) where -- module Hanabi where import qualified Data.IntMap as IM import System.Random@@ -32,7 +32,7 @@  data Number  = Empty | K1 | K2 | K3 | K4 | K5 deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic) data Color = White | Yellow | Red | Green | Blue | Multicolor-  deriving (Eq, Show, Read, Enum, Generic)+  deriving (Eq, Show, Read, Enum, Bounded, Generic) readsColorChar :: ReadS Color readsColorChar (c:str)   | isSpace c = readsColorChar str@@ -150,7 +150,7 @@  --                 , numHandCards :: [Int]  -- the number of cards each player has. This was used by isMoveValid, but now abolished because @numHandCards == map length . givenHints@.                      , deadline   :: Maybe Int        -- ^ The number of turns until the endgame, after the pile exhausted. @Nothing@ when @pileNum > 0@.-                     , givenHints :: [[(Maybe Color, Maybe Number)]]+                     , givenHints :: [[Marks]]                                                       -- ^ The Number and Color hints given to each card in each player's hand.                                                        -- Negative hints should also be implemented, but they should be kept separate from givenHints,@@ -158,7 +158,8 @@                      , result :: Result               -- ^ The result of the last move. This info may be separated from 'PublicInfo' in future.                      } deriving (Read, Show, Eq, Generic) -+-- | 'Marks' is the type synonym representing the hint trace of a card.+type Marks = (Maybe Color, Maybe Number)   -- | the best achievable rank for each color.@@ -169,7 +170,7 @@ numCards gs iro = if iro==Multicolor then numMulticolors $ rule gs else [3,2,2,2,1] -- | isUseless pi card means either the card is already played or it is above the bestPossibleRank. isUseless :: PublicInfo -> Card -> Bool-isUseless pub card =  number card <= (played pub IM.! fromEnum (color card)) -- the card is already played+isUseless pub card =  number card <= achievedRank pub (color card) -- the card is already played                    || number card > bestPossibleRank pub (color card) -- | A critical card is a useful card and the last card that has not been dropped. --@@ -179,9 +180,62 @@                       && succ (discarded pub IM.! cardToInt card) == (numCards (gameSpec pub) (color card) !! (pred $ fromEnum $ number card))  isPlayable :: PublicInfo -> Card -> Bool-isPlayable pub card = pred (number card) == played pub IM.! fromEnum (color card)+isPlayable pub card = pred (number card) == achievedRank pub (color card) +isHinted :: Marks -> Bool+isHinted = not . (==(Nothing, Nothing)) +-- | 'isMostObviouslyPlayable' only looks at the current hint marks (and the played piles) and decides if the card is surely playable.+--   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++-- | 'isMoreObviouslyPlayable' looks at the publicly available current info and decides if the card is surely playable.+isMoreObviouslyPlayable :: PublicInfo -> Marks -> Bool+isMoreObviouslyPlayable pub = iOP (nonPublic pub) pub++-- | In addition to 'isMoreObviouslyPlayable', 'isObviouslyPlayable' also looks at other players' hand and decides if the card is surely playable.+isObviouslyPlayable :: PrivateView -> Marks -> Bool+isObviouslyPlayable pv = iOP (invisibleBag pv) (publicView pv)++iOP bag pub (Just c, Just n) = isPlayable pub $ C c n+iOP bag pub (Nothing,Just n) = all (isPlayable pub) [ card | color <- colors pub, let card = C color n, (bag IM.! cardToInt card) > 0 ]+iOP _   _   _                = False++-- | 'isMoreObviouslyUseless' looks at the publicly available current info and decides if the card is surely useless.+isObviouslyUseless :: PublicInfo -> Marks -> Bool+isObviouslyUseless pub (Just c,  Just n)  = isUseless pub $ C c n+isObviouslyUseless pub (Just c,  Nothing) = bestPossibleRank pub c == achievedRank pub c+isObviouslyUseless pub (Nothing, Just n)  = all (\c -> n <= achievedRank pub c || bestPossibleRank pub c < n) $ colors pub+isObviouslyUseless pub (Nothing, Nothing) = False++-- | @'choppiri' marks@ = [unmarked last, unmarked second last, ...]. This is "beginner players' idea of chops". +choppiri :: [Marks] -> [(Index, Marks)]+choppiri = reverse . filter (not . isHinted . snd) . zip [0..]++-- | In addition to 'choppiri', 'chopss' considers 'isObviouslyUseless'. Since "from which card to drop among obviously-useless cards" depends on conventions, cards with the same uselessness are wrapped in a list within the ordered list.+chopss :: PublicInfo -> [Marks] -> [[(Index, Marks)]]+chopss pub hls = (if null useless then id else (useless :)) $ map (:[]) (choppiri hls)+   where useless = filter (isObviouslyUseless pub . snd) (zip [0..] hls)+-- | 'chops' is the flattened version of 'chopss'+chops :: PublicInfo -> [Marks] -> [(Index, Marks)]+chops pub hls = concat $ map reverse $ chopss pub hls+++colors :: PublicInfo -> [Color]+colors pub = take (numColors $ rule $ gameSpec pub) [minBound .. maxBound]++achievedRank :: PublicInfo -> Color -> Number+achievedRank pub k = case IM.lookup (fromEnum k) (played pub) of+                            Just n  -> n+#ifdef DEBUG+                            Nothing | numColors (rule $ gameSpec pub) <= k -> error "requesting invalid color."+                                    | otherwise                            -> error "PublicInfo is not initialized."+#else+                            Nothing -> Empty+#endif+ -- | 'Result' is the result of the last move. data Result = None -- ^ Hinted or at the beginning of the game             | Discard Card | Success Card | Fail Card deriving (Read, Show, Eq, Generic)@@ -197,23 +251,28 @@                                                       --   This is based on the viewer's viewpoint (unlike 'hands' which is based on the current player's viewpoint),                                                       --   and the view history @[PrivateView]@ must be from the same player's viewpoint (as the matter of course).                       } deriving (Read, Show, Eq, Generic)--- | 'invisibleBag' returns the bag of unknown cards (which are either in the pile or in the player's hand).+-- | 'invisibleBag' returns the bag of unknown cards (which are either in the pile or in the player's hand and not fully hinted). invisibleBag :: PrivateView                 -> IM.IntMap Int -- ^ @'Card' -> Int@-invisibleBag pv = foldr (IM.update (Just . pred)) (nonPublic $ publicView pv) $ map cardToInt $ concat $ handsPV pv +invisibleBag pv = foldr (IM.update (Just . pred)) (nonPublic $ publicView pv) $ map cardToInt $ concat $ [ C c n | (Just c, Just n) <- head $ givenHints $ publicView pv ] : handsPV pv  prettyPV :: Verbosity -> PrivateView -> String prettyPV v pv@PV{publicView=pub} = prettyPI pub ++ "\nMy hand:\n"                                               ++ concat (replicate (length myHand) " __") ++ "\n"+--                                              ++ concat [ if markObviouslyPlayable v && isObviouslyPlayable pv h then " _^" else " __" | h <- myHand ] ++"\n"                                               ++ concat (replicate (length myHand) "|**") ++ "|\n"                                               ++ (if markHints v then showHintLine myHand else "")                                      -- x         ++ concat (replicate (length myHand) " ~~") ++ "\n"-                                              ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ]+-- x                                             ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ]+                                              ++ concat [ '+':(if markChops v && d `elem` map fst (concat $ take 1 $ chopss pub myHand) then ('X':) else shows d)+                                                                      (if markObviouslyUseless  v && isObviouslyUseless pub h then "." else+                                                                       if markObviouslyPlayable v && isObviouslyPlayable pv h then "^" else "-") | (d,h) <- zip [0..] myHand ]+                                               ++ concat (zipWith3 (prettyHand v pub (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (handsPV pv) $ tail $ givenHints pub)   where myHand = head (givenHints pub) prettySt ithP st@St{publicState=pub} = prettyPI pub ++ concat (zipWith3 (prettyHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (hands st) $ givenHints pub)-verbose = V{warnCritical=True,markUseless=True,markPlayable=True,markHints=True}-prettyHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Card] -> [(Maybe Color, Maybe Number)] -> String+verbose = V{warnCritical=True,markUseless=True,markPlayable=True,markObviouslyUseless=True,markObviouslyPlayable=True,markHints=True,markChops=True}+prettyHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Card] -> [Marks] -> String prettyHand v pub ithPnumP i cards hl = "\n\n" ++ ithPnumP i ++ " hand:\n" --                          ++ concat (replicate (length cards) " __") ++ " \n"                           ++ concat [ if markUseless v && isUseless pub card then " .."@@ -225,16 +284,22 @@                                     | (card, tup) <- zip cards hl ] ++"\n"                           ++ concat [ '|':show card | card <- cards ] ++"|\n"                           ++ (if markHints v then showHintLine hl else "")-                          ++ concat (replicate (length cards) "+--")+-- x                          ++ concat (replicate (length cards) "+--")+                          ++ concat [ '+':(if markChops v && map fst (take 1 $ chops pub hl) == [d] then ('X':) else ('-':))+                                             (if markObviouslyUseless  v && isObviouslyUseless      pub h then "." else+                                              if markObviouslyPlayable v && isMoreObviouslyPlayable pub h then "^" else "-") | (d,h) <- zip [0..] hl ] -showHintLine :: [(Maybe Color, Maybe Number)] -> String+showHintLine :: [Marks] -> String showHintLine hl = '|' : concat [ maybe ' ' (head . show) mc : maybe ' ' (head . show . fromEnum) mk : "|" | (mc,mk) <- hl] ++ "\n"  -- | 'Verbosity' is the set of options used by verbose 'Strategy's data Verbosity = V { warnCritical :: Bool -- ^ mark unhinted critical cards with "!!" ("!^" if it is playable and markPlayable==True.)-                   , markUseless  :: Bool -- ^ mark useless cards with ".."+                   , markUseless  :: Bool -- ^ mark useless  cards with "..".                    , markPlayable :: Bool -- ^ mark playable cards with "_^". ("!^" if it is unhinted critical and warnCritical==True.)-                   , markHints    :: Bool -- ^ mark hints+                   , markObviouslyUseless  :: Bool -- ^ mark useless  cards with "_." based on the hint marks.+                   , markObviouslyPlayable :: Bool -- ^ mark playable cards with "_^" based on the hint marks.+                   , markChops     :: Bool -- ^ mark the chop card(s) with "X". All obviously-useless cards will be marked, if any.+                   , markHints    :: Bool -- ^ mark hints.                    } deriving (Read, Show, Eq, Generic)  @@ -247,11 +312,11 @@     in  "Turn "++ shows (turn pub) ": " ++ showDeck (pileNum pub) ++ shows (lives pub) " live(s) left, " ++ shows (hintTokens pub) " hint tokens;\n\n" -}   = let-      showDeck 0 = "Deck: 0 (" ++ shows (fromJust $ deadline pub) " turn(s) left),  "+      showDeck 0 = if prolong $ rule $ gameSpec pub then "Deck: 0,  " else "Deck: 0 (" ++ shows (fromJust $ deadline pub) " turn(s) left),  "       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 .. playedMax]] | c <- [White .. Multicolor], Just playedMax <- [IM.lookup (fromEnum c) (played pub)] ]+            ++ "played:" ++ concat [ "  " ++ concat [ show $ C c k | k <- [K1 .. achievedRank pub c]] | c <- [minBound .. Multicolor] ]             ++ "\ndropped: " ++ concat [ '|' : concat (replicate n $ show $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ] ++"|\n"  view :: State -> PrivateView@@ -485,7 +550,7 @@ cardBag rule = concat         [ replicate n c | (c,n) <- cardAssoc rule ] cardMap rule = IM.fromList [ (cardToInt c, n) | (c,n) <- cardAssoc rule ] -shuffle :: RandomGen g => [Card] -> g -> ([Card], g)+shuffle :: RandomGen g => [c] -> g -> ([c], g) shuffle xs = shuf [] xs $ length xs shuf result _  0 gen  = (result, gen) shuf result xs n gen  = let (i,  g)    = randomR (0, pred n) gen@@ -517,6 +582,9 @@                                                               d:ps -> (d:droppedHand, (Nothing,Nothing):droppedHint, ps, pred $ pileNum pub)   nextHands = nextHand : tail (hands st)   nextHints = nextHint : tail (givenHints pub)+  nextDeadline = case deadline pub of Nothing | nextPileNum==0 && not (prolong $ rule $ gameSpec pub) -> Just $ numPlayers gS+                                              | otherwise                                             -> Nothing+                                      Just i  -> Just $ pred i   prc (Drop _) = st{pile = nextPile,                     hands = nextHands,                     publicState = pub{pileNum = nextPileNum,@@ -525,9 +593,7 @@                                       turn       = succ $ turn pub,                                       hintTokens = succ $ hintTokens pub,                                       givenHints = nextHints,-                                      deadline   = case deadline pub of Nothing | nextPileNum==0 -> Just $ numPlayers gS-                                                                                | otherwise      -> Nothing-                                                                        Just i  -> Just $ pred i,+                                      deadline   = nextDeadline,                                       result     = Discard nth}}   prc (Play i) | failure   = let newst@St{publicState=newpub} = prc (Drop i) in newst{publicState=newpub{hintTokens = hintTokens pub, lives = pred $ lives pub, result = Fail nth}}                | otherwise = st{pile = nextPile,@@ -538,17 +604,13 @@                                                   turn       = succ $ turn pub,                                                   hintTokens = if hintTokens pub < 8 && number nth == K5 then succ $ hintTokens pub else hintTokens pub,                                                   givenHints = nextHints,-                                                  deadline   = case deadline pub of Nothing | nextPileNum==0 -> Just $ numPlayers gS-                                                                                            | otherwise      -> Nothing-                                                                                    Just i  -> Just $ pred i,+                                                  deadline   = nextDeadline,                                                   result = Success nth}}-    where failure = played pub IM.! fromEnum (color nth) /= pred (number nth)+    where failure = not $ isPlayable pub nth   prc (Hint hintedpl eik) = st{publicState = pub{hintTokens = pred $ hintTokens pub,                                                  turn       = succ $ turn pub,                                                  givenHints = snd $ updateNth hintedpl newHints (givenHints pub),-                                                 deadline   = case deadline pub of Nothing | pileNum pub==0 -> Just $ numPlayers gS-                                                                                           | otherwise      -> Nothing-                                                                                   Just i  -> Just $ pred i,+                                                 deadline   = nextDeadline,                                                  result     = None}}     where newHints hs = zipWith zipper (hands st !! hintedpl) hs           zipper (C ir ka) (mi,mk) = case eik of Left  i | i==ir -> (Just i, mk)@@ -566,8 +628,8 @@ data EndGame = Failure | Soso Int | Perfect deriving (Show,Read,Eq,Generic)  checkEndGame :: PublicInfo -> Maybe EndGame-checkEndGame pub | lives pub == 0                                        = Just Failure-                 | all (==Just K5) $ map (\k -> IM.lookup (fromEnum k) (played pub)) $ take (numColors $ rule $ gameSpec pub) [White .. Multicolor] = Just Perfect+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                  | 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

@@ -190,11 +190,10 @@ interpret mbVerb inp params   = let sender :: String -> IO ()         sender = sendTextData (conn params) . endecodeX mbVerb . Str-    in case lex inp of-        [("version", _)]   -> sender $ "hanabi-dealer server " ++ versionString params-        [("create", args)] -> case reads args of [(rule,rest)] | isRuleValid rule -> create rule rest-                                                 _             -> create defaultRule args-                    where create rule args =+        createR creater args = case reads args of [(rule,rest)] | isRuleValid rule -> create creater rule rest+                                                  _             -> create creater defaultRule args+        create :: Maybe Int -> Rule -> String -> IO ()+        create from rule args =                               case wordsBy (==',') args of                                 is | numAllies > 0 -> if numAllies >= 9                                                       then sender "Too many teemmates!\n"@@ -215,7 +214,11 @@                                                                    constructor _     algIx = fromJust $ Map.lookup algIx $ gsConstructorMap params                                                                ixSs <- sequence $ zipWith constructor [0..] is                                                                sender "starting the game\n"-                                                               eithFinalSituation <- try $ start (GS (succ numAllies) rule) (mkDS "via WebSocket" (VWS (conn params) mbVerb sendFullHistoryInFact) : ixSs) $ gen params+                                                               let playerList = mkDS "via WebSocket" (VWS (conn params) mbVerb sendFullHistoryInFact) : ixSs+                                                                   (playOrder,g) = case from of Just n  -> (dr++tk, gen params)+                                                                                                   where (tk,dr) = splitAt n playerList+                                                                                                Nothing -> shuffle playerList $ gen params+                                                               eithFinalSituation <- try $ start (GS (succ numAllies) rule) playOrder g                                                                finalSituation <- case eithFinalSituation of                                                                                    Left e -> do hPutStrLn stderr $ displayException (e::SomeException)                                                                                                 return Nothing@@ -225,6 +228,12 @@                                                                putMVar mvFinalSituation finalSituation                                            where numAllies = length is                                 _  -> sender "The arguments of the `create' command could not be parsed."+    in case lex inp of+        [("version", _)]   -> sender $ "hanabi-dealer server " ++ versionString params+        [("create", args)] -> createR (Just 0) args+        [("from",   args)] -> case reads args of [(n, ars)] -> createR (Just n) ars+                                                 _          -> sender "Parse error. The player number expected."+        [("shuffle",args)] -> createR Nothing args         [("available", s)] | all isSpace s -> when (isJust mbVerb) $ available mbVerb (mvTIDToMVH params) (conn params)         [("attend", arg)] -> case reads arg of                                [(gid, s)] | all isSpace s -> do tidToMVH <- readMVar $ mvTIDToMVH params

@@ -6,14 +6,15 @@ module Game.Hanabi.Client(client, Game.Hanabi.Msg.Options(..), Game.Hanabi.Msg.defaultOptions, mkDS) where  import Game.Hanabi hiding (main, rule)+import qualified Game.Hanabi(rule) import Game.Hanabi.Msg  import           Data.Aeson   hiding (Success)-import           GHC.Generics hiding (K1)+import           GHC.Generics hiding (K1, from) import           Data.Bool import qualified Data.Map as M import qualified Data.IntMap as IM-import Data.Maybe(fromJust)+import Data.Maybe(fromJust, isNothing) import Data.List(intersperse)  import           Miso         hiding (Fail)@@ -37,7 +38,7 @@  client :: Game.Hanabi.Msg.Options -> IO () client options = runApp $ startApp App{-    model  = Model{tboxval = Message "available", players = ["via WebSocket"], rule = defaultRule, received = [], fullHistory = False},+    model  = Model{tboxval = Message "available", players = ["via WebSocket"], from = Just 0, rule = defaultRule, received = [], fullHistory = False},     update = updateModel,     view   = appView strNames $ version options,     subs   = [ websocketSub uri protocols HandleWebSocket ],@@ -67,6 +68,7 @@ updateModel (SendMessage msg) model = model{fullHistory=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}@@ -87,6 +89,7 @@   = HandleWebSocket (WebSocket Message)   | SendMessage Message   | UpdateTBoxVal MisoString+  | From (Maybe Int)   | IncreasePlayers   | DecreasePlayers   | UpdatePlayer Int MisoString@@ -96,7 +99,8 @@  data Model = Model {     tboxval :: Message-  , players :: [MisoString]+  , players :: [MisoString] -- REVERSED list of players other than this client+  , from :: Maybe Int   , rule :: Rule   , received :: [Msg]   , fullHistory :: Bool@@ -158,13 +162,40 @@            tr_ [] [ th_ [solid] [text $ S.pack str] | str <- ["Game ID", "available", "total"] ] :            map renderAvailable games,       div_ [] [-           input_ [type_ "text", onInput (UpdateRule . head . (++[rule mdl]) . map fst . reads . S.unpack), value_ $ S.pack $ show $ rule mdl, style_ $ M.fromList [("width","70%")]],-           div_ [] [+--             table_ [] $ caption_ [textProp "text-align" "left", textProp "margin-left" "auto"] [ -- Seemingly these styles do not work.+             text "Player list",              button_ [onClick IncreasePlayers] [text $ S.pack "+"],              button_ [onClick DecreasePlayers] [text $ S.pack "-"],-             span_ [] $ intersperse (text ",") $ zipWith (renderPlayer strategies) [0..] $ players mdl,-             button_ [onClick $ SendMessage $ Message $ S.pack $ "create " ++ show (rule mdl) ++ concat (intersperse "," $ map S.unpack $ players mdl)] [text $ S.pack "create a game"]-           ]+             input_ [type_ "radio", id_ "shuffle", onClick (From Nothing), checked_ $ from mdl == Nothing],+             label_ [for_ "shuffle"] [text "shuffle before the game"],+-- x                                   ] :+             table_ [] $ [ tr_ [] [td_ [solid] [x], td_ [] [input_ [type_ "radio", id_ iD, onClick (From $ Just n), checked_ $ from mdl == Just n],+                                                            label_ [for_ iD] [text "Turn 0"]]]+                         | (n,x) <- zip [0..] $ text "You" : reverse (zipWith (renderPlayer strategies) [0..] (players mdl))+                         , let iD = S.pack $ "radio"++show n ]+-- x                       ++ [tr_ [] [td_ [] [], td_ [] [input_ [type_ "radio", id_ "shuffle", onClick (From Nothing), checked_ $ from mdl == Nothing],+--                                                        label_ [for_ "shuffle"] [text "shuffle the player list before the game"]]]]+                     ,+--             div_ [] [text $ "Rules"],+--             div_ [] [input_ [type_ "text", onInput (UpdateRule . head . (++[rule mdl]) . map fst . reads . S.unpack), value_ $ S.pack $ show $ rule mdl, style_ $ M.fromList [("width","70%")]]],++             let mkTR label updater access = tr_ [] [+                          td_ [] [text label],+                          td_ [] [+                             input_ [type_ "text", onInput (UpdateRule . updater . head . (++[access $ rule mdl]) . map fst . reads . S.unpack), value_ $ S.pack $ show $ access $ rule mdl]+                            ]+                        ] in+               table_ [] [+                   caption_ [] [text "Rules"],+                   mkTR "Number of lives"                               (\n -> (rule mdl){numBlackTokens=n}) numBlackTokens,+                   mkTR "Number of colors"                              (\n -> (rule mdl){numColors=n})      numColors,+                   mkTR "Continue the game after the pile is exhausted" (\n -> (rule mdl){prolong=n})        prolong,+                   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 -> "from " ++ shows n " "+                                                                                   Nothing-> "shuffle ") ++ show (rule mdl) ++ concat (intersperse "," $ map S.unpack $ reverse $ players mdl)] [text $ S.pack "create a game"]       ]    ] renderPlayer :: [MisoString] -> Int -> MisoString -> View Action@@ -228,7 +259,7 @@     in  "Turn "++ shows (turn pub) ": " ++ showDeck (pileNum pub) ++ shows (lives pub) " live(s) left, " ++ shows (hintTokens pub) " hint tokens;\n\n" -}   = let-      showDeck 0 = "Deck: 0 (" ++ shows (fromJust $ deadline pub) " turn(s) left),  "+      showDeck 0 = if prolong $ Game.Hanabi.rule $ gameSpec pub then "Deck: 0,  " else "Deck: 0 (" ++ shows (fromJust $ deadline pub) " turn(s) left),  "       showDeck 1 = "Deck: 1,  "       showDeck n = "Deck: " ++ shows n ",  "     in div_ [] [@@ -259,39 +290,43 @@   div_ [] ( --      div_ [] [text $ S.pack $ "My hand:"] : --      renderCards v pub [ Nothing | _ <- myHand] myHand :-      renderHand v pub (const "My") 0 [ Nothing | _ <- myHand] myHand :+      renderHand v pv (const "My") 0 [ Nothing | _ <- myHand] myHand : --                                              ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ]-      (zipWith3 (renderHand v pub (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) $ tail $ givenHints pub)+      (zipWith3 (renderHand v pv (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) $ tail $ givenHints pub)     )   ]   where myHand = head (givenHints pub)  renderSt ithP st@St{publicState=pub} = div_ [] $   renderPI pub :-  zipWith3 (renderHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (map (map Just) $ hands st) (givenHints pub)+  zipWith3 (renderHand verbose (Game.Hanabi.view st) (ithP $ numPlayers $ gameSpec pub)) [0..] (map (map Just) $ hands st) (givenHints pub) -renderHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action-renderHand v pub ithPnumP i mbcards hl = div_ [] [+renderHand :: Verbosity -> PrivateView -> (Int->String) -> Int -> [Maybe Card] -> [Marks] -> View Action+renderHand v pv ithPnumP i mbcards hl = div_ [] [   div_ [] [text $ S.pack $ ithPnumP i ++ " hand:"],-   renderHand' v pub i mbcards hl+   renderHand' v pv i mbcards hl --  renderCards v pub (map Just cards) hl   ]-renderHand' :: Verbosity -> PublicInfo -> Int -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action-renderHand' v pub pli mbcards hl = -   table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"), ("height","48px")]] (zipWith3 (renderCard v pub pli) [0..] mbcards hl)]+renderHand' :: Verbosity -> PrivateView -> Int -> [Maybe Card] -> [Marks] -> View Action+renderHand' v pv pli mbcards hl = +   table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"), ("height","48px")]] (zipWith3 (renderCard v pv pli hl) [0..] mbcards hl)] -renderCard :: Verbosity -> PublicInfo -> Int -> Index -> Maybe Card -> (Maybe Color, Maybe Number) -> View Action-renderCard v pub pli i mbc tup@(mc,mk) = td_ [style_ $ M.fromList [("width","36px"),+renderCard :: Verbosity -> PrivateView -> Int -> [Marks] -> Index -> Maybe Card -> Marks -> View Action+renderCard v pv pli hl i mbc tup@(mc,mk) = td_ [style_ $ M.fromList [("width","36px"),                                                                    ("color", colorStr $ fmap color mbc)]] [      maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'p':show i) ] [ text (S.pack "play") ]) (const $ span_[][]) mbc,      div_ [] [         cardStr v pub pli mbc tup      ],-     div_ [] [text $ S.pack $ if markHints v then maybe '_' (head . show) mc : [maybe '_' (head . show . fromEnum) mk] else "__" ],+     div_ [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-  ]+  ] where+          pub = publicView pv+          myStyle = style_ $ M.fromList [ ("background-color",if markChops v && i `elem` map fst (concat $ take 1 $ chopss pub hl) then "#888888" else "#000000"),+                                          ("font-weight", if markObviouslyUseless v && isObviouslyUseless pub tup then "100" else "normal"),+                                          ("font-style",  if markObviouslyPlayable v && (if isNothing mbc then isObviouslyPlayable pv else isMoreObviouslyPlayable pub) tup then "oblique" else "normal")] {--renderCards :: Verbosity -> PublicInfo -> [Maybe Card] -> [(Maybe Color, Maybe Number)] -> View Action+renderCards :: Verbosity -> PublicInfo -> [Maybe Card] -> [Marks] -> View Action renderCards v pub mbcs tups = table_ [style_ $ M.fromList [("border-color","#FFFFFF"),("border-width","medium")]] [   tr_ [style_ $ M.fromList [("background-color","#000000")]]      [@@ -325,16 +360,17 @@ #else cardStr v pub pli mbc tup = case mbc of           Nothing -> span_ [] [text $ S.pack "??"]-          Just c  -> span_ [style_ $ M.fromList [-- ("width","30px"),-                              ("font-weight", if markUseless v && isUseless pub c then "100"-                                              else if warnCritical v && tup==(Nothing,Nothing) && isCritical pub c then "bold" else "normal"),-                              ("font-style",  if markPlayable v && isPlayable pub c then "oblique" else "normal")]] [+          Just c  -> span_ [style] [ --                                    text $ S.pack $ show c                                     span_ [style_ $ M.fromList [("font-size","20px")],                                               onClick (SendMessage $ Message $ S.pack $ shows pli $ take 1 $ show $ color c)] [text $ S.pack $ take 1 $ show $ color c],                                     span_ [style_ $ M.fromList [("font-size","20px")],                                               onClick (SendMessage $ Message $ S.pack $ shows pli $ show $ fromEnum $ number c)][text $ S.pack $ show $ fromEnum $ number c]                              ]+                     where style = style_ $ M.fromList [-- ("width","30px"),+                              ("font-weight", if markUseless v && isUseless pub c then "100"+                                              else if warnCritical v && tup==(Nothing,Nothing) && isCritical pub c then "bold" else "normal"),+                              ("font-style",  if markPlayable v && isPlayable pub c then "oblique" else "normal")] #endif colorStr Nothing       = "#00FFFF" colorStr (Just White)  = "#FFFFFF"

@@ -4,16 +4,32 @@ import System.Random  -- An example of a simple and stupid strategy.-data Simple = S ()+data Simple = S  instance Monad m => Strategy Simple m where   strategyName ms = return "Stupid example strategy"+  move (pv:_) (Hint 1 (Left c) : _) s = return (Play $ length $ takeWhile ((/=Just c) . fst) $ head $ givenHints $ publicView pv, s)   move (pv:_) _mvs s = let pub = publicView pv+                           tsuginohitoNoTe = head $ handsPV pv ::[Card]+                           tsuginohitoNoHint = givenHints pub !! 1                            numHand = length $ head $ givenHints pub-                           mov | hintTokens pub == 8 = Play 0           -- Play the newest card if there are the max number of hint tokens.-                               | otherwise           = Drop (numHand-1) -- Otherwise, drop the oldest card.+                           mov | hintTokens pub >= 1 = case filter (\(ix, te, hint) -> hint == (Nothing,Nothing) && isCritical pub te) $ zip3 [0..] tsuginohitoNoTe tsuginohitoNoHint of+                                                             [] -> foo+                                                             us -> Hint 1 $ Right (number $ sndOf3 $ last us)+                               | otherwise           = foo+                                   where foo = case filter ((==(Nothing,Nothing)) . snd) $ zip [0..] $ head $ givenHints pub of+                                                                        ts@(_:_) | hintTokens pub < 4 -> Drop (fst $ last ts)+                                                                                 | otherwise          -> case break (isPlayable pub) tsuginohitoNoTe of+                                                                                                             (_,d:_) -> Hint 1 $ Left $ color d+                                                                                                             (_,[]) | hintTokens pub < 8 -> Drop (fst $ last ts)+                                                                                                                    | otherwise          -> Hint 1 $ Right $ number $ last $ tsuginohitoNoTe+                                                                        _       | hintTokens pub < 1 -> Drop $ pred $ length $ head $ givenHints pub+                                                                                | otherwise          -> Hint 1 $ Right $ number $ last $ tsuginohitoNoTe                        in return (mov, s) +sndOf3 (_,b,_) = b+ main = do g <- newStdGen-          ((eg,_),_) <- start defaultGS ([S ()],[stdio]) g -- Play it with standard I/O (human player).+--          ((eg,_),_) <- start defaultGS ([S],[stdio]) g -- Play it with standard I/O (human player).+          ((eg,_),_) <- start defaultGS [S,S] g -- Play it with itself.           putStrLn $ prettyEndGame eg

@@ -7,6 +7,6 @@  -- strs :: [(String, IO (DynamicStrategy IO))] strs = [-     ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S ())+     ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S)  -- 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.3.2.0+version:             0.4.0.0  -- A short (one-line) description of the package. synopsis:            Hanabi card game@@ -19,7 +19,7 @@ -- description:  -- URL for the project homepage or repository.--- homepage:            http://nautilus.cs.miyazaki-u.ac.jp/~skata/Sontakki/Hanabi.html+homepage:            http://nautilus.cs.miyazaki-u.ac.jp/~skata/Sontakki/  -- The license under which the package is released. license:             BSD3@@ -93,16 +93,16 @@   if impl(ghcjs) || flag(server)     exposed-modules:     Game.Hanabi.VersionInfo     other-modules:       Game.Hanabi.Msg+    -- cpp-options:      -DCABAL+    -- -DCABAL is used for detecting the version of hanabi-dealer, which is impossible when building as the library.+    if flag(TH)+      build-depends: template-haskell    if !impl(ghcjs) && flag(server)     ghc-options:      -O2     -- Not sure if -O2 is worthy, but this should be OK because the server is not built by default.     exposed-modules:     Game.Hanabi.Backend     build-depends:    websockets >=0.12 && <0.13, network >=2.6 && <3.2, hashable >=1.3, time >=1.6 && <1.9, text >=1.2, utf8-string-    -- cpp-options:      -DCABAL-    -- -DCABAL is used for detecting the version of hanabi-dealer, which is impossible when building as the library.-    if flag(TH)-      build-depends: template-haskell     if flag(TFRANDOM)       build-depends: tf-random       cpp-options: -DTFRANDOM@@ -112,13 +112,9 @@   if impl(ghcjs)       exposed-modules:     Game.Hanabi.Client       ghcjs-options:      -dedupe -O-      -- cpp-options:        -DCABAL       build-depends:      base >=4.12 && <4.13, jsaddle-warp >=0.9, aeson, miso, time-      default-language:   Haskell2010       if flag(official)         cpp-options:  -DURI="ws://133.54.228.39:8720"-      if flag(TH)-        build-depends: template-haskell  executable server   main-is:       server.hs

@@ -7,6 +7,6 @@  strs :: [(String, IO (DynamicStrategy IO))] strs = [-     ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S ())+     ("Stupid example strategy", return $ mkDS "Stupid example strategy" S)  -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault))   ]