diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for hanabi-dealer + ## 0.11.0.2 -- 2021-01-30 + + * EndGameLite falls back when there is a contradiction + This fixes the bug causing non-exhaustive pattern. + ## 0.11.0.1 -- 2021-01-17 * introduce the "suggested strategy" argument to egl and egml for efficiency reasons diff --git a/Game/Hanabi.hs b/Game/Hanabi.hs --- a/Game/Hanabi.hs +++ b/Game/Hanabi.hs @@ -536,6 +536,8 @@ in case checkEndGame $ publicState nxt of Nothing -> runSilently (nxt:states) (mov:mvs) strs Just eg -> return ((eg, nxt:states, mov:mvs), strs) +type Probability = Integer + -- | 'EndGameMirrorLite' assumes that other players think in the same way as itself during endgame. data EndGameMirrorLite sp p = EGML (EndGameLite sp p [EndGameMirrorLite sp p]) egml :: (PublicInfo -> Bool) -- ^ from when to start the endgame search @@ -554,58 +556,60 @@ -- | @'EGL' f sp p ps memory@ usually behaves based on @p@, but it conducts the exhaustive search assuming that others behave based on @ps@ when @f@ returns True. -- The strategy @sp@ suggests a desired move in order to prioritize a promising strategy. -data EndGameLite sp p ps = EGL {fromWhenL::PublicInfo->Bool, suggestedStrategyL::sp, myUsualStrategyL::p, otherPlayersL::ps, memory :: M.Map Key ([Move],[([State],ps,Int)])} +data EndGameLite sp p ps = EGL {fromWhenL::PublicInfo->Bool, suggestedStrategyL::sp, myUsualStrategyL::p, otherPlayersL::ps, memory :: M.Map Key ([Move],[([State],ps,Probability)])} type Key = (Maybe Card, [Marks], [Move], [Card]) instance (Monad m, Strategy sp m, Strategy p m, Strategies ps m) => Strategy (EndGameLite sp p ps) m where strategyName ms = return "EndGameLite" move pvs mvs str@(EGL f sp 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 ] + | f pub && not (null statess) = do -- null statess means that there is a contradiction. This can happen when using a PrivateView based on wrong assumption, such as using sontakuColorHint for preprocessing and actually the team mate is not exactly Stateless. (_i, (mp,m)) <- endGameMoveLite statess pvs' mvs sp return (m, EGL f sp 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 ] + where 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, fromIntegral n) | (state, n) <- possibleStates hdpv ] + 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 + [([State],ps,Probability)] -- ^ 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)) + -> m (Probability, (M.Map Key ([Move], [([State],ps,Probability)]), Move)) endGameMoveLite statess pvs@(pv:_) mvs p = do (defaultMove, q) <- move pvs mvs p let candidateMoves = defaultMove : delete defaultMove (validMoves pv) tups <- mapM (evalMoveLite statess mvs q) candidateMoves let asc = zipWith (\(mp, score) mv -> (score, (mp,mv))) tups candidateMoves pub = publicView pv - achievable = sum [ n | (_,_,n) <- statess ] * moreStrictlyAchievableScore pub + achievable = sum [ n | (_,_,n) <- statess ] * fromIntegral (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 :: (Monad m, Strategies ps m, Strategy p m) => [([State], ps, Probability)] -> [Move] -> p -> Move -> m ( M.Map Key ([Move], [([State],ps,Probability)]) , Probability ) evalMoveLite statess@((st:_,_,_):_) mvs p mov = do roundResults <- fmap concat $ mapM (\sts ->tryAMoveARound sts mvs mov) statess let pub = publicState st - instantScore = sum [ egToInt s eg * n | ((Just eg, s:_, _), _, n) <- roundResults ] + instantScore = sum [ egToNum s eg * n | ((Just eg, s:_, _), _, 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 ] + scores <- sequence [ fmap fst $ endGameMoveLite stss (viewStates sts) moves p | (moves, stss@((sts,_,_):_)) <- roundResults, not $ null stss ] return (roundResultMap, instantScore + sum scores) +evalMoveLite [] _ _ _ = error "evalMoveLite []" -- This should not happen, because evalMoveLite is only called by endGameMoveLite, and @null statess@ is checked before every call of @endGameMoveLite statess@. -groupARound :: PublicInfo -> [((Maybe EndGame, [State], [Move]),ps,Int)] -> M.Map Key ([Move], [([State],ps,Int)]) -- ToDo: IntMap could be used instead. +groupARound :: PublicInfo -> [((Maybe EndGame, [State], [Move]),ps,Probability)] -> M.Map Key ([Move], [([State],ps,Probability)]) -- 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 :: [((Maybe EndGame, [State],[Move]),ps,Probability)] -> ([Move], [([State],ps,Probability)]) 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. @@ -618,10 +622,11 @@ resToMbC r = Just $ revealed r -- does not work for stateful monads including IO. -tryAMoveARound :: (Monad m, Strategies ps m) => ([State],ps,Int) -> [Move] -> Move -> m [((Maybe EndGame, [State], [Move]),ps,Int)] +tryAMoveARound :: (Monad m, Strategies ps m) => ([State],ps,Probability) -> [Move] -> Move -> m [((Maybe EndGame, [State], [Move]),ps,Probability)] tryAMoveARound (states@(state:_),strs,n) mvs mov = let sts = proceeds state mov + pilen = pileNum $ publicState state numCases = case sts of -- [] -> error $ show mov ++ ": invalid move!" -- We should just silently ignore errorful strategy programs - sts@[st] -> n * product [1 .. pileNum (publicState st)] + sts@[st] | pilen>0 -> n * fromIntegral pilen -- The condition pilen>0 is necessary because even when pileNum == 0 there is one valid case. sts -> n in sequence $ do st <- sts let nxt = rotate 1 st @@ -1216,6 +1221,7 @@ egToInt _ Failure = 0 egToInt st _ = currentScore $ publicState st +egToNum st eg = fromIntegral $ egToInt st eg checkEndGame :: PublicInfo -> Maybe EndGame checkEndGame pub | lives pub == 0 = Just Failure 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.11.0.1 +version: 0.11.0.2 -- A short (one-line) description of the package. synopsis: Hanabi card game