hanabi-dealer-0.15.1.1: Game/Hanabi/Strategies/SimpleStrategy.hs
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module Game.Hanabi.Strategies.SimpleStrategy where
import Game.Hanabi hiding (main)
import System.Random
import Data.Maybe(isNothing)
import Data.List(sortOn, tails)
import Data.Bits(bit, (.&.))
-- Was an example of a simple and stupid strategy.
data Simple = S {aggressivePositionalDrop :: Bool}
instance Monad m => Strategy Simple m where
strategyName ms = return "Stupid example strategy"
move (pv:pvs) mvs s = let
pub = publicView pv
nextPlayersHand = head $ handsPV pv ::[Card]
nextPlayersAnns = annotations pub !! 1
nextPlayer = zip3 [0..] nextPlayersHand nextPlayersAnns
myAnns = head $ annotations pub
myHand = zip [0..] myAnns
numHand = length myAnns
colorHint pl = Hint pl . Left . color
rankHint pl = Hint pl . Right . rank
isMarked = isHinted . marks
isUnmarked = not . isMarked
nextPlayersUnmarked = filter (isUnmarked . getAnn) nextPlayer
getAnn (_,_,ann) = ann
nitchimo anns = length (filter (\ann -> isMarked ann && not (isObviouslyUncritical pub (possibilities ann) || isObviouslyPlayable pub (possibilities ann))) anns)
isColorMarkable col = isPlayable pub (head [ c | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == col ])
|| any (isPlayable pub) [ c | (j,c,Ann{marks=(Nothing,Just _)}) <- nextPlayer, color c == col ]
isNewestOfColor i d = null [ () | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == color d, j < i ] -- True if there is no newer rank-unmarked card of the same color in nextPlayer.
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 = mr [ if isColorMarkable (color te) then colorHint 1 te else rankHint 1 te | (_ix, te, _) <- reverse nextPlayersUnmarked, isCritical pub te ]
-- keep2 = mr [ Hint 1 $ Right K2 | (_ix, te@(C c K2), ann) <- reverse nextPlayer, not (isHinted $ marks ann), not $ isUseless pub te, not $ isPlayable pub te && havePlayableCardWithTheSameColor c ]
keep21 = mr [ rankHint 1 te | (_ix, te@(C c k), _) <- reverse nextPlayersUnmarked, k <= K2, keptCards pub te <= 2, not $ isUseless pub te, not $ isPlayable pub te && havePlayableCardWithTheSameColor c ]
unhintedNon2 = [ t | t@(_, c@(C _ n), _) <- nextPlayersUnmarked, n/=K2 || isUseless pub c ]
colorMarkUnmarkedPlayable = mr [ colorHint 1 d | (i,d,ann) <- markCandidates, -- Mark the color ff a (not obviously) playable card
isUnmarked ann, -- if it is not marked yet
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 = mr [ colorHint 1 d | (_,d,Ann{marks=(Nothing, Just _)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is only rank-marked.
not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color
]
colorMarkPlayable5 = mr [ colorHint 1 d | (_,d,Ann{marks=(Nothing, Just K5)}) <- markCandidates ]
removeDuplicate = mr [ Drop i | (i,Ann{marks=m}):xs <- tails [ anned | anned@(_,Ann{marks=(Just _, Just _)}) <- reverse myHand ],
m `elem` [ m' | (_, Ann{marks=m'}) <- xs ]
]
numberMarkPlayable = mr [ rankHint 1 d | (_,d,Ann{marks=(_, Nothing)}) <- markCandidates, -- Mark the rank if a (not obviously) playable card is not rank-marked.
not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color
]
numberMarkPlayable5 = mr [ Hint 1 $ Right K5 | (_, C _ K5, Ann{marks=(_, Nothing)}) <- markCandidates ]
havePlayableCardWithTheSameColor c = or [ isDefinitelyPlayable pv ann | (_,ann@Ann{marks=(Just d,_)}) <- myHand, c==d ]
numberMarkIfInformative cond = mr [ rankHint 1 d | (_,d,Ann{marks=(Just _,Nothing),possibilities=p}) <- nextPlayer, not $ cond pub p, cond pub (p .&. rankToQit (rank d)) ]
numberMarkUselessIfInformative = numberMarkIfInformative isObviouslyUseless
numberMarkUncriticalIfInformative = numberMarkIfInformative isObviouslyUncritical
colorMarkIfInformative cond = mr [ colorHint 1 d | (i,d,Ann{marks=(Nothing,Just _),possibilities=p}) <- reverse nextPlayer, not $ cond pub p, cond pub (p .&. colorToQit (color d)),
isNewestOfColor i d ] -- but be cautious not to color-mark newer cards.
colorMarkUselessIfInformative = colorMarkIfInformative isObviouslyUseless
colorMarkUncriticalIfInformative = colorMarkIfInformative isObviouslyUncritical
numberMarkUnmarked = mr [ rankHint 1 d | (_,d,_) <- nextPlayersUnmarked, not $ isUseless pub d ]
numberMarkNumberUnmarked = mr [ rankHint 1 d | (_,d,Ann{marks=(Just _, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ]
colorMarkColorUnmarked = mr [ colorHint 1 d | (i,d,Ann{marks=(Nothing, Just _),possibilities=p}) <- reverse nextPlayer, not $ isObviouslyUseless pub p,
isNewestOfColor i d ] -- but be cautious not to color-mark newer cards.
pass = mr $ case span (\(_,_,ann) -> isMarked ann) nextPlayer of (tk,dr) -> [ rankHint 1 d | (_,d,_) <- tk, rank d `notElem` [ rank c | (_,c,_) <- dr ] ]
++ [ colorHint 1 d | (_,d,_) <- tk, color d `notElem` [ color c | (_,c,_) <- dr ] ]
hailMary | lives pub < 2 = id
| otherwise = mr $ case filter (not . isDefinitelyUnplayable pv . snd) myHand of ts -> map (Play . fst) ts
playPlayable = mr $ case span (isObviouslyPlayable pub . possibilities . snd) $ filter (isDefinitelyPlayable pv . snd) myHand of (ob,nob) -> map (Play . fst) $ nob++ob -- Play a playable card. Prioritize those that are not publicly playable.
playPlayable5 = mr [ Play i | (i,ann@Ann{marks=(_,Just K5)}) <- myHand, isDefinitelyPlayable pv ann ]
dropUselessOrDuplicate = dropUselessCard . removeDuplicate
dropUselessCard = mr [ Drop i | (i,ann@Ann{possibilities=p}) <- reverse myHand, isDefinitelyUseless pv ann && isMarked ann || isObviouslyUseless pub p ]
dropSafe = mr [ Drop i | (i,ann) <- reverse myHand, isDefinitelyUncritical pv ann ]
dropPossiblyUncritical = mr [ Drop i | (i,ann) <- reverse myHand, not $ isDefinitelyCritical pv ann ]
sontakuColorMark = mr $ case mvs of -- When the last move is color mark,
Hint 1 (Left c) : _ -- x | isDefinitelyUseless pv (myAnns!!i) -> [Drop i] -- If the first color-marked is obviously useless, drop it.
-- The above pattern is unnecessary, and it can be mistakenly interpreted as positional drop if there are other useless cards.
| isDefinitelyUnplayable pv (myAnns!!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 . marks) myAnns -- (This should also be rewritten using list comprehension.)
_ -> []
sontakuPositionalDrop = mr $ case mvs of
Drop i : _ | i `notElem` unusualChops || length myAnns <= i -> [] -- It is not a positional drop if nothing is unusual or the corresponding card does not exist.
| not $ isDefinitelyUnplayable pv (myAnns!!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 unusualChops = drop 1 $ concat $ map reverse $ obviousChopss lastpub lastAnns
_ -> []
makePositionalDrop = mr $ case mvs of -- This assumes the last teammate marks a critical card if there is.
Hint _ (Right _) : _ -> [] -- refrain if the last move was rank-mark in order to avoid dropping a critical card. This condition can be relaxed.
-- Drop i : _ | not $ isDefinitelyUseless (head pvs) $ lastAnns !! i -> [] -- refrain if the last move was Drop in order to avoid double-drop-like situation. This condition can be relaxed.
mv : _ | discarded (result pub) && not (isDefinitelyUseless pv $ lastAnns !! index mv) -> [] -- refrain if the last move was Drop in order to avoid double-drop-like situation. This condition can be relaxed.
_ : Drop i : _ | i `elem` sndlastUnusualChop -> [] -- avoid consecutive positional drop. This condition can be relaxed.
_ | hints >= 2 && hints <= 6 && turn pub >= 7 && not (null chops)
-> [Drop i | ( (i,card,Ann{possibilities=p}), mann) <- zip nextPlayer myAnns,
isUnmarked mann, not (isDefinitelyCritical pv mann || isDefinitelyPlayable pv mann),
head chops /= i, isPlayable pub card, not $ isObviouslyPlayable pub p]
| otherwise -> []
where chops = concat $ map reverse $ obviousChopss pub myAnns
hints = hintTokens pub
discarded (Discard _) = True
discarded (Fail _) = True
discarded _ = False
dropChopUnlessDoubleDrop = mr $ case mvs of
_ : Drop i : _ | i `elem` sndlastUnusualChop -> [] -- avoid dropping after positional drop. This condition can be relaxed.
_ -> [ Drop i | is@(i:_) <- take 1 $ map reverse $ definiteChopss pv myAnns, not $ isDoubleDrop pv (result pub) is $ myAnns !! i ]
sndlastUnusualChop = drop 1 $ concat $ map reverse $ obviousChopss sndlastpub sndlastAnns
lastpub = publicView (head pvs)
lastAnns = last (annotations lastpub)
sndlastpub = publicView (head $ tail pvs)
sndlastAnns = last $ init (annotations sndlastpub)
dropChop = mr [ Drop i | i:_ <- definiteChopss pv myAnns ]
current = currentScore pub
achievable = seeminglyAchievableScore pub
continue = prolong (Game.Hanabi.rule $ gameSpec pub)
noDeck = not (continue || 0 < pileNum pub)
spareDeck = continue || achievable - current < pileNum pub + 2
enoughDeck = continue || achievable - current < pileNum pub
mr = mkRule pv
Just mov = (\f -> f Nothing) $
-- sontakuPositionalDrop . -- StatefulStrategy does the sontaku more flexibly.
(if noDeck then playPlayable else markUnhintedCritical)
. (if aggressivePositionalDrop s && enoughDeck then makePositionalDrop else id)
. (if hintTokens pub >= 2 || not enoughDeck then colorMarkUnmarkedPlayable else id)
. colorMarkPlayable5 . numberMarkPlayable5
. (if hintTokens pub >= 4 then colorMarkNumberMarkedPlayable . numberMarkPlayable . if length unhintedNon2 >= 2 then keep21 else id else id) -- Do one of these only when there are spare hint tokens.
. (if noDeck then hailMary . markUnhintedCritical else playPlayable5)
. (if enoughDeck then (if nitchimo nextPlayersAnns >= 4 then colorMarkUselessIfInformative . numberMarkUselessIfInformative . colorMarkUncriticalIfInformative . numberMarkUncriticalIfInformative else id) .
dropUselessOrDuplicate else id) -- Drop a useless card unless endgame is approaching.
. playPlayable
. sontakuColorMark -- guess the meaning of the last move, and believe it.
. (if enoughDeck then dropChopUnlessDoubleDrop else id)
. colorMarkUnmarkedPlayable . colorMarkNumberMarkedPlayable . numberMarkPlayable . keep21
. (if spareDeck then dropUselessOrDuplicate . dropChopUnlessDoubleDrop else id)
. colorMarkUselessIfInformative
. numberMarkUselessIfInformative
. (if spareDeck && nitchimo myAnns >= 5 then dropSafe else id)
. colorMarkColorUnmarked
. numberMarkNumberUnmarked
. numberMarkUnmarked
. pass
. dropUselessOrDuplicate .
dropChopUnlessDoubleDrop
. dropSafe -- drop the oldest 'safe to drop' card
. dropChop
. mr ([Hint 1 $ Right n | n <- [K1 .. K5]]
-- ++ dropPossiblyUncritical -- This may not be a good idea. See Haddock comment on Hanabi.isDefinitelyCritical.
++ reverse [ Drop i | (i,_) <- sortOn (\(_,Ann{marks=(_,mb)}) -> mb) myHand ] ++ [Play 0])
in return (mov, s)
main = do g <- newStdGen
((eg,_),_) <- start defaultGS [] ([S False],[stdio]) g -- Play it with standard I/O (human player).
-- ((eg,_),_) <- start defaultGS [peek] [S False, S False] g -- Play it with itself.
putStrLn $ prettyEndGame eg