diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for hanabi-dealer + ## 0.7.2.0 -- 2020-04-02 + + * make SimpleStrategy less stupid, more fun to play with + + * introduce some utility functions with which to build strategies + + * consider viewport when rendering the GUI frontend + ## 0.7.1.1 -- 2020-03-13 * remove reference to a not-publicly-available strategy diff --git a/Game/Hanabi.hs b/Game/Hanabi.hs --- a/Game/Hanabi.hs +++ b/Game/Hanabi.hs @@ -17,10 +17,11 @@ -- * Utilities -- ** Hints isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, currentScore, achievableScore, - isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, obviousChopss, definiteChopss, isDoubleDrop, + definitely, obviously, + isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isDefinitelyUncritical, isDefinitelyCritical, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, isObviouslyUnplayable, isDefinitelyUnplayable, obviousChopss, definiteChopss, isDoubleDrop, possibleCards, tryMove, (|||), ifA, -- ** Minor ones - what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, prettySt, ithPlayerFromTheLast, view, replaceNth, shuffle, showPossibilities, showColorPossibilities, showNumberPossibilities, showTrial) where + what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, prettySt, ithPlayerFromTheLast, view, replaceNth, shuffle, showPossibilities, showColorPossibilities, showNumberPossibilities, showTrial, showDeck) where -- module Hanabi where import qualified Data.IntMap as IM import System.Random @@ -219,22 +220,45 @@ isMoreObviouslyPlayable :: PublicInfo -> Marks -> Bool isMoreObviouslyPlayable pub = iOP (nonPublic pub) pub +obviously :: (PublicInfo -> Card -> Bool) -> PublicInfo -> Possibilities -> Bool +obviously predicate pub (pc,pn) = all (\card -> (nonPublic pub IM.! cardToInt card) == 0 || predicate pub card) + [ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ] + -- | In addition to 'isMoreObviouslyPlayable', 'isObviouslyPlayable' also looks into the color/number possibilities of the card and decides if the card is surely playable. isObviouslyPlayable :: PublicInfo -> Possibilities -> Bool -isObviouslyPlayable pub (pc,pn) = all (\card -> (nonPublic pub IM.! cardToInt card) == 0 || isPlayable pub card) - [ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ] +isObviouslyPlayable = obviously isPlayable +isObviouslyUnplayable :: PublicInfo -> Possibilities -> Bool +isObviouslyUnplayable = obviously (\pub -> not . isPlayable pub) + +definitely :: (PrivateView -> Card -> Bool) -> PrivateView -> Marks -> Possibilities -> Bool +definitely predicate pv marks pos = all (predicate pv) $ possibleCards pv marks pos + -- | In addition to 'isObviouslyPlayable', 'isDefinitelyPlayable' also looks at other players' hand and decides if the card is surely playable. {- This is a weaker version not looking into the possibilities. isDefinitelyPlayable :: PrivateView -> Marks -> Bool isDefinitelyPlayable pv = iOP (invisibleBag pv) (publicView pv) -} isDefinitelyPlayable :: PrivateView -> Marks -> Possibilities -> Bool -isDefinitelyPlayable pv (Just c, Just n) _ = isPlayable (publicView pv) $ C c n -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible. -isDefinitelyPlayable pv _ (pc,pn) = all (\card -> (invisibleBag pv IM.! cardToInt card) == 0 || isPlayable (publicView pv) card) - [ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ] +isDefinitelyPlayable = definitely (isPlayable . publicView) +isDefinitelyUnplayable :: PrivateView -> Marks -> Possibilities -> Bool +isDefinitelyUnplayable = definitely (\pv -> not . isPlayable (publicView pv)) +-- | Unlike 'isDefinitelyUseless', 'isDefinitelyUnciritical' does not care whether the card is the last one or not. 'isDefinitelyUncritical' is, in other words, safe to drop. +isDefinitelyUncritical :: PrivateView -> Marks -> Possibilities -> Bool +isDefinitelyUncritical = definitely (\pv -> not . isCritical (publicView pv)) + +-- | If all of your cards are marked and not safe to drop, and you do not have enough hint token, one option is to drop a card that can be uncritical. (You can then assign them a priority order.) +-- [NB: Maybe this is not a good idea. E.g. when the other player draws the last W2 to fully-marked [R5,G5,B5,Y5], we usually mark 2 to give up a 5, but if the player does not guess the intention and resort the above option, W2 is dropped.] +isDefinitelyCritical :: PrivateView -> Marks -> Possibilities -> Bool +isDefinitelyCritical = definitely (\pv -> isCritical $ publicView pv) + +possibleCards :: PrivateView -> Marks -> Possibilities -> [Card] +possibleCards pv (Just c, Just n) _ = [C c n] -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible. +possibleCards pv _ (pc,pn) = [ card | color <- colorPossibilities pc, number <- numberPossibilities pn, let card = C color number, (invisibleBag pv IM.! cardToInt card) /= 0 ] + where pub = publicView pv + 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 ] @@ -248,14 +272,10 @@ 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 card) == 0 ) - [ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ] +isObviouslyUseless = obviously (\pub (C c n) -> n <= achievedRank pub c || bestPossibleRank pub c < n) isDefinitelyUseless :: PrivateView -> Marks -> Possibilities -> Bool -isDefinitelyUseless pv (Just c, Just n) _ = isUseless (publicView pv) $ C c n -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible. -isDefinitelyUseless pv _ (pc,pn) = all (\card@(C c n) -> n <= achievedRank pub c || bestPossibleRank pub c < n || (invisibleBag pv IM.! cardToInt card) == 0 ) - [ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ] - where pub = publicView pv +isDefinitelyUseless = definitely (\pv -> isUseless (publicView pv)) {- This is a weaker version not looking into the possibilities. isDefinitelyUseless :: PrivateView -> Marks -> Bool @@ -345,7 +365,7 @@ 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 -prettyPV v pv@PV{publicView=pub} = prettyPI pub ++ "\nMy hand:\n" +prettyPV v pv@PV{publicView=pub} = prettyPI pub ++ "\nYour hand:\n" ++ concat (replicate (length myHand) $ wrap "+--+") ++ "\n" -- ++ concat [ if markObviouslyPlayable v && isDefinitelyPlayable pv h then " _^" else " __" | h <- myHand ] ++"\n" ++ concat (replicate (length myHand) $ wrap "|**|") ++ "\n" @@ -430,8 +450,6 @@ } deriving (Read, Show, Eq, Generic) -prettyPI :: PublicInfo -> String -prettyPI pub {- This was too verbose = let showDeck 0 = "no card at the deck (the game will end in " ++ shows (fromJust $ deadline pub) " turn(s)), " @@ -439,11 +457,15 @@ showDeck n = shows n " cards at the deck, " in "Turn "++ shows (turn pub) ": " ++ showDeck (pileNum pub) ++ shows (lives pub) " live(s) left, " ++ shows (hintTokens pub) " hint tokens;\n\n" -} - = let - showDeck 0 = 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" +showDeck pub = case deadline pub of + Nothing -> "Deck: " ++ shows (pileNum pub) ", " + Just 0 -> "Deck: 0 (no turn left), " + Just 1 -> "Deck: 0 (1 turn left), " + Just t -> "Deck: 0 (" ++ shows t " turns left), " + +prettyPI :: PublicInfo -> String +prettyPI pub + = "Turn: "++ shows (turn pub) ", " ++ showDeck pub ++ "Lives: " ++ shows (lives pub) ", Hints: " ++ shows (hintTokens pub) ";\n\n" ++ "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 @@ -646,7 +668,7 @@ _ -> "." ithPlayer :: Int -> Int -> String -ithPlayer _ 0 = "My" +ithPlayer _ 0 = "Your" ithPlayer _ i = "The " ++ ith i ++"next player's" ith :: Int -> String ith 1 = "" diff --git a/Game/Hanabi/Client.hs b/Game/Hanabi/Client.hs --- a/Game/Hanabi/Client.hs +++ b/Game/Hanabi/Client.hs @@ -22,6 +22,9 @@ import Miso.String (MisoString) import qualified Miso.String as S +import Miso.Subscription.History(getCurrentURI) +import Network.URI -- maybe this can conflict #define URI + import Control.Monad.IO.Class(liftIO) import System.Random @@ -76,25 +79,43 @@ -- https://github.com/dmjio/miso/blob/master/frontend-src/Miso/Subscription/WebSocket.hs clientJSM :: Game.Hanabi.Msg.Options -> JSM () -clientJSM options = do mvStr <- liftIO newMVarStrategy +clientJSM options = do thisURI <- getCurrentURI + let query = parseURIQuery thisURI + wsURI = maybe uri (\_ -> URL "ws://localhost:8720") $ lookup "localhost" query + defStr = maybe "via WebSocket" id $ lookup "strategy" query + mvStr <- liftIO newMVarStrategy startApp App{ - model = Model{tboxval = Message "available", players = ["via WebSocket"], from = Just 0, rule = defaultRule{numMulticolors=replicate 5 1}, received = [], fullHistory = False, showVerbosity = False, verbosity = verbose, play = True, localStrategy = mvStr, local = False}, + model = Model{tboxval = Message "available", players = [S.pack defStr], from = Just 0, rule = defaultRule{numMulticolors=replicate 5 1}, 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 ], + subs = [ websocketSub wsURI protocols HandleWebSocket ], events = defaultEvents, initialAction = Id, -- initialAction = SendMessage $ Message "available", -- Seemingly sending as initialAction does not work, even if connect is executed before send. mountPoint = Nothing} where strNames = "via WebSocket" : [ S.pack name | (name, _) <- strategies options ] -#ifdef URI -uri = URL URI +#ifdef WSURI +uri = URL WSURI #else -- uri = URL "ws://133.54.228.39:8720" uri = URL "ws://localhost:8720" #endif protocols = Protocols [] +parseURIQuery :: URI -> [(String,String)] +parseURIQuery = parseQ . drop 1 . uriQuery +parseQ str + = case span (/='&') str of + (tk,[]) -> [parseField tk] + (tk,_:dr) -> parseField tk : parseQ dr +parseField str + = case span (/='=') str of + (tk,dr) -> (decodeString tk, decodeString $ drop 1 dr) +decodeString = map decoS . unEscapeString +decoS '+' = ' ' +decoS c = c + + {- At last, I chose to hide the history by default. lenHistory = 400 -- A better approach might be @@ -299,12 +320,12 @@ 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 []) = div_ [] [ +renderMsg _ verb _ (Watch st []) = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [ hr_ [], renderSt verb ithPlayerFromTheLast st, hr_ [] ] -renderMsg _ verb _ (Watch st (mv:_)) = div_ [] [ +renderMsg _ verb _ (Watch st (mv:_)) = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [ hr_ [], renderTrial verb (publicState st) (const "") undefined (Game.Hanabi.view st) mv, hr_ [], @@ -406,17 +427,17 @@ solid = style_ $ M.fromList [("border-style","solid")] renderWhatsUp :: Verbosity -> String -> [PrivateView] -> [Move] -> View Action -renderWhatsUp verb name views@(v:_) moves = div_ [] [ +renderWhatsUp verb name views@(v:_) moves = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [ hr_ [], text $ S.pack "Your turn.", hr_ [], renderRecentEvents verb (publicView v) ithPlayer views moves, hr_ [], - text $ S.pack $ "Algorithm: " ++ name, +-- text $ S.pack $ "Algorithm: " ++ name, renderPV verb v ] renderWhatsUp1 :: Verbosity -> PrivateView -> Move -> View Action -renderWhatsUp1 verb v m = div_ [style_ $ M.fromList [("background-color","#555555"),("color","#000000")]] [ +renderWhatsUp1 verb v m = div_ [style_ $ M.fromList [("background-color","#555555"),("color","#000000"),("font-size", "1.8vmin")]] [ hr_ [], renderTrial verb (publicView v) (const "") undefined v m, hr_ [], @@ -425,11 +446,11 @@ renderEndGame :: Verbosity -> (EndGame, [State], [Move]) -> View Action renderEndGame verb (eg,sts@(st:_),mvs) - = div_ [] [ + = div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [ hr_ [], renderRecentEvents verb (publicState st) ithPlayerFromTheLast (map Game.Hanabi.view sts) mvs, hr_ [], - h1_ [style_ $ M.fromList [("background-color","#FF0000"),("color","#000000")]] [text $ S.pack $ show eg], + h1_ [style_ $ M.fromList [("background-color","#FF0000"),("color","#000000"),("font-size", "5vmin")]] [text $ S.pack $ show eg], hr_ [], renderSt verb ithPlayerFromTheLast st, hr_ [] @@ -451,31 +472,22 @@ ] renderPI :: Verbosity -> PublicInfo -> View Action renderPI verb pub -{- This was too verbose - = let - showDeck 0 = "no card at the deck (the game will end in " ++ shows (fromJust $ deadline pub) " turn(s)), " - showDeck 1 = "1 card at the deck, " - showDeck n = shows n " cards at the deck, " - in "Turn "++ shows (turn pub) ": " ++ showDeck (pileNum pub) ++ shows (lives pub) " live(s) left, " ++ shows (hintTokens pub) " hint tokens;\n\n" --} - = let - showDeck 0 = 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_ [] [ - text $ S.pack $ "Turn: "++ shows (turn pub) ", " ++ showDeck (pileNum pub) ++ "Lives: " ++ show (lives pub), + = div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [ + text $ S.pack $ "Turn: "++ shows (turn pub) ", " ++ showDeck pub ++ "Lives: " ++ show (lives pub), span_ [style_ $ M.fromList [("font-size","1.5em"),("color","#FF0000")]] [text $ S.pack (concat $ replicate (lives pub) "💓"{-"♥"-})], -- In html, heart is ♥ or ♥ and info is ⓘ but they show up literally when used here. span_ [style_ $ M.fromList [("font-size","1.1em"),("color","#000000")]] [text $ S.pack (concat $ replicate (numBlackTokens (Game.Hanabi.rule $ gameSpec pub) - lives pub) "💔")], - text $ S.pack $ ", Hints: " ++ show (hintTokens pub), - span_ [style_ $ M.fromList [("font-size","1.3em"),("color","#008800")]] [text $ S.pack (concat $ replicate (hintTokens pub) "ⓘ")], - s_ [style_ $ M.fromList [("font-size","1.1em"),("color","#000000")]] [text $ S.pack (concat $ replicate (8 - hintTokens pub) "ⓘ")], + span_ [] [ + 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 $ "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 "🕛🕚🕙🕘🕗🕖🕕🕔🕓🕒🕑🕐" ], + Nothing -> span_ [style_ $ M.fromList [("font-size","0.65em")]] $ map (text . S.pack) $ replicate (pileNum pub) "🂠 " + Just dl -> span_ [style_ $ M.fromList [("font-size","1.5em")]] [ 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"] @@ -486,7 +498,8 @@ 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") +-- span_ [] [ 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") + span_ [] [ span_ [] $ text (S.pack "|") : renderCardsInline verb pub c [K1 .. playedMax] : map (text . S.pack) (replicate (possible - fromEnum playedMax) "_" ++ replicate (5 - possible) "X") | c <- colors pub , let playedMax = achievedRank pub c possible = fromEnum $ bestPossibleRank pub c @@ -496,17 +509,37 @@ div_ [] [ text $ S.pack $ "dropped: ", - 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 ], +-- span_ [] [ span_ [] $ text (S.pack "|") : (replicate n $ renderCardInline verb pub $ intToCard ci) | (ci, n) <- IM.toList $ discarded pub ], + span_ [] [ span_ [] [text (S.pack "|"), renderCardsInline verb pub c (replicate n r)] | (ci, n) <- IM.toList $ discarded pub, n>0, let C c r = intToCard ci ], text $ S.pack "|" ] ] where current = currentScore pub achievable = achievableScore pub + +-- renderCardsInline is a compact version of renderCardInline that prints the color letter only once. +renderCardsInline :: Verbosity -> PublicInfo -> Color -> [Number] -> View Action +renderCardsInline v pub c ns = span_ [style_ $ M.fromList [("font-family", "monospace"),("font-size", "4vmin"),("color", colorStr $ Just c),("background-color","#000000")]] $ span_ [] [text $ S.pack $ take 1 $ show c] : map (numberStrInline v pub c) ns + +numberStrInline v pub c n = cardStrInline v pub (C c n) $ show $ fromEnum n + 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)] +renderCardInline v pub c = span_ [style_ $ M.fromList [("font-family", "monospace"),("font-size", "4vmin"),("color", colorStr $ Just $ color c),("background-color","#000000")]] [cardStrInline v pub c $ head (show $ color c) : show (fromEnum $ number c)] +cardStrInline v pub c xs = (if useless then s_ else span_) [style] [ +-- text $ S.pack $ show c + span_ [] [text $ S.pack xs] + ] + where style = style_ $ M.fromList [ + ("font-weight", if useless then "100" + else if critical then "bold" else "normal"), + ("font-style", if markPlayable v && isPlayable pub c then "oblique" else "normal")] + critical = warnCritical v && isCritical pub c + useless = markUseless v && isUseless pub c + + renderRecentEvents :: Verbosity -> PublicInfo -> (Int -> Int -> String) -> [PrivateView] -> [Move] -> View Action -renderRecentEvents verb pub ithP vs@(v:_) ms = div_ [] $ reverse $ zipWith3 (renderTrial verb pub $ ithP nump) [pred nump, nump-2..0] vs ms +renderRecentEvents verb pub ithP vs@(v:_) ms = div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] $ reverse $ zipWith3 (renderTrial verb pub $ ithP nump) [pred nump, nump-2..0] vs ms where nump = numPlayers $ gameSpec $ publicView v @@ -514,14 +547,14 @@ renderPV v pv@PV{publicView=pub} = div_ [] [ renderPI v pub, div_ [] ( --- div_ [] [text $ S.pack $ "My hand:"] : --- renderCards v pub [ Nothing | _ <- myHand] myHand : - renderHand v pv (const "My") 0 [ Nothing | _ <- myHand] myHand (head $ possibilities pub) : --- ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ] +-- div_ [] [text $ S.pack $ "Your hand:"] : +-- renderCards v pub [ Nothing | _ <- yourHand] yourHand : + renderHand v pv (const "Your") 0 [ Nothing | _ <- yourHand] yourHand (head $ possibilities pub) : +-- ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length yourHand] ] (zipWith4 (renderHand v pv (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) (tail $ givenHints pub) (tail $ possibilities pub)) ) ] - where myHand = head (givenHints pub) + where yourHand = head (givenHints pub) renderSt :: Verbosity -> (Int -> Int -> String) -> State -> View Action renderSt verb ithP st@St{publicState=pub} = div_ [] $ @@ -530,26 +563,36 @@ renderHand :: Verbosity -> PrivateView -> (Int->String) -> Int -> [Maybe Card] -> [Marks] -> [Possibilities] -> View Action renderHand v pv ithPnumP i mbcards hl ps = div_ [] [ - div_ [] [text $ S.pack $ ithPnumP i ++ " hand:"], + div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [text $ S.pack $ ithPnumP i ++ " hand:"], renderHand' v pv i mbcards hl ps -- renderCards v pub (map Just cards) hl ] renderHand' :: Verbosity -> PrivateView -> Int -> [Maybe Card] -> [Marks] -> [Possibilities] -> View Action renderHand' v pv pli mbcards hl ps = - table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"), ("height","48px")]] (zipWith4 (renderCard v pv pli hl ps) [0..] mbcards hl ps)] + table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"){- , ("height","48px") -}]] (zipWith4 (renderCard v pv pli hl ps) [0..] mbcards hl ps)] renderCard :: Verbosity -> PrivateView -> Int -> [Marks] -> [Possibilities] -> Index -> Maybe Card -> Marks -> Possibilities -> View Action -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_ [style_ $ M.fromList [("font-size","1.2em")]] [ +renderCard v pv pli hl ps i mbc tup@(mc,mk) ptup@(pc,pn) = td_ [style_ $ M.fromList [("text-align","center"), + ("width", S.pack $ shows cardWidth "vmin"), + ("color", colorStr $ fmap color mbc), + ("font-family", "monospace") -- , + ]] [ -- ("font-size", S.pack $ shows (cardWidth - cardWidth `div` 10) "vmin")]] [ + maybe (button_ [ onClick (SendMessage $ Message $ S.pack $ 'p':show i), style_ $ M.fromList [("width", S.pack $ shows cardWidth "vmin"), + ("font-size", S.pack $ shows (cardWidth / 5) "vmin" -- "0.3em" + )] ] [ text (S.pack "play") ]) (const $ span_[][]) mbc, + div_ [style_ $ M.fromList [{- ("height", S.pack $ shows (cardWidth / 2) "vmin"), -} ("font-family", "serif"), ("font-size", S.pack $ shows (if isNothing mbc then cardWidth / 3 else cardWidth * (4/9)) "vmin")]] [ -- "1.2em")]] [ cardStr v pub pli mbc tup ], - (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_[][] + (if useless then s_ [] . (:[]) else id) $ div_ [style_ $ M.fromList $ ("text-align","center") : ("font-size", S.pack $ shows (cardWidth / 3) "vmin") : 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), style_ $ M.fromList [("width", S.pack $ shows cardWidth "vmin"), + ("font-size", S.pack $ shows (cardWidth / 5) "vmin" -- "0.3em" + )] ] [ text (S.pack "drop") ]) (const $ span_[][]) mbc, + if markPossibilities v then div_ [style_ $ M.fromList [("font-size", S.pack $ shows (cardWidth / 7) "vmin" -- "0.3em" + )]] [text $ S.pack $ showColorPossibilities pc, -- br_[], + text $ S.pack $ showNumberPossibilities pn] else span_[][] ] where pub = publicView pv + cardWidth = 90 / fromIntegral (handSize $ gameSpec pub) (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"), @@ -592,24 +635,28 @@ 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-family", if critical then "sans-serif" else "serif"), ("font-weight", if useless then "100" - else if warnCritical v && tup==(Nothing,Nothing) && isCritical pub c then "bold" else "normal"), + else if critical 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 "??"] + Nothing -> div_ [style_ $ M.fromList [("text-align","center")]] [text $ S.pack "? ?"] Just c -> (if useless then s_ else span_) [style] [ -- text $ S.pack $ show c - span_ [style_ $ M.fromList [("font-size","1.3em")], + 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","1.3em")], + text " ", + 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-family", if critical then "sans-serif" else "serif"), ("font-weight", if useless then "100" - else if warnCritical v && tup==(Nothing,Nothing) && isCritical pub c then "bold" else "normal"), + else if critical then "bold" else "normal"), ("font-style", if markPlayable v && isPlayable pub c then "oblique" else "normal")] #endif + critical = warnCritical v && tup==(Nothing,Nothing) && isCritical pub c useless = markUseless v && isUseless pub c colorStr :: Maybe Color -> MisoString colorStr Nothing = "#00FFFF" 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 @@ -3,42 +3,86 @@ import Game.Hanabi hiding (main) import System.Random import Data.Maybe(isNothing) +import Data.List(zip4, sortOn) +import Data.Bits(bit) -- An example of a simple and stupid strategy. data Simple = S instance Monad m => Strategy Simple m where strategyName ms = return "Stupid example strategy" - move (pv:_) mvs s = let pub = publicView pv + move (pv:pvs) mvs s = let + pub = publicView pv nextPlayersHand = head $ handsPV pv ::[Card] nextPlayersHints = givenHints pub !! 1 - nextPlayer = zip3 [0..] nextPlayersHand nextPlayersHints + nextPlayersPos = possibilities pub !! 1 + nextPlayer = zip4 [0..] nextPlayersHand nextPlayersHints nextPlayersPos myHints = head $ givenHints pub myPos = head $ possibilities pub + myHand = zip3 [0..] myHints myPos numHand = length myHints - mov = case filter (\(ix, te, hint) -> not (isHinted hint) && isCritical pub te) nextPlayer of - [] -> foo - us -> tryMove pv (Hint 1 $ Right (number $ sndOf3 $ last us)) foo - where foo = case break (\(_,card,_) -> isPlayable pub card) nextPlayer of - (ts,(_,d,(Nothing, _)) :_) | hintTokens pub >= 3 && all (\(_,c,_) -> color c /= color d) ts -> Hint 1 $ Left $ color d - (ts,(_,d,(Just _, Nothing)):_) | hintTokens pub >= 4 -> Hint 1 $ Right $ number d -- This should actually be ANY card. - _ -> - case filter (\(i,marks,pos) -> isDefinitelyPlayable pv marks pos) $ zip3 [0..] myHints myPos of - (i,_,_):_ -> Play i - [] -> - case mvs of - Hint 1 (Left c) : _ | isDefinitelyUseless pv (myHints!!i) (myPos!!i) -> tryMove pv (Drop i) rest - | otherwise -> Play i - where i = length $ takeWhile ((/=Just c) . fst) $ head $ givenHints $ publicView pv - _ -> rest - where rest = case definiteChopss pv myHints myPos of - ((i:_):_) -> tryMove pv (Drop i) - (Hint 1 $ Right $ number $ last $ nextPlayersHand) - _ -> tryMove pv (Hint 1 $ Right $ number $ last $ nextPlayersHand) - (Drop $ pred numHand) + isColorMarkable col = isPlayable pub (head [ c | (j,c,(_,Nothing),_) <- nextPlayer, color c == col ]) + || any (isPlayable pub) [ c | (j,c,(Nothing,Just num),_) <- nextPlayer, color c == col ] + isNewestOfColor i d = null [ () | (j,c,(_,Nothing),_) <- nextPlayer, color c == color d, j < i ] -- True if there is no newer number-unmarked card of the same color in nextPlayer. + markCandidates = filter (\(_,card,_,pos) -> isPlayable pub card && not (isObviouslyPlayable pub pos)) $ reverse nextPlayer -- Playable cards that are not enough hinted, old to new. + markUnhintedCritical = take 1 [ Hint 1 (if isColorMarkable (color te) then Left $ color te else Right $ number te) | (_ix, te, hint, _pos) <- reverse nextPlayer, not (isHinted hint), isCritical pub te ] + keep2 = take 1 [ Hint 1 $ Right $ K2 | (_ix, te@(C _ K2), hint, _pos) <- reverse nextPlayer, not (isHinted hint), not $ isUseless pub te ] + colorMarkUnmarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (i,d,(Nothing, Nothing),_) <- markCandidates, -- Mark the color if a (not obviously) playable card is not marked + isNewestOfColor i d ] -- but be cautious not to color-mark newer cards. + colorMarkNumberMarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (_,d,(Nothing, Just _),_) <- markCandidates ] -- Mark the color if a (not obviously) playable card is only number-marked. + numberMarkPlayable = take 1 [ Hint 1 $ Right $ number d | (_,d,(_, Nothing),_) <- markCandidates ] -- Mark the number if a (not obviously) playable card is not number-marked. + numberMarkUselessIfInformative = take 1 [ Hint 1 $ Right $ number d | (_,d,_,p@(pc, _)) <- nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (pc, bit $ 5 - fromEnum (number d)) ] + colorMarkUselessIfInformative = take 1 [ Hint 1 $ Left $ color d | (i,d,_,p@(_, pn)) <- reverse nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (bit $ 5 - fromEnum (color d), pn), + isNewestOfColor i d ] -- but be cautious not to color-mark newer cards. + numberMarkUnmarked = take 1 [ Hint 1 $ Right $ number d | (_,d,(Nothing, Nothing),p) <- nextPlayer, not $ isObviouslyUseless pub p ] + numberMarkNumberUnmarked = take 1 [ Hint 1 $ Right $ number d | (_,d,(Just _, Nothing),p) <- nextPlayer, not $ isObviouslyUseless pub p ] + colorMarkColorUnmarked = take 1 [ Hint 1 $ Left $ color d | (i,d,(Nothing, Just _),p) <- reverse nextPlayer, not $ isObviouslyUseless pub p, + isNewestOfColor i d ] -- but be cautious not to color-mark newer cards. + playPlayable5 = take 1 [ Play i | (i,marks@(_,Just K5),pos) <- myHand, isDefinitelyPlayable pv marks pos ] + dropUselessCard = take 1 [ Drop i | hintTokens pub < 7, (i,marks,pos) <- reverse myHand, isDefinitelyUseless pv marks pos ] + dropSafe = take 1 [ Drop i | (i,marks,pos) <- reverse myHand, isDefinitelyUncritical pv marks pos ] + dropPossiblyUncritical = take 1 [ Drop i | (i,marks,pos) <- reverse myHand, not $ isDefinitelyCritical pv marks pos ] + sontakuColorMark = case mvs of -- When the last move is color mark, + Hint 1 (Left c) : _ | isDefinitelyUseless pv (myHints!!i) (myPos!!i) -> [Drop i] -- If the first color-marked is obviously useless, drop it. + | isDefinitelyUnplayable pv (myHints!!i) (myPos!!i) -> [] -- If the first color-marked is unplayable for now, ignore it. + | otherwise -> [Play i] -- Otherwise, it means "Play!" + where i = length $ takeWhile ((/=Just c) . fst) $ head $ givenHints $ publicView pv -- (This should also be rewritten using list comprehension.) + _ -> [] + sontakuPositionalDrop = case mvs of + Drop i : _ | i `notElem` unusualChops -> [] -- It is not a positional drop if nothing is unusual. + | not $ isDefinitelyUnplayable pv (myHints!!i) (myPos!!i) -> [Play i] + | otherwise -> [Drop i] -- if by no means it is playable, it means "drop it" (unless there are 8 hints), even if isDefinitelyCritical. + where lastpub = publicView (head pvs) + lastHints = last (givenHints lastpub) + lastPos = last (possibilities lastpub) + unusualChops = drop 1 $ concat $ map reverse $ obviousChopss lastpub lastHints lastPos + _ -> [] + dropChopUnlessDoubleDrop = [ Drop i | is@(i:_) <- take 1 $ map reverse $ definiteChopss pv myHints myPos, not $ isDoubleDrop pv (result pub) is $ myPos !! i ] + dropChop = [ Drop i | i:_ <- take 1 $ definiteChopss pv myHints myPos ] + current = currentScore pub + achievable = achievableScore pub + enoughDeck = prolong (Game.Hanabi.rule $ gameSpec pub) || achievable - current < pileNum pub + mov = head $ filter (isMoveValid pv) $ + sontakuPositionalDrop + ++ markUnhintedCritical + ++ (if hintTokens pub >= 2 || not enoughDeck then colorMarkUnmarkedPlayable else []) + ++ (if hintTokens pub >= 4 then colorMarkNumberMarkedPlayable ++ numberMarkPlayable ++ keep2 else []) -- Do one of these only when there are spare hint tokens. + ++ playPlayable5 + ++ (if enoughDeck then dropUselessCard else []) -- Drop a useless card unless endgame is approaching. + ++ take 1 [ Play i | (i,marks,pos) <- myHand, isDefinitelyPlayable pv marks pos ] -- Play a playable card + ++ sontakuColorMark -- guess the meaning of the last move, and believe it. + ++ dropChopUnlessDoubleDrop + ++ colorMarkUnmarkedPlayable ++ colorMarkNumberMarkedPlayable ++ numberMarkPlayable ++ dropUselessCard ++ keep2 + ++ colorMarkUselessIfInformative + ++ numberMarkUselessIfInformative + ++ colorMarkColorUnmarked ++ numberMarkNumberUnmarked + ++ dropSafe -- drop the oldest 'safe to drop' card + ++ numberMarkUnmarked + ++ [Hint 1 $ Right n | n <- [K1 .. K5]] + ++ dropChop +-- ++ dropPossiblyUncritical -- This may not be a good idea. See Haddock comment on Hanabi.isDefinitelyCritical. + ++ reverse [ Drop i | (i,_,_) <- sortOn (\(_,(_,mb),_) -> fmap fromEnum mb) myHand ] 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). 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.7.1.1 +version: 0.7.2.0 -- A short (one-line) description of the package. synopsis: Hanabi card game @@ -132,9 +132,9 @@ -- || flag(jsaddle) exposed-modules: Game.Hanabi.Client ghcjs-options: -dedupe -O - build-depends: base >=4.12 && <4.13, jsaddle-warp >=0.9, aeson, miso, time >=1.6 + build-depends: base >=4.12 && <4.13, jsaddle-warp >=0.9, aeson, miso, time >=1.6, network-uri >=2.6 if flag(official) - cpp-options: -DURI="ws://133.54.228.39:8720" + cpp-options: -DWSURI="ws://133.54.228.39:8720" -- if flag(jsaddle) -- build-depends: warp, wai, websockets @@ -146,8 +146,8 @@ buildable: False else ghc-options: -O0 -rtsopts - cpp-options: -DURI="ws://localhost:8080/ws/" -DWARP - 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 + cpp-options: -DWSURI="ws://localhost:8080/ws/" -DWARP + 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, network-uri >=2.6 -- I am not sure but seemingly miso fails to build without servant. if flag(TFRANDOM) build-depends: tf-random @@ -187,10 +187,10 @@ else ghcjs-options: -dedupe -O cpp-options: -DCABAL - build-depends: base >=4.12 && <4.13, containers >=0.5, random >=1.1, jsaddle-warp >=0.9, aeson, miso, time >=1.6, hanabi-dealer + build-depends: base >=4.12 && <4.13, containers >=0.5, random >=1.1, jsaddle-warp >=0.9, aeson, miso, time >=1.6, hanabi-dealer, network-uri >=2.6 default-language: Haskell2010 if flag(official) - cpp-options: -DURI="ws://133.54.228.39:8720" + cpp-options: -DWSURI="ws://133.54.228.39:8720" if flag(TH) build-depends: template-haskell -- if flag(jsaddle)