diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Game/Hanabi.hs b/Game/Hanabi.hs --- a/Game/Hanabi.hs +++ b/Game/Hanabi.hs @@ -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 diff --git a/Game/Hanabi/Backend.lhs b/Game/Hanabi/Backend.lhs --- a/Game/Hanabi/Backend.lhs +++ b/Game/Hanabi/Backend.lhs @@ -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) diff --git a/Game/Hanabi/Client.hs b/Game/Hanabi/Client.hs --- a/Game/Hanabi/Client.hs +++ b/Game/Hanabi/Client.hs @@ -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 diff --git a/Game/Hanabi/Msg.hs b/Game/Hanabi/Msg.hs --- a/Game/Hanabi/Msg.hs +++ b/Game/Hanabi/Msg.hs @@ -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 diff --git a/Game/Hanabi/Strategies/EndGameSearch.hs b/Game/Hanabi/Strategies/EndGameSearch.hs --- a/Game/Hanabi/Strategies/EndGameSearch.hs +++ b/Game/Hanabi/Strategies/EndGameSearch.hs @@ -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 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 @@ -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 ] 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.9.0.0 +version: 0.9.1.0 -- A short (one-line) description of the package. synopsis: Hanabi card game