{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, Safe, DeriveGeneric, RecordWildCards #-} module Game.Hanabi( -- * Functions for Dealing Games main, selfplay, start, createGame, startFromCards, createGameFromCards, run, createDeck, prettyEndGame, isMoveValid, checkEndGame, help, -- * Datatypes -- ** The Class of Strategies Strategies, Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose, quiet, Replay(..), -- ** Audience Peeker, peek, -- ** The Game Specification GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid, makeRuleValid, colors, handSize, setHandSize, -- ** The Game State and Interaction History Move(..), Index, State(..), PrivateView(..), PublicInfo(..), Result(..), EndGame(..), discarded, -- ** The Cards and Annotations Card(..), Color(..), Rank(..), Marks, Possibilities, Annotation(..), cardToInt, intToCard, readsColorChar, readsRankChar, colorToBitPos, rankToBitPos, -- * Utilities -- ** Hints isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, seeminglyAchievableScore, moreStrictlyAchievableScore, achievableScore, definitely, obviously, isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isDefinitelyUncritical, isDefinitelyCritical, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, isObviouslyUnplayable, isDefinitelyUnplayable, obviousChopss, definiteChopss, isDoubleDrop, possibleCards, endGameMoveOld, EndGameOld(..), EndGameMirrorOld(..), egmo, EndGameLite(..), egl, EndGameMirrorLite(..), egml, tryMove, (|||), ifA, -- ** Legacy functions and types givenHints, possibilities_until_Ver0720, Number, readsNumberChar, numberToBitPos, showNumberPossibilities, -- ** Minor ones what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, prettySt, ithPlayerFromTheLast, view, replaceNth, shuffle, showPossibilities, showColorPossibilities, showRankPossibilities, showTrial, showDeck, cardBag) where -- module Hanabi where import qualified Data.Map as M import System.Random import Control.Applicative((<*>)) import Control.Monad(when) import Control.Monad.IO.Class(MonadIO, liftIO) import Data.Char(isSpace, isAlpha, isAlphaNum, toLower, toUpper) import Data.Maybe(fromJust) import Data.List(isPrefixOf, group, maximumBy, delete, sort) import Data.Function(on) import System.IO import Data.Dynamic import Data.Bits hiding (rotate) import Data.Int(Int64) import GHC.Generics hiding (K1) data Rank = Empty | K1 | K2 | K3 | K4 | K5 deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic) data Color = White | Yellow | Red | Green | Blue | Multicolor deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic) type Number = Rank readsColorChar :: ReadS Color readsColorChar (c:str) | isSpace c = readsColorChar str | otherwise = case lookup (toUpper c) [(head $ show i, i) | i <- [White .. Multicolor]] of Nothing -> [] Just i -> [(i, str)] readsColorChar [] = [] readsRankChar :: ReadS Rank readsRankChar xs = [ (toEnum d, rest) | (d, rest) <- reads xs, d<=5 ] readsNumberChar = readsRankChar data Card = C {color :: Color, rank :: Rank} deriving (Eq, Ord, 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) <- readsRankChar 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::Rank)) + fromEnum (rank c) -- cardToQitPos is a variant of cardToInt whose value is less than 32. Since the Empty rank is never used for a card, there is no reason to use cardToInt, but it exists mainly for backward compatibility. -- cardToQitPos c = fromEnum (color c) * fromEnum (maxBound::Rank) + pred (fromEnum $ rank c) cardToQitPos c = pred (fromEnum $ rank c) * (succ $ fromEnum (maxBound :: Color)) + fromEnum (color c) -- This is preferred over the above for efficient implementation of bestPossibleRank. intToCard :: Int -> Card intToCard i = case i `divMod` (succ $ fromEnum (maxBound::Rank)) 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 Rank) -- ^ give hint to the ith next player deriving (Eq, Ord, Generic) instance Show Move where showsPrec _ (Drop i) = ("Drop"++) . shows i showsPrec _ (Play i) = ("Play"++) . shows i showsPrec _ (Hint i eith) = ("Hint"++) . shows i . (either (\c -> (take 1 (show c) ++)) (\k -> tail . shows k) eith) instance Read Move where readsPrec _ str = let (cmd,other) = span (not.isSpace) str' str' = dropWhile 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) <- readsRankChar 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,4,4,4,4,4,4] , numColors :: Int -- ^ number of colors. 5 for the normal rule, and 6 for Variant 1-3 of the rule book. , prolong :: Bool -- ^ continue even after a round after the pile is exhausted. @True@ for Variant 4 of the rule book. , earlyQuit :: Bool -- ^ quit the game when the best possible score is achieved. , numMulticolors :: [Int] -- ^ number of each of multicolor cards. @[3,2,2,2,1]@ for 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, Eq, Generic) isRuleValid :: Rule -> Bool isRuleValid rl@R{..} = numBlackTokens > 0 && and [ h>0 && h<=mh | (h,mh) <- zip funPlayerHand $ maxPlayerHand rl ] && numColors>0 && numColors <=6 && (numColors < 6 || all (>0) numMulticolors) makeRuleValid :: Rule -> Rule makeRuleValid rl@R{..} = rl{numBlackTokens = max 1 numBlackTokens, numColors = max 1 (min 6 numColors), numMulticolors = if numColors<6 then numMulticolors else take 5 (map (max 1) numMulticolors ++ [1,1,1,1,1]), funPlayerHand = [ max 1 h | h <- zipWith min funPlayerHand $ maxPlayerHand rl ]} maxPlayerHand rl = [ succ (numberOfCards rl) `div` numP | numP <- [2..]] -- This makes sure that there is at least one card on the deck. -- | @defaultRule@ is the normal rule from the rule book of the original card game Hanabi. defaultRule :: Rule defaultRule = R { numBlackTokens = 3 , funPlayerHand = [5,5]++take 8 (repeat 4) , numColors = 5 , prolong = False , earlyQuit = False , numMulticolors = replicate 5 0 -- x , multicolor = False } defaultGS :: GameSpec defaultGS = GS{numPlayers=2, rule=defaultRule} numberOfCards :: Rule -> Int numberOfCards rl = sum (take (numColors rl) $ [10,10,10,10,10]++[sum (numMulticolors rl)]) initialPileNum :: GameSpec -> Int initialPileNum gs = numberOfCards (rule gs) - handSize gs * numPlayers gs handSize :: GameSpec -> Int handSize GS{..} = (funPlayerHand rule ++ repeat 1) !! (numPlayers - 2) setHandSize :: GameSpec -> Int -> Rule setHandSize GS{..} n = rule{funPlayerHand = snd $ replaceNth (numPlayers - 2) n $ funPlayerHand rule} data GameSpec = GS {numPlayers :: Int, rule :: Rule} deriving (Read, Show, Eq, Generic) -- | State consists of all the information of the current game state, including public info, private info, and the hidden deck. data State = St { publicState :: PublicInfo , 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. } deriving (Read, Show, Eq, Generic) type ColorToRank = Int -- | CardTo4 is the type synonym for Int64, representing Card -> {0,1,2,3} type CardTo4 = Int64 lookupCardTo4 :: CardTo4 -> Card -> Int lookupCardTo4 ct4 c = fromIntegral ((ct4 `shiftR` (cardToQitPos c * 2)) .&. 3) deleteACard :: Card -> CardTo4 -> CardTo4 deleteACard c ct4 = ct4 - bit (cardToQitPos c * 2) insertACard :: Card -> CardTo4 -> CardTo4 insertACard c ct4 = ct4 + bit (cardToQitPos c * 2) -- something like @fmap abs@ absCardTo4 :: CardTo4 -> CardTo4 absCardTo4 ct4 = (ct4 .&. 0x5555555555555555) .|. ((ct4.&. 0x2AAAAAAAAAAAAAAA ) `shiftR` 1) cardTo4ToList :: CardTo4 -> [Card] cardTo4ToList ct4 = ctl ct4 [ C i k | k <- [K1 .. K5], i <- [White .. Multicolor] ] ctl 0 _ = [] ctl n (c:cs) = replicate (fromIntegral n .&. 3) c ++ ctl (n `shiftR` 2) cs -- | PublicInfo is the info that is available to all players. data PublicInfo = PI { gameSpec :: GameSpec , pileNum :: Int -- ^ The number of cards at the pile. , currentScore :: Int , nextToPlay :: CardTo4 -- ^ 3(4) or 11(2) if the card is playable (ignoring whether it is extinct or not), and 0(4) or 00(2) otherwise. , kept :: CardTo4 -- ^ The multiset of not-discarded cards, packed into Int64. , nonPublic :: CardTo4 -- ^ The multiset of Cards that have not been revealed to the public. -- This does not include cards whose Color and Rank are both revealed. -- -- This is redundant information that can be computed from 'achieved' and 'discarded'. , 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 . annotations@. , deadline :: Maybe Int -- ^ The number of turns until the endgame, after the pile exhausted. @Nothing@ when @pileNum > 0@. , 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 Rank) -- | A 'Possibilities' is a pair of data that are instances of Bits. The first represents which colors are possible, and the second is for ranks. type Possibilities = (Int, Int) colorToBitPos :: Color -> Int colorToBitPos i = 5 - fromEnum i rankToBitPos :: Rank -> Int rankToBitPos k = 5 - fromEnum k numberToBitPos = rankToBitPos data Annotation = Ann {ixDeck :: Int -- ^ Index in the initial deck , marks :: Marks -- ^ The Rank 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 -> Rank bestPossibleRank pub iro = toEnum $ (countTrailingZeros ((((kept pub `shiftR` (fromEnum iro * 2)) .&. 0x3003003003003) - 0x1001001001001) .&. 0x4004004004004) ) `div` 12 {- bestPossibleRank pub iro = toEnum $ length $ takeWhile (/=0) $ zipWith subtract (numEachCard (gameSpec pub) iro) [ discarded pub (C iro k) | k <- [K1 .. K5] ] -} -- | @discarded pub c@ represents the number of discarded @c@. Please rewrite old @discarded pub Data.IntMap.! cardToInt c@ into @discarded pub c@. -- Implementation of @discarded@ is not very fast, and 'kept'/'keptCards' should be used instead for efficient implementation of your algorithms. discarded :: PublicInfo -> Card -> Int discarded pub c = (numEachCard (gameSpec pub) (color c) !! pred (fromEnum $ rank c)) - keptCards pub c keptCards, nonPublicCards :: PublicInfo -> Card -> Int keptCards pub = lookupCardTo4 (kept pub) nonPublicCards = lookupCardTo4 . nonPublic invisibleBagCards :: PrivateView -> Card -> Int invisibleBagCards = lookupCardTo4 . invisibleBag numEachCard :: GameSpec -> Color -> [Int] numEachCard gs iro = if iro==Multicolor then numMulticolors $ rule gs else [3,2,2,2,1] {- packedNumEachCard :: GameSpec -> CardTo4 packedNumEachCard gs = 0x1AB6ADAB6ADAB .|. pack4 (numMulticolors $ rule gs) `shiftL` 50 -- 1222312223122231222312223 in base 4 pack4 :: [Int] -> CardTo4 pack4 [] = 0 pack4 (x:xs) = fromIntegral x .|. (pack4 xs `shiftL` 2) -} -- packedNumEachCard need not be efficient, because it is executed only when a game is created. packedNumEachCard :: GameSpec -> CardTo4 packedNumEachCard gs = mask (numColors (rule gs)) .&. (0x1552AA2AA2AA3FF .|. (pack4 (numMulticolors $ rule gs) `shiftL` 10)) -- mask .&. ( .|. 11111022222022222022222033333 in base 4) where mask 0 = 0 mask n = 0x3003003003003 .|. (mask (pred n) `shiftL` 2) pack4 :: [Int] -> CardTo4 pack4 [] = 0 pack4 (x:xs) = fromIntegral x .|. (pack4 xs `shiftL` 12) -- | isUseless pi card means either the card is already played or it is above the bestPossibleRank. isUseless :: PublicInfo -> Card -> Bool isUseless pub card = rank card <= achievedRank pub (color card) -- the card is already played || rank card > bestPossibleRank pub (color card) -- | A critical card is a useful card and the last card that has not been dropped. -- -- Unmarked critical card on the chop should be marked. isCritical :: PublicInfo -> Card -> Bool isCritical pub card = not (isUseless pub card) && keptCards pub card == 1 isPlayable :: PublicInfo -> Card -> Bool isPlayable pub card = pred (rank card) == achievedRank pub (color card) isHinted :: Marks -> Bool isHinted = not . (==(Nothing, Nothing)) -- | 'isMostObviouslyPlayable' only looks at the current hint marks (and the played piles) and decides if the card is surely playable. -- This is useful only for predicting the behaviors of beginner players. isMostObviouslyPlayable :: PublicInfo -> Marks -> Bool isMostObviouslyPlayable pub (Just c, Just n) = isPlayable pub $ C c n isMostObviouslyPlayable _ _ = False -- | 'isMoreObviouslyPlayable' looks at the publicly available current info and decides if the card is surely playable. isMoreObviouslyPlayable :: PublicInfo -> Marks -> Bool isMoreObviouslyPlayable pub = iOP (nonPublic pub) pub obviously :: (PublicInfo -> Card -> Bool) -> PublicInfo -> Possibilities -> Bool obviously predicate pub pos@(pc,pn) = all (predicate pub) $ cardTo4ToList $ absCardTo4 $ possibilitiesQits pos .&. nonPublic pub {- obviously predicate pub (pc,pn) = all (\card -> (nonPublicCards pub card) == 0 || predicate pub card) [ C color number | color <- colorPossibilities pc, number <- rankPossibilities pn ] -} obviouslyQits :: (PublicInfo -> CardTo4) -> PublicInfo -> Possibilities -> Bool obviouslyQits predicate pub pos = (possibilitiesQits pos .&. nonPublic pub .&. complement (predicate pub)) == 0 -- | In addition to 'isMoreObviouslyPlayable', 'isObviouslyPlayable' also looks into the color/rank possibilities of the card and decides if the card is surely playable. isObviouslyPlayable :: PublicInfo -> Possibilities -> Bool isObviouslyPlayable = obviouslyQits nextToPlay isObviouslyUnplayable :: PublicInfo -> Possibilities -> Bool isObviouslyUnplayable = obviouslyQits (complement . nextToPlay) definitely :: (PrivateView -> Card -> Bool) -> PrivateView -> Annotation -> Bool definitely predicate pv ann = all (predicate pv) $ possibleCards pv ann definitelyQits :: (PrivateView -> CardTo4) -> PrivateView -> Annotation -> Bool definitelyQits predicate pv Ann{marks = (Just c, Just n)} = predicate pv `testBit` (cardToQitPos (C c n) * 2) -- The condition is indispensable, because now invisibleBag considers fully-marked cards visible. definitelyQits predicate pv Ann{possibilities = pos@(pc,pn)} = (possibilitiesQits pos .&. invisibleBag pv .&. complement (predicate pv)) == 0 -- | 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 -> Annotation -> Bool isDefinitelyPlayable = definitelyQits (nextToPlay . publicView) isDefinitelyUnplayable :: PrivateView -> Annotation -> Bool isDefinitelyUnplayable = definitelyQits (complement . nextToPlay . publicView) -- | 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 -> 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 -> Annotation -> Bool isDefinitelyCritical = definitely (\pv -> isCritical $ publicView pv) 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 = pos@(pc,pn)} = cardTo4ToList $ absCardTo4 $ possibilitiesQits pos .&. invisibleBag pv where pub = publicView pv iOP :: CardTo4 -> PublicInfo -> (Maybe Color, Maybe Rank) -> Bool iOP _ pub (Just c, Just n) = isPlayable pub $ C c n iOP bag pub (Nothing,Just n) = all (\card -> (lookupCardTo4 bag card) == 0 || isPlayable pub card) [ C color n | color <- colors pub ] iOP _ _ _ = False -- | 'isMoreObviouslyUseless' looks at the publicly available current info and decides if the card is surely useless. isMoreObviouslyUseless :: PublicInfo -> Marks -> Bool isMoreObviouslyUseless pub (Just c, Just n) = isUseless pub $ C c n isMoreObviouslyUseless pub (Just c, Nothing) = bestPossibleRank pub c == achievedRank pub c isMoreObviouslyUseless pub (Nothing, Just n) = all (\c -> n <= achievedRank pub c || bestPossibleRank pub c < n) $ colors pub isMoreObviouslyUseless _ (Nothing, Nothing) = False isObviouslyUseless :: PublicInfo -> Possibilities -> Bool isObviouslyUseless = obviously (\pub (C c n) -> n <= achievedRank pub c || bestPossibleRank pub c < n) isDefinitelyUseless :: PrivateView -> Annotation -> Bool isDefinitelyUseless = definitely (\pv -> isUseless (publicView pv)) {- This is a weaker version not looking into the possibilities. isDefinitelyUseless :: PrivateView -> Marks -> Bool isDefinitelyUseless pv (Just c, Just n) = isUseless (publicView pv) $ C c n isDefinitelyUseless pv (Just c, Nothing) = all ((==0) . (invisibleBagCards pv) . C c . toEnum) [ succ $ fromEnum $ achievedRank (publicView pv) c .. fromEnum $ bestPossibleRank (publicView pv) c ] isDefinitelyUseless pv (Nothing, Just n) = all (\c -> n <= achievedRank (publicView pv) c || bestPossibleRank (publicView pv) c < n || (invisibleBagCards pv (C c n)) == 0 ) $ colors $ publicView pv isDefinitelyUseless pv (Nothing, Nothing) = all (\c -> all ((==0) . (invisibleBagCards pv) . C c . toEnum) [ succ $ fromEnum $ achievedRank (publicView pv) c .. fromEnum $ bestPossibleRank (publicView pv) c ]) $ colors $ publicView pv -} -- In fact, invisibleBag should be included in PrivateView for efficiency of isDefinitelyUseless, etc., but should not be sent via WebSocket. This is the matter of Read and Show (or ToJSON and FromJSON). -- | @'choppiri' marks@ = [unmarked last, unmarked second last, ...]. This is "beginner players' idea of chops". choppiri :: [Marks] -> [(Index, Marks)] 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 -> [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 -> [Annotation] -> [Index] chops pub anns = concat $ map reverse $ obviousChopss pub anns isDoubleDrop :: PrivateView -> Result -> [Index] -> Annotation -> Bool isDoubleDrop _pv None _chopset _anns = False isDoubleDrop _pv (Success _) _chopset _anns = False isDoubleDrop pv@PV{publicView=pub} lastResult [_i] Ann{possibilities=(pc,pn)} = not (any ((==(Just color, Just rank)).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 && rank `elem` rankPossibilities pn && invisibleBagCards pv c > 0 where myAnns = head $ annotations pub c@C{..} = revealed lastResult isDoubleDrop _pv _lastresult _chopset _anns = False colors :: PublicInfo -> [Color] colors pub = take (numColors $ rule $ gameSpec pub) [minBound .. maxBound] achievedRank :: PublicInfo -> Color -> Rank achievedRank pub k = toEnum $ countTrailingZeros ((nextToPlay pub `shiftR` (2 * fromEnum k)) .&. 0x3003003003003) `div` 12 -- | achievable score based on the info of extinct cards. seeminglyAchievableScore :: PublicInfo -> Int seeminglyAchievableScore pub = sum [ fromEnum $ bestPossibleRank pub k | k <- colors pub ] -- | alias to 'seeminglyAchievableScore'. This function name may point to the function with stricter check in future. achievableScore :: PublicInfo -> Int achievableScore = seeminglyAchievableScore -- | In addition to 'seeminglyAchievableScore', 'moreStrictlyAchievableScore' checks the number of cards at the deck, unless 'prolong' is @True@. moreStrictlyAchievableScore :: PublicInfo -> Int moreStrictlyAchievableScore pub = if prolong $ rule $ gameSpec pub then seeminglyAchievableScore pub else seeminglyAchievableScore pub `min` (currentScore pub + pileNum pub + numPlayers (gameSpec pub)) tryMove :: PrivateView -> Move -> Move -> Move tryMove pv m alt | isMoveValid pv m = m | otherwise = alt (|||) :: (PrivateView -> Move) -> (PrivateView -> Move) -> PrivateView -> Move a ||| b = tryMove <*> a <*> b ifA :: (PrivateView -> Bool) -> (PrivateView -> Move) -> (PrivateView -> Move) -> PrivateView -> Move ifA pred at af = (\pv t f -> if pred pv then t else f) <*> at <*> af -- | 'Result' is the result of the last move. data Result = None -- ^ Hinted or at the beginning of the game | Discard {revealed::Card} | Success {revealed::Card} | Fail {revealed::Card} deriving (Read, Show, Eq, Generic) -- The view history [PrivateView] records the memory of what has been visible `as is'. That is, the info of the cards in the history is not updated by revealing them. -- I guess, sometimes, ignorance of other players might also be an important knowledge. -- Algorithms that want updated info could implement the functionality for themselves. -- | 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 :: CardTo4 -- ^ 'invisibleBag' is the bag of unknown cards (which are either in the pile or in the player's hand and not fully hinted). } deriving (Generic) -- ToDo: Instance for Generic should also be specialized for efficiency. instance Show PrivateView where showsPrec p (PV pub h _) = showsPrec p (pub,h) instance Read PrivateView where readsPrec p str = [ (mkPV pub hs, rest) | ((pub,hs), rest) <- readsPrec p str ] instance Eq PrivateView where PV pub1 hs1 _ == PV pub2 hs2 _ = (pub1,hs1) == (pub2,hs2) -- | recede rolls back 1 turn without rotating. recede :: PublicInfo -> Move -> State -> State recede lastpub (Hint _ _) st = st{ publicState = lastpub } recede lastpub mv st = St{ publicState = lastpub, pile = if pileNum lastpub == 0 then [] else (head myHand, initAnn (gameSpec lastpub) $ ixDeck $ head $ head $ annotations $ publicState st) : pile st, hands = case splitAt (index mv) $ if pileNum lastpub == 0 then myHand else tail myHand of (tk,dr) -> (tk ++ revealed (result $ publicState st) : dr) : tail (hands st)} where myHand = head $ hands st -- | stateToStateHistory deduces the state history from the 'PublicState' history, the 'Move' history, and the current 'State'. stateToStateHistory :: [PublicInfo] -> [Move] -> State -> [State] stateToStateHistory [] [] st = [st] stateToStateHistory (pi:pis) (mv:mvs) st = st : stateToStateHistory pis mvs (rotate (-1) $ recede pi mv st) -- | @'EGS' f p ps@ usually behaves based on @p@, but it conducts the exhaustive search assuming that others behave based on @ps@ when the deck size is @f@ or below @f@. -- @move pvs mvs (EGO f p ps)@ may cause an error if @p@ can choose an invalid move. data EndGameOld p ps = EGO {fromWhen::PublicInfo->Bool, myUsualStrategy::p, otherPlayers::ps} instance (Monad m, Strategy p m, Strategies ps m) => Strategy (EndGameOld p ps) m where strategyName ms = return "EndGameOld" move pvs@(pv:_) mvs str@(EGO f p ps) | f (publicView pv) = do (defaultMove, _) <- move pvs mvs p m <- endGameMoveOld pvs mvs (ps, [EGO f p ps]) $ defaultMove : delete defaultMove (validMoves pv) return (m,str) | otherwise = do (m,_) <- move pvs mvs p return (m,str) -- | 'EndGameMirrorStrategy' assumes that other players think in the same way as itself during endgame. -- @move pvs mvs (EGMO (EGO f p ps))@ may cause an error if @p@ can choose an invalid move. data EndGameMirrorOld p = EGMO (EndGameOld p [EndGameMirrorOld p]) egmo :: (PublicInfo -> Bool) -- ^ from when to start the endgame search -> p -- ^ the default strategy used until endgame -> Int -- ^ number of players, including the resulting player -> EndGameMirrorOld p egmo from p nump = egmo where egmo = EGMO (EGO from p $ replicate (pred nump) egmo) instance (Monad m, Strategy p m) => Strategy (EndGameMirrorOld p) m where strategyName ms = return "EndGameMirrorOld" move pvs mvs (EGMO egs) = do (m, egs') <- move pvs mvs egs return (m, EGMO egs') endGameMoveOld :: (Monad m, Strategies ps m) => [PrivateView] -- ^ view history -> [Move] -- ^ move history -> ps -> [Move] -- ^ move candidates. More promising moves appear earlier. -> m Move endGameMoveOld pvs@(pv:tlpvs) mvs ps candidates = do let states = possibleStates pv scores <- mapM (evalMove states (map publicView tlpvs) mvs ps) candidates let asc = zip scores candidates pub = publicView pv achievable = moreStrictlyAchievableScore pub -- ToDo: Also consider critical cards at the bottom deck. return $ case lookup (achievable * length states) asc of Nothing -> snd $ maximumBy (compare `on` fst) $ reverse asc Just k -> k -- Stop search when the best possible score is found. validMoves :: PrivateView -> [Move] validMoves pv@PV{publicView=pub@PI{gameSpec=gs,hintTokens=numHints},handsPV=tlHands} -- = mkPlay (playables++others) $ mkDrop [chop] $ mkHints usefulHints $ mkDrop nochops $ mkPlay uselesses $ mkHints uselessHints [] -- exhaustive but still prioritized | pileNum pub == 0 = mkPlay (playables++others) $ mkDrop [chop] $ mkHints usefulHints $ mkDrop nochops [] | numHints == 8 && lives pub > 1 = mkPlay (playables++others) $ mkHints usefulHints $ mkPlay uselesses [] | otherwise = mkPlay (playables++others) $ mkDrop [chop] $ mkHints usefulHints $ mkDrop nochops $ take 1 $ mkHints uselessHints [] where myHandSize = length myAnn myAnn = head $ annotations pub (usefulColors, uselessColors) = span (\c -> achievedRank pub c /= bestPossibleRank pub c) $ colors pub maxUselessRank = minimum [ achievedRank pub c | c <- colors pub] usefulHints = map Left usefulColors ++ map Right [K5, K4 .. succ maxUselessRank] uselessHints = map Left uselessColors ++ map Right [K1 .. maxUselessRank] mkHints hints | numHints > 0 = ([ Hint hintedpl eck | hintedpl <- [1 .. numPlayers gs - 1], eck <- hints, not (null $ filter (either (\c -> (==c).color) (\k -> (==k).rank) eck) (tlHands !! pred hintedpl)) ] ++) | otherwise = id mkDrop tups | numHints < 8 = (tups ++) | otherwise = id mkPlay xs = (map (Play . fst) xs ++) (uselesses, usefuls) = span (\(ix,ann) -> isDefinitelyUseless pv ann) $ zip [0..] myAnn (playables, others) = span (\(ix,ann) -> isDefinitelyPlayable pv ann) usefuls chop:nochops = map (Drop . fst) $ reverse $ playables ++ others ++ uselesses evalMove :: (Monad m, Strategies ps m) => [(State, Int)] -> [PublicInfo] -> [Move] -> ps -> Move -> m Int evalMove states pubs@(pub:_) mvs ps mv = fmap (sum . map (\(((eg,st:_,_),_),n) -> n * egToInt st eg)) $ mapM (\(st,n) -> fmap (\a->(a,n)) $ tryAMove (stateToStateHistory pubs mvs st) mvs ps mv) states -- | 'tryAMove' tries a 'Move' and then simulate the game to the end, using given 'Strategies'. Running this with empty history, such as @tryAMove [st] [] strs m@ is possible, but that assumes other strategies does not depend on the history. tryAMove :: (Monad m, Strategies ps m) => [State] -> [Move] -> ps -> Move -> m ((EndGame, [State], [Move]),ps) tryAMove states@(st:_) mvs strs mov = case proceed st mov of Nothing -> error $ show mov ++ ": invalid move!" Just st -> let nxt = rotate 1 st in case checkEndGame $ publicState nxt of Nothing -> runSilently (nxt:states) (mov:mvs) strs Just eg -> return ((eg, nxt:states, mov:mvs), strs) -- | 'EndGameMirrorLite' assumes that other players think in the same way as itself during endgame. data EndGameMirrorLite sp p = EGML (EndGameLite sp p [EndGameMirrorLite sp p]) egml :: (PublicInfo -> Bool) -- ^ from when to start the endgame search -> sp -- ^ the recommended strategy used at endgame, in order to prioritize endgame search. This strategy is supposed to be lightweight. -> p -- ^ the default strategy used until endgame -> Int -- ^ number of players, including the resulting player -> EndGameMirrorLite sp p egml from sp p nump = egmo where egmo = EGML (egl from sp p $ replicate (pred nump) egmo) instance (Monad m, Strategy sp m, Strategy p m) => Strategy (EndGameMirrorLite sp p) m where strategyName ms = return "EndGameMirrorLite" move pvs mvs (EGML egs) = do (m, egs') <- move pvs mvs egs return (m, EGML egs') egl f sp p ps = EGL f sp p ps M.empty -- | @'EGL' f sp p ps memory@ usually behaves based on @p@, but it conducts the exhaustive search assuming that others behave based on @ps@ when @f@ returns True. -- The strategy @sp@ suggests a desired move in order to prioritize a promising strategy. data EndGameLite sp p ps = EGL {fromWhenL::PublicInfo->Bool, suggestedStrategyL::sp, myUsualStrategyL::p, otherPlayersL::ps, memory :: M.Map Key ([Move],[([State],ps,Int)])} type Key = (Maybe Card, [Marks], [Move], [Card]) instance (Monad m, Strategy sp m, Strategy p m, Strategies ps m) => Strategy (EndGameLite sp p ps) m where strategyName ms = return "EndGameLite" move pvs mvs str@(EGL f sp p ps memory) | f pub = do let statess = case M.lookup (resToMbC $ result $ publicView $ pvs !! pred numP, map marks $ head $ annotations pub, take (pred numP) mvs, map headC $ handsPV hdpv) memory of Just (_,tups) -> tups Nothing -> [ (stateToStateHistory (map publicView tlpvs) mvs state, ps, n) | (state, n) <- possibleStates hdpv ] (_i, (mp,m)) <- endGameMoveLite statess pvs' mvs sp return (m, EGL f sp p ps mp) | otherwise = do (m,_) <- move pvs mvs p return (m,str) where pvs'@(hdpv:tlpvs) = [ pv{publicView=pub{gameSpec=gs{rule=r{earlyQuit=True}}}} | pv@PV{publicView=pub@PI{gameSpec=gs@GS{rule=r}}}<- pvs ] pub = publicView hdpv numP = numPlayers $ gameSpec pub endGameMoveLite :: (Monad m, Strategies ps m, Strategy p m) => [([State],ps,Int)] -- ^ possible pairs of the state history and the internal memory states of other players' strategies -> [PrivateView] -- ^ view history -> [Move] -- ^ move history -> p -- ^ default (recommended) strategy -> m (Int, (M.Map Key ([Move], [([State],ps,Int)]), Move)) endGameMoveLite statess pvs@(pv:_) mvs p = do (defaultMove, q) <- move pvs mvs p let candidateMoves = defaultMove : delete defaultMove (validMoves pv) tups <- mapM (evalMoveLite statess mvs q) candidateMoves let asc = zipWith (\(mp, score) mv -> (score, (mp,mv))) tups candidateMoves pub = publicView pv achievable = sum [ n | (_,_,n) <- statess ] * moreStrictlyAchievableScore pub -- ToDo: Also consider critical cards at the bottom deck. return $ case lookup achievable asc of Nothing -> maximumBy (compare `on` fst) $ reverse asc Just k -> (achievable, k) -- Stop search when the best possible score is found. evalMoveLite :: (Monad m, Strategies ps m, Strategy p m) => [([State], ps, Int)] -> [Move] -> p -> Move -> m ( M.Map Key ([Move], [([State],ps,Int)]) , Int ) evalMoveLite statess@((st:_,_,_):_) mvs p mov = do roundResults <- fmap concat $ mapM (\sts ->tryAMoveARound sts mvs mov) statess let pub = publicState st instantScore = sum [ egToInt s eg * n | ((Just eg, s:_, _), _, n) <- roundResults ] roundResultMap = groupARound pub roundResults if M.null roundResultMap then return (roundResultMap, instantScore) else do let roundResults = M.elems roundResultMap scores <- sequence [ fmap fst $ endGameMoveLite stss (viewStates sts) moves p | (moves, stss@((sts,_,_):_)) <- roundResults ] return (roundResultMap, instantScore + sum scores) groupARound :: PublicInfo -> [((Maybe EndGame, [State], [Move]),ps,Int)] -> M.Map Key ([Move], [([State],ps,Int)]) -- ToDo: IntMap could be used instead. groupARound pub results = fmap procTip $ M.fromListWith (++) [ ( ( resToMbC $ result $ publicState $ stats !! pred numP, map marks $ head $ annotations $ publicState st, take (pred numP) movs, map headC $ tail $ hands st ), [r]) | r@((Nothing, stats@(st:_), movs), _, _) <- results ] where procTip :: [((Maybe EndGame, [State],[Move]),ps,Int)] -> ([Move], [([State],ps,Int)]) procTip ts@(((_noth, _, mv), _, _) : _) = (mv, [ (stats, ps, n) | ((_nothing, stats, _), ps, n) <- ts ]) numP = numPlayers $ gameSpec pub -- total version of head, just in case of dealing with empty hand. headC :: [Card] -> Card headC = foldr const $ C Multicolor Empty resToMbC :: Result -> Maybe Card resToMbC None = Nothing resToMbC r = Just $ revealed r -- does not work for stateful monads including IO. tryAMoveARound :: (Monad m, Strategies ps m) => ([State],ps,Int) -> [Move] -> Move -> m [((Maybe EndGame, [State], [Move]),ps,Int)] tryAMoveARound (states@(state:_),strs,n) mvs mov = let sts = proceeds state mov numCases = case sts of -- [] -> error $ show mov ++ ": invalid move!" -- We should just silently ignore errorful strategy programs sts@[st] -> n * product [1 .. pileNum (publicState st)] sts -> n in sequence $ do st <- sts let nxt = rotate 1 st return $ case checkEndGame $ publicState nxt of Nothing -> fmap (\(e,p) -> (e,p,numCases)) $ runARound (\_ _ -> return ()) (nxt:states) (mov:mvs) strs Just eg -> return ((Just eg, nxt:states, mov:mvs), strs, numCases) {- tryAMoveARound :: (Monad m, Strategies ps m) => ([State],ps,Int) -> [Move] -> Move -> m ((Maybe EndGame, [State], [Move]),ps,Int) tryAMoveARound (states@(st:_),strs,n) mvs mov = case proceed st mov of Nothing -> error $ show mov ++ ": invalid move!" Just st -> let nxt = rotate 1 st in case checkEndGame $ publicState nxt of Nothing -> fmap (\(e,p) -> (e,p,n)) $ runARound (\_ _ -> return ()) (nxt:states) (mov:mvs) strs Just eg -> return ((Just eg, nxt:states, mov:mvs), strs, n) -} {- possibleStates :: PrivateView -> [(State, Int)] possibleStates pv@PV{publicView=pub@PI{gameSpec=gs}} = [(St{ publicState = pub , pile = zipWith (\c i -> (c, initAnn gs i)) deck [ (numberOfCards (rule $ gameSpec pub) - pileNum pub) ..] , hands = hand : handsPV pv } , n) | ((hand, deck), n) <- uniqSort $ possiblePermutations pv ] uniqSort :: (Eq a, Ord a) => [a] -> [(a,Int)] uniqSort xs = map (\ys -> (head ys, length ys)) $ group $ sort xs possiblePermutations :: PrivateView -> [([Card],[Card])] possiblePermutations pv@PV{publicView=PI{annotations=anns:_}} = possiblePerms anns (invisibleCards pv) invisibleCards :: PrivateView -> [Card] invisibleCards PV{publicView=PI{annotations=anns}, invisibleBag=inv} = cardTo4ToList inv -- x ++ [ C i k | (Just i, Just k) <- map marks anns ] possiblePerms :: [Annotation] -> [Card] -> [([Card],[Card])] possiblePerms [] cards = [([],cards)] possiblePerms (Ann{marks = (Just i, Just k)} : anns) cards = [ (C i k : hand, deck) | (hand, deck) <- possiblePerms anns cards ] possiblePerms (Ann{possibilities = (pi, pk)} : anns) cards = [ (card : hand, deck) | card@(C i k) <- cards, (pi .&. bit (colorToBitPos i)) * (pk .&. bit (rankToBitPos k)) /= 0, (hand, deck) <- possiblePerms anns $ delete card cards ] -} possibleStates :: PrivateView -> [(State, Int)] possibleStates pv@PV{publicView=pub@PI{gameSpec=gs}} = [(St{ publicState = pub , pile = zipWith (\c i -> (c, initAnn gs i)) (cardTo4ToList deck) [ (numberOfCards (rule $ gameSpec pub) - pileNum pub) ..] , hands = hand : handsPV pv } , n) | (hand, deck, n) <- possiblePermutations pv ] possiblePermutations :: PrivateView -> [([Card],CardTo4,Int)] possiblePermutations pv@PV{publicView=PI{annotations=anns:_}} = possiblePerms anns (invisibleBag pv) possiblePerms :: [Annotation] -> CardTo4 -> [([Card],CardTo4,Int)] -- 最後のIntは場合の数。ただし、CardTo4での場合の数をちゃんと数えるなら数える必要はないはず。 possiblePerms [] cards = [([],cards,1)] possiblePerms (Ann{marks = (Just i, Just k)} : anns) cards = [ (C i k : hand, deck, n) | (hand, deck, n) <- possiblePerms anns cards ] possiblePerms (Ann{possibilities = (pi, pk)} : anns) cards = [ (card : hand, deck, n*num) | (card@(C i k), rest, n) <- cardTo4ToAssocList cards, (pi .&. bit (colorToBitPos i)) * (pk .&. bit (rankToBitPos k)) /= 0, (hand, deck, num) <- possiblePerms anns rest ] cardTo4ToAssocList :: CardTo4 -> [(Card, CardTo4, Int)] cardTo4ToAssocList ct4 = ctal 1 ct4 [ C i k | k <- [K1 .. K5], i <- [White .. Multicolor] ] where ctal sub 0 _ = [] ctal sub n (c:cs) | num /= 0 = (c, ct4 - sub, num) : rest | otherwise = rest where num = fromIntegral n .&. 3 rest = ctal (sub `shiftL` 2) (n `shiftR` 2) cs -- | 'mkPV' is the constructor of PrivateView. mkPV :: PublicInfo -> [[Card]] -> PrivateView mkPV pub hs = PV pub hs $ foldr deleteACard (nonPublic pub) $ 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 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 hp && d `elem` chopSet then ('D':) else if markChops v && d `elem` chopSet then ('X':) else shows d) (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 $ 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 myAnn prettySt :: (Int -> Int -> String) -> State -> String 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] -> [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 "+..+" else case (warnCritical v && tup==(Nothing,Nothing) && isCritical pub card, markPlayable v && isPlayable pub card) of (True, True) -> "+!^+" (True, False) -> "+!!+" (False,True) -> "+-^+" (False,False) -> "+--+" | (card, tup) <- zip cards hl ] ++"\n" ++ concat [ wrap $ '|':shows card "|" | card <- cards ] ++"\n" ++ (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 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" showPosLines :: [Possibilities] -> String showPosLines ps = concat [ ' ' : showColorPossibilities cs | (cs,_) <- ps] ++ "\n" ++ concat [ showRankPossibilities ns ++" " | (_,ns) <- ps] showColorPossibilities, showRankPossibilities :: Int -> String showColorPossibilities = reverse . showPossibilities ' ' colorkeys showRankPossibilities = reverse . showPossibilities ' ' "54321 " showNumberPossibilities = showRankPossibilities colorkeys :: String colorkeys = map (head . show) [maxBound, pred maxBound .. minBound::Color] -- colorkeys == "MBGRYW", but I just prefer to make this robust to changes in the order. showPossibilities :: a -> [a] -> Int -> [a] showPossibilities _ [] _ = [] showPossibilities blank (x:xs) pos = (if odd pos then x else blank) : showPossibilities blank xs (pos `div` 2) colorPossibilities :: Int -> [Color] -- The result is in the reverse order but I do not care. colorPossibilities = concat . showPossibilities [] (map (:[]) [maxBound, pred maxBound .. minBound]) rankPossibilities :: Int -> [Rank] -- The result is in the reverse order but I do not care. rankPossibilities = concat . showPossibilities [] (map (:[]) [K5,K4 .. K1]) possibilitiesQits :: (Int,Int) -> CardTo4 possibilitiesQits (c,r) = colorPossibilitiesQits c .&. rankPossibilitiesQits r colorPossibilitiesQits :: Int -> CardTo4 colorPossibilitiesQits i = let bs = cpq i qs = fromIntegral $ bs .|. (bs `shiftL` 1) qs2 = qs .|. (qs `shiftL` 12) qs4 = qs2 .|. (qs2 `shiftL` 24) qs5 = qs .|. (qs4 `shiftL` 12) in qs5 cpq :: Int -> Int cpq i = (i .&. 32 .|. (i .&. 16) `shiftL` 3 .|. (i .&. 8) `shiftL` 6 .|. (i .&. 4) `shiftL` 9 .|. (i .&. 2) `shiftL` 12 .|. (i .&. 1) `shiftL` 15) `shiftR` 5 rankPossibilitiesQits :: Int -> CardTo4 rankPossibilitiesQits i = let r1 = rpq i r2 = r1 .|. (r1 `shiftR` 1) r4 = r2 .|. (r2 `shiftR` 2) r8 = r4 .|. (r4 `shiftR` 4) r12 = r4 .|. (r8 `shiftR` 4) in r12 rpq :: Int -> CardTo4 rpq i = let i1 = fromIntegral $ i `shiftL` 7 i2 = i1 .|. (i1 `shiftL` 13) i4 = i2 .|. (i2 `shiftL` 26) i5 = i1 .|. (i4 `shiftL` 13) in i5 .&. 0x800800800800800 -- | 'Verbosity' is the set of options used by verbose 'Strategy's data Verbosity = V { warnCritical :: Bool -- ^ mark unhinted critical cards with "!!" ("!^" if it is playable and markPlayable==True.) , markUseless :: Bool -- ^ mark useless cards with "..". , markPlayable :: Bool -- ^ mark playable cards with "_^". ("!^" if it is unhinted critical and warnCritical==True.) , markObviouslyUseless :: Bool -- ^ mark useless cards with "_." based on the hint marks. , markObviouslyPlayable :: Bool -- ^ mark playable cards with "_^" based on the hint marks. , markChops :: Bool -- ^ mark the chop card(s) with "X". All obviously-useless cards will be marked, if any. , warnDoubleDrop:: Bool -- ^ mark the chop card with "D" when dropping it is double-dropping. , markHints :: Bool -- ^ mark hints. , markPossibilities :: Bool -- ^ mark more detailed hints based on the positive/negative hint history. -- markPossibilities == True && markHints == False is a reasonable choice, though markHints should still be informative for guessing other players' behavior. } deriving (Read, Show, Eq, Generic) {- 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" -} showDeck pub = case deadline pub of Nothing -> "Deck: " ++ shows (pileNum pub) ", " Just 0 -> "Deck: 0 (no turn left), " Just 1 -> "Deck: 0 (1 turn left), " Just t -> "Deck: 0 (" ++ shows t " turns left), " prettyPI :: PublicInfo -> String prettyPI pub = "Turn: "++ shows (turn pub) ", " ++ showDeck pub ++ "Lives: " ++ shows (lives pub) ", Hints: " ++ shows (hintTokens pub) ";\n\n" ++ "played (" ++ shows (currentScore pub) " / " ++ shows (seeminglyAchievableScore pub) "):" ++ concat [ " " ++ concat ( [ show $ C c k | k <- [K1 .. achievedRank pub c] ] ++ replicate (possible - fromEnum playedMax) "__" ++ replicate (5 - possible) "XX") | c <- colors pub , let playedMax = achievedRank pub c possible = fromEnum $ bestPossibleRank pub c ] ++ "\ndropped: " ++ concat [ '|' : concat (replicate (discarded pub c) $ show c) | i <- colors pub, k <- [K1 .. maxBound], let c = C i k ] ++"|\n" view :: State -> PrivateView view st = mkPV (publicState st) (tail $ hands st) main :: IO () main = selfplay defaultGS -- | 'selfplay' starts selfplay with yourself:) -- -- Also, -- -- > selfplay defaultGS{numPlayers=n} -- -- (where 1 IO () selfplay gs = do g <- newStdGen ((finalSituation,_),_) <- start gs [] [stdio] g putStrLn $ prettyEndGame finalSituation -- | 'prettyEndGame' can be used to pretty print the final situation. prettyEndGame :: (EndGame, [State], [Move]) -> String 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 :: [a] -> [a] -> [a] surround ys xs = let len = length xs len2 =len `div` 2 in reverse (drop len2 ys) ++ xs ++ drop (len - len2) ys type Peeker m = State -> [Move] -> m () peek :: Peeker IO peek st [] = putStrLn $ prettySt ithPlayerFromTheLast st peek st (mv:_) = putStrLn $ replicate 20 '-' ++ '\n' : showTrial (const "") undefined (view st) mv ++ '\n' : replicate 20 '-' ++ '\n' : prettySt ithPlayerFromTheLast st -- | 'start' creates and runs a game. This is just the composition of 'createGame' and 'run'. start :: (RandomGen g, Monad m, Strategies ps m) => GameSpec -> [Peeker m] -> ps -> g -> m (((EndGame, [State], [Move]), ps), g) start gs audience players gen = let (st, g) = createGame gs gen in fmap (\e -> (e,g)) $ run audience [st] [] players startFromCards :: (Monad m, Strategies ps m) => GameSpec -> [Peeker m] -> ps -> [Card] -> m ((EndGame, [State], [Move]), ps) startFromCards gs audience players shuffled = let st = createGameFromCards gs shuffled in run audience [st] [] players run :: (Monad m, Strategies ps m) => [Peeker m] -> [State] -> [Move] -> ps -> m ((EndGame, [State], [Move]), ps) run audience states moves players = do ((mbeg, sts, mvs), ps) <- runARound (\sts@(st:_) mvs -> let myOffset = turn (publicState st) in mapM_ (\p -> p st mvs) audience >> broadcast (zipWith rotate [-myOffset, 1-myOffset ..] sts) mvs players (myOffset `mod` numPlayers (gameSpec $ publicState st)) >> return ()) states moves players case mbeg of Nothing -> run audience sts mvs ps Just eg -> return ((eg, sts, mvs), ps) -- | 'runSilently' is a light variant of 'run' that does not broadcast the process. This is useful for simulating the game within a strategy. runSilently :: (Monad m, Strategies ps m) => [State] -> [Move] -> ps -> m ((EndGame, [State], [Move]), ps) runSilently states moves players = do ((mbeg, sts, mvs), ps) <- runARound (\_ _ -> return ()) states moves players case mbeg of Nothing -> runSilently sts mvs ps Just eg -> return ((eg, sts, mvs), ps) -- | The 'Strategy' class is exactly the interface that -- AI researchers defining their algorithms have to care about. class Monad m => Strategy p m where -- | '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. -} -- StrategyDict should be used instead of class Strategy, maybe. -- | 'StrategyDict' is a dictionary implementation of class 'Strategy'. It can be used instead if you like. data StrategyDict m s = SD{sdName :: String, sdMove :: Mover s m, sdObserve :: Observer s m, sdState :: s} type Mover s m = [PrivateView] -> [Move] -> s -> m (Move, s) type Observer s m = [PrivateView] -> [Move] -> s -> m () mkSD :: (Monad m, Typeable s, Strategy s m) => String -> s -> StrategyDict m s mkSD name s = SD{sdName=name, sdMove=move, sdObserve=observe, sdState=s} instance Monad m => Strategy (StrategyDict m s) m where strategyName mp = do p <- mp return $ sdName p move pvs mvs s = sdMove s pvs mvs (sdState s) >>= \ (m, nexts) -> return (m, s{sdState=nexts}) observe pvs mvs s = sdObserve s pvs mvs $ sdState s -- Should DynamicStrategy be limited to IO? type DynamicStrategy m = StrategyDict m Dynamic mkDS :: (Monad m, Typeable s, Strategy s m) => String -> s -> DynamicStrategy m mkDS name s = mkDS' $ mkSD name s mkDS' :: (Monad m, Typeable s) => StrategyDict m s -> DynamicStrategy m mkDS' gs = SD{sdName = sdName gs, sdMove = \pvs mvs dyn -> fmap (\(m,p)->(m, toDyn p)) $ sdMove gs pvs mvs (fromDyn dyn (error "mkDS': impossible")), sdObserve = \pvs mvs dyn -> sdObserve gs pvs mvs (fromDyn dyn (error "mkDS': impossible")), sdState = toDyn $ sdState gs} -- | 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 -> Int -> m ([State], Int) {- 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) offset = do (sts, ofs) <- broadcast states moves p1 offset broadcast sts moves p2 ofs instance (Strategy p m, Monad m) => Strategies [p] m where -- runARound hook states moves [] = return ((Nothing, states, moves), []) runARound _ _ _ [] = 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] ofs = when (ofs/=0) (observe (viewStates states) moves p) >> return (map (rotate 1) states, pred ofs) broadcast states moves (p:ps) ofs = when (ofs/=0) (observe (viewStates states) moves p) >> broadcast (map (rotate 1) states) moves ps (pred ofs) viewStates :: [State] -> [PrivateView] viewStates = map view . zipWith rotate [0..] runATurn :: (Strategy p m, Monad m) => [State] -> [Move] -> p -> m ((Maybe EndGame, [State], [Move]), p) runATurn states moves p = let alg = move (viewStates 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. data Verbose p = Verbose {unV :: p, verbV :: Verbosity} 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@(_:_) moves (Verbose p verb) = let alg = move views moves p in do name <- strategyName (fmap (\a -> Verbose (snd a) verb) alg) liftIO $ putStrLn $ what'sUp verb name views moves (mv,p') <- alg -- liftIO $ putStrLn $ "Move is " ++ show mv -- This is redundant because of echo back. return (mv, Verbose p' verb) observe _ [] _ = return () observe (v:_) (m:_) (Verbose _ verb) = liftIO $ putStrLn $ what'sUp1 verb v m what'sUp :: Verbosity -> String -> [PrivateView] -> [Move] -> String what'sUp verb name views@(v:_) moves = replicate 20 '-' ++ '\n' : recentEvents ithPlayer views moves ++ '\n' : replicate 20 '-' ++ '\n' : "Algorithm: " ++ name ++ '\n' : prettyPV verb v ++ "\nYour turn.\n" what'sUp1 :: Verbosity -> PrivateView -> Move -> String what'sUp1 verb v m = replicate 20 '-' ++ '\n' : showTrial (const "") undefined v m ++ '\n' : replicate 20 '-' ++ '\n' : prettyPV verb v recentEvents :: (Int -> Int -> String) -> [PrivateView] -> [Move] -> String 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 :: (Int -> String) -> Int -> PrivateView -> Move -> String 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 :: Int -> Int -> String ithPlayer _ 0 = "Your" ithPlayer _ i = "The " ++ ith i ++"next player's" ith :: Int -> String ith 1 = "" ith 2 = "2nd " ith 3 = "3rd " ith i = shows i "th " ithPlayerFromTheLast :: Int -> Int -> String ithPlayerFromTheLast nump j = "The " ++ ith (nump-j) ++"last player's" newtype Replay = Replay String deriving (Read, Show) instance (MonadIO m) => Strategy Replay m where strategyName _ = return "Replay" move (v:_) _ (Replay xs) = case splitAt 2 xs of ("","") -> do mov <- liftIO $ repeatReadingAMoveUntilSuccess stdin stdout v return (mov, Replay "") (tk,dr) -> return (read tk, Replay dr) type STDIO = Verbose Blind stdio :: Verbose Blind stdio = Verbose Blind verbose data Blind = Blind instance (MonadIO m) => Strategy Blind m where strategyName _ = return "Blind" move (v:_) _ _ = do mov <- liftIO $ repeatReadingAMoveUntilSuccess stdin stdout v return (mov, Blind) data ViaHandles = VH {hin :: Handle, hout :: Handle, verbVH :: Verbosity} instance (MonadIO m) => Strategy ViaHandles m where strategyName _ = return "via handles" move views@(v:_) moves vh = liftIO $ do hPutStrLn (hout vh) $ what'sUp (verbVH vh) "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 -- | 'createGameFromCards' deals cards and creates the initial state. createGameFromCards :: GameSpec -> [Card] -> State createGameFromCards gs cards = splitCons (numPlayers gs) [] [ (c, initAnn gs i) | (c,i) <- zip cards [0..] ] where pNEC = packedNumEachCard gs splitCons 0 hnds stack = St {publicState = PI {gameSpec = gs, pileNum = initialPileNum gs, currentScore = 0, nextToPlay = 0xFFF, kept = pNEC, nonPublic = pNEC, turn = 0, lives = numBlackTokens $ rule gs, hintTokens = 8, deadline = Nothing, annotations = map (map snd) hnds, result = None }, pile = stack, hands = map (map fst) hnds } splitCons n hnds stack = case splitAt (handSize gs) stack of (tk,dr) -> splitCons (pred n) (tk:hnds) dr initAnn gs i = Ann{ixDeck=i, marks=(Nothing, Nothing), possibilities=unknown gs} createGame :: RandomGen g => GameSpec -> g -> (State, g) -- Also returns the new RNG state, in order not to require safe 'split' for collecting statistics. RNG is only used for initial shuffling. createGame gs gen = (createGameFromCards gs shuffled, g) where (shuffled, g) = createDeck (rule gs) gen createDeck :: RandomGen g => Rule -> g -> ([Card], g) createDeck r gen = shuffle (cardBag r) gen numAssoc :: [(Rank, Int)] 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 -> [Card] cardBag rule = concat [ replicate n c | (c,n) <- cardAssoc rule ] unknown :: GameSpec -> Possibilities unknown gs = (64 - bit (6 - numColors (rule gs)), 31) shuffle :: RandomGen g => [c] -> g -> ([c], g) shuffle xs = shuf [] xs $ length xs shuf :: RandomGen g => [a] -> [a] -> Int -> g -> ([a], g) 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 $ 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 not (null $ filter willBeHinted (tlHands !! pred hintedpl)) where willBeHinted :: Card -> Bool willBeHinted = either (\c -> (==c).color) (\k -> (==k).rank) eck pickNth :: Int -> [a] -> (a, [a]) pickNth n xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++dr) replaceNth :: Int -> a -> [a] -> (a, [a]) replaceNth n x xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++x:dr) -- = updateNth n (const x) xs updateNth :: Int -> (a -> a) -> [a] -> (a, [a]) 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 mv = if (isMoveValid (view st) mv) then return (prc st mv) else Nothing prc st (Hint hintedpl eik) = prcHint st hintedpl eik prc st mv = prcCard st mv $ pile st prcCard st@(St{publicState=pub@PI{gameSpec=gS}}) mv currentPile = let (nth, droppedHand) = pickNth (index mv) playersHand where playersHand = head $ hands st (_ , droppedAnn) = pickNth (index mv) playersAnn where playersAnn = head $ annotations pub (nextHand, nextAnn, nextPile, nextPileNum) = case currentPile of [] -> ( droppedHand, droppedAnn, [], 0) d:ps -> (fst d : droppedHand, snd d : droppedAnn, ps, pred $ pileNum pub) nextHands = nextHand : tail (hands st) 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 in st{pile = nextPile, hands = nextHands, publicState = case mv of Drop _ -> pub{pileNum = nextPileNum, kept = deleteACard nth $ kept pub, nonPublic = deleteACard nth $ nonPublic pub, turn = succ $ turn pub, hintTokens = succ $ hintTokens pub, annotations = nextAnns, deadline = nextDeadline, result = Discard nth} Play i | failure -> pub{pileNum = nextPileNum, kept = deleteACard nth $ kept pub, nonPublic = deleteACard nth $ nonPublic pub, turn = succ $ turn pub, lives = pred $ lives pub, annotations = nextAnns, deadline = nextDeadline, result = Fail nth} | otherwise -> pub{pileNum = nextPileNum, currentScore = succ $ currentScore pub, nextToPlay = ((nextToPlay pub .&. complement mask) .|. ((nextToPlay pub .&. mask) `shiftL` 12)) .&. 0xFFFFFFFFFFFFFFF, nonPublic = deleteACard nth $ nonPublic pub, turn = succ $ turn pub, hintTokens = if hintTokens pub < 8 && rank nth == K5 then succ $ hintTokens pub else hintTokens pub, annotations = nextAnns, deadline = nextDeadline, result = Success nth} where failure = not $ isPlayable pub nth mask = 0x3003003003003 `shiftL` (fromEnum (color nth) * 2) } prcHint st@(St{publicState=pub}) hintedpl eik = st{ publicState = pub{hintTokens = pred $ hintTokens pub, turn = succ $ turn pub, annotations = snd $ updateNth hintedpl newAnns (annotations pub), deadline = case deadline pub of Nothing -> Nothing Just i -> Just $ pred i, result = None}} 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 = colorToBitPos i Right k | k == ka -> ann{marks=(mi, Just k), possibilities = (c, bit kbit)} |otherwise-> ann{possibilities = (c, clearBit n kbit)} where kbit = rankToBitPos k -- 'proceeds' is the variant of proceed that enumerates draw possibilities. This can be used to simulate the environment within a strategy. proceeds :: State -> Move -> [State] proceeds st mv | not $ isMoveValid (view st) mv = [] proceeds st (Hint hintedpl eik) = [prcHint st hintedpl eik] proceeds st mv = case pileNum $ publicState st of 0 -> [prcCard st mv []] numPSt -> [ prcCard st mv $ nth:rest | n <- [0..numPSt-1], let (nth,rest) = pickNth n $ pile st ] -- | @'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{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. -- It is not just @Int@ in order to distinguish 'Failure' (disaster / no life) from @'Soso' 0@ (not playing any card), though @'Soso' 0@ does not look more attractive than 'Failure'. data EndGame = Failure | Soso Int | Perfect deriving (Show,Read,Eq,Generic) egToInt _ Failure = 0 egToInt st _ = currentScore $ publicState st checkEndGame :: PublicInfo -> Maybe EndGame checkEndGame pub | lives pub == 0 = Just Failure | current == numColors r * 5 = Just Perfect | deadline pub == Just 0 || (earlyQuit r && current == seeminglyAchievableScore pub) = Just $ Soso current | 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 where current = currentScore pub r = rule $ gameSpec pub