hanabi-dealer-0.11.0.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)
-- An example of a simple and stupid strategy.
data Simple = S
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
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 num)}) <- 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 = take 1 [ Hint 1 (if isColorMarkable (color te) then Left $ color te else Right $ rank te) | (_ix, te, ann) <- reverse nextPlayer, not (isHinted $ marks ann), isCritical pub te ]
keep2 = take 1 [ 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 ]
unhintedNon2 = [ t | t@(_, c@(C _ n), ann) <- nextPlayer, n/=K2 || isUseless pub c, 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.
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 rank-marked.
not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color
]
removeDuplicate = take 1 [ Drop i | (i,Ann{marks=m}):xs <- tails [ anned | anned@(_,Ann{marks=(Just _, Just _)}) <- myHand ],
m `elem` [ m' | (_, Ann{marks=m'}) <- xs ]
]
numberMarkPlayable = take 1 [ Hint 1 $ Right $ rank 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
]
havePlayableCardWithTheSameColor c = or [ isDefinitelyPlayable pv ann | (_,ann@Ann{marks=(Just d,_)}) <- myHand, c==d ]
numberMarkUselessIfInformative = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{possibilities=p@(pc, _)}) <- nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (pc, bit $ rankToBitPos (rank 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.
numberMarkUnmarked = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(Nothing, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ]
numberMarkNumberUnmarked = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(Just _, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ]
colorMarkColorUnmarked = take 1 [ Hint 1 $ Left $ color 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.
playPlayable5 = take 1 [ Play i | (i,ann@Ann{marks=(_,Just K5)}) <- myHand, isDefinitelyPlayable pv ann ]
dropUselessCard = take 1 [ Drop i | hintTokens pub < 7, (i,ann) <- reverse myHand, isDefinitelyUseless pv ann ]
dropSafe = take 1 [ Drop i | (i,ann) <- reverse myHand, isDefinitelyUncritical pv ann ]
dropPossiblyUncritical = take 1 [ Drop i | (i,ann) <- reverse myHand, not $ isDefinitelyCritical pv ann ]
sontakuColorMark = case mvs of -- When the last move is color mark,
Hint 1 (Left c) : _ | isDefinitelyUseless pv (myAnns!!i) -> [Drop i] -- If the first color-marked is obviously useless, drop it.
| 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) $ head $ annotations $ publicView pv -- (This should also be rewritten using list comprehension.)
_ -> []
sontakuPositionalDrop = 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 lastpub = publicView (head pvs)
lastAnns = last (annotations lastpub)
unusualChops = drop 1 $ concat $ map reverse $ obviousChopss lastpub lastAnns
_ -> []
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 = seeminglyAchievableScore pub
noDeck = pileNum pub == 0 && not (prolong (Game.Hanabi.rule $ gameSpec pub))
enoughDeck = prolong (Game.Hanabi.rule $ gameSpec pub) || achievable - current < pileNum pub
mov = head $ filter (isMoveValid pv) $
sontakuPositionalDrop
++ (if noDeck then playPlayable5 else markUnhintedCritical)
++ (if hintTokens pub >= 2 || not enoughDeck then colorMarkUnmarkedPlayable else [])
++ (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.
++ (if noDeck then markUnhintedCritical else playPlayable5)
++ (if enoughDeck then removeDuplicate ++ dropUselessCard else []) -- Drop a useless card unless endgame is approaching.
++ take 1 [ Play i | (i,ann) <- myHand, isDefinitelyPlayable pv ann ] -- Play a playable card
++ sontakuColorMark -- guess the meaning of the last move, and believe it.
++ dropChopUnlessDoubleDrop
++ colorMarkUnmarkedPlayable ++ colorMarkNumberMarkedPlayable ++ numberMarkPlayable ++ dropUselessCard ++ keep2
++ colorMarkUselessIfInformative
++ numberMarkUselessIfInformative
++ colorMarkColorUnmarked ++ numberMarkNumberUnmarked
++ 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 ]
in return (mov, s)
main = do g <- newStdGen
-- ((eg,_),_) <- start defaultGS [] ([S],[stdio]) g -- Play it with standard I/O (human player).
((eg,_),_) <- start defaultGS [peek] [S,S] g -- Play it with itself.
putStrLn $ prettyEndGame eg