hanabi-dealer-0.15.1.1: Game/Hanabi/Strategies/EndGameLite.hs
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module Game.Hanabi.Strategies.EndGameLite(EndGameLite(..), egl, EndGameMirrorLite(..), egml, tryAMoveARound) where
import Game.Hanabi
import qualified Data.Map as M
import Data.List(maximumBy, delete)
import Data.Function(on)
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
-> sp -- ^ the recommended strategy used at endgame, in order to prioritize endgame search. This strategy is supposed to be lightweight.
-> p -- ^ the default strategy used until endgame
-> Int -- ^ number of players, including the resulting player
-> EndGameMirrorLite sp p
egml from sp p nump = egmo where egmo = EGML (egl from sp p $ replicate (pred nump) egmo)
instance (Monad m, Strategy sp m, Strategy p m) => Strategy (EndGameMirrorLite sp 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 sp p ps = EGL f sp p ps M.empty
-- | @'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,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 && 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 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,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 (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 (effectiveMoves 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 ] * 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, 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 [ 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, 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,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,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.
headC :: [Card] -> Card
headC = foldr const $ C Multicolor Empty
resToMbC :: Result -> Maybe Card
resToMbC None = Nothing
resToMbC r = Just $ revealed r
-- does not work for stateful monads including IO.
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] | 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
return $ case checkEndGame $ publicState nxt of
Nothing -> fmap (\(e,p) -> (e,p,numCases)) $ runARound (\_ _ -> return ()) (nxt:states) (mov:mvs) strs
Just eg -> return ((Just eg, nxt:states, mov:mvs), strs, numCases)
{-
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 -> error $ 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)
-}