diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for hanabi-dealer + ## 0.9.0.0 -- 2020-04-22 + + * add end-game search + + * add Replay strategy for debugging + + * fix a bug preventing reducing the number of colors when using GUI + ## 0.8.0.0 -- 2020-04-11 * assign unique numbers to cards on the deck. diff --git a/Game/Hanabi.hs b/Game/Hanabi.hs --- a/Game/Hanabi.hs +++ b/Game/Hanabi.hs @@ -5,20 +5,20 @@ prettyEndGame, isMoveValid, checkEndGame, help, -- * Datatypes -- ** The Class of Strategies - Strategies, Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose, quiet, + Strategies, Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose, quiet, Replay(..), -- ** Audience Peeker, peek, -- ** The Game Specification - GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid, colors, handSize, setHandSize, + GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid, makeRuleValid, colors, handSize, setHandSize, -- ** The Game State and Interaction History Move(..), Index, State(..), PrivateView(..), PublicInfo(..), Result(..), EndGame(..), - -- ** The Cards - Card(..), Color(..), Number(..), Marks, Possibilities, Annotation(..), cardToInt, intToCard, readsColorChar, readsNumberChar, + -- ** The Cards and Annotations + Card(..), Color(..), Number(..), Marks, Possibilities, Annotation(..), cardToInt, intToCard, readsColorChar, readsNumberChar, colorToBitPos, numberToBitPos, -- * Utilities -- ** Hints isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, currentScore, achievableScore, definitely, obviously, - isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isDefinitelyUncritical, isDefinitelyCritical, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, isObviouslyUnplayable, isDefinitelyUnplayable, obviousChopss, definiteChopss, isDoubleDrop, possibleCards, + isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isDefinitelyUncritical, isDefinitelyCritical, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, isObviouslyUnplayable, isDefinitelyUnplayable, obviousChopss, definiteChopss, isDoubleDrop, possibleCards, endGameMove, EndGameStrategy(..), EndGameMirrorStrategy(..), egms, tryMove, (|||), ifA, -- ** Legacy functions givenHints, possibilities_until_Ver0720, @@ -32,7 +32,8 @@ import Control.Monad.IO.Class(MonadIO, liftIO) import Data.Char(isSpace, isAlpha, isAlphaNum, toLower, toUpper) import Data.Maybe(fromJust) -import Data.List(isPrefixOf, group) +import Data.List(isPrefixOf, group, maximumBy, delete) +import Data.Function(on) import System.IO import Data.Dynamic import Data.Bits hiding (rotate) @@ -124,8 +125,13 @@ -- x , multicolor :: Bool -- ^ multicolor play, or Variant 3 } deriving (Show, Read, Eq, Generic) isRuleValid :: Rule -> Bool -isRuleValid rl@R{..} = numBlackTokens > 0 && and [ h>0 && h<=mh | (h,mh) <- zip funPlayerHand maxPlayerHand ] && numColors>0 && numColors <=6 && (numColors < 6 || all (>0) numMulticolors) - where maxPlayerHand = [ succ (numberOfCards rl) `div` numP | numP <- [2..]] +isRuleValid rl@R{..} = numBlackTokens > 0 && and [ h>0 && h<=mh | (h,mh) <- zip funPlayerHand $ maxPlayerHand rl ] && numColors>0 && numColors <=6 && (numColors < 6 || all (>0) numMulticolors) +makeRuleValid :: Rule -> Rule +makeRuleValid rl@R{..} = rl{numBlackTokens = max 1 numBlackTokens, + numColors = max 1 (min 6 numColors), + numMulticolors = if numColors<6 then numMulticolors else take 5 (map (max 1) numMulticolors ++ [1,1,1,1,1]), + funPlayerHand = [ max 1 h | h <- zipWith min funPlayerHand $ maxPlayerHand rl ]} +maxPlayerHand rl = [ succ (numberOfCards rl) `div` numP | numP <- [2..]] -- This makes sure that there is at least one card on the deck. -- | @defaultRule@ is the normal rule from the rule book of the original card game Hanabi. @@ -192,6 +198,11 @@ -- | A 'Possibilities' is a pair of data that are instances of Bits. The first represents which colors are possible, and the second is for numbers. type Possibilities = (Int, Int) +colorToBitPos :: Color -> Int +colorToBitPos i = 5 - fromEnum i +numberToBitPos :: Number -> Int +numberToBitPos k = 5 - fromEnum k + data Annotation = Ann {ixDeck :: Int -- ^ Index in the initial deck , marks :: Marks -- ^ The Number and Color hints given to the card. , possibilities :: Possibilities} @@ -340,6 +351,8 @@ #endif currentScore :: PublicInfo -> Int currentScore pub = sum [ fromEnum $ achievedRank pub k | k <- colors pub ] + +-- | achievable score based on the info of extinct cards. achievableScore :: PublicInfo -> Int achievableScore pub = sum [ fromEnum $ bestPossibleRank pub k | k <- colors pub ] @@ -353,7 +366,7 @@ -- | 'Result' is the result of the last move. data Result = None -- ^ Hinted or at the beginning of the game - | Discard Card | Success Card | Fail Card deriving (Read, Show, Eq, Generic) + | Discard {revealed::Card} | Success {revealed::Card} | Fail {revealed::Card} deriving (Read, Show, Eq, Generic) -- The view history [PrivateView] records the memory of what has been visible `as is'. That is, the info of the cards in the history is not updated by revealing them. -- I guess, sometimes, ignorance of other players might also be an important knowledge. @@ -374,6 +387,89 @@ instance Eq PrivateView where PV pub1 hs1 _ == PV pub2 hs2 _ = (pub1,hs1) == (pub2,hs2) + +-- | recede rolls back 1 turn without rotating. +recede :: PublicInfo -> Move -> State -> State +recede lastpub (Hint _ _) st = st{ publicState = lastpub } +recede lastpub mv st = St{ publicState = lastpub, + pile = if pileNum lastpub == 0 then [] else (head myHand, initAnn (gameSpec lastpub) $ ixDeck $ head $ head $ annotations $ publicState st) : pile st, + hands = case splitAt (index mv) $ if pileNum lastpub == 0 then myHand else tail myHand of (tk,dr) -> (tk ++ revealed (result $ publicState st) : dr) : tail (hands st)} + where myHand = head $ hands st +-- | stateToStateHistory deduces the state history from the 'PublicState' history, the 'Move' history, and the current 'State'. +stateToStateHistory :: [PublicInfo] -> [Move] -> State -> [State] +stateToStateHistory [] [] st = [st] +stateToStateHistory (pi:pis) (mv:mvs) st = st : stateToStateHistory pis mvs (rotate (-1) $ recede pi mv st) + +-- | @'EGS' f p ps@ usually behaves based on @p@, but it conducts the exhaustive search assuming that others behave based on @ps@ when the deck size is @f@ or below @f@. +data EndGameStrategy p ps = EGS {fromWhen::PublicInfo->Bool, myUsualStrategy::p, otherPlayers::ps} + +instance (Monad m, Strategy p m, Strategies ps m) => Strategy (EndGameStrategy p ps) m where + strategyName ms = return "EndGameStrategy" + move pvs@(pv:_) mvs str@(EGS f p ps) | f (publicView pv) = do (defaultMove, _) <- move pvs mvs p + m <- endGameMove pvs mvs (ps, [EGS f p ps]) $ defaultMove : delete defaultMove (validMoves pv) + return (m,str) + | otherwise = do (m,_) <- move pvs mvs p + return (m,str) + +-- | 'EndGameMirrorStrategy' assumes that other players think in the same way as itself during endgame. +data EndGameMirrorStrategy p = EGMS (EndGameStrategy p [EndGameMirrorStrategy p]) +egms :: (PublicInfo -> Bool) -- ^ from when to start the endgame search + -> p -- ^ the default strategy used until endgame + -> Int -- ^ number of players, including the resulting player + -> EndGameMirrorStrategy p +egms from p nump = egms where egms = EGMS (EGS from p $ replicate (pred nump) egms) + +instance (Monad m, Strategy p m) => Strategy (EndGameMirrorStrategy p) m where + strategyName ms = return "EndGameMirrorStrategy" + move pvs mvs (EGMS egs) = do (m, egs') <- move pvs mvs egs + return (m, EGMS egs') + +endGameMove :: (Monad m, Strategies ps m) => + [PrivateView] -- ^ view history + -> [Move] -- ^ move history + -> ps + -> [Move] -- ^ move candidates. More promising moves appear earlier. + -> m Move +endGameMove pvs@(pv:tlpvs) mvs ps candidates = do + let states = possibleStates pv + scores <- mapM (evalMove states (map publicView tlpvs) mvs ps) candidates + let asc = zip scores candidates + pub = publicView pv + achievable = if prolong $ rule $ gameSpec pub then achievableScore pub else achievableScore pub `min` (currentScore pub + pileNum pub + numPlayers (gameSpec pub)) + -- ToDo: Also consider critical cards at the bottom deck. + return $ case lookup (achievable * length states) asc of Nothing -> snd $ maximumBy (compare `on` fst) $ reverse asc + Just k -> k -- Stop search when the best possible score is found. + +validMoves :: PrivateView -> [Move] +validMoves pv@PV{publicView=pub@PI{gameSpec=gs,hintTokens=hints},handsPV=tlHands} + = map Play [0 .. pred myHandSize] ++ (if hints > 0 then ([ Hint hintedpl eck | hintedpl <- [1 .. numPlayers gs - 1], eck <- map Left (colors pub) ++ map Right [K1 .. K5], not (null $ filter (either (\c -> (==c).color) (\k -> (==k).number) eck) (tlHands !! pred hintedpl)) ] ++) else id) (if hints < 8 then (map Drop [0 .. pred myHandSize]) else []) + where myHandSize = length (head $ annotations pub) + +evalMove :: (Monad m, Strategies ps m) => [State] -> [PublicInfo] -> [Move] -> ps -> Move -> m Int +evalMove states pubs@(pub:_) mvs ps mv = fmap (sum . map (\((eg,_,_),_) -> egToInt pub eg)) $ mapM (\st -> tryAMove (stateToStateHistory pubs mvs st) mvs ps mv) states + +-- | 'tryAMove' tries a 'Move' and then simulate the game to the end, using given 'Strategies'. Running this with empty history, such as @tryAMove [st] [] strs m@ is possible, but that assumes other strategies does not depend on the history. +tryAMove :: (Monad m, Strategies ps m) => [State] -> [Move] -> ps -> Move -> m ((EndGame, [State], [Move]),ps) +tryAMove states@(st:_) mvs strs mov = case proceed st mov of Nothing -> fail $ show mov ++ ": invalid move!" + Just st -> let nxt = rotate 1 st + in case checkEndGame $ publicState nxt of Nothing -> runSilently (nxt:states) (mov:mvs) strs + Just eg -> return ((eg, nxt:states, mov:mvs), strs) + +possibleStates :: PrivateView -> [State] +possibleStates pv@PV{publicView=pub@PI{gameSpec=gs}} + = [ St{ publicState = pub + , pile = zipWith (\c i -> (c, initAnn gs i)) deck [ (numberOfCards (rule $ gameSpec pub) - pileNum pub) ..] + , hands = hand : handsPV pv } + | (hand, deck) <- possiblePermutations pv ] +possiblePermutations :: PrivateView -> [([Card],[Card])] +possiblePermutations pv@PV{publicView=PI{annotations=anns:_}} = possiblePerms anns (invisibleCards pv) +invisibleCards :: PrivateView -> [Card] +invisibleCards PV{publicView=PI{annotations=anns}, invisibleBag=inv} = [ c | (k,v) <- IM.toList inv, c <- replicate v $ intToCard k ] -- x ++ [ C i k | (Just i, Just k) <- map marks anns ] +possiblePerms :: [Annotation] -> [Card] -> [([Card],[Card])] +possiblePerms [] cards = [([],cards)] +possiblePerms (Ann{marks = (Just i, Just k)} : anns) cards = [ (C i k : hand, deck) | (hand, deck) <- possiblePerms anns cards ] +possiblePerms (Ann{possibilities = (pi, pk)} : anns) cards = [ (card : hand, deck) | card@(C i k) <- cards, (pi .&. bit (colorToBitPos i)) * (pk .&. bit (numberToBitPos k)) /= 0, (hand, deck) <- possiblePerms anns $ delete card cards ] + -- | 'mkPV' is the constructor of PrivateView. mkPV :: PublicInfo -> [[Card]] -> PrivateView mkPV pub hs = PV pub hs $ foldr (IM.update (Just . pred)) (nonPublic pub) $ map cardToInt $ concat $ [ C c n | Ann{marks=(Just c, Just n)} <- head $ annotations pub ] : hs @@ -544,6 +640,13 @@ case mbeg of Nothing -> run audience sts mvs ps Just eg -> return ((eg, sts, mvs), ps) +-- | 'runSilently' is a light variant of 'run' that does not broadcast the process. This is useful for simulating the game within a strategy. +runSilently :: (Monad m, Strategies ps m) => [State] -> [Move] -> ps -> m ((EndGame, [State], [Move]), ps) +runSilently states moves players = do + ((mbeg, sts, mvs), ps) <- runARound (\_ _ -> return ()) states moves players + case mbeg of Nothing -> runSilently sts mvs ps + Just eg -> return ((eg, sts, mvs), ps) + -- | The 'Strategy' class is exactly the interface that -- AI researchers defining their algorithms have to care about. class Monad m => Strategy p m where @@ -691,6 +794,15 @@ ithPlayerFromTheLast :: Int -> Int -> String ithPlayerFromTheLast nump j = "The " ++ ith (nump-j) ++"last player's" + +newtype Replay = Replay String deriving (Read, Show) +instance (MonadIO m) => Strategy Replay m where + strategyName _ = return "Replay" + move (v:_) _ (Replay xs) = case splitAt 2 xs of ("","") -> do mov <- liftIO $ repeatReadingAMoveUntilSuccess stdin stdout v + return (mov, Replay "") + (tk,dr) -> return (read tk, Replay dr) + + type STDIO = Verbose Blind stdio :: Verbose Blind stdio = Verbose Blind verbose @@ -714,7 +826,7 @@ -- | 'createGameFromCards' deals cards and creates the initial state. createGameFromCards :: GameSpec -> [Card] -> State -createGameFromCards gs cards = splitCons (numPlayers gs) [] [ (c, Ann{ixDeck=i, marks=(Nothing, Nothing), possibilities=unknown gs}) | (c,i) <- zip cards [0..] ] +createGameFromCards gs cards = splitCons (numPlayers gs) [] [ (c, initAnn gs i) | (c,i) <- zip cards [0..] ] where splitCons 0 hnds stack = St {publicState = PI {gameSpec = gs, pileNum = initialPileNum gs, @@ -733,6 +845,7 @@ hands = map (map fst) hnds } splitCons n hnds stack = case splitAt (handSize gs) stack of (tk,dr) -> splitCons (pred n) (tk:hnds) dr +initAnn gs i = Ann{ixDeck=i, marks=(Nothing, Nothing), possibilities=unknown gs} createGame :: RandomGen g => GameSpec -> g -> (State, g) -- Also returns the new RNG state, in order not to require safe 'split' for collecting statistics. RNG is only used for initial shuffling. createGame gs gen = (createGameFromCards gs shuffled, g) where (shuffled, g) = createDeck (rule gs) gen @@ -823,10 +936,10 @@ zipper (C ir ka) ann@Ann{marks=(mi,mk),possibilities=(c,n)} = case eik of Left i | i == ir -> ann{marks=(Just i, mk), possibilities = (bit ibit, n)} |otherwise-> ann{possibilities = (clearBit c ibit, n)} - where ibit = 5 - fromEnum i + where ibit = colorToBitPos i Right k | k == ka -> ann{marks=(mi, Just k), possibilities = (c, bit kbit)} |otherwise-> ann{possibilities = (c, clearBit n kbit)} - where kbit = 5 - fromEnum k + where kbit = numberToBitPos k -- | @'rotate' num@ rotates the first person by @num@ (modulo the number of players). @@ -838,6 +951,10 @@ -- | 'EndGame' represents the game score, along with the info of how the game ended. -- It is not just @Int@ in order to distinguish 'Failure' (disaster / no life) from @'Soso' 0@ (not playing any card), though @'Soso' 0@ does not look more attractive than 'Failure'. data EndGame = Failure | Soso Int | Perfect deriving (Show,Read,Eq,Generic) + +egToInt _ Failure = 0 +egToInt _ (Soso n) = n +egToInt pub Perfect = 5 * numColors (rule $ gameSpec pub) checkEndGame :: PublicInfo -> Maybe EndGame checkEndGame pub | lives pub == 0 = Just Failure diff --git a/Game/Hanabi/Client.hs b/Game/Hanabi/Client.hs --- a/Game/Hanabi/Client.hs +++ b/Game/Hanabi/Client.hs @@ -85,7 +85,7 @@ defStr = maybe "via WebSocket" id $ lookup "strategy" query mvStr <- liftIO newMVarStrategy startApp App{ - model = Model{tboxval = Message "available", players = [S.pack defStr], from = Just 0, rule = defaultRule{numMulticolors=replicate 5 1}, received = [], fullHistory = False, showVerbosity = False, verbosity = verbose, play = True, localStrategy = mvStr, local = False}, + model = Model{tboxval = Message "available", players = [S.pack defStr], from = Just 0, rule = defaultRule{numMulticolors=replicate 5 1}, received = [CreateGame], fullHistory = False, showVerbosity = False, verbosity = verbose, play = True, localStrategy = mvStr, local = False}, update = updateModel options, view = appView strNames $ version options, subs = [ websocketSub wsURI protocols HandleWebSocket ], @@ -151,7 +151,7 @@ ns -> ns } updateModel _ (UpdatePlayer ix pl) model = noEff model{players = snd $ replaceNth ix pl $ players model} -updateModel _ (UpdateRule r) model | isRuleValid r = noEff model{rule=r} +updateModel _ (UpdateRule r) model = noEff model{rule=makeRuleValid r} updateModel _ (UpdateVerbosity v) model = noEff model{verbosity = v} updateModel _ Toggle model = noEff model{fullHistory = not $ fullHistory model} updateModel _ ToggleVerbosity model = noEff model{showVerbosity = not $ showVerbosity model} @@ -259,8 +259,7 @@ , span_ [style_ $ M.fromList [("clear","both"), ("font-size","10px"), ("float","right")]] [text $ S.pack $ "hanabi-dealer client "++versionInfo] -- , hr_ [] - , div_ [style_ $ M.fromList [("clear","both")]] $ if null received then renderCreateGame strategies mdl - else ((if fullHistory then id else take lenShownHistory) $ map (renderMsg strategies verbosity mdl) received) + , div_ [style_ $ M.fromList [("clear","both")]] $ ((if fullHistory then id else take lenShownHistory) $ map (renderMsg strategies verbosity mdl) received) , div_ [] $ if null $ drop lenShownHistory received then [] else [ hr_ [] , input_ [ type_ "checkbox", id_ "showhist", onClick Toggle, checked_ fullHistory] diff --git a/Game/Hanabi/Strategies/EndGameSearch.hs b/Game/Hanabi/Strategies/EndGameSearch.hs new file mode 100644 --- /dev/null +++ b/Game/Hanabi/Strategies/EndGameSearch.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +module Game.Hanabi.Strategies.EndGameSearch where +import Game.Hanabi hiding (main) +import Game.Hanabi.Strategies.Stateless hiding (main) +import Game.Hanabi.Strategies.SimpleStrategy hiding (main) +import System.Random + +-- A strategy with endgame search +data EndGameSearch = EG + +instance (Monad m) => Strategy EndGameSearch m where + strategyName ms = return "EndGame" + move pvs@(pv:_) mvs EG = do (m, _) <- -- move (sontakuColorHint pvs mvs) mvs $ searchExhaustively SL + -- move (sontakuColorHint pvs mvs) mvs $ assumeOthersAreSL SL + move (sontakuColorHint pvs mvs) mvs $ searchExhaustively $ assumeOthersAreSL SL + return (m, EG) + where searchExhaustively fallback = egms (\pub -> pileNum pub == 0) fallback (numPlayers $ gameSpec $ publicView pv) + assumeOthersAreSL fallback = EGS (\pub -> pileNum pub <= 1 && hintTokens pub <= 4) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL +-- assumeOthersAreSL fallback = EGS (\pub -> pileNum pub <=2 && hintTokens pub <= 4) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL +-- assumeOthersAreSL fallback = EGS (\pub -> pileNum pub + hintTokens pub < 4) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL +main = do g <- newStdGen + ((eg,_),_) <- start defaultGS [] ([EG], [stdio]) g -- Play it with standard I/O (human player). +-- ((eg,_),_) <- start defaultGS [peek] [EG, EG] g -- Play it with itself. + putStrLn $ prettyEndGame eg diff --git a/Game/Hanabi/Strategies/SimpleStrategy.hs b/Game/Hanabi/Strategies/SimpleStrategy.hs --- a/Game/Hanabi/Strategies/SimpleStrategy.hs +++ b/Game/Hanabi/Strategies/SimpleStrategy.hs @@ -29,8 +29,8 @@ isNewestOfColor i d ] -- but be cautious not to color-mark newer cards. 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 number-marked. numberMarkPlayable = take 1 [ Hint 1 $ Right $ number d | (_,d,Ann{marks=(_, Nothing)}) <- markCandidates ] -- Mark the number if a (not obviously) playable card is not number-marked. - numberMarkUselessIfInformative = take 1 [ Hint 1 $ Right $ number d | (_,d,Ann{possibilities=p@(pc, _)}) <- nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (pc, bit $ 5 - fromEnum (number d)) ] - colorMarkUselessIfInformative = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{possibilities=p@(_, pn)}) <- reverse nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (bit $ 5 - fromEnum (color d), pn), + numberMarkUselessIfInformative = take 1 [ Hint 1 $ Right $ number d | (_,d,Ann{possibilities=p@(pc, _)}) <- nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (pc, bit $ numberToBitPos (number 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 $ number d | (_,d,Ann{marks=(Nothing, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ] numberMarkNumberUnmarked = take 1 [ Hint 1 $ Right $ number d | (_,d,Ann{marks=(Just _, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ] diff --git a/Game/Hanabi/Strategies/StatefulStrategy.hs b/Game/Hanabi/Strategies/StatefulStrategy.hs --- a/Game/Hanabi/Strategies/StatefulStrategy.hs +++ b/Game/Hanabi/Strategies/StatefulStrategy.hs @@ -26,13 +26,13 @@ hintedColors = [ c | (p, Hint q (Left c)) <- zip [1..] $ take (numPlayers $ gameSpec pub) mvs, p==q, - (Just c, Just $ succ $ achievedRank pub c) `notElem` map marks myAnns -- Exclude if there is a playable card with the color. + 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 $ 4 - fromEnum (achievedRank pub c), -- This is -1 when achievedRank pub c == K5, but then isDefinitelyUnplayable pv ann should be True. + newNumberPos = bit $ numberToBitPos (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 diff --git a/Game/Hanabi/Strategies/Stateless.hs b/Game/Hanabi/Strategies/Stateless.hs new file mode 100644 --- /dev/null +++ b/Game/Hanabi/Strategies/Stateless.hs @@ -0,0 +1,48 @@ +{-# 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 + +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 = (currentColPos, newNumberPos)} + | Ann{ixDeck=ix, marks=(Just c, Nothing), possibilities=(currentColPos, currentNumPos)} <- 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 newNumberPos = bit $ numberToBitPos (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 + , newNumberPos .&. currentNumPos /= 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 = move (sontakuColorHint pvs mvs) mvs S >>= \(mov,S) -> return (mov, SL) + +main = do g <- newStdGen + ((eg,_),_) <- start defaultGS [] ([SL],[stdio]) g -- Play it with standard I/O (human player). +-- ((eg,_),_) <- start defaultGS [peek] [SL,SL] g -- Play it with itself. + putStrLn $ prettyEndGame eg diff --git a/client.hs b/client.hs --- a/client.hs +++ b/client.hs @@ -3,12 +3,16 @@ import Game.Hanabi.Strategies.SimpleStrategy hiding (main) import Game.Hanabi.Strategies.StatefulStrategy hiding (main) +import Game.Hanabi.Strategies.Stateless hiding (main) +import Game.Hanabi.Strategies.EndGameSearch hiding (main) main = client defOpt{strategies=strs} -- strs :: [(String, IO (DynamicStrategy IO))] strs = [ ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S), - ("Example strategy with states", return $ mkDS "Example strategy with states" $ SF []) + ("Example strategy with states", return $ mkDS "Example strategy with states" $ SF []), + ("Stateless implementation of the strategy with states", return $ mkDS "Stateless implementation of the strategy with states" SL), + ("Strategy with end game search", return $ mkDS "Strategy with end game search" EG) -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault)) ] diff --git a/hanabi-dealer.cabal b/hanabi-dealer.cabal --- a/hanabi-dealer.cabal +++ b/hanabi-dealer.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.8.0.0 +version: 0.9.0.0 -- A short (one-line) description of the package. synopsis: Hanabi card game @@ -156,7 +156,7 @@ executable hanabib main-is: server.hs - other-modules: Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy + other-modules: Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy, Game.Hanabi.Strategies.Stateless, Game.Hanabi.Strategies.EndGameSearch if impl(ghcjs) || !flag(server) buildable: False else @@ -180,7 +180,7 @@ executable hanabif main-is: client.hs - other-modules: Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy + other-modules: Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy, Game.Hanabi.Strategies.Stateless, Game.Hanabi.Strategies.EndGameSearch if !impl(ghcjs) -- && !flag(jsaddle) buildable: False diff --git a/server.hs b/server.hs --- a/server.hs +++ b/server.hs @@ -3,12 +3,16 @@ import Game.Hanabi.Strategies.SimpleStrategy hiding (main) import Game.Hanabi.Strategies.StatefulStrategy hiding (main) +import Game.Hanabi.Strategies.Stateless hiding (main) +import Game.Hanabi.Strategies.EndGameSearch hiding (main) main = server defOpt{strategies=strs} strs :: [(String, IO (DynamicStrategy IO))] strs = [ ("Stupid example strategy", return $ mkDS "Stupid example strategy" S), - ("Example strategy with states", return $ mkDS "Example strategy with states" $ SF []) + ("Example strategy with states", return $ mkDS "Example strategy with states" $ SF []), + ("Stateless implementation of the strategy with states", return $ mkDS "Stateless implementation of the strategy with states" SL), + ("Strategy with end game search", return $ mkDS "Strategy with end game search" EG) -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault)) ]