Stateless.hs

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module Game.Hanabi.Strategies.Stateless 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

-- A stateless implementation of Stateful
data Stateless = SL Simple

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

sontakuColorHint :: [PrivateView] -> [Move] -> [PrivateView]
sontakuColorHint pvs@(pv:_) mvs = let
                           consistentGuess = [ case lookupOn ixDeck realAnn hintedAnns of
                                                 guessedAnn:_ -> guessedAnn
                                                 _            -> realAnn
                                             | realAnn <- myAnns ]
                           hintedAnns = [ ann{possibilities = narrowedPos}
                                        | Ann{ixDeck=ix, marks=(Just c, Nothing), possibilities=currentPos} <- myAnns
                                        , (p,pvInQ,c) <- take 1 [ (p,pvq,c) | (p, pvq, Hint q (Left d)) <- zip3 [1..] pvs mvs,
                                                                  c==d  &&  p `mod` numPlayers (gameSpec pub) == q ]
                                        , let pubInQ = publicView pvInQ
                                              myAnnsInQ = head $ annotations pubInQ
                                        , not $ or [ isObviouslyPlayable pubInQ m | Ann{marks=(Just i, _),possibilities=m} <- myAnnsInQ, c==i ] -- Exclude if there is a playable card with the color.

                                        , ann <- take 1 [ ann | ann@Ann{marks=(Just i,_)} <- myAnnsInQ, c==i ]
                                        , let narrowedPos = currentPos .&. rankToQit (succ $ achievedRank pubInQ c) -- This is undefined when achievedRank pub c == K5, but then isDefinitelyUnplayable pv ann should be True.
                                        , ixDeck ann == ix

                                        , not $ isDefinitelyUnplayable pvInQ ann
                                        , narrowedPos /= 0 ]
                           pub = publicView pv
                           myAnns = head $ annotations pub
                       in pv{publicView=pub{annotations=consistentGuess : tail (annotations pub)}} : tail pvs

instance Monad m => Strategy Stateless m where
  strategyName ms = return "Stateless"
  move pvs@(pv:_) mvs (SL s) = move (sontakuColorHint pvs mvs) mvs s >>= \(mov, s') -> return (mov, SL s')

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