StatefulStrategy.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module Game.Hanabi.Strategies.StatefulStrategy where
import Game.Hanabi hiding (main)
import Game.Hanabi.Strategies.SimpleStrategy
import System.Random
import Data.Maybe(isNothing)
import Data.List(sortOn)
import Data.Bits(bit, (.&.))
import qualified Data.IntMap as IM

-- An example of a strategy with state.
newtype Stateful = SF [Annotation]

lookupOn :: Eq b => (a -> b) -> a -> [a] -> [a]
lookupOn fun key xs = [ result | result <- xs, fun key == fun result ]

instance Monad m => Strategy Stateful m where
  strategyName ms = return "Stateful strategy"
  move (pv:pvs) mvs (SF lastGuess) = let
                           consistentGuess = [ case lookupOn ixDeck realAnn $ hintedAnns ++ lastGuess of
                                                 guessedAnn:_ | narrowedPos /= 0 -> realAnn{possibilities = (fst realPos, narrowedPos)}
                                                              where narrowedPos = snd realPos .&. snd (possibilities guessedAnn)
                                                                    realPos = possibilities realAnn
                                                 _            -> realAnn
                                             | realAnn <- myAnns ]

                           hintedColors = [ c | (p, Hint q (Left c)) <- zip [1..] $ take (numPlayers $ gameSpec pub) mvs,
                                                p==q,
                                                not $ or [ isObviouslyPlayable pub m | Ann{marks=(Just i, _),possibilities=m} <- myAnns, c==i ] -- Exclude if there is a playable card with the color.
                                              ]
                           hintedAnns = [ ann{possibilities = (fst $ possibilities ann, newNumberPos)}
                                                | c <- hintedColors,
                                                  let i   = length $ takeWhile ((/=Just c) . fst . marks) myAnns
                                                      ann = myAnns !! i
                                                      newNumberPos = bit $ rankToBitPos (succ $ achievedRank pub c), -- This is undefined when achievedRank pub c == K5, but then isDefinitelyUnplayable pv ann should be True.
                                                  not $ isDefinitelyUnplayable pv ann,
                                                  newNumberPos .&. snd (possibilities ann) /= 0 ]
                           pub = publicView pv
                           myAnns = head $ annotations pub
                       in move (pv{publicView=pub{annotations=consistentGuess : tail (annotations pub)}} : pvs) mvs S >>= \(mov,S) -> return (mov, SF consistentGuess)

main = do g <- newStdGen
          ((eg,_),_) <- start defaultGS [] ([SF[]],[stdio]) g -- Play it with standard I/O (human player).
--          ((eg,_),_) <- start defaultGS [peek] [SF[],SF[]] g -- Play it with itself.
          putStrLn $ prettyEndGame eg