diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Game/Hanabi.hs b/Game/Hanabi.hs --- a/Game/Hanabi.hs +++ b/Game/Hanabi.hs @@ -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 diff --git a/Game/Hanabi/Backend.lhs b/Game/Hanabi/Backend.lhs --- a/Game/Hanabi/Backend.lhs +++ b/Game/Hanabi/Backend.lhs @@ -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 diff --git a/Game/Hanabi/Client.hs b/Game/Hanabi/Client.hs --- a/Game/Hanabi/Client.hs +++ b/Game/Hanabi/Client.hs @@ -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" diff --git a/Game/Hanabi/Strategies/SimpleStrategy.hs b/Game/Hanabi/Strategies/SimpleStrategy.hs --- a/Game/Hanabi/Strategies/SimpleStrategy.hs +++ b/Game/Hanabi/Strategies/SimpleStrategy.hs @@ -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 diff --git a/client.hs b/client.hs --- a/client.hs +++ b/client.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)) ] diff --git a/hanabi-dealer.cabal b/hanabi-dealer.cabal --- a/hanabi-dealer.cabal +++ b/hanabi-dealer.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.3.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 diff --git a/server.hs b/server.hs --- a/server.hs +++ b/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)) ]