hanabi-dealer 0.7.0.0 → 0.7.1.0
raw patch · 5 files changed
+138/−71 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Game.Hanabi: (|||) :: (PrivateView -> Move) -> (PrivateView -> Move) -> PrivateView -> Move
+ Game.Hanabi: createDeck :: RandomGen g => Rule -> g -> ([Card], g)
+ Game.Hanabi: createGameFromCards :: GameSpec -> [Card] -> State
+ Game.Hanabi: handSize :: GameSpec -> Int
+ Game.Hanabi: ifA :: (PrivateView -> Bool) -> (PrivateView -> Move) -> (PrivateView -> Move) -> PrivateView -> Move
+ Game.Hanabi: quiet :: Verbosity
+ Game.Hanabi: setHandSize :: GameSpec -> Int -> Rule
+ Game.Hanabi: startFromCards :: (Monad m, Strategies ps m) => GameSpec -> [Peeker m] -> ps -> [Card] -> m ((EndGame, [State], [Move]), ps)
+ Game.Hanabi: tryMove :: PrivateView -> Move -> Move -> Move
Files
- ChangeLog.md +14/−1
- Game/Hanabi.hs +55/−26
- Game/Hanabi/Client.hs +41/−27
- Game/Hanabi/Strategies/SimpleStrategy.hs +27/−16
- hanabi-dealer.cabal +1/−1
ChangeLog.md view
@@ -1,4 +1,17 @@-# Revision history for hanabi-dealer+ # Revision history for hanabi-dealer++ ## 0.7.1.0 -- 2020-03-13++ * fix freeze after invalid move when played locally++ * improve the menu GUI for rules and verbosity++ * fix problems related to the 6th-color++ * slightly substantiate the function set for implementing strategies++ * slightly improve SimpleStrategy+ ## 0.7.0.0 -- 2020-02-28 * start games locally when possible.
Game/Hanabi.hs view
@@ -1,15 +1,15 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, Safe, DeriveGeneric, RecordWildCards #-} module Game.Hanabi( -- * Functions for Dealing Games- main, selfplay, start, createGame, run,+ main, selfplay, start, createGame, startFromCards, createGameFromCards, run, createDeck, prettyEndGame, isMoveValid, checkEndGame, help, -- * Datatypes -- ** The Class of Strategies- Strategies, Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose,+ Strategies, Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose, quiet, -- ** Audience Peeker, peek, -- ** The Game Specification- GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid, colors,+ GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid, colors, handSize, setHandSize, -- ** The Game State and Interaction History Move(..), Index, State(..), PrivateView(..), PublicInfo(..), Result(..), EndGame(..), -- ** The Cards@@ -18,11 +18,13 @@ -- ** Hints isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, currentScore, achievableScore, isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, obviousChopss, definiteChopss, isDoubleDrop,+ tryMove, (|||), ifA, -- ** Minor ones what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, prettySt, ithPlayerFromTheLast, view, replaceNth, shuffle, showPossibilities, showColorPossibilities, showNumberPossibilities, showTrial) where -- module Hanabi where import qualified Data.IntMap as IM import System.Random+import Control.Applicative((<*>)) import Control.Monad(when) import Control.Monad.IO.Class(MonadIO, liftIO) import Data.Char(isSpace, isAlpha, isAlphaNum, toLower, toUpper)@@ -40,7 +42,7 @@ readsColorChar :: ReadS Color readsColorChar (c:str) | isSpace c = readsColorChar str- | otherwise = case lookup (toUpper c) [(head $ show i, i) | i <- [White, Yellow, Red, Green, Blue]] of+ | otherwise = case lookup (toUpper c) [(head $ show i, i) | i <- [White .. Multicolor]] of Nothing -> [] Just i -> [(i, str)] readsColorChar [] = []@@ -108,7 +110,7 @@ -- -- See also the definition of 'checkEndGame'. data Rule = R { numBlackTokens :: Int -- ^ E.g., if this is 3, the third failure ends the game with failure.- , funPlayerHand :: [Int] -- ^ memoized function taking the number of players; the default is [5,5,4,4,4,4,4,4,4,4,4,4,4,4]+ , funPlayerHand :: [Int] -- ^ memoized function taking the number of players; the default is [5,5,4,4,4,4,4,4,4,4] , numColors :: Int -- ^ number of colors. 5 for the normal rule, and 6 for Variant 1-3 of the rule book. , prolong :: Bool -- ^ continue even after a round after the pile is exhausted. @True@ for Variant 4 of the rule book. , earlyQuit :: Bool -- ^ quit the game when the best possible score is achieved. @@ -117,11 +119,14 @@ -- x , multicolor :: Bool -- ^ multicolor play, or Variant 3 } deriving (Show, Read, Eq, Generic) isRuleValid :: Rule -> Bool-isRuleValid R{..} = numBlackTokens > 0 && all (>0) funPlayerHand && numColors>0 && numColors <=6 && (numColors < 6 || all (>0) numMulticolors)+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..]]+ -- 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. defaultRule :: Rule defaultRule = R { numBlackTokens = 3- , funPlayerHand = [5,5]++take 12 (repeat 4)+ , funPlayerHand = [5,5]++take 8 (repeat 4) , numColors = 5 , prolong = False , earlyQuit = False@@ -130,11 +135,15 @@ } defaultGS :: GameSpec defaultGS = GS{numPlayers=2, rule=defaultRule}+numberOfCards :: Rule -> Int+numberOfCards rl = sum (take (numColors rl) $ [10,10,10,10,10]++[sum (numMulticolors rl)]) initialPileNum :: GameSpec -> Int-initialPileNum gs = sum (take (numColors $ rule gs) $ [10,10,10,10,10]++[sum (numMulticolors $ rule gs)])- - numPlayerHand gs * numPlayers gs-numPlayerHand :: GameSpec -> Int-numPlayerHand gs = (funPlayerHand (rule gs) ++ repeat 4) !! (numPlayers gs - 2)+initialPileNum gs = numberOfCards (rule gs)+ - handSize gs * numPlayers gs+handSize :: GameSpec -> Int+handSize GS{..} = (funPlayerHand rule ++ repeat 1) !! (numPlayers - 2)+setHandSize :: GameSpec -> Int -> Rule+setHandSize GS{..} n = rule{funPlayerHand = snd $ replaceNth (numPlayers - 2) n $ funPlayerHand rule} data GameSpec = GS {numPlayers :: Int, rule :: Rule} deriving (Read, Show, Eq, Generic) -- | State consists of all the information of the current game state, including public info, private info, and the hidden deck.@@ -179,10 +188,10 @@ -- | the best achievable rank for each color. bestPossibleRank :: PublicInfo -> Color -> Number-bestPossibleRank pub iro = toEnum $ length $ takeWhile (/=0) $ zipWith subtract (numCards (gameSpec pub) iro)+bestPossibleRank pub iro = toEnum $ length $ takeWhile (/=0) $ zipWith subtract (numEachCard (gameSpec pub) iro) (map ((discarded pub IM.!) . cardToInt . C iro) [K1 .. K5])-numCards :: GameSpec -> Color -> [Int]-numCards gs iro = if iro==Multicolor then numMulticolors $ rule gs else [3,2,2,2,1]+numEachCard :: GameSpec -> Color -> [Int]+numEachCard gs iro = if iro==Multicolor then numMulticolors $ rule gs else [3,2,2,2,1] -- | isUseless pi card means either the card is already played or it is above the bestPossibleRank. isUseless :: PublicInfo -> Card -> Bool isUseless pub card = number card <= achievedRank pub (color card) -- the card is already played@@ -192,7 +201,7 @@ -- Unmarked critical card on the chop should be marked. isCritical :: PublicInfo -> Card -> Bool isCritical pub card = not (isUseless pub card)- && succ (discarded pub IM.! cardToInt card) == (numCards (gameSpec pub) (color card) !! (pred $ fromEnum $ number card))+ && succ (discarded pub IM.! cardToInt card) == (numEachCard (gameSpec pub) (color card) !! (pred $ fromEnum $ number card)) isPlayable :: PublicInfo -> Card -> Bool isPlayable pub card = pred (number card) == achievedRank pub (color card)@@ -300,6 +309,14 @@ achievableScore :: PublicInfo -> Int achievableScore pub = sum [ fromEnum $ bestPossibleRank pub k | k <- colors pub ] +tryMove :: PrivateView -> Move -> Move -> Move+tryMove pv m alt | isMoveValid pv m = m+ | otherwise = alt+(|||) :: (PrivateView -> Move) -> (PrivateView -> Move) -> PrivateView -> Move+a ||| b = tryMove <*> a <*> b+ifA :: (PrivateView -> Bool) -> (PrivateView -> Move) -> (PrivateView -> Move) -> PrivateView -> Move+ifA pred at af = (\pv t f -> if pred pv then t else f) <*> at <*> af+ -- | '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)@@ -351,8 +368,9 @@ chopSet = concat $ take 1 $ definiteChopss pv myHand myPos prettySt :: (Int -> Int -> String) -> State -> String prettySt ithP st@St{publicState=pub} = prettyPI pub ++ concat (zipWith4 (prettyHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (hands st) (givenHints pub) (possibilities pub))-verbose :: Verbosity-verbose = V{warnCritical=True,markUseless=True,markPlayable=True,markObviouslyUseless=True,markObviouslyPlayable=True,markHints=True,markPossibilities=True,markChops=True,warnDoubleDrop=True}+verbose, quiet :: Verbosity+verbose = V{warnCritical=True, markUseless=True, markPlayable=True, markObviouslyUseless=True, markObviouslyPlayable=True, markHints=True, markPossibilities=True, markChops=True, warnDoubleDrop=True}+quiet = V{warnCritical=False,markUseless=False,markPlayable=False,markObviouslyUseless=False,markObviouslyPlayable=False,markHints=False,markPossibilities=False,markChops=False,warnDoubleDrop=False} prettyHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Card] -> [Marks] -> [Possibilities] -> String prettyHand v pub ithPnumP i cards hl ps = "\n\n" ++ ithPnumP i ++ " hand:\n" -- ++ concat (replicate (length cards) " __") ++ " \n"@@ -480,6 +498,11 @@ start gs audience players gen = let (st, g) = createGame gs gen in fmap (\e -> (e,g)) $ run audience [st] [] players+startFromCards :: (Monad m, Strategies ps m) =>+ GameSpec -> [Peeker m] -> ps -> [Card] -> m ((EndGame, [State], [Move]), ps)+startFromCards gs audience players shuffled = let+ st = createGameFromCards gs shuffled+ in run audience [st] [] players run :: (Monad m, Strategies ps m) => [Peeker m] -> [State] -> [Move] -> ps -> m ((EndGame, [State], [Move]), ps) run audience states moves players = do ((mbeg, sts, mvs), ps) <- runARound (\sts@(st:_) mvs -> let myOffset = turn (publicState st) in mapM_ (\p -> p st mvs) audience >> broadcast (zipWith rotate [-myOffset, 1-myOffset ..] sts) mvs players (myOffset `mod` numPlayers (gameSpec $ publicState st)) >> return ()) states moves players@@ -654,11 +677,11 @@ case reads str of [(mv, rest)] | all isSpace rest -> if isMoveValid v mv then return mv else hPutStrLn hout "Invalid Move" >> repeatReadingAMoveUntilSuccess hin hout v _ -> hPutStr hout ("Parse error.\n"++help) >> repeatReadingAMoveUntilSuccess hin hout v --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 = splitCons (numPlayers gs) [] shuffled+-- | 'createGameFromCards' deals cards and creates the initial state.+createGameFromCards :: GameSpec -> [Card] -> State+createGameFromCards gs = splitCons (numPlayers gs) [] where splitCons 0 hnds stack- = (St {publicState = PI {gameSpec = gs,+ = St {publicState = PI {gameSpec = gs, pileNum = initialPileNum gs, played = IM.fromAscList [ (i, Empty) | i <- [0 .. pred $ numColors $ rule gs] ], discarded = IM.fromList [ (cardToInt $ C i k, 0) | i <- take (numColors $ rule gs) [White .. Multicolor],@@ -668,15 +691,21 @@ lives = numBlackTokens $ rule gs, hintTokens = 8, deadline = Nothing,- givenHints = replicate (numPlayers gs) $ replicate (numPlayerHand gs) (Nothing, Nothing),- possibilities = replicate (numPlayers gs) $ replicate (numPlayerHand gs) (unknown gs),+ givenHints = replicate (numPlayers gs) $ replicate (handSize gs) (Nothing, Nothing),+ possibilities = replicate (numPlayers gs) $ replicate (handSize gs) (unknown gs), result = None }, pile = stack, hands = hnds- }, g)- splitCons n hnds stack = case splitAt (numPlayerHand gs) stack of (tk,dr) -> splitCons (pred n) (tk:hnds) dr- (shuffled, g) = shuffle (cardBag $ rule gs) gen+ }+ splitCons n hnds stack = case splitAt (handSize gs) stack of (tk,dr) -> splitCons (pred n) (tk:hnds) dr+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+createDeck :: RandomGen g => Rule -> g -> ([Card], g)+createDeck r gen = shuffle (cardBag r) gen++ numAssoc :: [(Number, Int)] numAssoc = zip [K1 ..K5] [3,2,2,2,1] cardAssoc :: Rule -> [(Card,Int)]
Game/Hanabi/Client.hs view
@@ -68,9 +68,9 @@ -- https://github.com/dmjio/miso/blob/master/frontend-src/Miso/Subscription/WebSocket.hs clientJSM :: Game.Hanabi.Msg.Options -> JSM ()-clientJSM options = do mvStr <- newMVarStrategy+clientJSM options = do mvStr <- liftIO newMVarStrategy startApp App{- model = Model{tboxval = Message "available", players = ["via WebSocket"], from = Just 0, rule = defaultRule, received = [], fullHistory = False, showVerbosity = False, verbosity = verbose, play = True, localStrategy = mvStr, local = False},+ model = Model{tboxval = Message "available", players = ["via WebSocket"], from = Just 0, rule = defaultRule{numMulticolors=replicate 5 1}, received = [], fullHistory = False, showVerbosity = False, verbosity = verbose, play = True, localStrategy = mvStr, local = False}, update = updateModel options, view = appView strNames $ version options, subs = [ websocketSub uri protocols HandleWebSocket ],@@ -100,7 +100,7 @@ updateModel _ (SendMessage msg@(Message str)) model = model{fullHistory=False, showVerbosity=False} <# -- connect uri protocols >> if local model then case reads $ S.unpack str of- [(m,str)] -> do+ [(m,str)] -> liftIO $ do putMVar (mvMov $ localStrategy model) m msg <- takeMVar (mvMsg $ localStrategy model) return $ ProcMsg msg@@ -108,7 +108,7 @@ else send msg >> return Id updateModel _ (SendMove mov) model = model{fullHistory=False, showVerbosity=False} <# -- connect uri protocols >> if local model- then do+ then liftIO $ do putMVar (mvMov $ localStrategy model) mov msg <- takeMVar (mvMsg $ localStrategy model) return $ ProcMsg msg@@ -144,7 +144,7 @@ ) updateModel _ (WriteLocalResult fs@(_,sts,mvs)) model = model{received = CreateGame : PrettyEndGame (Just fs) : zipWith Watch (tail sts) (iterate (drop 1) $ drop 1 mvs) ++ received model} <# return (SendMessage $ Message "available")-updateModel opt PlayLocally model = model{local=True} <# do+updateModel opt PlayLocally model = model{local=True} <# liftIO (do let constructor algIx = fromJust $ lookup algIx $ strategies opt playerList <- mapM (constructor . S.unpack) $ reverse $ players model let thePlayerList = mkDS "local strategy" (localStrategy model) : playerList@@ -160,11 +160,13 @@ putMVar (mvMsg $ localStrategy model) $ PrettyEndGame $ Just fs msg <- takeMVar (mvMsg $ localStrategy model) return $ ProcMsg msg+ ) updateModel _ (ProcMsg msg@(PrettyEndGame (Just fs))) model = model{local=False, received = CreateGame : msg : received model} <# return (SendMessage $ Message "available") updateModel _ (ProcMsg msg@(WhatsUp _ _ _)) model = noEff model{received = msg : received model}-updateModel _ (ProcMsg msg) model = model{received = msg : received model} <# do+updateModel _ (ProcMsg msg) model = model{received = msg : received model} <# liftIO (do msg <- takeMVar (mvMsg $ localStrategy model) return $ ProcMsg msg+ ) #ifdef DEBUG updateModel _ (HandleWebSocket act) model = noEff model{received = Str (show act) : received model } #endif@@ -236,19 +238,22 @@ ] renderVerbosity :: Verbosity -> View Action renderVerbosity v = div_ [] [- mkChx v "mark unhinted critical cards" (\b -> v{warnCritical=b}) warnCritical,- mkChx v "mark useless cards" (\b -> v{markUseless=b}) markUseless,- mkChx v "mark playable cards" (\b -> v{markPlayable=b}) markPlayable,- mkChx v "mark useless cards without looking at the cards" (\b -> v{markObviouslyUseless=b}) markObviouslyUseless, - mkChx v "mark playable cards without looking at the cards" (\b -> v{markObviouslyPlayable=b}) markObviouslyPlayable,- mkChx v "shade the chop card(s)" (\b -> v{markChops=b}) markChops,- mkChx v "warn possible double-dropping"(\b -> v{warnDoubleDrop=b}) warnDoubleDrop,- mkChx v "mark hints" (\b -> v{markHints=b}) markHints,- mkChx v "mark possibilities" (\b -> v{markPossibilities=b}) markPossibilities+ mkChx span_ v "beginner" (\b -> if b then verbose else v) (==verbose),+ mkChx span_ v "expert" (\b -> if b then quiet else v) (==quiet),+ hr_ [],+ mkChx div_ v "mark unhinted critical cards" (\b -> v{warnCritical=b}) warnCritical,+ mkChx div_ v "mark useless cards" (\b -> v{markUseless=b}) markUseless,+ mkChx div_ v "mark playable cards" (\b -> v{markPlayable=b}) markPlayable,+ mkChx div_ v "mark useless cards without looking at the cards" (\b -> v{markObviouslyUseless=b}) markObviouslyUseless, + mkChx div_ v "mark playable cards without looking at the cards" (\b -> v{markObviouslyPlayable=b}) markObviouslyPlayable,+ mkChx div_ v "shade the chop card(s)" (\b -> v{markChops=b}) markChops,+ mkChx div_ v "warn possible double-dropping"(\b -> v{warnDoubleDrop=b}) warnDoubleDrop,+ mkChx div_ v "mark hints" (\b -> v{markHints=b}) markHints,+ mkChx div_ v "mark possibilities" (\b -> v{markPossibilities=b}) markPossibilities ] -mkChx verb label update access = div_ [] [+mkChx divspan verb label update access = divspan [] [ input_ [ type_ "checkbox", id_ idName, onClick (UpdateVerbosity $ update $ not $ access verb), checked_ $ access verb ], label_ [ for_ idName ] [text label] ]@@ -331,10 +336,10 @@ -- div_ [] [text $ "Rules"], -- div_ [] [input_ [type_ "text", onInput (UpdateRule . head . (++[rule mdl]) . map fst . reads . S.unpack), value_ $ S.pack $ show $ rule mdl, style_ $ M.fromList [("width","70%")]]], - let mkTR label updater access = tr_ [] [+ let mkTR list label updater access = tr_ [] [ td_ [] [text label], td_ [] [- input_ [type_ "text", onInput (UpdateRule . updater . head . (++[access $ rule mdl]) . map fst . reads . S.unpack), value_ $ S.pack $ show $ access $ rule mdl]+ input_ $ list ++ [type_ "text", onInput (UpdateRule . updater . head . (++[access $ rule mdl]) . map fst . reads . S.unpack), (if null list then value_ else placeholder_) $ S.pack $ show $ access $ rule mdl] ] ] mkTRd label updater access options = tr_ [] [@@ -342,17 +347,23 @@ td_ [] [ dropdownLiteral options (UpdateRule . updater) (access $ rule mdl) ]- ] in- table_ [solid] [+ ]+ gs = GS{numPlayers = length (players mdl) + if play mdl then 1 else 0,+ Game.Hanabi.rule = rule mdl}+ in+ table_ [solid] $ [ caption_ [] [text "Rules"], mkTRd "Number of lives" (\n -> (rule mdl){numBlackTokens=n}) numBlackTokens [1 .. 9], mkTRd "Number of colors" (\n -> (rule mdl){numColors=n}) numColors [1 .. 6], mkTRd "Continue the game after the pile is exhausted" (\n -> (rule mdl){prolong=n}) prolong [False,True], mkTRd "Quit the game when no more score is possible" (\n -> (rule mdl){earlyQuit=n}) earlyQuit [False,True],- mkTR "numMulticolors" (\n -> (rule mdl){numMulticolors=n}) numMulticolors,- mkTR "funPlayerHand" (\n -> (rule mdl){funPlayerHand=n}) funPlayerHand- ],-+-- mkTR [] "funPlayerHand" (\n -> (rule mdl){funPlayerHand=n}) funPlayerHand+ mkTRd "Hand size" (setHandSize gs) (const (handSize gs)) [1 .. 9]+ ] +++ if numColors (rule mdl) == 6 then [+ mkTR [list_ "numMulticolors"] "Numbers of M1 .. M5" (\n -> (rule mdl){numMulticolors=n}) numMulticolors+ ] else [],+ datalist_ [id_ "numMulticolors"] [option_ [value_ "[1, 1, 1, 1, 1]"] [text "[1, 1, 1, 1, 1]"], option_ [value_ "[3, 2, 2, 2, 1]"] [text "[3, 2, 2, 2, 1]"]], button_ [onClick $ if all (not . isWS . S.unpack) (players mdl) then if play mdl then PlayLocally else ObserveLocally@@ -604,12 +615,15 @@ data MVarStrategy = MVS {mvMsg :: MVar Msg, mvMov :: MVar Move} deriving Eq instance Strategy MVarStrategy IO where strategyName _ = return "local player"- move pvs mvs mvstr@(MVS mvmsg mvmov) = do+ move pvs@(pv:_) mvs mvstr@(MVS mvmsg mvmov) = do putMVar mvmsg $ WhatsUp "local player" pvs mvs- mov <- takeMVar mvmov+ mov <- getMoveUntilSuccess pv mvstr return (mov, mvstr) observe (v:_) (m:_) (MVS mvmsg mvmov) = putMVar mvmsg $ WhatsUp1 v m-+getMoveUntilSuccess pv mvstr@(MVS mvmsg mvmov) = do+ m <- takeMVar mvmov+ if isMoveValid pv m then return m else do putMVar mvmsg $ Str "invalid move"+ getMoveUntilSuccess pv mvstr newMVarStrategy = do mvmsg <- newEmptyMVar mvmov <- newEmptyMVar
Game/Hanabi/Strategies/SimpleStrategy.hs view
@@ -2,29 +2,40 @@ module Game.Hanabi.Strategies.SimpleStrategy where import Game.Hanabi hiding (main) import System.Random+import Data.Maybe(isNothing) -- 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:_) (Hint 1 (Left c) : _) s = return (Play $ length $ takeWhile ((/=Just c) . fst) $ head $ givenHints $ publicView pv, s)- move (pv:_) _mvs s = let pub = publicView pv- tsuginohitoNoTe = head $ handsPV pv ::[Card]- tsuginohitoNoHint = givenHints pub !! 1- numHand = length $ head $ givenHints pub- mov | hintTokens pub >= 1 = case filter (\(ix, te, hint) -> hint == (Nothing,Nothing) && isCritical pub te) $ zip3 [0..] tsuginohitoNoTe tsuginohitoNoHint of+ move (pv:_) mvs s = let pub = publicView pv+ nextPlayersHand = head $ handsPV pv ::[Card]+ nextPlayersHints = givenHints pub !! 1+ nextPlayer = zip3 [0..] nextPlayersHand nextPlayersHints+ myHints = head $ givenHints pub+ myPos = head $ possibilities pub+ numHand = length myHints+ mov = case filter (\(ix, te, hint) -> not (isHinted hint) && isCritical pub te) nextPlayer of [] -> foo- us -> Hint 1 $ Right (number $ sndOf3 $ last us)- | otherwise = foo- where foo = case filter ((==(Nothing,Nothing)) . snd) $ zip [0..] $ head $ givenHints pub of- ts@(_:_) | hintTokens pub < 4 -> Drop (fst $ last ts)- | otherwise -> case break (isPlayable pub) tsuginohitoNoTe of- (_,d:_) -> Hint 1 $ Left $ color d- (_,[]) | hintTokens pub < 8 -> Drop (fst $ last ts)- | otherwise -> Hint 1 $ Right $ number $ last $ tsuginohitoNoTe- _ | hintTokens pub < 1 -> Drop $ pred $ length $ head $ givenHints pub- | otherwise -> Hint 1 $ Right $ number $ last $ tsuginohitoNoTe+ us -> tryMove pv (Hint 1 $ Right (number $ sndOf3 $ last us)) foo+ where foo = case break (\(_,card,_) -> isPlayable pub card) nextPlayer of+ (ts,(_,d,(Nothing, _)) :_) | hintTokens pub >= 3 && all (\(_,c,_) -> color c /= color d) ts -> Hint 1 $ Left $ color d+ (ts,(_,d,(Just _, Nothing)):_) | hintTokens pub >= 4 -> Hint 1 $ Right $ number d -- This should actually be ANY card.+ _ ->+ case filter (\(i,marks,pos) -> isDefinitelyPlayable pv marks pos) $ zip3 [0..] myHints myPos of+ (i,_,_):_ -> Play i+ [] ->+ case mvs of+ Hint 1 (Left c) : _ | isDefinitelyUseless pv (myHints!!i) (myPos!!i) -> tryMove pv (Drop i) rest+ | otherwise -> Play i+ where i = length $ takeWhile ((/=Just c) . fst) $ head $ givenHints $ publicView pv+ _ -> rest+ where rest = case definiteChopss pv myHints myPos of+ ((i:_):_) -> tryMove pv (Drop i)+ (Hint 1 $ Right $ number $ last $ nextPlayersHand)+ _ -> tryMove pv (Hint 1 $ Right $ number $ last $ nextPlayersHand)+ (Drop $ pred numHand) in return (mov, s) sndOf3 (_,b,_) = b
hanabi-dealer.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.7.0.0+version: 0.7.1.0 -- A short (one-line) description of the package. synopsis: Hanabi card game