hanabi-dealer (empty) → 0.1.0.0
raw patch · 5 files changed
+606/−0 lines, 5 filesdep +basedep +containersdep +randomsetup-changed
Dependencies added: base, containers, random
Files
- ChangeLog.md +5/−0
- Game/Hanabi.hs +491/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- hanabi-dealer.cabal +78/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for hanabi-dealer++## 0.1.0.0 -- 2019-12-18++* First version. Released on an unsuspecting world.
+ Game/Hanabi.hs view
@@ -0,0 +1,491 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, Safe #-}+module Game.Hanabi(+ -- * Functions for Dealing Games+ main, selfplay, start, createGame, run,+ prettyEndGame, isMoveValid, checkEndGame, help,+ -- * Datatypes+ -- ** The Class of Strategies+ Strategies, Strategy(..), Verbose(..), STDIO, Blind, ViaHandles(..),+ -- ** The Game Specification+ GameSpec(..), defaultGS, Rule(..), defaultRule,+ -- ** The Game State and Interaction History+ Move(..), Index, State(..), PrivateView(..), PublicInfo(..), EndGame(..),+ -- ** The Cards+ Card(..), Color(..), Number(..), cardToInt, intToCard, readsColorChar, readsNumberChar,+ -- * Other Utilities+ what'sUp, what'sUp1, ithPlayer) where+-- module Hanabi where+import qualified Data.IntMap as IM+import System.Random+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 System.IO++data Number = Empty | K1 | K2 | K3 | K4 | K5 deriving (Eq, Ord, Show, Read, Enum, Bounded)+data Color = White | Yellow | Red | Green | Blue | Multicolor+ deriving (Eq, Show, Read, Enum)+readsColorChar :: ReadS Color+readsColorChar (c:str) = case lookup (toUpper c) [(head $ show i, i) | i <- [White, Yellow, Red, Green, Blue]] of+ Nothing -> []+ Just i -> [(i, str)]+readsColorChar [] = []+readsNumberChar :: ReadS Number+readsNumberChar ('0':rest) = [(Empty,rest)]+readsNumberChar str = reads ('K':str)++data Card = C {color :: Color, number :: Number} deriving Eq+instance Show Card where+ showsPrec _ (C color number) = (head (show color) :) . (show (fromEnum number) ++)+instance Read Card where+ readsPrec _ str = [(C i k, rest) | (i, xs) <- readsColorChar str, (k, rest) <- readsNumberChar xs]+cardToInt c = fromEnum (color c) * (succ $ fromEnum (maxBound::Number)) + fromEnum (number c)+intToCard i = case i `divMod` (succ $ fromEnum (maxBound::Number)) of (c,k) -> C (toEnum c) (toEnum k)+type Index = Int -- starts from 0++data Move = Drop {index::Index} -- ^ drop the card (0-origin)+ | Play {index::Index} -- ^ play the card (0-origin)+ | Hint Int (Either Color Number) -- ^ give hint to the ith next player+instance Show Move where+ showsPrec _ (Drop i) = ("Drop"++) . shows i+ showsPrec _ (Play i) = ("Play"++) . shows i+ showsPrec _ (Hint i eith) = ("Hint"++) . shows i . (either shows (\k -> tail . shows k) eith)+instance Read Move where+ readsPrec _ str+ = let (cmd,other) = span (not.isSpace) str+ in case span (not . (`elem` "dDpP")) cmd of+ (tk, d:dr) | all (not.isAlphaNum) tkdr && null (drop 1 $ group tkdr) -> [((if toLower d == 'd' then Drop else Play) $ length tk, other)] + where tkdr = tk++dr+ _ -> case span isAlpha str of+ (kw, xs) | kwl `isPrefixOf` "hint" -> parseHint xs -- Since kwl can be "", "11" parses as "Hint11".+ | kwl `isPrefixOf` "drop" -> [(Drop i, rest) | (i, rest) <- reads xs]+ | kwl `isPrefixOf` "play" -> [(Play i, rest) | (i, rest) <- reads xs]+ where kwl = map toLower kw+ _ -> []+ where parseHint xs = [(Hint i eith, rest) | let (istr, ys) = splitAt 1 $ dropWhile isSpace xs -- These two lines is similar to @(i, ys) <- reads xs@,+ , (i, _) <- reads istr -- but additionally accepts something like "hint12".+ , let ys' = dropWhile isSpace ys+ , (eith, rest) <- [ (Left c, zs) | (c,zs) <- readsColorChar ys' ] ++ [ (Right c, zs) | (c,zs) <- readsNumberChar ys' ] ]++-- | The help text.+help :: String+help = "`Play0', `play0', `P0', `p0', etc. ... play the 0th card from the left (0-origin).\n"+ ++"`Drop1', `drop1', `D1', `d1', etc. ... drop the 1st card from the left (0-origin).\n"+ ++"`Hint2W', `hint2w', `h2w', `H2W', `2w', etc. ... tell the White card(s) of the 2nd next player.\n"+ ++"`Hint14', `h14', `H14', `14', etc. ... tell the Rank-4 card(s) of the next player.\n"+ ++"`---P-', `@@@p@', `___P', `...p', etc. ... play the 3rd card from the left (0-origin). Letters other than p or P must not be alphanumeric. Also note that just `p' or `P' means playing the 0th card.\n"+ ++"`D////', `d~~~~', `D', `d', etc. ... drop the 0th card from the left (0-origin). Letters other than d or D must not be alphanumeric.\n"++-- | 'Rule' is the datatype representing the game variants.+--+-- [Minor remark] When adopting Variant 4, that is, the rule of continuing even after a round after the pile is exhausted, there can be a situation where a player cannot choose any valid move, because she has no card and there is no hint token.+-- This can happen, after one player (who has no critical card) repeats discarding, and other players repeat hinting each other, consuming hint tokens.+-- Seemingly, the rule book does not state what happens in such a case, but I (Susumu) believe the game should end as failure, then, because+--+-- * This situation can easily be made, and easily be avoided;+--+-- * If deadline is set up, this should cause time out;+--+-- * When Variant 4 is adopted, the game must end with either the perfect game or failure.+--+-- 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]++repeat 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.+ , numMulticolors :: [Int] -- ^ number of each of multicolor cards. @[3,2,2,2,1]@ for normal and Variant 1 (and Variant 3?), and @[1,1,1,1,1]@ for Variant 2.++-- x , multicolor :: Bool -- ^ multicolor play, or Variant 3+ } deriving (Show, Read)++-- | @defaultRule@ is the normal rule from the rule book of the original card game Hanabi.+defaultRule = R { numBlackTokens = 3+ , funPlayerHand = [5,5]++repeat 4+ , numColors = 5+ , prolong = False+ , numMulticolors = replicate 5 0+-- x , multicolor = False+ }+defaultGS = GS{numPlayers=2, rule=defaultRule}+initialPileNum gs = sum (take (numColors $ rule gs) $ [10,10,10,10,10]++[sum (numMulticolors $ rule gs)])+ - numPlayerHand gs * numPlayers gs+numPlayerHand gs = funPlayerHand (rule gs) !! (numPlayers gs - 2)+data GameSpec = GS {numPlayers :: Int, rule :: Rule} deriving (Read, Show)++-- | State consists of all the information of the current game state, including public info, private info, and the hidden deck.+data State = St { publicState :: PublicInfo+ , pile :: [Card] -- ^ invisible card pile or deck.+ , hands :: [[Card]] -- ^ partly invisible list of each player's hand.+ -- In the current implementation (arguably), this represents [current player's hand, next player's hand, second next player's hand, ...]+ -- and this is rotated every turn.+ } deriving (Read, Show)++-- | PublicInfo is the info that is available to all players.+data PublicInfo = PI { gameSpec :: GameSpec+ , pileNum :: Int -- ^ The number of cards at the pile.+ , played :: IM.IntMap Number -- ^ @'Color' -> 'Number'@. The maximum number of successfully played cards of etch number.++ -- Just a list with length 5 or 6 could do the job.+ , discarded :: IM.IntMap Int -- ^ @'Card' -> Int@. The multiset of discarded cards.++ , nonPublic :: IM.IntMap Int -- ^ @'Card' -> Int@. The multiset of Cards that have not been revealed to the public.+ -- This does not include cards whose Color and Number are both revealed.+ --+ -- This is redundant information that can be computed from 'played' and 'discarded'.+ , turn :: Int -- ^ How many turns have been completed since the game started. This can be computed from 'pileNum', 'deadline', and @map length 'givenHints'@.+ , lives :: Int -- ^ The number of black tokens. decreases at each failure+ , hintTokens :: Int -- ^ The number of remaining hint tokens.++-- , numHandCards :: [Int] -- the number of cards each player has. This was used by isMoveValid, but now abolished because @numHandCards == map length . givenHints@.+ , deadline :: Maybe Int -- ^ The number of turns until the endgame, after the pile exhausted. @Nothing@ when @pileNum > 0@.+ , givenHints :: [[(Maybe Color, Maybe Number)]]+ -- ^ The Number and Color hints given to each card in each player's hand.++ -- Negative hints should also be implemented, but they should be kept separate from givenHints,+ -- in order to guess the behavior of algorithms that do not use such information.+ , result :: Result -- ^ The result of the last move. This info may be separated from 'PublicInfo' in future.+ } deriving (Read, Show)++-- | '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)++-- 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.+-- Algorithms that want updated info could implement the functionality for themselves.++-- 特にStateのHistoryについて語る場合、捨てたりplayすることでカードの内容が明らかになり、「そのカードについてそういうヒントを出したからには」みたいな推論ができるようになる。ので、単にStateを積み重ねていくのではなく、どんどん更新していくべきか？でも、「こいつは知らないはずだからこういうヒントを出した」みたいなこともありえるわけで、更新すればいいってものでもない。まあ、そういうのがよく出てくるのはmulticolorの場合だが。+-- てか、Historyのupdateを行う関数をcomponent libraryにいれとけばよいだけ。+-- | PrivateView is the info that is available to the player that has @head 'hands'@.+data PrivateView = PV { publicView :: PublicInfo+ , handsPV :: [[Card]] -- ^ Other players' hands. [next player's hand, second next player's hand, ...]+ -- This is based on the viewer's viewpoint (unlike 'hands' which is based on the current player's viewpoint),+ -- and the view history @[PrivateView]@ must be from the same player's viewpoint (as the matter of course).+ , invisibleBag :: IM.IntMap Int -- ^ @'Card' -> Int@. This represents the bag of unknown cards (which are either in the pile or in the player's hand).+ -- This can be computed from publicView and handsSV.+ } deriving (Read, Show)+prettyPV pv@PV{publicView=pub} = prettyPI pub ++ "\nMy hand:\n"+ ++ concat (replicate (length myHand) " __") ++ "\n"+ ++ concat (replicate (length myHand) "|**") ++ "|\n|"+ ++ showHintLine myHand ++ "\n"+ -- x ++ concat (replicate (length myHand) " ~~") ++ "\n"+ ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ]+ ++ concat (zipWith3 (prettyHand ithPlayer $ numPlayers $ gameSpec $ pub) [1..] (handsPV pv) $ tail $ givenHints pub)+ where myHand = head (givenHints pub)+prettySt ithP st@St{publicState=pub} = prettyPI pub ++ concat (zipWith3 (prettyHand ithP $ numPlayers $ gameSpec $ pub) [0..] (hands st) $ givenHints pub)+prettyHand :: (Int->Int->String) -> Int -> Int -> [Card] -> [(Maybe Color, Maybe Number)] -> String+prettyHand ithP numP i cards hl = "\n\n" ++ ithP numP i ++ " hand:\n"+ ++ concat (replicate (length cards) " __") ++ " \n"+ ++ concat [ '|':show card | card <- cards ] ++"|\n|"+ ++ showHintLine hl ++ "\n"+ ++ concat (replicate (length cards) "+--")++showHintLine :: [(Maybe Color, Maybe Number)] -> String+showHintLine hl = concat [ maybe ' ' (head . show) mc : maybe ' ' (head . show . fromEnum) mk : "|" | (mc,mk) <- hl]++prettyPI pub+{- This was too verbose+ = let+ showDeck 0 = "no card at the deck (the game will end in " ++ shows (fromJust $ deadline pub) " turn(s)), "+ showDeck 1 = "1 card at the deck, "+ showDeck n = shows n " cards at the deck, "+ in "Turn "++ shows (turn pub) ": " ++ showDeck (pileNum pub) ++ shows (lives pub) " live(s) left, " ++ shows (hintTokens pub) " hint tokens;\n\n"+-}+ = let+ showDeck 0 = "Deck: 0 (" ++ shows (fromJust $ deadline pub) " turn(s) left), "+ showDeck 1 = "Deck: 1, "+ showDeck n = "Deck: " ++ shows n ", "+ in "Turn: "++ shows (turn pub) ", " ++ showDeck (pileNum pub) ++ "Lives: " ++ shows (lives pub) ", Hints: " ++ shows (hintTokens pub) ";\n\n"+ ++ "played:" ++ concat [ " " ++ concat [ show $ C c k | k <- [K1 .. playedMax]] | c <- [White .. Multicolor], Just playedMax <- [IM.lookup (fromEnum c) (played pub)] ]+ ++ "\ndropped: " ++ concat [ '|' : concat (replicate n $ show $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ] ++"|\n"++view :: State -> PrivateView+view st = PV {publicView = publicState st,+ handsPV = tail $ hands st,+ invisibleBag = foldr (IM.update (Just . pred)) (nonPublic $ publicState st) $ map cardToInt $ concat $ tail $ hands st}++-- 自分のturnが来た時のstateのhistoryだけでは不十分で、他の各playerのturnでのStateがわからないと、そのplayerがどういうMoveを選んだのかわからない。+-- てか、Stateだけでなく必ずMoveの情報は必要。Hint moveの場合、Stateは変化しない。変化するようにHintをメモったものをStateにするにしても、すでにわかっているものを敢えてHintし直す、というconventionをやったときにどういうHintかわからない（ので、Hatみたいな感じで意味をもたせられない）+-- まあ、Hanabi Learning Environmentがそのへんをちゃんと考えているかしらないが、でもまあHatを実装しているはずなので大丈夫だろう。+main = selfplay defaultGS++-- | 'selfplay' starts selfplay with yourself:)+--+-- Also, @selfplay defaultGS{numPlayers=n}@ (where 1<n<10} starts selfplay with youselves:D+selfplay gs+ = do g <- newStdGen+ ((finalSituation,_),_) <- start gs [stdio] g+ putStrLn $ prettyEndGame finalSituation++-- | 'prettyEndGame' can be used to pretty print the final situation.+prettyEndGame (eg,sts@(st:_),mvs)+ = unlines $ recentEvents ithPlayerFromTheLast (map view sts) mvs :+ replicate 80 '!' :+ surround (replicate 40 '!') (show eg) :+ replicate 80 '!' :+ map (surround $ replicate 38 ' ' ++"!!") (lines $ prettySt ithPlayerFromTheLast st) +++ [ replicate 80 '!' ]+surround ys xs = let len = length xs+ len2 =len `div` 2+ in reverse (drop len2 ys) ++ xs ++ drop (len - len2) ys++-- | 'start' creates and runs a game. This is just the composition of createGame and run.+start :: (RandomGen g, Monad m, Strategies ps m) =>+ GameSpec -> ps -> g -> m (((EndGame, [State], [Move]), ps), g)+start gs players gen = let+ (st, g) = createGame gs gen+ in fmap (\e -> (e,g)) $ run [st] [] players+run :: (Monad m, Strategies ps m) => [State] -> [Move] -> ps -> m ((EndGame, [State], [Move]), ps)+run states moves players = do ((mbeg, sts, mvs), ps) <- runARound (\sts@(st:_) mvs -> let myOffset = turn (publicState st) in broadcast (zipWith rotate [-myOffset, 1-myOffset ..] sts) mvs players >> return ()) states moves players+ case mbeg of Nothing -> run 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+ -- | 'strategyName' is just the name of the strategy. The designer of the instance should choose one.+ strategyName :: m p -> m String++ -- | 'move' is the heart of the strategy. It takes the history of observations and moves, and selects a 'Move'.+ -- Because the full history is available, your algorithm can be stateless, but still there is the option to design it in the stateful manner.+ move :: [PrivateView] -- ^ The history of 'PrivateView's, new to old.+ -> [Move] -- ^ The history of 'Move's, new to old.+ -> p -- ^ The strategy's current state. This can be isomorphic to @()@ if the strategy does not have any parameter.+ -> m (Move, p) -- ^ 'move' returns the pair of the Move and the next state, wrapped with monad m that is usually either IO or Identity.+ -- The next state can be the same as the current one unless the algorithm is learning on-line during the game.++ -- | 'observe' is called during other players' turns. It allows (mainly) human players to think while waiting.+ --+ -- It is arguable whether algorithms running on the same machine may think during other players' turn, especially when the game is timed.+ observe :: [PrivateView] -- ^ The history of 'PrivateView's, new to old.+ -> [Move] -- ^ The history of 'Move's, new to old.+ -> p -- ^ The strategy's current state. This can be isomorphic to @()@ if the strategy does not have any parameter.+ -> m ()+ observe _pvs _moves st = return () -- The default does nothing.+{-+ -> m ((), p) -- ^ 'observe' returns the next state, wrapped with monad m that is usually either IO or Identity.+ -- The next state can be the same as the current one unless the algorithm is learning on-line during the game.+ observe _pvs _moves st = return ((),st) -- The default does nothing.+-}++-- | The 'Strategies' class defines the list of 'Strategy's. If all the strategies have the same type, one can use the list instance.+-- I (Susumu) guess that in most cases one can use 'Dynamic' in order to force the same type, but just in case, the tuple instance is also provided. (Also, the tuple instance should be more handy.)+--+-- The strategies are used in order, cyclically.+-- The number of strategies need not be the same as 'numPlayers', though the latter should be a divisor of the former.+-- For normal play, they should be the same. +-- If only one strategy is provided, that means selfplay, though this is not desired because all the hidden info can be memorized. (In order to avoid such cheating, the same strategy should be repeated.)+-- If there are twice as many strategies as 'numPlayers', the game will be "Pair Hanabi", like "Pair Go" or "Pair Golf" or whatever. (Maybe this is also interesting.)+class Strategies ps m where+ runARound :: ([State] -> [Move] -> m ()) -> [State] -> [Move] -> ps -> m ((Maybe EndGame, [State], [Move]), ps)+ broadcast :: [State] -> [Move] -> ps -> m [State]+{- Abolished in order to avoid confusion due to overlapping instances. When necessary, use a singleton list instead.+instance {-# OVERLAPS #-} (Strategy p1 m, Monad m) => Strategies p1 m where+ runARound states moves p = runATurn states moves p+-}+instance (Strategies p1 m, Strategies p2 m, Monad m) => Strategies (p1,p2) m where+ runARound hook states moves (p,ps) = runARound hook states moves p >>= \(tup@(mbeg,sts,mvs), p') -> case mbeg of+ Nothing -> do (tups,ps') <- runARound hook sts mvs ps+ return (tups, (p',ps'))+ _ -> return (tup, (p',ps))+ broadcast states moves (p1,p2) = do sts <- broadcast states moves p1+ broadcast sts moves p2+instance (Strategy p m, Monad m) => Strategies [p] m where+-- runARound hook states moves [] = return ((Nothing, states, moves), [])+ runARound hook states moves [] = error "It takes at least one algorithm to play Hanabi!"+ runARound hook states moves [p] = hook states moves >> runATurn states moves p >>= \(tup, p') -> return (tup, [p'])+ runARound hook states moves (p:ps) = hook states moves >> runATurn states moves p >>= \(tup@(mbeg,sts,mvs), p') -> case mbeg of + Nothing -> do (tups,ps') <- runARound hook sts mvs ps+ return (tups, (p':ps'))+ _ -> return (tup, (p':ps))+ broadcast _ _ [] = error "It takes at least one algorithm to play Hanabi!"+ broadcast states moves [p] = observe (map view states) moves p >> return (map (rotate 1) states)+ broadcast states moves (p:ps) = observe (map view states) moves p >> broadcast (map (rotate 1) states) moves ps++runATurn :: (Strategy p m, Monad m) => [State] -> [Move] -> p -> m ((Maybe EndGame, [State], [Move]), p)+runATurn states moves p = let alg = move (map view $ zipWith rotate [0..] states) moves p in+ do (mov, p') <- alg+ case proceed (head states) mov of+ Nothing -> do name <- strategyName (fmap snd alg)+ error $ show mov ++ " by " ++ name ++ ": invalid move!" -- 'strategyName' exists in order to blame stupid algorithms:) + -- (but seriously, this could end with failure. There is a safety net for human players.)+ Just st -> let nxt = rotate 1 st+ in return ((checkEndGame $ publicState nxt, nxt:states, mov:moves), p')++-- | Verbose makes a player verbose. It is useful to monitor the viewpoint of a specific player.+newtype Verbose p = Verbose {unV :: p} deriving (Read, Show)+instance (Strategy p m, MonadIO m) => Strategy (Verbose p) m where+ strategyName mp = do name <- strategyName $ fmap unV mp+ return $ if name == "Blind" then "STDIO" else "Verbose " ++ name+ move views@(v:_) moves (Verbose p) = let alg = move views moves p in+ do name <- strategyName (fmap (Verbose . snd) alg)+ liftIO $ putStrLn $ what'sUp name views moves+ (mv,p') <- alg+ -- liftIO $ putStrLn $ "Move is " ++ show mv -- This is redundant because of echo back.+ return (mv, Verbose p')+ observe _ [] _ = return ()+ observe (v:_) (m:_) _ = liftIO $ putStrLn $ what'sUp1 v m++what'sUp name views@(v:_) moves = replicate 20 '-' ++ '\n' :+ recentEvents ithPlayer views moves ++ '\n' :+ replicate 20 '-' ++ '\n' :+ "Algorithm: " ++ name ++ '\n' :+ prettyPV v ++ '\n' : "Your turn.\n"+what'sUp1 v m = replicate 20 '-' ++ '\n' :+ showTrial (const "") undefined v m ++ '\n' :+ replicate 20 '-' ++ '\n' :+ prettyPV v++recentEvents ithP vs@(v:_) ms = unlines $ reverse $ zipWith3 (showTrial $ ithP nump) [pred nump, nump-2..0] vs ms+ where nump = numPlayers $ gameSpec $ publicView v++showTrial ithP i v m = ithP i ++ " move: " ++ replicate (length (ithP 2) - length (ithP i)) ' ' ++ show m +++ case result $ publicView v of Discard c -> ", which revealed "++shows c "."+ Success c -> ", which succeeded revealing "++shows c "."+ Fail c -> ", which failed revealing " ++ shows c "."+ _ -> "."++ithPlayer _ 0 = "My"+ithPlayer _ i = "The " ++ ith i ++"next player's"+ith 1 = ""+ith 2 = "2nd "+ith 3 = "3rd "+ith i = shows i "th "+ithPlayerFromTheLast nump j = "The " ++ ith (nump-j) ++"last player's"++type STDIO = Verbose Blind+stdio = Verbose Blind+data Blind = Blind+instance (MonadIO m) => Strategy Blind m where+ strategyName p = return "Blind"+ move (v:_) _ _ = do mov <- liftIO $ repeatReadingAMoveUntilSuccess stdin stdout v+ return (mov, Blind)+data ViaHandles = VH {hin :: Handle, hout :: Handle}+instance (MonadIO m) => Strategy ViaHandles m where+ strategyName p = return "via handles"+ move views@(v:_) moves vh = liftIO $ do hPutStrLn (hout vh) $ what'sUp "via handles" views moves+ mov <- repeatReadingAMoveUntilSuccess (hin vh) (hout vh) v+ return (mov, vh)++repeatReadingAMoveUntilSuccess :: Handle -> Handle -> PrivateView -> IO Move+repeatReadingAMoveUntilSuccess hin hout v = do+ str <- hGetLine hin+ 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+ where splitCons 0 hnds stack+ = (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],+ k <- [K1 ..K5] ],+ nonPublic = cardMap $ rule gs,+ turn = 0,+ lives = numBlackTokens $ rule gs,+ hintTokens = 8,+ deadline = Nothing,+ givenHints = replicate (numPlayers gs) $ replicate (numPlayerHand gs) (Nothing, Nothing),+ 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+numAssoc = zip [K1 ..K5] [3,2,2,2,1]+cardAssoc :: Rule -> [(Card,Int)]+cardAssoc rule = take (5 * numColors rule) $+ [ (C i k, n) | i <- [White .. pred Multicolor], (k,n) <- numAssoc ] ++ [ (C Multicolor k, n) | (k, n) <- zip [K1 ..K5] (numMulticolors rule) ]+cardBag rule = concat [ replicate n c | (c,n) <- cardAssoc rule ]+cardMap rule = IM.fromList [ (cardToInt c, n) | (c,n) <- cardAssoc rule ]++shuffle :: RandomGen g => [Card] -> g -> ([Card], g)+shuffle xs = shuf [] xs $ length xs+shuf result _ 0 gen = (result, gen)+shuf result xs n gen = let (i, g) = randomR (0, pred n) gen+ (nth,rest) = pickNth i xs+ in shuf (nth:result) rest (pred n) g++-- | 'isMoveValid' can be used to check if the candidate Move is compliant to the rule under the current situation. Each player can decide it based on the current 'PrivateView' (without knowing the full state).+isMoveValid :: PrivateView -> Move -> Bool+isMoveValid PV{publicView=pub} (Drop ix) = hintTokens pub < 8 && length (head $ givenHints pub) > ix && ix >= 0+isMoveValid PV{publicView=pub} (Play ix) = length (head $ givenHints pub) > ix && ix >= 0+isMoveValid PV{publicView=pub,handsPV=tlHands} (Hint hintedpl eck)+ = hintTokens pub > 0 &&+ hintedpl > 0 && hintedpl < numPlayers (gameSpec pub) && -- existing player other than the current+ not (null $ filter willBeHinted (tlHands !! pred hintedpl))+ where willBeHinted :: Card -> Bool+ willBeHinted = either (\c -> (==c).color) (\k -> (==k).number) eck+pickNth n xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++dr)+replaceNth n x xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++x:dr) -- = updateNth n (const x) xs+updateNth n f xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++f nth:dr)++-- | 'proceed' updates the state based on the current player's Move, without rotating.+proceed :: State -> Move -> Maybe State+proceed st@(St{publicState=pub@PI{gameSpec=gS}}) mv = if (isMoveValid (view st) mv) then return (prc mv) else Nothing where++ -- only used by Drop and Play+ (nth, droppedHand) = pickNth (index mv) playersHand where playersHand = head $ hands st+ (_ , droppedHint) = pickNth (index mv) playersHint where playersHint = head $ givenHints pub+ (nextHand,nextHint,nextPile, nextPileNum) = case pile st of [] -> (droppedHand, droppedHint, [], 0)+ d:ps -> (d:droppedHand, (Nothing,Nothing):droppedHint, ps, pred $ pileNum pub)+ nextHands = nextHand : tail (hands st)+ nextHints = nextHint : tail (givenHints pub)+ prc (Drop _) = st{pile = nextPile,+ hands = nextHands,+ publicState = pub{pileNum = nextPileNum,+ discarded = IM.update (Just . succ) (cardToInt nth) $ discarded pub,+ nonPublic = IM.update (Just . pred) (cardToInt nth) $ nonPublic pub,+ turn = succ $ turn pub,+ hintTokens = succ $ hintTokens pub,+ givenHints = nextHints,+ deadline = case deadline pub of Nothing | nextPileNum==0 -> Just $ numPlayers gS+ | otherwise -> Nothing+ Just i -> Just $ pred i,+ result = Discard nth}}+ prc (Play i) | failure = let newst@St{publicState=newpub} = prc (Drop i) in newst{publicState=newpub{hintTokens = hintTokens pub, lives = pred $ lives pub, result = Fail nth}}+ | otherwise = st{pile = nextPile,+ hands = nextHands,+ publicState = pub{pileNum = nextPileNum,+ played = IM.update (Just . succ) (fromEnum $ color nth) (played pub),+ nonPublic = IM.update (Just . pred) (cardToInt nth) $ nonPublic pub,+ turn = succ $ turn pub,+ hintTokens = if hintTokens pub < 8 && number nth == K5 then succ $ hintTokens pub else hintTokens pub,+ givenHints = nextHints,+ deadline = case deadline pub of Nothing | nextPileNum==0 -> Just $ numPlayers gS+ | otherwise -> Nothing+ Just i -> Just $ pred i,+ result = Success nth}}+ where failure = played pub IM.! fromEnum (color nth) /= pred (number nth)+ prc (Hint hintedpl eik) = st{publicState = pub{hintTokens = pred $ hintTokens pub,+ turn = succ $ turn pub,+ givenHints = snd $ updateNth hintedpl newHints (givenHints pub),+ deadline = case deadline pub of Nothing | pileNum pub==0 -> Just $ numPlayers gS+ | otherwise -> Nothing+ Just i -> Just $ pred i,+ result = None}}+ where newHints hs = zipWith zipper (hands st !! hintedpl) hs+ zipper (C ir ka) (mi,mk) = case eik of Left i | i==ir -> (Just i, mk)+ Right k | k==ka -> (mi, Just k)+ _ -> (mi, mk)++-- | @'rotate' num@ rotates the first person by @num@ (modulo the number of players).+rotate :: Int -> State -> State+rotate num st@(St{publicState=pub@PI{gameSpec=gS}}) = st{hands = rotateList $ hands st,+ publicState = pub{givenHints = rotateList $ givenHints pub}}+ where rotateList xs = case splitAt (num `mod` numPlayers gS) xs of (tk,dr) -> dr++tk++-- | '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)++checkEndGame :: PublicInfo -> Maybe EndGame+checkEndGame pub | lives pub == 0 = Just Failure+ | all (==Just K5) $ map (\k -> IM.lookup (fromEnum k) (played pub)) $ take (numColors $ rule $ gameSpec pub) [White .. Multicolor] = Just Perfect+ | deadline pub == Just 0 = Just $ Soso $ IM.foldr (+) 0 $ fmap fromEnum $ played pub+ | hintTokens pub == 0 && null (head $ givenHints pub) = Just Failure -- No valid play is possible for the next player. This can happen when prolong==True.+ | otherwise = Nothing
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Susumu Katayama++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Susumu Katayama nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hanabi-dealer.cabal view
@@ -0,0 +1,78 @@+-- Initial hanabi-dealer.cabal generated by cabal init. For further+-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name: hanabi-dealer++-- The package version. See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- https://wiki.haskell.org/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: Hanabi card game++-- A longer description of the package.+-- description:++-- URL for the project homepage or repository.+-- homepage: http://nautilus.cs.miyazaki-u.ac.jp/~skata/Sontakki/Hanabi.html++-- The license under which the package is released.+license: BSD3++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Susumu Katayama++-- An email address to which users can send suggestions, bug reports, and+-- patches.+maintainer: Susumu Katayama <skata@cs.miyazaki-u.ac.jp>++-- A copyright notice.+-- copyright:++category: Game++build-type: Simple++-- Extra files to be distributed with the package, such as examples or a+-- README.+extra-source-files: ChangeLog.md++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.10++-- Flag SNAP+-- Description: Use Snap instead of runServer+-- Default: True++library+ -- Modules exported by the library.+ exposed-modules: Game.Hanabi+ -- , Game.Hanabi.Backend++ -- Modules included in this library but not exported.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ other-extensions: MultiParamTypeClasses, FlexibleInstances, Safe+ -- , CPP, TupleSections, NoOverlappingInstances++ -- Other library packages from which modules are imported.+ build-depends: base >=4.8 && <4.12, containers >=0.5, random >=1.1++ -- Directories containing source files.+ -- hs-source-dirs:++ -- Base language which the package is written in.+ default-language: Haskell2010++ -- if flag(SNAP)+ -- build-depends: network >=3.1 && <3.2, websockets >=0.12 && <0.13, time >=1.6 && <1.7, unix >=2.7 && <2.8, websockets-snap >=0.10 && <0.11, snap-server >=1.1 && <1.2, network >=2.6 && <2.7, abstract-par >=0.3 && <0.4, monad-par >=0.3 && <0.4+ -- cpp-options: -DSNAP