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, tails)
import Data.Bits(bit, (.&.), complement)
import qualified Data.IntMap as IM

-- An example of a strategy with state.
data Stateful s = SF {guessColorToPlay::Bool, guessPositionalDrop::Bool, baseStrategy::s, anns::[Annotation]}
sfs smpl = SF True True smpl []

lookupOn :: Eq b => (a -> b) -> a -> [a] -> [a]
lookupOn fun key xs = [ result | result <- xs, fun key == fun result ]
instance (Monad m, Strategy s m) => Strategy (Stateful s) m where
  strategyName ms = ms >>= \sf -> strategyName (return $ baseStrategy sf) >>= \name -> return ("Stateful strategy of "++name)
  move pvs@(pv:tlpvs) mvs (SF ctp pd s lastGuess) = let
                         numP = numPlayers $ gameSpec pub
                         pub  = publicView pv
                         lG | turn pub < numP = []
                            | otherwise       = lastGuess
                         consistentGuesses = [ [ case lookupOn ixDeck realAnn $ (if ctp then colorToPlay numP pvs mvs else []) ++ (if pd then positionalDrop numP pvs mvs else []) ++ lG of
                                                 Ann{possibilities=guessedPos}:_ | not $ isObviouslyInconsistent pub newPos -> newAnn
                                                              where newAnn = realAnn{possibilities = newPos}
                                                                    newPos = realPos .&. guessedPos
                                                 _            -> realAnn
                                               | realAnn@Ann{possibilities=realPos} <- anns ]
                                             | anns <- annotations pub ]
                       in move (pv{publicView=pub{annotations=consistentGuesses}} : tlpvs) mvs s >>= \(mov, s') -> return (mov, SF ctp pd s' $ concat consistentGuesses)

colorToPlay numP pvs mvs = [ focusedAnn{possibilities = rankToQit (succ $ achievedRank pub hintedColor)} -- This is undefined when achievedRank pub c == K5, but then isDefinitelyUnplayable pv ann should be True.
                            | (p, pv, Hint q (Left hintedColor)) <- zip3 [1..] pvs $ take numP mvs,
                              let pub   = publicView pv,
                              let ix    = (q-p) `mod` numP
                                  anns  = annotations pub !! ix
                                  cards = (repeat undefined:handsPV pv) !! ix,
                              let hintedTups@((focusedAnn,focusedCard):_) = [ tup | tup@(Ann{marks=(Just i, _)}, _) <- zip anns cards, hintedColor==i ],
                              not $ any (isObviouslyPlayable pub . possibilities . fst) hintedTups, -- Exclude if there is a playable card with the color.
                              if p==q then not $ isDefinitelyUnplayable pv focusedAnn else isPlayable pub focusedCard                    -- Exclude if the focused card is definitely unplayable.
                                       ]

positionalDrop numP pvs mvs = concat $ zipWith3 (positionalDrop' numP) [0,-1..1-numP] (tails pvs) mvs
positionalDrop' numP rot (pv:lastpv:_) mv = case mv of
                           Drop i | i `notElem` unusualChops || length anns <= i -> []     -- It is not a positional drop if nothing is unusual or the corresponding card does not exist.
                                  | if rot==0 then not (isDefinitelyUnplayable pv focused)
                                              else isPlayable pub (hand !! i)              -> [focused{possibilities=nextToPlay pub}]
                                  | otherwise -> [focused{possibilities = complement $ critical pub}] -- Suggest dropping the card by telling that it is not critical when almost everything is marked.
                                                       where pub = publicView pv
                                                             lastpub = publicView lastpv
                                                             unusualChops = drop 1 $ concat $ map reverse $ obviousChopss lastpub lastAnns
                                                             lastAnns  = annotations lastpub !! (pred rot `mod` numP)
                                                             anns      = annotations pub !! player
                                                             hand      = handsPV pv !! pred player
                                                             player = rot `mod` numP
                                                             focused   = anns!!i
                           _ -> []




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