hanabi-dealer 0.7.2.0 → 0.8.0.0

raw patch · 11 files changed

+234/−170 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• Game/Hanabi.hs +89/−85
• Game/Hanabi/Backend.lhs +10/−9
• Game/Hanabi/Client.hs +33/−29
• Game/Hanabi/Msg.hs +2/−2
• Game/Hanabi/Strategies/SimpleStrategy.hs +35/−38
• Game/Hanabi/Strategies/StatefulStrategy.hs +45/−0
• all.hs +3/−1
• client.hs +3/−1
• hanabi-dealer.cabal +4/−4
• server.hs +3/−1

@@ -1,5 +1,12 @@ 	# Revision history for hanabi-dealer +	## 0.8.0.0 -- 2020-04-11++	* assign unique numbers to cards on the deck.+	  This changes the API and the communication protocol.++	* client prints the deck at endgames+ 	## 0.7.2.0 -- 2020-04-02  	* make SimpleStrategy less stupid, more fun to play with

@@ -13,13 +13,15 @@               -- ** The Game State and Interaction History               Move(..), Index, State(..), PrivateView(..), PublicInfo(..), Result(..), EndGame(..),               -- ** The Cards-              Card(..), Color(..), Number(..), Marks, Possibilities, cardToInt, intToCard, readsColorChar, readsNumberChar,+              Card(..), Color(..), Number(..), Marks, Possibilities, Annotation(..), cardToInt, intToCard, readsColorChar, readsNumberChar,               -- * 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,               tryMove, (|||), ifA,+              -- ** Legacy functions+              givenHints, possibilities_until_Ver0720,               -- ** Minor ones               what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, prettySt, ithPlayerFromTheLast, view, replaceNth, shuffle, showPossibilities, showColorPossibilities, showNumberPossibilities, showTrial, showDeck) where -- module Hanabi where@@ -30,7 +32,7 @@ import Control.Monad.IO.Class(MonadIO, liftIO) import Data.Char(isSpace, isAlpha, isAlphaNum, toLower, toUpper) import Data.Maybe(fromJust)-import Data.List(isPrefixOf, group, zipWith4)+import Data.List(isPrefixOf, group) import System.IO import Data.Dynamic import Data.Bits hiding (rotate)@@ -48,14 +50,16 @@                            Just i  -> [(i, str)] readsColorChar [] = [] readsNumberChar :: ReadS Number-readsNumberChar ('0':rest) = [(Empty,rest)]-readsNumberChar str = reads ('K':str)+readsNumberChar xs = [ (toEnum d, rest) | (d, rest) <- reads xs, d<=5 ]  data Card = C {color :: Color, number :: Number} deriving (Eq, Generic) instance Show Card where   showsPrec _ (C color number) = (head (show color) :) . (show (fromEnum number) ++)+  showList = foldr (.) id . map shows instance Read Card where   readsPrec _ str = [(C i k, rest) | (i, xs) <- readsColorChar str, (k, rest) <- readsNumberChar xs]+  readList xs = case reads xs of []       -> [([],xs)]+                                 [(c,ys)] -> [ (c:cs, zs) | (cs,zs) <- readList ys ] cardToInt :: Card -> Int cardToInt c = fromEnum (color c) * (succ $ fromEnum (maxBound::Number)) + fromEnum (number c) intToCard :: Int -> Card@@ -149,7 +153,7 @@  -- | 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.+                , pile :: [(Card,Annotation)]    -- ^ 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.@@ -167,26 +171,36 @@                                                       --   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'@.+                     , turn      :: Int               -- ^ How many turns have been completed since the game started. This can be computed from 'pileNum', 'deadline', and @map length 'annotations'@.                      , 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@.+--                 , numHandCards :: [Int]  -- the number of cards each player has. This was used by isMoveValid, but now abolished because @numHandCards == map length . annotations@.                      , deadline   :: Maybe Int        -- ^ The number of turns until the endgame, after the pile exhausted. @Nothing@ when @pileNum > 0@.-                     , givenHints :: [[Marks]]-                                                      -- ^ 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.-                     , possibilities :: [[Possibilities]]+                     , annotations :: [[Annotation]]  -- ^ Known information for each card in each player's hand.                      , result :: Result               -- ^ The result of the last move. This info may be separated from 'PublicInfo' in future.                      } deriving (Read, Show, Eq, Generic) +givenHints :: PublicInfo -> [[Marks]]+givenHints = map (map marks) . annotations+possibilities_until_Ver0720 :: PublicInfo -> [[Possibilities]]+possibilities_until_Ver0720 = map (map possibilities) . annotations+ -- | 'Marks' is the type synonym representing the hint trace of a card. type Marks = (Maybe Color, Maybe Number) +-- | 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) +data Annotation = Ann {ixDeck :: Int                   -- ^ Index in the initial deck+                      , marks :: Marks                 -- ^ The Number and Color hints given to the card.+                      , possibilities :: Possibilities}+  deriving (Eq, Generic)+instance Show Annotation where+  showsPrec p (Ann i ms ps) = showsPrec p (i,ms,ps)+instance Read Annotation where+  readsPrec p str = [ (Ann i ms ps, rest) | ((i,ms,ps), rest) <- readsPrec p str ]+   -- | the best achievable rank for each color. bestPossibleRank :: PublicInfo -> Color -> Number bestPossibleRank pub iro = toEnum $ length $ takeWhile (/=0) $ zipWith subtract (numEachCard (gameSpec pub) iro)@@ -231,32 +245,32 @@ isObviouslyUnplayable :: PublicInfo -> Possibilities -> Bool isObviouslyUnplayable = obviously (\pub -> not . isPlayable pub) -definitely :: (PrivateView -> Card -> Bool) -> PrivateView -> Marks -> Possibilities -> Bool-definitely predicate pv marks pos = all (predicate pv) $ possibleCards pv marks pos+definitely :: (PrivateView -> Card -> Bool) -> PrivateView -> Annotation -> Bool+definitely predicate pv ann = all (predicate pv) $ possibleCards pv ann  -- | In addition to 'isObviouslyPlayable', 'isDefinitelyPlayable' also looks at other players' hand and decides if the card is surely playable. {- This is a weaker version not looking into the possibilities. isDefinitelyPlayable :: PrivateView -> Marks -> Bool isDefinitelyPlayable pv = iOP (invisibleBag pv) (publicView pv) -}-isDefinitelyPlayable :: PrivateView -> Marks -> Possibilities -> Bool+isDefinitelyPlayable :: PrivateView -> Annotation -> Bool isDefinitelyPlayable = definitely (isPlayable . publicView) -isDefinitelyUnplayable :: PrivateView -> Marks -> Possibilities -> Bool+isDefinitelyUnplayable :: PrivateView -> Annotation -> Bool isDefinitelyUnplayable = definitely (\pv -> not . isPlayable (publicView pv))  -- | Unlike 'isDefinitelyUseless', 'isDefinitelyUnciritical' does not care whether the card is the last one or not. 'isDefinitelyUncritical' is, in other words, safe to drop.-isDefinitelyUncritical :: PrivateView -> Marks -> Possibilities -> Bool+isDefinitelyUncritical :: PrivateView -> Annotation -> Bool isDefinitelyUncritical = definitely (\pv -> not . isCritical (publicView pv))  -- | If all of your cards are marked and not safe to drop, and you do not have enough hint token, one option is to drop a card that can be uncritical. (You can then assign them a priority order.) --   [NB: Maybe this is not a good idea. E.g. when the other player draws the last W2 to fully-marked [R5,G5,B5,Y5], we usually mark 2 to give up a 5, but if the player does not guess the intention and resort the above option, W2 is dropped.]-isDefinitelyCritical :: PrivateView -> Marks -> Possibilities -> Bool+isDefinitelyCritical :: PrivateView -> Annotation -> Bool isDefinitelyCritical = definitely (\pv -> isCritical $ publicView pv) -possibleCards :: PrivateView -> Marks -> Possibilities -> [Card] -possibleCards pv (Just c, Just n) _       = [C c n] -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible.-possibleCards pv _                (pc,pn) = [ card | color <- colorPossibilities pc, number <- numberPossibilities pn, let card = C color number, (invisibleBag pv IM.! cardToInt card) /= 0 ]+possibleCards :: PrivateView -> Annotation -> [Card]+possibleCards pv Ann{marks = (Just c, Just n)} = [C c n] -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible.+possibleCards pv Ann{possibilities = (pc,pn)}  = [ card | color <- colorPossibilities pc, number <- numberPossibilities pn, let card = C color number, (invisibleBag pv IM.! cardToInt card) /= 0 ]                             where pub = publicView pv  iOP :: IM.IntMap Int -> PublicInfo -> (Maybe Color, Maybe Number) -> Bool@@ -274,7 +288,7 @@ isObviouslyUseless :: PublicInfo -> Possibilities -> Bool isObviouslyUseless = obviously (\pub (C c n) -> n <= achievedRank pub c || bestPossibleRank pub c < n) -isDefinitelyUseless :: PrivateView -> Marks -> Possibilities -> Bool+isDefinitelyUseless :: PrivateView -> Annotation -> Bool isDefinitelyUseless = definitely (\pv -> isUseless (publicView pv))  {- This is a weaker version not looking into the possibilities.@@ -292,25 +306,25 @@ choppiri = reverse . filter (not . isHinted . snd) . zip [0..]  -- | In addition to 'choppiri', 'definiteChopss' and 'obviousChopss' consider 'isDefinitelyUseless' and 'isObviouslyUseless' respectively. Since "from which card to drop among obviously-useless cards" depends on conventions, cards with the same uselessness are wrapped in a list within the ordered list.-definiteChopss :: PrivateView -> [Marks] -> [Possibilities] -> [[Index]]-definiteChopss pv hls ps = (if null useless then id else (useless :)) $ map ((:[]) . fst) (choppiri hls)-   where useless = map fst $ filter (uncurry (isDefinitelyUseless pv) . snd) (zip [0..] $ zip hls ps)-obviousChopss :: PublicInfo -> [Marks] -> [Possibilities] -> [[Index]]-obviousChopss pub hls ps = (if null useless then id else (useless :)) $ map ((:[]) . fst) (choppiri hls)-   where useless = map fst $ filter (isObviouslyUseless pub . snd) (zip [0..] ps)+definiteChopss :: PrivateView -> [Annotation] -> [[Index]]+definiteChopss pv anns = (if null useless then id else (useless :)) $ map (:[]) $ filter (`notElem` useless) $ map fst (choppiri $ map marks anns)+   where useless = map fst $ filter (isDefinitelyUseless pv . snd) (zip [0..] anns)+obviousChopss :: PublicInfo -> [Annotation] -> [[Index]]+obviousChopss pub anns = (if null useless then id else (useless :)) $ map (:[]) $ filter (`notElem` useless) $ map fst (choppiri $ map marks anns)+   where useless = map fst $ filter (isObviouslyUseless pub . snd) (zip [0..] $ map possibilities anns) -- | 'chops' is the flattened version of 'obviousChopss'-chops :: PublicInfo -> [Marks] -> [Possibilities] -> [Index]-chops pub hls ps = concat $ map reverse $ obviousChopss pub hls ps+chops :: PublicInfo -> [Annotation] -> [Index]+chops pub anns = concat $ map reverse $ obviousChopss pub anns -isDoubleDrop :: PrivateView -> Result -> [Index] -> (Int, Int) -> Bool-isDoubleDrop pv@PV{publicView=pub} (Discard c@C{..}) [_i] (pc,pn) = not (any (==(Just color, Just number)) myHints) &&  -- This pattern captures: the last player discards B1; I have a card which is hinted as B and 1; I don't know where the third B1 is.+isDoubleDrop :: PrivateView -> Result -> [Index] -> Annotation -> Bool+isDoubleDrop pv@PV{publicView=pub} (Discard c@C{..}) [_i] Ann{possibilities=(pc,pn)} = not (any ((==(Just color, Just number)).marks) myAnns) &&  -- This pattern captures: the last player discards B1; I have a card which is hinted as B and 1; I don't know where the third B1 is.                                                                                                                         -- This can be improved to check whether any card other than the chop is obviously the just-dropped card or not, by looking at the Possibilities.                                                                     isCritical pub c &&                                                                     color  `elem` colorPossibilities pc &&                                                                     number `elem` numberPossibilities pn &&                                                                     (invisibleBag pv IM.! cardToInt c) > 0-                                         where myHints = head $ givenHints pub-isDoubleDrop _pv _lastresult _chopset _ps = False+                                         where myAnns = head $ annotations pub+isDoubleDrop _pv _lastresult _chopset _anns = False  colors :: PublicInfo -> [Color] colors pub = take (numColors $ rule $ gameSpec pub) [minBound .. maxBound]@@ -362,37 +376,35 @@  -- | '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 | (Just c, Just n) <- head $ givenHints pub ] : hs+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  prettyPV :: Verbosity -> PrivateView -> String prettyPV v pv@PV{publicView=pub} = prettyPI pub ++ "\nYour hand:\n"-                                              ++ concat (replicate (length myHand) $ wrap "+--+") ++ "\n"---                                              ++ concat [ if markObviouslyPlayable v && isDefinitelyPlayable pv h then " _^" else " __" | h <- myHand ] ++"\n"-                                              ++ concat (replicate (length myHand) $ wrap "|**|") ++ "\n"-                                              ++ (if markHints v then showHintLine wrap myHand else "")+                                              ++ concat (replicate (length myAnn) $ wrap "+--+") ++ "\n"+--                                              ++ concat [ if markObviouslyPlayable v && isDefinitelyPlayable pv h then " _^" else " __" | h <- myAnn ] ++"\n"+                                              ++ concat (replicate (length myAnn) $ wrap "|**|") ++ "\n"+                                              ++ (if markHints v then showHintLine wrap $ map marks myAnn else "")                                      -- x         ++ concat (replicate (length myHand) " ~~") ++ "\n" -- x                                             ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length myHand] ]                                               ++ concat [ wrap $-                                                          '+':(if warnDoubleDrop v && isDoubleDrop pv (result pub) chopSet p && d `elem` chopSet then ('D':) else+                                                          '+':(if warnDoubleDrop v && isDoubleDrop pv (result pub) chopSet hp && d `elem` chopSet then ('D':) else                                                                if markChops v && d `elem` chopSet then ('X':) else shows d)-                                                                      (if markObviouslyUseless  v && isDefinitelyUseless pv h p then ".+" else-                                                                       if markObviouslyPlayable v && isDefinitelyPlayable pv h p then "^+" else "-+") | (d,h,p) <- zip3 [0..] myHand myPos ]-+                                                                      (if markObviouslyUseless  v && isDefinitelyUseless pv hp then ".+" else+                                                                       if markObviouslyPlayable v && isDefinitelyPlayable pv hp then "^+" else "-+") | (d,hp) <- zip [0..] myAnn ]                                               ++"\n"-                                              ++ (if markPossibilities v then showPosLines $ head $ possibilities pub else "")-                                              ++ concat (zipWith4 (prettyHand v pub (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (handsPV pv) (tail $ givenHints pub) (tail $ possibilities pub))++"\n"-  where myHand = head (givenHints pub)-        myPos  = head (possibilities pub)+                                              ++ (if markPossibilities v then showPosLines $ map possibilities $ head $ annotations pub else "")+                                              ++ concat (zipWith3 (prettyHand v pub (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (handsPV pv) (tail $ annotations pub))++"\n"+  where myAnn = head (annotations pub)         wrap xs | markPossibilities v = "  "++xs++" "                 | otherwise           = xs-        chopSet = concat $ take 1 $ definiteChopss pv myHand myPos+        chopSet = concat $ take 1 $ definiteChopss pv myAnn 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))+prettySt ithP st@St{publicState=pub} = prettyPI pub ++ concat (zipWith3 (prettyHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (hands st) (annotations pub)) 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"+prettyHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Card] -> [Annotation] -> String+prettyHand v pub ithPnumP i cards anns = "\n\n" ++ ithPnumP i ++ " hand:\n" --                          ++ concat (replicate (length cards) " __") ++ " \n"                           ++ concat [ wrap $                                       if markUseless v && isUseless pub card then "+..+"@@ -406,13 +418,14 @@                           ++ (if markHints v then showHintLine wrap hl else "") -- x                          ++ concat (replicate (length cards) "+--")                           ++ concat [ wrap $-                                      '+':(if markChops v && d `elem` (concat $ take 1 $ obviousChopss pub hl ps) then ('X':) else ('-':))+                                      '+':(if markChops v && d `elem` (concat $ take 1 $ obviousChopss pub anns) then ('X':) else ('-':))                                              (if markObviouslyUseless  v && isObviouslyUseless  pub h then ".+" else                                               if markObviouslyPlayable v && isObviouslyPlayable pub h then "^+" else "-+") | (d,h) <- zip [0..] ps ]++"\n"                           ++ (if markPossibilities v then showPosLines ps else "")                     where wrap xs | markPossibilities v = "  "++xs++" "                                   | otherwise           = {- take 3 -} xs-+                          hl = map marks anns+                          ps = map possibilities anns  showHintLine :: (String -> String) -> [Marks] -> String showHintLine wrapper hl = concat [ wrapper $ '|' : maybe ' ' (head . show) mc : maybe ' ' (head . show . fromEnum) mk : "|" | (mc,mk) <- hl] ++ "\n"@@ -701,7 +714,7 @@  -- | 'createGameFromCards' deals cards and creates the initial state. createGameFromCards :: GameSpec -> [Card] -> State-createGameFromCards gs = splitCons (numPlayers gs) []+createGameFromCards gs cards = splitCons (numPlayers gs) [] [ (c, Ann{ixDeck=i, marks=(Nothing, Nothing), possibilities=unknown gs}) | (c,i) <- zip cards [0..] ]            where splitCons 0 hnds stack                    = St {publicState = PI {gameSpec   = gs,                                             pileNum    = initialPileNum gs,@@ -713,12 +726,11 @@                                             lives      = numBlackTokens $ rule gs,                                             hintTokens = 8,                                             deadline   = Nothing,-                                            givenHints = replicate (numPlayers gs) $ replicate (handSize gs) (Nothing, Nothing),-                                            possibilities = replicate (numPlayers gs) $ replicate (handSize gs) (unknown gs),+                                            annotations = map (map snd) hnds,                                             result     = None                                            },                            pile  = stack,-                           hands = hnds+                           hands = map (map fst) hnds                           }                  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.@@ -750,8 +762,8 @@  -- | '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} (Drop ix) = hintTokens pub < 8 && length (head $ annotations pub) > ix && ix >= 0+isMoveValid PV{publicView=pub} (Play ix) = length (head $ annotations 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@@ -771,13 +783,11 @@    -- 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-  (_  , droppedPos)  = pickNth (index mv) playersPos  where playersPos  = head $ possibilities pub-  (nextHand,nextHint,nextPos,nextPile, nextPileNum) = case pile st of []   -> (droppedHand,   droppedHint,                   droppedPos,              [], 0)-                                                                      d:ps -> (d:droppedHand, (Nothing,Nothing):droppedHint, unknown gS : droppedPos, ps, pred $ pileNum pub)+  (_  , droppedAnn)  = pickNth (index mv) playersAnn  where playersAnn  = head $ annotations pub+  (nextHand,nextAnn,nextPile, nextPileNum) = case pile st of []   -> (        droppedHand,         droppedAnn, [], 0)+                                                             d:ps -> (fst d : droppedHand, snd d : droppedAnn, ps, pred $ pileNum pub)   nextHands = nextHand : tail (hands st)-  nextHints = nextHint : tail (givenHints pub)-  nextPoss  = nextPos  : tail (possibilities pub)+  nextAnns  = nextAnn : tail (annotations pub)   nextDeadline = case deadline pub of Nothing | nextPileNum==0 && not (prolong $ rule $ gameSpec pub) -> Just $ numPlayers gS                                               | otherwise                                             -> Nothing                                       Just i  -> Just $ pred i@@ -788,8 +798,7 @@                                       nonPublic = IM.update (Just . pred) (cardToInt nth) $ nonPublic pub,                                       turn       = succ $ turn pub,                                       hintTokens = succ $ hintTokens pub,-                                      givenHints = nextHints,-                                      possibilities = nextPoss,+                                      annotations = nextAnns,                                       deadline   = nextDeadline,                                       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}}@@ -800,35 +809,30 @@                                                   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,-                                                  possibilities = nextPoss,+                                                  annotations = nextAnns,                                                   deadline   = nextDeadline,                                                   result = Success nth}}     where failure = not $ isPlayable pub nth   prc (Hint hintedpl eik) = st{publicState = pub{hintTokens = pred $ hintTokens pub,                                                  turn       = succ $ turn pub,-                                                 givenHints = snd $ updateNth hintedpl newHints (givenHints pub),-                                                 possibilities = snd $ updateNth hintedpl newPoss (possibilities pub),+                                                 annotations = snd $ updateNth hintedpl newAnns (annotations pub),                                                  deadline   = case deadline pub of Nothing -> 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)-          newPoss  hs = zipWith zipperPos (hands st !! hintedpl) hs-          zipperPos (C ir ka) (c,n) = case eik of Left i  | i == ir -> (bit ibit,        n)-                                                          |otherwise-> (clearBit c ibit, n)-                                                       where ibit = 5 - fromEnum i-                                                  Right k | k == ka -> (c, bit kbit)-                                                          |otherwise-> (c, clearBit n kbit)-                                                       where kbit = 5 - fromEnum k+    where newAnns hs = zipWith zipper (hands st !! hintedpl) hs+          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+                          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   -- | @'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, possibilities = rotateList $ possibilities pub}}+                                                         publicState = pub{annotations = rotateList $ annotations 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.@@ -841,5 +845,5 @@                  | deadline pub == Just 0 ||                    (earlyQuit (rule $ gameSpec pub) && currentScore pub == achievableScore pub)                                                                        = 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.+                 | hintTokens pub == 0 && null (head $ annotations pub) = Just Failure -- No valid play is possible for the next player. This can happen when prolong==True.                  | otherwise                                           = Nothing

@@ -117,7 +117,7 @@     return $ websocketsOr defaultConnectionOptions (loop params) fallbackApp #endif -type GameData = IntMap.IntMap ([MVar ViaWebSocket], MVar (Maybe (EndGame,[State],[Move])))+type GameData = IntMap.IntMap ([MVar ViaWebSocket], MVar ([Card], Maybe (EndGame,[State],[Move]))) data Params g = Params{gen :: g,                        mvTIDToMVH :: MVar GameData,                        conn :: Connection,@@ -236,7 +236,7 @@                                                                let gid  = case [ i | ("ThreadId", xs) <- lex tidstr, (i, ys) <- reads xs, all isSpace ys ] of                                                                              [i] -> i                                                                              _   -> hash tidstr -- Just for future compatibility.-                                                               mvFinalSituation <- newEmptyMVar :: IO (MVar (Maybe (EndGame,[State],[Move])))+                                                               mvFinalSituation <- newEmptyMVar :: IO (MVar ([Card], Maybe (EndGame,[State],[Move])))                                                                modifyMVar_ (mvTIDToMVH params) (return . IntMap.insert gid (map snd pl2MVHs, mvFinalSituation)) -- IntMap.insert replaces with the new value if the key already exists. This behavior is good here because that means the game for the threadId has either finished or been killed and the threadId is reused.                                                                sender $ "The ID of the game is " ++ show gid                                                                let constructor :: Int -> String -> IO (DynamicStrategy IO)@@ -250,15 +250,16 @@                                                                    (playOrder,g) = case from of Just n  -> (dr++tk, gen params)                                                                                                    where (tk,dr) = splitAt n playerList                                                                                                 Nothing -> shuffle playerList $ gen params-                                                               eithFinalSituation <- try $ if observe then start (GS numAllies rule)        [watch (conn params) mbVerb] playOrder g-                                                                                                      else start (GS (succ numAllies) rule) []                           playOrder g+                                                                   (shuffled, _) = createDeck rule g+                                                               eithFinalSituation <- try $ if observe then startFromCards (GS numAllies rule)        [watch (conn params) mbVerb] playOrder shuffled+                                                                                                      else startFromCards (GS (succ numAllies) rule) []                           playOrder shuffled                                                                finalSituation <- case eithFinalSituation of                                                                                    Left e -> do hPutStrLn stderr $ displayException (e::SomeException)                                                                                                 return Nothing-                                                                                   Right ((fs@(eg,sts,mvs),_),_) -> return $ Just $ if sendFullHistoryInFact then fs else (eg, truncate sts, truncate mvs)+                                                                                   Right (fs@(eg,sts,mvs),_) -> return $ Just $ if sendFullHistoryInFact then fs else (eg, truncate sts, truncate mvs)                                                                                            where truncate = take $ numPlayers $ gameSpec $ publicState $ head sts-                                                               sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame finalSituation-                                                               putMVar mvFinalSituation finalSituation+                                                               sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame shuffled finalSituation+                                                               putMVar mvFinalSituation (shuffled, finalSituation)                                            where numAllies = length is                                 _  -> sender "The arguments of the `create' command could not be parsed."     in case lex inp of@@ -279,8 +280,8 @@                                                                                   case emptyMVHs of                                                                                     emvh:_ -> putMVar emvh (VWS (conn params) mbVerb sendFullHistoryInFact) >> sender "Successfully registered to the game.\n"                                                                                     []     -> sender "The game already has enough number of players.\n"-                                                                                  finalSituation <- readMVar mvFinalSituation-                                                                                  sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame finalSituation -- This could be from the viewpoint of this player.+                                                                                  (initialDeck, finalSituation) <- readMVar mvFinalSituation+                                                                                  sendTextData (conn params) $ endecodeX mbVerb $ PrettyEndGame initialDeck finalSituation -- This could be from the viewpoint of this player.                                _  -> sender "The arguments of the `attend' command could not be parsed."         _ -> sender $ inp ++ " : command unknown\n" ++ commandHelp available :: Maybe Verbosity -> MVar GameData -> Connection -> IO ()

@@ -16,7 +16,7 @@ import qualified Data.Map as M import qualified Data.IntMap as IM import Data.Maybe(fromJust, isNothing)-import Data.List(intersperse, zipWith4)+import Data.List(intersperse)  import           Miso         hiding (Fail) import           Miso.String  (MisoString)@@ -168,10 +168,11 @@                                                    let (playOrder,g) = case from model of Just n  -> (dr++tk, gen)                                                                                            where (tk,dr) = splitAt n playerList                                                                                           Nothing -> shuffle playerList gen-                                                   finalSituation <- start (GS (length playerList) (rule model)) [] playOrder g-                                                   return $ WriteLocalResult $ fst $ fst finalSituation+                                                       (shuffled, _) = createDeck (rule model) g+                                                   (fs,_) <- startFromCards (GS (length playerList) (rule model)) [] playOrder shuffled+                                                   return $ WriteLocalResult shuffled fs                                                 )-updateModel _ (WriteLocalResult fs@(_,sts,mvs)) model = model{received = CreateGame : PrettyEndGame (Just fs) : zipWith Watch (tail sts) (iterate (drop 1) $ drop 1 mvs) ++ received model}+updateModel _ (WriteLocalResult initDeck fs@(_,sts,mvs)) model = model{received = CreateGame : PrettyEndGame initDeck (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} <# liftIO (do                                                    let constructor algIx = fromJust $ lookup algIx $ strategies opt@@ -185,12 +186,13 @@                                                    let (playOrder,g) = case from model of Just n  -> (dr++tk, gen)                                                                                            where (tk,dr) = splitAt n thePlayerList                                                                                           Nothing -> shuffle thePlayerList gen-                                                   forkIO $ do ((fs,_),_) <- start (GS (length thePlayerList) (rule model)) [] playOrder g-                                                               putMVar (mvMsg $ localStrategy model) $ PrettyEndGame $ Just fs+                                                       (shuffled, _) = createDeck (rule model) g+                                                   forkIO $ do (fs,_) <- startFromCards (GS (length thePlayerList) (rule model)) [] playOrder shuffled+                                                               putMVar (mvMsg $ localStrategy model) $ PrettyEndGame shuffled $ 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@(PrettyEndGame shuffled (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} <# liftIO (do                                                    msg <- takeMVar (mvMsg $ localStrategy model)@@ -222,7 +224,7 @@   | ToggleVerbosity   | TogglePlay   | ObserveLocally-  | WriteLocalResult (EndGame, [State], [Move])+  | WriteLocalResult [Card] (EndGame, [State], [Move])   | PlayLocally   | ProcMsg Msg   | Id@@ -318,8 +320,8 @@ renderMsg _ _    _ (Str xs)             = div_ [] [hr_ [], pre_ [] [ text $ S.pack xs ]] renderMsg _ verb _ (WhatsUp name ps ms) = renderWhatsUp  verb name ps ms renderMsg _ verb _ (WhatsUp1     p  m)  = renderWhatsUp1 verb p m-renderMsg _ _    _ (PrettyEndGame Nothing)     = pre_ [] [ text $ S.pack $ prettyMbEndGame Nothing]-renderMsg _ verb _ (PrettyEndGame (Just tup))  = renderEndGame verb tup -- pre_ [] [ text $ S.pack $ prettyEndGame tup]+renderMsg _ _    _ (PrettyEndGame initDeck Nothing)     = pre_ [] [ text $ S.pack $ prettyMbEndGame Nothing ++ "By the way, the initial deck was " ++ shows initDeck ".\n"]+renderMsg _ verb _ (PrettyEndGame initDeck (Just tup))  = renderEndGame verb initDeck tup -- pre_ [] [ text $ S.pack $ prettyEndGame initDeck tup] renderMsg _ verb _ (Watch st [])           = div_ [style_ $ M.fromList [("font-size", "2vmin")]] [          hr_ [],          renderSt verb ithPlayerFromTheLast st,@@ -444,8 +446,8 @@   renderPV verb v  ] -renderEndGame :: Verbosity -> (EndGame, [State], [Move]) -> View Action-renderEndGame verb (eg,sts@(st:_),mvs)+renderEndGame :: Verbosity -> [Card] -> (EndGame, [State], [Move]) -> View Action+renderEndGame verb initDeck (eg,sts@(st:_),mvs)   = div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [          hr_ [],          renderRecentEvents verb (publicState st) ithPlayerFromTheLast (map Game.Hanabi.view sts) mvs,@@ -453,6 +455,8 @@          h1_ [style_ $ M.fromList [("background-color","#FF0000"),("color","#000000"),("font-size", "5vmin")]] [text $ S.pack $ show eg],          hr_ [],          renderSt verb ithPlayerFromTheLast st,+         hr_ [],+         text $ S.pack $ "By the way, the initial deck was " ++ shows initDeck ".\n",          hr_ []          ] @@ -549,30 +553,30 @@   div_ [] ( --      div_ [] [text $ S.pack $ "Your hand:"] : --      renderCards v pub [ Nothing | _ <- yourHand] yourHand :-      renderHand v pv (const "Your") 0 [ Nothing | _ <- yourHand] yourHand (head $ possibilities pub) :+      renderHand v pv (const "Your") 0 [ Nothing | _ <- yourHand] yourHand : --                                              ++ concat [ '+':shows d "-" | d <- [0 .. pred $ length yourHand] ]-      (zipWith4 (renderHand v pv (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) (tail $ givenHints pub) (tail $ possibilities pub))+      (zipWith3 (renderHand v pv (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (map (map Just) $ handsPV pv) (tail $ annotations pub))     )   ]-  where yourHand = head (givenHints pub)+  where yourHand = head (annotations pub)  renderSt :: Verbosity -> (Int -> Int -> String) -> State -> View Action renderSt verb ithP st@St{publicState=pub} = div_ [] $   renderPI verb pub :-  zipWith4 (renderHand verb (Game.Hanabi.view st) (ithP $ numPlayers $ gameSpec pub)) [0..] (map (map Just) $ hands st) (givenHints pub) (possibilities pub)+  zipWith3 (renderHand verb (Game.Hanabi.view st) (ithP $ numPlayers $ gameSpec pub)) [0..] (map (map Just) $ hands st) (annotations pub) -renderHand :: Verbosity -> PrivateView -> (Int->String) -> Int -> [Maybe Card] -> [Marks] -> [Possibilities] -> View Action-renderHand v pv ithPnumP i mbcards hl ps = div_ [] [+renderHand :: Verbosity -> PrivateView -> (Int->String) -> Int -> [Maybe Card] -> [Annotation] -> View Action+renderHand v pv ithPnumP i mbcards anns = div_ [] [   div_ [style_ $ M.fromList [("font-size", "2.5vmin")]] [text $ S.pack $ ithPnumP i ++ " hand:"],-   renderHand' v pv i mbcards hl ps+   renderHand' v pv i mbcards anns --  renderCards v pub (map Just cards) hl   ]-renderHand' :: Verbosity -> PrivateView -> Int -> [Maybe Card] -> [Marks] -> [Possibilities] -> View Action-renderHand' v pv pli mbcards hl ps = -   table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"){- , ("height","48px") -}]] (zipWith4 (renderCard v pv pli hl ps) [0..] mbcards hl ps)]+renderHand' :: Verbosity -> PrivateView -> Int -> [Maybe Card] -> [Annotation] -> View Action+renderHand' v pv pli mbcards anns = +   table_ [style_ $ M.fromList [("border-color","#FFFFFF"), ("border-width","medium")]] [tr_ [style_ $ M.fromList [("background-color","#000000"){- , ("height","48px") -}]] (zipWith3 (renderCard v pv pli anns) [0..] mbcards anns)] -renderCard :: Verbosity -> PrivateView -> Int -> [Marks] -> [Possibilities] -> Index -> Maybe Card -> Marks -> Possibilities -> View Action-renderCard v pv pli hl ps i mbc tup@(mc,mk) ptup@(pc,pn) = td_ [style_ $ M.fromList [("text-align","center"),+renderCard :: Verbosity -> PrivateView -> Int -> [Annotation] -> Index -> Maybe Card -> Annotation -> View Action+renderCard v pv pli anns i mbc ann@Ann{marks=tup@(mc,mk), possibilities=ptup@(pc,pn)} = td_ [style_ $ M.fromList [("text-align","center"),                                                                                      ("width", S.pack $ shows cardWidth "vmin"),                                                                                      ("color", colorStr $ fmap color mbc),                                                                                      ("font-family", "monospace") -- ,@@ -593,18 +597,18 @@   ] where           pub = publicView pv           cardWidth = 90 / fromIntegral (handSize $ gameSpec pub)-          (useless,myStyle) | isNothing mbc = (markObviouslyUseless v && isDefinitelyUseless pv tup ptup,-                                                        [ ("background-color", if warnDoubleDrop v && isDoubleDrop pv (result pub) chopSet ptup && i `elem` chopSet then "#880000" else+          (useless,myStyle) | isNothing mbc = (markObviouslyUseless v && isDefinitelyUseless pv ann,+                                                        [ ("background-color", if warnDoubleDrop v && isDoubleDrop pv (result pub) chopSet ann && i `elem` chopSet then "#880000" else                                                                                if markChops v && i `elem` chopSet then "#888888" else "#000000"),                                                           ("font-weight", if useless then "100" else "normal"),-                                                          ("font-style",  if markObviouslyPlayable v && isDefinitelyPlayable pv tup ptup then "oblique" else "normal")]+                                                          ("font-style",  if markObviouslyPlayable v && isDefinitelyPlayable pv ann then "oblique" else "normal")]                                               )                             | otherwise     = (markObviouslyUseless v && isObviouslyUseless pub ptup,-                                                        [ ("background-color",if markChops v && i `elem` concat (take 1 $ obviousChopss pub hl ps) then "#888888" else "#000000"),+                                                        [ ("background-color",if markChops v && i `elem` concat (take 1 $ obviousChopss pub anns) then "#888888" else "#000000"),                                                           ("font-weight", if useless then "100" else "normal"),                                                           ("font-style",  if markObviouslyPlayable v && isObviouslyPlayable pub ptup then "oblique" else "normal")]                                               )-          chopSet = concat $ take 1 $ definiteChopss pv hl ps+          chopSet = concat $ take 1 $ definiteChopss pv anns {- renderCards :: Verbosity -> PublicInfo -> [Maybe Card] -> [Marks] -> View Action renderCards v pub mbcs tups = table_ [style_ $ M.fromList [("border-color","#FFFFFF"),("border-width","medium")]] [

@@ -33,12 +33,12 @@ #endif  -- WhatsUp and WhatsUp1 should be minimized after better clients are implemented. 効率上はminimizeすべきだが、テスト目的ではとりあえずこのままの方がやりやすい。-data Msg = Str String | WhatsUp String [PrivateView] [Move] | WhatsUp1 PrivateView Move | PrettyEndGame (Maybe (EndGame, [State], [Move])) | Watch State [Move] | PrettyAvailable [(Int, (Int, Int))] | CreateGame deriving (Show, Read, Eq, Generic)+data Msg = Str String | WhatsUp String [PrivateView] [Move] | WhatsUp1 PrivateView Move | PrettyEndGame [Card] (Maybe (EndGame, [State], [Move])) | Watch State [Move] | PrettyAvailable [(Int, (Int, Int))] | CreateGame deriving (Show, Read, Eq, Generic) prettyMsg :: Verbosity -> Msg -> String prettyMsg _    (Str xs)        = xs prettyMsg verb (WhatsUp name ps ms) = what'sUp  verb name ps ms prettyMsg verb (WhatsUp1     p  m)  = what'sUp1 verb      p  m-prettyMsg _    (PrettyEndGame tup)  = prettyMbEndGame tup+prettyMsg _    (PrettyEndGame cards tup)  = prettyMbEndGame tup ++ "By the way, the initial deck was " ++ shows cards ".\n" prettyMsg _    (Watch st [])        = prettySt ithPlayerFromTheLast st prettyMsg _    (Watch st (mv:_))    = replicate 20 '-' ++ '\n' :                 showTrial (const "") undefined (view st) mv ++ '\n' :

@@ -3,7 +3,7 @@ import Game.Hanabi hiding (main) import System.Random import Data.Maybe(isNothing)-import Data.List(zip4, sortOn)+import Data.List(sortOn) import Data.Bits(bit)  -- An example of a simple and stupid strategy.@@ -14,51 +14,48 @@   move (pv:pvs) mvs s = let                            pub = publicView pv                            nextPlayersHand = head $ handsPV pv ::[Card]-                           nextPlayersHints = givenHints pub !! 1-                           nextPlayersPos   = possibilities pub !! 1-                           nextPlayer = zip4 [0..] nextPlayersHand nextPlayersHints nextPlayersPos-                           myHints = head $ givenHints pub-                           myPos   = head $ possibilities pub-                           myHand  = zip3 [0..] myHints myPos-                           numHand = length myHints-                           isColorMarkable col = isPlayable pub (head [ c | (j,c,(_,Nothing),_) <- nextPlayer, color c == col ])-                                               || any (isPlayable pub) [ c | (j,c,(Nothing,Just num),_) <- nextPlayer, color c == col ]-                           isNewestOfColor i d = null [ () | (j,c,(_,Nothing),_) <- nextPlayer, color c == color d, j < i ] -- True if there is no newer number-unmarked card of the same color in nextPlayer.-                           markCandidates = filter (\(_,card,_,pos) -> isPlayable pub card && not (isObviouslyPlayable pub pos)) $ reverse nextPlayer  -- Playable cards that are not enough hinted, old to new.-                           markUnhintedCritical = take 1 [ Hint 1 (if isColorMarkable (color te) then Left $ color te else Right $ number te) | (_ix, te, hint, _pos) <- reverse nextPlayer, not (isHinted hint), isCritical pub te ]-                           keep2 = take 1 [ Hint 1 $ Right $ K2 | (_ix, te@(C _ K2), hint, _pos) <- reverse nextPlayer, not (isHinted hint), not $ isUseless pub te ]-                           colorMarkUnmarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (i,d,(Nothing, Nothing),_) <- markCandidates,  -- Mark the color if a (not obviously) playable card is not marked+                           nextPlayersAnns = annotations pub !! 1+                           nextPlayer = zip3 [0..] nextPlayersHand nextPlayersAnns+                           myAnns = head $ annotations pub+                           myHand  = zip [0..] myAnns+                           numHand = length myAnns+                           isColorMarkable col = isPlayable pub (head [ c | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == col ])+                                               || any (isPlayable pub) [ c | (j,c,Ann{marks=(Nothing,Just num)}) <- nextPlayer, color c == col ]+                           isNewestOfColor i d = null [ () | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == color d, j < i ] -- True if there is no newer number-unmarked card of the same color in nextPlayer.+                           markCandidates = filter (\(_,card,ann) -> isPlayable pub card && not (isObviouslyPlayable pub $ possibilities ann)) $ reverse nextPlayer  -- Playable cards that are not enough hinted, old to new.+                           markUnhintedCritical = take 1 [ Hint 1 (if isColorMarkable (color te) then Left $ color te else Right $ number te) | (_ix, te, ann) <- reverse nextPlayer, not (isHinted $ marks ann), isCritical pub te ]+                           keep2 = take 1 [ Hint 1 $ Right $ K2 | (_ix, te@(C _ K2), ann) <- reverse nextPlayer, not (isHinted $ marks ann), not $ isUseless pub te ]+                           colorMarkUnmarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{marks=(Nothing, Nothing)}) <- markCandidates,  -- Mark the color if a (not obviously) playable card is not marked                                                                                           isNewestOfColor i d ] -- but be cautious not to color-mark newer cards.-                           colorMarkNumberMarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (_,d,(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,(_, Nothing),_) <- markCandidates ] -- Mark the number if a (not obviously) playable card is not number-marked.-                           numberMarkUselessIfInformative = take 1 [ Hint 1 $ Right $ number d | (_,d,_,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,_,p@(_, pn)) <- reverse nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (bit $ 5 - fromEnum (color d), pn),+                           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),                                                                                               isNewestOfColor i d ] -- but be cautious not to color-mark newer cards.-                           numberMarkUnmarked       = take 1 [ Hint 1 $ Right $ number d | (_,d,(Nothing, Nothing),p) <- nextPlayer, not $ isObviouslyUseless pub p ]-                           numberMarkNumberUnmarked = take 1 [ Hint 1 $ Right $ number d | (_,d,(Just _, Nothing),p) <- nextPlayer, not $ isObviouslyUseless pub p ]-                           colorMarkColorUnmarked   = take 1 [ Hint 1 $ Left  $ color d  | (i,d,(Nothing, Just _),p) <- reverse nextPlayer, not $ isObviouslyUseless pub p,+                           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 ]+                           colorMarkColorUnmarked   = take 1 [ Hint 1 $ Left  $ color d  | (i,d,Ann{marks=(Nothing, Just _),possibilities=p}) <- reverse nextPlayer, not $ isObviouslyUseless pub p,                                                                                            isNewestOfColor i d ] -- but be cautious not to color-mark newer cards.-                           playPlayable5 = take 1 [ Play i | (i,marks@(_,Just K5),pos) <- myHand, isDefinitelyPlayable pv marks pos ]-                           dropUselessCard = take 1 [ Drop i | hintTokens pub < 7, (i,marks,pos) <- reverse myHand, isDefinitelyUseless pv marks pos ]-                           dropSafe        = take 1 [ Drop i | (i,marks,pos) <- reverse myHand, isDefinitelyUncritical pv marks pos ]-                           dropPossiblyUncritical = take 1 [ Drop i | (i,marks,pos) <- reverse myHand, not $ isDefinitelyCritical pv marks pos ]+                           playPlayable5 = take 1 [ Play i | (i,ann@Ann{marks=(_,Just K5)}) <- myHand, isDefinitelyPlayable pv ann ]+                           dropUselessCard = take 1 [ Drop i | hintTokens pub < 7, (i,ann) <- reverse myHand, isDefinitelyUseless pv ann ]+                           dropSafe        = take 1 [ Drop i | (i,ann) <- reverse myHand, isDefinitelyUncritical pv ann ]+                           dropPossiblyUncritical = take 1 [ Drop i | (i,ann) <- reverse myHand, not $ isDefinitelyCritical pv ann ]                            sontakuColorMark = case mvs of                                                                        -- When the last move is color mark,-                                                Hint 1 (Left c) : _ | isDefinitelyUseless pv (myHints!!i) (myPos!!i) -> [Drop i] -- If the first color-marked is obviously useless, drop it.-                                                                    | isDefinitelyUnplayable pv (myHints!!i) (myPos!!i) -> []    -- If the first color-marked is unplayable for now, ignore it.-                                                                    | otherwise -> [Play i]                                      -- Otherwise, it means "Play!"-                                                     where i = length $ takeWhile ((/=Just c) . fst) $ head $ givenHints $ publicView pv -- (This should also be rewritten using list comprehension.)+                                                Hint 1 (Left c) : _ | isDefinitelyUseless    pv (myAnns!!i) -> [Drop i] -- If the first color-marked is obviously useless, drop it.+                                                                    | isDefinitelyUnplayable pv (myAnns!!i) -> []       -- If the first color-marked is unplayable for now, ignore it.+                                                                    | otherwise                             -> [Play i] -- Otherwise, it means "Play!"+                                                     where i = length $ takeWhile ((/=Just c) . fst . marks) $ head $ annotations $ publicView pv -- (This should also be rewritten using list comprehension.)                                                 _                   -> []                            sontakuPositionalDrop = case mvs of                                                      Drop i : _ | i `notElem` unusualChops  -> []     -- It is not a positional drop if nothing is unusual.-                                                                | not $ isDefinitelyUnplayable pv (myHints!!i) (myPos!!i) -> [Play i]+                                                                | not $ isDefinitelyUnplayable pv (myAnns!!i) -> [Play i]                                                                 | otherwise -> [Drop i] -- if by no means it is playable, it means "drop it" (unless there are 8 hints), even if isDefinitelyCritical.                                                        where lastpub   = publicView (head pvs)-                                                             lastHints = last (givenHints lastpub)-                                                             lastPos   = last (possibilities lastpub)-                                                             unusualChops = drop 1 $ concat $ map reverse $ obviousChopss lastpub lastHints lastPos+                                                             lastAnns  = last (annotations lastpub)+                                                             unusualChops = drop 1 $ concat $ map reverse $ obviousChopss lastpub lastAnns                                                      _ -> []-                           dropChopUnlessDoubleDrop = [ Drop i | is@(i:_) <- take 1 $ map reverse $ definiteChopss pv myHints myPos, not $ isDoubleDrop pv (result pub) is $ myPos !! i ]-                           dropChop = [ Drop i | i:_ <- take 1 $ definiteChopss pv myHints myPos ]+                           dropChopUnlessDoubleDrop = [ Drop i | is@(i:_) <- take 1 $ map reverse $ definiteChopss pv myAnns, not $ isDoubleDrop pv (result pub) is $ myAnns !! i ]+                           dropChop = [ Drop i | i:_ <- take 1 $ definiteChopss pv myAnns ]                            current    = currentScore pub                            achievable = achievableScore pub                            enoughDeck = prolong (Game.Hanabi.rule $ gameSpec pub) || achievable - current < pileNum pub@@ -69,7 +66,7 @@                                         ++ (if hintTokens pub >= 4 then colorMarkNumberMarkedPlayable ++ numberMarkPlayable ++ keep2 else []) -- Do one of these only when there are spare hint tokens.                                         ++ playPlayable5                                         ++ (if enoughDeck then dropUselessCard else []) -- Drop a useless card unless endgame is approaching.-                                        ++ take 1 [ Play i | (i,marks,pos) <- myHand,     isDefinitelyPlayable pv marks pos ] -- Play a playable card+                                        ++ take 1 [ Play i | (i,ann) <- myHand,     isDefinitelyPlayable pv ann ] -- Play a playable card                                         ++ sontakuColorMark                                      -- guess the meaning of the last move, and believe it.                                         ++ dropChopUnlessDoubleDrop                                         ++ colorMarkUnmarkedPlayable ++ colorMarkNumberMarkedPlayable ++ numberMarkPlayable ++ dropUselessCard ++ keep2@@ -81,7 +78,7 @@                                         ++ [Hint 1 $ Right n | n <- [K1 .. K5]]                                         ++ dropChop --                                        ++ dropPossiblyUncritical  -- This may not be a good idea. See Haddock comment on Hanabi.isDefinitelyCritical.-                                        ++ reverse [ Drop i | (i,_,_) <- sortOn (\(_,(_,mb),_) -> fmap fromEnum mb) myHand ]+                                        ++ reverse [ Drop i | (i,_) <- sortOn (\(_,Ann{marks=(_,mb)}) -> fmap fromEnum mb) myHand ]                        in return (mov, s)  main = do g <- newStdGen

@@ -0,0 +1,45 @@+{-# 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)+import Data.Bits(bit, (.&.))+import qualified Data.IntMap as IM++-- An example of a strategy with state.+newtype Stateful = SF [Annotation]++lookupOn :: Eq b => (a -> b) -> a -> [a] -> [a]+lookupOn fun key xs = [ result | result <- xs, fun key == fun result ]++instance Monad m => Strategy Stateful m where+  strategyName ms = return "Stateful strategy"+  move (pv:pvs) mvs (SF lastGuess) = let+                           consistentGuess = [ case lookupOn ixDeck realAnn $ hintedAnns ++ lastGuess of+                                                 guessedAnn:_ | narrowedPos /= 0 -> realAnn{possibilities = (fst realPos, narrowedPos)}+                                                              where narrowedPos = snd realPos .&. snd (possibilities guessedAnn)+                                                                    realPos = possibilities realAnn+                                                 _            -> realAnn+                                             | realAnn <- myAnns ]++                           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.+                                              ]+                           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.+                                                  not $ isDefinitelyUnplayable pv ann,+                                                  newNumberPos .&. snd (possibilities ann) /= 0 ]+                           pub = publicView pv+                           myAnns = head $ annotations pub+                       in move (pv{publicView=pub{annotations=consistentGuess : tail (annotations pub)}} : pvs) mvs S >>= \(mov,S) -> return (mov, SF consistentGuess)++main = do g <- newStdGen+          ((eg,_),_) <- start defaultGS [] ([SF[]],[stdio]) g -- Play it with standard I/O (human player).+--          ((eg,_),_) <- start defaultGS [peek] [SF[],SF[]] g -- Play it with itself.+          putStrLn $ prettyEndGame eg

@@ -9,6 +9,7 @@ import Game.Hanabi.Msg(defaultOptions, Options(..))  import Game.Hanabi.Strategies.SimpleStrategy hiding (main)+import Game.Hanabi.Strategies.StatefulStrategy hiding (main) main :: IO () main = do putStrLn "localhost:8080"  -- Seemingly other port than 8080 does not work.           let opt = defaultOptions{version="hanabi-dealer quickbuilt server", strategies=strs}@@ -23,6 +24,7 @@  strs :: [(String, IO (DynamicStrategy IO))] strs = [-     ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S)+     ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S),+     ("Example strategy with states", return $ mkDS "Example strategy with states" $ SF [])  -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault))   ]

@@ -2,11 +2,13 @@ import Game.Hanabi.Client  import Game.Hanabi.Strategies.SimpleStrategy hiding (main)+import Game.Hanabi.Strategies.StatefulStrategy hiding (main)  main = client defOpt{strategies=strs}  -- strs :: [(String, IO (DynamicStrategy IO))] strs = [-     ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S)+     ("Stupid example strategy", return $ mkDS "Stupid example strategy" $ S),+     ("Example strategy with states", return $ mkDS "Example strategy with states" $ SF [])  -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault))   ]

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.7.2.0+version:             0.8.0.0  -- A short (one-line) description of the package. synopsis:            Hanabi card game@@ -140,7 +140,7 @@  executable hanabiq   main-is: all.hs-  other-modules: Game.Hanabi, Game.Hanabi.Msg, Game.Hanabi.Backend, Game.Hanabi.Client, Game.Hanabi.Strategies.SimpleStrategy+  other-modules: Game.Hanabi, Game.Hanabi.Msg, Game.Hanabi.Backend, Game.Hanabi.Client, Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy --  if !flag(all)   if !flag(jsaddle)     buildable: False@@ -156,7 +156,7 @@  executable hanabib   main-is:       server.hs-  other-modules: Game.Hanabi.Strategies.SimpleStrategy+  other-modules: Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy   if impl(ghcjs) || !flag(server)     buildable: False   else@@ -180,7 +180,7 @@  executable hanabif   main-is:       client.hs-  other-modules: Game.Hanabi.Strategies.SimpleStrategy+  other-modules: Game.Hanabi.Strategies.SimpleStrategy, Game.Hanabi.Strategies.StatefulStrategy   if !impl(ghcjs) --                 && !flag(jsaddle)     buildable: False

@@ -2,11 +2,13 @@ import Game.Hanabi.VersionInfo  import Game.Hanabi.Strategies.SimpleStrategy hiding (main)+import Game.Hanabi.Strategies.StatefulStrategy hiding (main)  main = server defOpt{strategies=strs}  strs :: [(String, IO (DynamicStrategy IO))] strs = [-     ("Stupid example strategy", return $ mkDS "Stupid example strategy" S)+     ("Stupid example strategy", return $ mkDS "Stupid example strategy" S),+     ("Example strategy with states", return $ mkDS "Example strategy with states" $ SF [])  -- x , ("Sontakki", return $ mkDS "Sontakki" (Sontakki emptyDefault))   ]