hanabi-dealer 0.9.0.0 → 0.9.1.0
raw patch · 8 files changed
+186/−70 lines, 8 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Game.Hanabi: EGL :: (PublicInfo -> Bool) -> p -> ps -> Map Key ([Move], [([State], ps, Int)]) -> EndGameLite p ps
+ Game.Hanabi: EGML :: EndGameLite p [EndGameMirrorLite p] -> EndGameMirrorLite p
+ Game.Hanabi: [fromWhenL] :: EndGameLite p ps -> PublicInfo -> Bool
+ Game.Hanabi: [memory] :: EndGameLite p ps -> Map Key ([Move], [([State], ps, Int)])
+ Game.Hanabi: [myUsualStrategyL] :: EndGameLite p ps -> p
+ Game.Hanabi: [otherPlayersL] :: EndGameLite p ps -> ps
+ Game.Hanabi: data EndGameLite p ps
+ Game.Hanabi: data EndGameMirrorLite p
+ Game.Hanabi: egl :: () => (PublicInfo -> Bool) -> p -> ps -> EndGameLite p ps
+ Game.Hanabi: egml :: (PublicInfo -> Bool) -> p -> Int -> EndGameMirrorLite p
+ Game.Hanabi: instance (GHC.Base.Monad m, Game.Hanabi.Strategy p m) => Game.Hanabi.Strategy (Game.Hanabi.EndGameMirrorLite p) m
+ Game.Hanabi: instance (GHC.Base.Monad m, Game.Hanabi.Strategy p m, Game.Hanabi.Strategies ps m) => Game.Hanabi.Strategy (Game.Hanabi.EndGameLite p ps) m
+ Game.Hanabi: instance GHC.Classes.Ord Game.Hanabi.Card
+ Game.Hanabi: instance GHC.Classes.Ord Game.Hanabi.Color
+ Game.Hanabi: instance GHC.Classes.Ord Game.Hanabi.Move
+ Game.Hanabi: moreStrictlyAchievableScore :: PublicInfo -> Int
+ Game.Hanabi: seeminglyAchievableScore :: PublicInfo -> Int
Files
- ChangeLog.md +4/−0
- Game/Hanabi.hs +118/−18
- Game/Hanabi/Backend.lhs +6/−13
- Game/Hanabi/Client.hs +18/−28
- Game/Hanabi/Msg.hs +17/−0
- Game/Hanabi/Strategies/EndGameSearch.hs +9/−4
- Game/Hanabi/Strategies/SimpleStrategy.hs +13/−6
- hanabi-dealer.cabal +1/−1
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for hanabi-dealer + ## 0.9.1.0 -- 2020-05-05++ * add efficiency-improved end-game search agents+ ## 0.9.0.0 -- 2020-04-22 * add end-game search
Game/Hanabi.hs view
@@ -16,9 +16,9 @@ Card(..), Color(..), Number(..), Marks, Possibilities, Annotation(..), cardToInt, intToCard, readsColorChar, readsNumberChar, colorToBitPos, numberToBitPos, -- * Utilities -- ** Hints- isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, currentScore, achievableScore,+ isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, currentScore, seeminglyAchievableScore, moreStrictlyAchievableScore, achievableScore, definitely, obviously,- isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isDefinitelyUncritical, isDefinitelyCritical, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, isObviouslyUnplayable, isDefinitelyUnplayable, obviousChopss, definiteChopss, isDoubleDrop, possibleCards, endGameMove, EndGameStrategy(..), EndGameMirrorStrategy(..), egms,+ isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isDefinitelyUncritical, isDefinitelyCritical, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, isObviouslyUnplayable, isDefinitelyUnplayable, obviousChopss, definiteChopss, isDoubleDrop, possibleCards, endGameMove, EndGameStrategy(..), EndGameMirrorStrategy(..), egms, EndGameLite(..), egl, EndGameMirrorLite(..), egml, tryMove, (|||), ifA, -- ** Legacy functions givenHints, possibilities_until_Ver0720,@@ -26,13 +26,14 @@ 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 qualified Data.Map as M import System.Random import Control.Applicative((<*>)) import Control.Monad(when) import Control.Monad.IO.Class(MonadIO, liftIO) import Data.Char(isSpace, isAlpha, isAlphaNum, toLower, toUpper) import Data.Maybe(fromJust)-import Data.List(isPrefixOf, group, maximumBy, delete)+import Data.List(isPrefixOf, group, maximumBy, delete, sort) import Data.Function(on) import System.IO import Data.Dynamic@@ -42,7 +43,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, Bounded, Generic)+ deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic) readsColorChar :: ReadS Color readsColorChar (c:str) | isSpace c = readsColorChar str@@ -53,7 +54,7 @@ readsNumberChar :: ReadS Number readsNumberChar xs = [ (toEnum d, rest) | (d, rest) <- reads xs, d<=5 ] -data Card = C {color :: Color, number :: Number} deriving (Eq, Generic)+data Card = C {color :: Color, number :: Number} deriving (Eq, Ord, Generic) instance Show Card where showsPrec _ (C color number) = (head (show color) :) . (show (fromEnum number) ++) showList = foldr (.) id . map shows@@ -70,7 +71,7 @@ data Move = Drop {index::Index} -- ^ drop the card (0-origin) | Play {index::Index} -- ^ play the card (0-origin) | Hint Int (Either Color Number) -- ^ give hint to the ith next player- deriving (Eq, Generic)+ deriving (Eq, Ord, Generic) instance Show Move where showsPrec _ (Drop i) = ("Drop"++) . shows i showsPrec _ (Play i) = ("Play"++) . shows i@@ -353,9 +354,17 @@ currentScore pub = sum [ fromEnum $ achievedRank pub k | k <- colors pub ] -- | achievable score based on the info of extinct cards.+seeminglyAchievableScore :: PublicInfo -> Int+seeminglyAchievableScore pub = sum [ fromEnum $ bestPossibleRank pub k | k <- colors pub ]++-- | alias to 'seeminglyAchievableScore'. This function name may point to the function with stricter check in future. achievableScore :: PublicInfo -> Int-achievableScore pub = sum [ fromEnum $ bestPossibleRank pub k | k <- colors pub ]+achievableScore = seeminglyAchievableScore +-- | In addition to 'seeminglyAchievableScore', 'moreStrictlyAchievableScore' checks the number of cards at the deck, unless 'prolong' is @True@.+moreStrictlyAchievableScore :: PublicInfo -> Int+moreStrictlyAchievableScore pub = if prolong $ rule $ gameSpec pub then seeminglyAchievableScore pub else seeminglyAchievableScore pub `min` (currentScore pub + pileNum pub + numPlayers (gameSpec pub))+ tryMove :: PrivateView -> Move -> Move -> Move tryMove pv m alt | isMoveValid pv m = m | otherwise = alt@@ -435,7 +444,7 @@ scores <- mapM (evalMove states (map publicView tlpvs) mvs ps) candidates let asc = zip scores candidates pub = publicView pv- achievable = if prolong $ rule $ gameSpec pub then achievableScore pub else achievableScore pub `min` (currentScore pub + pileNum pub + numPlayers (gameSpec pub))+ achievable = moreStrictlyAchievableScore pub -- ToDo: Also consider critical cards at the bottom deck. return $ case lookup (achievable * length states) asc of Nothing -> snd $ maximumBy (compare `on` fst) $ reverse asc Just k -> k -- Stop search when the best possible score is found.@@ -445,8 +454,8 @@ = map Play [0 .. pred myHandSize] ++ (if hints > 0 then ([ Hint hintedpl eck | hintedpl <- [1 .. numPlayers gs - 1], eck <- map Left (colors pub) ++ map Right [K1 .. K5], not (null $ filter (either (\c -> (==c).color) (\k -> (==k).number) eck) (tlHands !! pred hintedpl)) ] ++) else id) (if hints < 8 then (map Drop [0 .. pred myHandSize]) else []) where myHandSize = length (head $ annotations pub) -evalMove :: (Monad m, Strategies ps m) => [State] -> [PublicInfo] -> [Move] -> ps -> Move -> m Int-evalMove states pubs@(pub:_) mvs ps mv = fmap (sum . map (\((eg,_,_),_) -> egToInt pub eg)) $ mapM (\st -> tryAMove (stateToStateHistory pubs mvs st) mvs ps mv) states+evalMove :: (Monad m, Strategies ps m) => [(State, Int)] -> [PublicInfo] -> [Move] -> ps -> Move -> m Int+evalMove states pubs@(pub:_) mvs ps mv = fmap (sum . map (\(((eg,_,_),_),n) -> n * egToInt pub eg)) $ mapM (\(st,n) -> fmap (\a->(a,n)) $ tryAMove (stateToStateHistory pubs mvs st) mvs ps mv) states -- | 'tryAMove' tries a 'Move' and then simulate the game to the end, using given 'Strategies'. Running this with empty history, such as @tryAMove [st] [] strs m@ is possible, but that assumes other strategies does not depend on the history. tryAMove :: (Monad m, Strategies ps m) => [State] -> [Move] -> ps -> Move -> m ((EndGame, [State], [Move]),ps)@@ -455,12 +464,100 @@ in case checkEndGame $ publicState nxt of Nothing -> runSilently (nxt:states) (mov:mvs) strs Just eg -> return ((eg, nxt:states, mov:mvs), strs) -possibleStates :: PrivateView -> [State]+-- | 'EndGameMirrorLite' assumes that other players think in the same way as itself during endgame.+data EndGameMirrorLite p = EGML (EndGameLite p [EndGameMirrorLite p])+egml :: (PublicInfo -> Bool) -- ^ from when to start the endgame search+ -> p -- ^ the default strategy used until endgame+ -> Int -- ^ number of players, including the resulting player+ -> EndGameMirrorLite p+egml from p nump = egms where egms = EGML (egl from p $ replicate (pred nump) egms)++instance (Monad m, Strategy p m) => Strategy (EndGameMirrorLite p) m where+ strategyName ms = return "EndGameMirrorLite"+ move pvs mvs (EGML egs) = do (m, egs') <- move pvs mvs egs+ return (m, EGML egs')++egl f p ps = EGL f p ps M.empty++-- | @'EGL' f p ps memory@ usually behaves based on @p@, but it conducts the exhaustive search assuming that others behave based on @ps@ when the deck size is @f@ or below @f@.+data EndGameLite p ps = EGL {fromWhenL::PublicInfo->Bool, myUsualStrategyL::p, otherPlayersL::ps, memory :: M.Map Key ([Move],[([State],ps,Int)])}+type Key = (Maybe Card, [Marks], [Move], [Card])++instance (Monad m, Strategy p m, Strategies ps m) => Strategy (EndGameLite p ps) m where+ strategyName ms = return "EndGameLite"+ move pvs mvs str@(EGL f p ps memory)+ | f pub = do let statess = case M.lookup (resToMbC $ result $ publicView $ pvs !! pred numP, map marks $ head $ annotations pub, take (pred numP) mvs, map headC $ handsPV hdpv) memory of+ Just (_,tups) -> tups+ Nothing -> [ (stateToStateHistory (map publicView tlpvs) mvs state, ps, n) | (state, n) <- possibleStates hdpv ]+ (_i, (mp,m)) <- endGameMoveLite statess pvs' mvs p+ return (m, EGL f p ps mp)+ | otherwise = do (m,_) <- move pvs mvs p+ return (m,str)+ where pvs'@(hdpv:tlpvs) = [ pv{publicView=pub{gameSpec=gs{rule=r{earlyQuit=True}}}} | pv@PV{publicView=pub@PI{gameSpec=gs@GS{rule=r}}}<- pvs ]+ pub = publicView hdpv+ numP = numPlayers $ gameSpec pub+endGameMoveLite :: (Monad m, Strategies ps m, Strategy p m) =>+ [([State],ps,Int)] -- ^ possible pairs of the state history and the internal memory states of other players' strategies+ -> [PrivateView] -- ^ view history+ -> [Move] -- ^ move history+ -> p -- ^ default (recommended) strategy+ -> m (Int, (M.Map Key ([Move], [([State],ps,Int)]), Move))+endGameMoveLite statess pvs@(pv:_) mvs p = do+ (defaultMove, _) <- move pvs mvs p+ let candidateMoves = defaultMove : delete defaultMove (validMoves pv)+ tups <- mapM (evalMoveLite statess mvs p) candidateMoves+ let asc = zipWith (\(mp, score) mv -> (score, (mp,mv))) tups candidateMoves+ pub = publicView pv+ achievable = sum [ n | (_,_,n) <- statess ] * moreStrictlyAchievableScore pub+ -- ToDo: Also consider critical cards at the bottom deck.+ return $ case lookup achievable asc of Nothing -> maximumBy (compare `on` fst) $ reverse asc+ Just k -> (achievable, k) -- Stop search when the best possible score is found.++evalMoveLite :: (Monad m, Strategies ps m, Strategy p m) => [([State], ps, Int)] -> [Move] -> p -> Move -> m ( M.Map Key ([Move], [([State],ps,Int)]) , Int )+evalMoveLite statess@((st:_,_,_):_) mvs p mov = do+ roundResults <- mapM (\sts ->tryAMoveARound sts mvs mov) statess+ let pub = publicState st+ instantScore = sum [ egToInt pub eg * n | ((Just eg, _, _), _, n) <- roundResults ]+ roundResultMap = groupARound pub roundResults+ if M.null roundResultMap then return (roundResultMap, instantScore) else do+ let roundResults = M.elems roundResultMap+ scores <- sequence [ fmap fst $ endGameMoveLite stss (viewStates sts) moves p | (moves, stss@((sts,_,_):_)) <- roundResults ]+ return (roundResultMap, instantScore + sum scores)++groupARound :: PublicInfo -> [((Maybe EndGame, [State], [Move]),ps,Int)] -> M.Map Key ([Move], [([State],ps,Int)]) -- ToDo: IntMap could be used instead.+groupARound pub results = fmap procTip $ M.fromListWith (++) [ ( ( resToMbC $ result $ publicState $ stats !! pred numP,+ map marks $ head $ annotations $ publicState st,+ take (pred numP) movs,+ map headC $ tail $ hands st ),+ [r])+ | r@((Nothing, stats@(st:_), movs), _, _) <- results ] where+ procTip :: [((Maybe EndGame, [State],[Move]),ps,Int)] -> ([Move], [([State],ps,Int)])+ procTip ts@(((_noth, _, mv), _, _) : _) = (mv, [ (stats, ps, n) | ((_nothing, stats, _), ps, n) <- ts ])+ numP = numPlayers $ gameSpec pub+-- total version of head, just in case of dealing with empty hand.+headC :: [Card] -> Card+headC = foldr const $ C Multicolor Empty+++resToMbC :: Result -> Maybe Card+resToMbC None = Nothing+resToMbC r = Just $ revealed r+tryAMoveARound :: (Monad m, Strategies ps m) => ([State],ps,Int) -> [Move] -> Move -> m ((Maybe EndGame, [State], [Move]),ps,Int)+tryAMoveARound (states@(st:_),strs,n) mvs mov = case proceed st mov of+ Nothing -> fail $ show mov ++ ": invalid move!"+ Just st -> let nxt = rotate 1 st+ in case checkEndGame $ publicState nxt of Nothing -> fmap (\(e,p) -> (e,p,n)) $ runARound (\_ _ -> return ()) (nxt:states) (mov:mvs) strs+ Just eg -> return ((Just eg, nxt:states, mov:mvs), strs, n)++possibleStates :: PrivateView -> [(State, Int)] possibleStates pv@PV{publicView=pub@PI{gameSpec=gs}}- = [ St{ publicState = pub+ = [(St{ publicState = pub , pile = zipWith (\c i -> (c, initAnn gs i)) deck [ (numberOfCards (rule $ gameSpec pub) - pileNum pub) ..] , hands = hand : handsPV pv }- | (hand, deck) <- possiblePermutations pv ]+ , n)+ | ((hand, deck), n) <- uniqSort $ possiblePermutations pv ]+uniqSort :: (Eq a, Ord a) => [a] -> [(a,Int)]+uniqSort xs = map (\ys -> (head ys, length ys)) $ group $ sort xs possiblePermutations :: PrivateView -> [([Card],[Card])] possiblePermutations pv@PV{publicView=PI{annotations=anns:_}} = possiblePerms anns (invisibleCards pv) invisibleCards :: PrivateView -> [Card]@@ -575,7 +672,7 @@ 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) "):"+ ++ "played (" ++ shows (currentScore pub) " / " ++ shows (seeminglyAchievableScore pub) "):" ++ concat [ " " ++ concat ( [ show $ C c k | k <- [K1 .. achievedRank pub c] ] ++ replicate (possible - fromEnum playedMax) "__" ++ replicate (5 - possible) "XX") | c <- colors pub , let playedMax = achievedRank pub c@@ -733,11 +830,14 @@ return (tups, (p':ps')) _ -> return (tup, (p':ps)) broadcast _ _ [] _ = error "It takes at least one algorithm to play Hanabi!"- broadcast states moves [p] ofs = when (ofs/=0) (observe (map view states) moves p) >> return (map (rotate 1) states, pred ofs)- broadcast states moves (p:ps) ofs = when (ofs/=0) (observe (map view states) moves p) >> broadcast (map (rotate 1) states) moves ps (pred ofs)+ broadcast states moves [p] ofs = when (ofs/=0) (observe (viewStates states) moves p) >> return (map (rotate 1) states, pred ofs)+ broadcast states moves (p:ps) ofs = when (ofs/=0) (observe (viewStates states) moves p) >> broadcast (map (rotate 1) states) moves ps (pred ofs) +viewStates :: [State] -> [PrivateView]+viewStates = map view . zipWith rotate [0..]+ runATurn :: (Strategy p m, Monad m) => [State] -> [Move] -> p -> m ((Maybe EndGame, [State], [Move]), p)-runATurn states moves p = let alg = move (map view $ zipWith rotate [0..] states) moves p in+runATurn states moves p = let alg = move (viewStates states) moves p in do (mov, p') <- alg case proceed (head states) mov of Nothing -> do name <- strategyName (fmap snd alg)@@ -960,7 +1060,7 @@ checkEndGame pub | lives pub == 0 = Just Failure | all (==K5) [ achievedRank pub k | k <- colors pub ] = Just Perfect | deadline pub == Just 0 ||- (earlyQuit (rule $ gameSpec pub) && currentScore pub == achievableScore pub)+ (earlyQuit (rule $ gameSpec pub) && currentScore pub == seeminglyAchievableScore pub) = Just $ Soso $ IM.foldr (+) 0 $ fmap fromEnum $ played pub | hintTokens pub == 0 && null (head $ annotations pub) = Just Failure -- No valid play is possible for the next player. This can happen when prolong==True. | otherwise = Nothing
Game/Hanabi/Backend.lhs view
@@ -127,13 +127,11 @@ #ifdef TFRANDOM mkParams :: Options -> IO (Params TFGen)-mkParams options = do- g <- newTFGen #else mkParams :: Options -> IO (Params StdGen)-mkParams options = do- g <- newStdGen #endif+mkParams options = do+ g <- newGen mv <- newMVar (IntMap.empty::GameData) return Params{gen = g, mvTIDToMVH = mv, versionString = version options, gsConstructorMap = Map.fromList $ strategies options, conn = error "Game.Hanabi.Backend.server: should not happen"} @@ -146,11 +144,7 @@ -- In this case, every time this program is run, the gen is refreshed, but the same gen (and thus the same card deck) is always used. let p = params{conn = c} #else-# ifdef TFRANDOM- g <- newTFGen-# else- g <- newStdGen-# endif+ g <- newGen let p = params{gen = g, conn = c} #endif withPingThread c 25 (return ()) $ fmap (const ()) $ answerHIO p@@ -247,11 +241,10 @@ sender "starting the game\n" let playerList | observe = ixSs |otherwise= 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+ (playOrder,g) = orderPlayers from (gen params) playerList (shuffled, _) = createDeck rule g- eithFinalSituation <- try $ if observe then startFromCards (GS numAllies rule) [watch (conn params) mbVerb] playOrder shuffled+ eithFinalSituation <- try $ if observe then sender ("The initial deck is " ++ show shuffled) >>+ startFromCards (GS numAllies rule) [watch (conn params) mbVerb] playOrder shuffled else startFromCards (GS (succ numAllies) rule) [] playOrder shuffled finalSituation <- case eithFinalSituation of Left e -> do hPutStrLn stderr $ displayException (e::SomeException)
Game/Hanabi/Client.hs view
@@ -12,11 +12,11 @@ import Data.Aeson hiding (Success) import GHC.Generics hiding (K1, from) import Data.Bool-import Data.Char(isSpace)+import Data.Char(isSpace, isLower) import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Maybe(fromJust, isNothing)-import Data.List(intersperse)+import Data.List(intersperse, transpose) import Miso hiding (Fail) import Miso.String (MisoString)@@ -28,9 +28,6 @@ import Control.Monad.IO.Class(liftIO) import System.Random-#ifdef TFRANDOM-import System.Random.TF-#endif import Control.Concurrent @@ -160,14 +157,8 @@ updateModel opt ObserveLocally model = model <# liftIO (do let constructor algIx = fromJust $ lookup algIx $ strategies opt playerList <- mapM (constructor . S.unpack) $ reverse $ players model-#ifdef TFRANDOM- gen <- newTFGen-#else- gen <- newStdGen-#endif- let (playOrder,g) = case from model of Just n -> (dr++tk, gen)- where (tk,dr) = splitAt n playerList- Nothing -> shuffle playerList gen+ gen <- newGen+ let (playOrder,g) = orderPlayers (from model) gen playerList (shuffled, _) = createDeck (rule model) g (fs,_) <- startFromCards (GS (length playerList) (rule model)) [] playOrder shuffled return $ WriteLocalResult shuffled fs@@ -178,14 +169,8 @@ let constructor algIx = fromJust $ lookup algIx $ strategies opt playerList <- mapM (constructor . S.unpack) $ reverse $ players model let thePlayerList = mkDS "local strategy" (localStrategy model) : playerList-#ifdef TFRANDOM- gen <- newTFGen-#else- gen <- newStdGen-#endif- let (playOrder,g) = case from model of Just n -> (dr++tk, gen)- where (tk,dr) = splitAt n thePlayerList- Nothing -> shuffle thePlayerList gen+ gen <- newGen+ let (playOrder,g) = orderPlayers (from model) gen thePlayerList (shuffled, _) = createDeck (rule model) g forkIO $ do (fs,_) <- startFromCards (GS (length thePlayerList) (rule model)) [] playOrder shuffled putMVar (mvMsg $ localStrategy model) $ PrettyEndGame shuffled $ Just fs@@ -340,12 +325,12 @@ caption_ [] [text $ S.pack "Available games", button_ [onClick $ SendMessage $ Message "available"] [text $ S.pack "refresh"]] : tr_ [] [ th_ [solid] [text $ S.pack str] | str <- ["Game ID", "available", "total"] ] : map renderAvailable games,- div_ [] $ renderCreateGame strategies mdl,+ div_ [] $ renderCreateGame True strategies mdl, hr_ [] ]-renderMsg strategies _ mdl CreateGame = div_ [] $ renderCreateGame strategies mdl-renderCreateGame :: [MisoString] -> Model -> [View Action]-renderCreateGame strategies mdl+renderMsg strategies _ mdl CreateGame = div_ [] $ renderCreateGame False strategies mdl+renderCreateGame :: Bool -> [MisoString] -> Model -> [View Action]+renderCreateGame online strategies mdl = [ table_ [solid] $ caption_ [textProp "text-align" "left", textProp "margin-left" "auto"] [ -- Seemingly these styles do not work. text "Players",@@ -395,7 +380,7 @@ ] else [], datalist_ [id_ "numMulticolors"] [option_ [value_ "[1, 1, 1, 1, 1]"] [text "[1, 1, 1, 1, 1]"], option_ [value_ "[3, 2, 2, 2, 1]"] [text "[3, 2, 2, 2, 1]"]], button_ [onClick $- if all (not . isWS . S.unpack) (players mdl)+ if not online && all (not . isWS . S.unpack) (players mdl) then if play mdl then PlayLocally else ObserveLocally else SendMessage $ Message $ S.pack $ (case from mdl of Just n | play mdl -> "from " ++ shows n " " | otherwise -> "observe " ++ shows n " "@@ -455,9 +440,14 @@ hr_ [], renderSt verb ithPlayerFromTheLast st, hr_ [],- text $ S.pack $ "By the way, the initial deck was " ++ shows initDeck ".\n",+ text $ S.pack $ "By the way, the initial deck was " ++ shows initDeck "\n and the move histories are" ++ tail (foldr showsMoves "." histories), hr_ [] ]+ where histories = transpose $ chopEvery (numPlayers $ gameSpec $ publicState st) $ reverse mvs+ showsMoves :: [Move] -> ShowS+ showsMoves mvs rest = ", " ++ filter (\c -> not (isLower c || c == 'H')) (foldr shows rest mvs)+chopEvery n xs = case splitAt n xs of ([], _) -> []+ (tk,dr) -> tk : chopEvery n dr renderTrial :: Verbosity -> PublicInfo -> (Int -> String) -> Int -> PrivateView -> Move -> View Action renderTrial verb pub ithP i v m = div_ [] [@@ -518,7 +508,7 @@ ] ] where current = currentScore pub- achievable = achievableScore pub+ achievable = seeminglyAchievableScore pub -- renderCardsInline is a compact version of renderCardInline that prints the color letter only once. renderCardsInline :: Verbosity -> PublicInfo -> Color -> [Number] -> View Action
Game/Hanabi/Msg.hs view
@@ -3,6 +3,11 @@ import Game.Hanabi import GHC.Generics +import System.Random+#ifdef TFRANDOM+import System.Random.TF+#endif+ #ifdef AESON import Data.Aeson @@ -69,3 +74,15 @@ isWS :: String -> Bool isWS = (`elem` ["0", "WS", "via WebSocket"])++# ifdef TFRANDOM+newGen :: IO TFGen+newGen = newTFGen+# else+newGen :: IO StdGen+newGen = newStdGen+# endif++orderPlayers :: (RandomGen g) => Maybe Int -> g -> [p] -> ([p], g)+orderPlayers (Just n) gen players = (dr++tk, gen) where (tk,dr) = splitAt n players+orderPlayers Nothing gen players = shuffle players gen
Game/Hanabi/Strategies/EndGameSearch.hs view
@@ -10,12 +10,17 @@ instance (Monad m) => Strategy EndGameSearch m where strategyName ms = return "EndGame"- move pvs@(pv:_) mvs EG = do (m, _) <- -- move (sontakuColorHint pvs mvs) mvs $ searchExhaustively SL+ move pvs@(pv:_) mvs EG = do (m, _) <- -- move (sontakuColorHint pvs mvs) mvs $ assumeOthersAreSLLite SL+ -- move (sontakuColorHint pvs mvs) mvs $ searchExhaustivelyLite SL+ move (sontakuColorHint pvs mvs) mvs $ searchExhaustivelyLite $ assumeOthersAreSLLite SL+ -- move (sontakuColorHint pvs mvs) mvs $ searchExhaustively SL -- move (sontakuColorHint pvs mvs) mvs $ assumeOthersAreSL SL- move (sontakuColorHint pvs mvs) mvs $ searchExhaustively $ assumeOthersAreSL SL+ -- move (sontakuColorHint pvs mvs) mvs $ searchExhaustively $ assumeOthersAreSL SL return (m, EG)- where searchExhaustively fallback = egms (\pub -> pileNum pub == 0) fallback (numPlayers $ gameSpec $ publicView pv)- assumeOthersAreSL fallback = EGS (\pub -> pileNum pub <= 1 && hintTokens pub <= 4) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL+ where searchExhaustivelyLite fallback = egml (\pub -> pileNum pub == 0) fallback (numPlayers $ gameSpec $ publicView pv)+ assumeOthersAreSLLite fallback = egl (\pub -> pileNum pub <= 1) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL+ searchExhaustively fallback = egms (\pub -> pileNum pub == 0) fallback (numPlayers $ gameSpec $ publicView pv)+ assumeOthersAreSL fallback = EGS (\pub -> pileNum pub <= 1 && hintTokens pub <= 2) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL -- assumeOthersAreSL fallback = EGS (\pub -> pileNum pub <=2 && hintTokens pub <= 4) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL -- assumeOthersAreSL fallback = EGS (\pub -> pileNum pub + hintTokens pub < 4) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL main = do g <- newStdGen
Game/Hanabi/Strategies/SimpleStrategy.hs view
@@ -25,10 +25,17 @@ markCandidates = filter (\(_,card,ann) -> isPlayable pub card && not (isObviouslyPlayable pub $ possibilities ann)) $ 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, ann) <- reverse nextPlayer, not (isHinted $ marks ann), isCritical pub te ] keep2 = take 1 [ Hint 1 $ Right $ K2 | (_ix, te@(C _ K2), ann) <- reverse nextPlayer, not (isHinted $ marks ann), not $ isUseless pub te ]+ unhintedNon2 = [ t | t@(_, C c n, ann) <- nextPlayer, n/=K2, not $ isHinted $ marks ann ] colorMarkUnmarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{marks=(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,Ann{marks=(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,Ann{marks=(_, Nothing)}) <- markCandidates ] -- Mark the number if a (not obviously) playable card is not number-marked.+ isNewestOfColor i d, -- but be cautious not to color-mark newer cards.+ not $ havePlayableCardWithTheSameColor $ color d ] -- refrain marking if I have a playable card with the same color+ colorMarkNumberMarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (_,d,Ann{marks=(Nothing, Just _)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is only number-marked.+ not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color+ ]+ numberMarkPlayable = take 1 [ Hint 1 $ Right $ number d | (_,d,Ann{marks=(_, Nothing)}) <- markCandidates, -- Mark the number if a (not obviously) playable card is not number-marked.+ not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color+ ]+ havePlayableCardWithTheSameColor c = or [ isDefinitelyPlayable pv ann | (_,ann@Ann{marks=(Just d,_)}) <- myHand, c==d ] numberMarkUselessIfInformative = take 1 [ Hint 1 $ Right $ number d | (_,d,Ann{possibilities=p@(pc, _)}) <- nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (pc, bit $ numberToBitPos (number d)) ] colorMarkUselessIfInformative = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{possibilities=p@(_, pn)}) <- reverse nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (bit $ colorToBitPos (color d), pn), isNewestOfColor i d ] -- but be cautious not to color-mark newer cards.@@ -57,13 +64,13 @@ dropChopUnlessDoubleDrop = [ Drop i | is@(i:_) <- take 1 $ map reverse $ definiteChopss pv myAnns, not $ isDoubleDrop pv (result pub) is $ myAnns !! i ] dropChop = [ Drop i | i:_ <- take 1 $ definiteChopss pv myAnns ] current = currentScore pub- achievable = achievableScore pub+ achievable = seeminglyAchievableScore 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.+ ++ (if hintTokens pub >= 4 then colorMarkNumberMarkedPlayable ++ numberMarkPlayable ++ if length unhintedNon2 >= 2 then keep2 else [] 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,ann) <- myHand, isDefinitelyPlayable pv ann ] -- Play a playable card@@ -73,9 +80,9 @@ ++ colorMarkUselessIfInformative ++ numberMarkUselessIfInformative ++ colorMarkColorUnmarked ++ numberMarkNumberUnmarked- ++ dropSafe -- drop the oldest 'safe to drop' card ++ numberMarkUnmarked ++ [Hint 1 $ Right n | n <- [K1 .. K5]]+ ++ dropSafe -- drop the oldest 'safe to drop' card ++ dropChop -- ++ dropPossiblyUncritical -- This may not be a good idea. See Haddock comment on Hanabi.isDefinitelyCritical. ++ reverse [ Drop i | (i,_) <- sortOn (\(_,Ann{marks=(_,mb)}) -> fmap fromEnum mb) myHand ]
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.9.0.0+version: 0.9.1.0 -- A short (one-line) description of the package. synopsis: Hanabi card game