hanabi-dealer 0.7.1.1 → 0.7.2.0
raw patch · 5 files changed
+227/−106 lines, 5 filesdep +network-uriPVP ok
version bump matches the API change (PVP)
Dependencies added: network-uri
API changes (from Hackage documentation)
+ Game.Hanabi: definitely :: (PrivateView -> Card -> Bool) -> PrivateView -> Marks -> Possibilities -> Bool
+ Game.Hanabi: isDefinitelyCritical :: PrivateView -> Marks -> Possibilities -> Bool
+ Game.Hanabi: isDefinitelyUncritical :: PrivateView -> Marks -> Possibilities -> Bool
+ Game.Hanabi: isDefinitelyUnplayable :: PrivateView -> Marks -> Possibilities -> Bool
+ Game.Hanabi: isObviouslyUnplayable :: PublicInfo -> Possibilities -> Bool
+ Game.Hanabi: obviously :: (PublicInfo -> Card -> Bool) -> PublicInfo -> Possibilities -> Bool
+ Game.Hanabi: possibleCards :: PrivateView -> Marks -> Possibilities -> [Card]
+ Game.Hanabi: showDeck :: PublicInfo -> [Char]
Files
- ChangeLog.md +8/−0
- Game/Hanabi.hs +44/−22
- Game/Hanabi/Client.hs +100/−53
- Game/Hanabi/Strategies/SimpleStrategy.hs +68/−24
- hanabi-dealer.cabal +7/−7
ChangeLog.md view
@@ -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
Game/Hanabi.hs view
@@ -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 = ""
Game/Hanabi/Client.hs view
@@ -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"
Game/Hanabi/Strategies/SimpleStrategy.hs view
@@ -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).
hanabi-dealer.cabal view
@@ -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)