{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, Safe, DeriveGeneric, RecordWildCards #-}
module Game.Hanabi(
main, selfplay, start, createGame, run,
prettyEndGame, isMoveValid, checkEndGame, help,
Strategies, Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose,
GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid, colors,
Move(..), Index, State(..), PrivateView(..), PublicInfo(..), Result(..), EndGame(..),
Card(..), Color(..), Number(..), Marks, cardToInt, intToCard, readsColorChar, readsNumberChar,
isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, isObviouslyUseless, isMoreObviouslyPlayable, isObviouslyPlayable, invisibleBag, chops, chopss,
what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, ithPlayerFromTheLast, view, replaceNth, shuffle) where
import qualified Data.IntMap as IM
import System.Random
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)
import System.IO
import Data.Dynamic
import GHC.Generics hiding (K1)
data Number = Empty | K1 | K2 | K3 | K4 | K5 deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic)
data Color = White | Yellow | Red | Green | Blue | Multicolor
deriving (Eq, Show, Read, Enum, Bounded, Generic)
readsColorChar :: ReadS Color
readsColorChar (c:str)
| isSpace c = readsColorChar str
| otherwise = case lookup (toUpper c) [(head $ show i, i) | i <- [White, Yellow, Red, Green, Blue]] of
Nothing -> []
Just i -> [(i, str)]
readsColorChar [] = []
readsNumberChar :: ReadS Number
readsNumberChar ('0':rest) = [(Empty,rest)]
readsNumberChar str = reads ('K':str)
data Card = C {color :: Color, number :: Number} deriving (Eq, Generic)
instance Show Card where
showsPrec _ (C color number) = (head (show color) :) . (show (fromEnum number) ++)
instance Read Card where
readsPrec _ str = [(C i k, rest) | (i, xs) <- readsColorChar str, (k, rest) <- readsNumberChar xs]
cardToInt c = fromEnum (color c) * (succ $ fromEnum (maxBound::Number)) + fromEnum (number c)
intToCard i = case i `divMod` (succ $ fromEnum (maxBound::Number)) of (c,k) -> C (toEnum c) (toEnum k)
type Index = Int
data Move = Drop {index::Index}
| Play {index::Index}
| Hint Int (Either Color Number)
deriving (Eq, 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 (\i -> (take 1 (show i) ++)) (\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
| 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
, (i, _) <- reads istr
, let ys' = dropWhile isSpace ys
, (eith, rest) <- [ (Left c, zs) | (c,zs) <- readsColorChar ys' ] ++ [ (Right c, zs) | (c,zs) <- readsNumberChar ys' ] ]
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"
data Rule = R { numBlackTokens :: Int
, funPlayerHand :: [Int]
, numColors :: Int
, prolong :: Bool
, numMulticolors :: [Int]
} deriving (Show, Read, Eq, Generic)
isRuleValid rule@R{..} = numBlackTokens > 0 && all (>0) funPlayerHand && numColors>0 && numColors <=6 && (numColors < 6 || all (>0) numMulticolors)
defaultRule = R { numBlackTokens = 3
, funPlayerHand = [5,5]++take 12 (repeat 4)
, numColors = 5
, prolong = False
, numMulticolors = replicate 5 0
}
defaultGS = GS{numPlayers=2, rule=defaultRule}
initialPileNum gs = sum (take (numColors $ rule gs) $ [10,10,10,10,10]++[sum (numMulticolors $ rule gs)])
- numPlayerHand gs * numPlayers gs
numPlayerHand gs = (funPlayerHand (rule gs) ++ repeat 4) !! (numPlayers gs - 2)
data GameSpec = GS {numPlayers :: Int, rule :: Rule} deriving (Read, Show, Eq, Generic)
data State = St { publicState :: PublicInfo
, pile :: [Card]
, hands :: [[Card]]
} deriving (Read, Show, Eq, Generic)
data PublicInfo = PI { gameSpec :: GameSpec
, pileNum :: Int
, played :: IM.IntMap Number
, discarded :: IM.IntMap Int
, nonPublic :: IM.IntMap Int
, turn :: Int
, lives :: Int
, hintTokens :: Int
, deadline :: Maybe Int
, givenHints :: [[Marks]]
, result :: Result
} deriving (Read, Show, Eq, Generic)
type Marks = (Maybe Color, Maybe Number)
bestPossibleRank :: PublicInfo -> Color -> Number
bestPossibleRank pub iro = toEnum $ length $ takeWhile (/=0) $ zipWith subtract (numCards (gameSpec pub) iro)
(map ((discarded pub IM.!) . cardToInt . C iro) [K1 .. K5])
numCards :: GameSpec -> Color -> [Int]
numCards gs iro = if iro==Multicolor then numMulticolors $ rule gs else [3,2,2,2,1]
isUseless :: PublicInfo -> Card -> Bool
isUseless pub card = number card <= achievedRank pub (color card)
|| number card > bestPossibleRank pub (color card)
isCritical :: PublicInfo -> Card -> Bool
isCritical pub card = not (isUseless pub card)
&& succ (discarded pub IM.! cardToInt card) == (numCards (gameSpec pub) (color card) !! (pred $ fromEnum $ number card))
isPlayable :: PublicInfo -> Card -> Bool
isPlayable pub card = pred (number card) == achievedRank pub (color card)
isHinted :: Marks -> Bool
isHinted = not . (==(Nothing, Nothing))
isMostObviouslyPlayable :: PublicInfo -> Marks -> Bool
isMostObviouslyPlayable pub (Just c, Just n) = isPlayable pub $ C c n
isMostObviouslyPlayable pub _ = False
isMoreObviouslyPlayable :: PublicInfo -> Marks -> Bool
isMoreObviouslyPlayable pub = iOP (nonPublic pub) pub
isObviouslyPlayable :: PrivateView -> Marks -> Bool
isObviouslyPlayable pv = iOP (invisibleBag pv) (publicView pv)
iOP bag pub (Just c, Just n) = isPlayable pub $ C c n
iOP bag pub (Nothing,Just n) = all (isPlayable pub) [ card | color <- colors pub, let card = C color n, (bag IM.! cardToInt card) > 0 ]
iOP _ _ _ = False
isObviouslyUseless :: PublicInfo -> Marks -> Bool
isObviouslyUseless pub (Just c, Just n) = isUseless pub $ C c n
isObviouslyUseless pub (Just c, Nothing) = bestPossibleRank pub c == achievedRank pub c
isObviouslyUseless pub (Nothing, Just n) = all (\c -> n <= achievedRank pub c || bestPossibleRank pub c < n) $ colors pub
isObviouslyUseless pub (Nothing, Nothing) = False
choppiri :: [Marks] -> [(Index, Marks)]
choppiri = reverse . filter (not . isHinted . snd) . zip [0..]
chopss :: PublicInfo -> [Marks] -> [[(Index, Marks)]]
chopss pub hls = (if null useless then id else (useless :)) $ map (:[]) (choppiri hls)
where useless = filter (isObviouslyUseless pub . snd) (zip [0..] hls)
chops :: PublicInfo -> [Marks] -> [(Index, Marks)]
chops pub hls = concat $ map reverse $ chopss pub hls
colors :: PublicInfo -> [Color]
colors pub = take (numColors $ rule $ gameSpec pub) [minBound .. maxBound]
achievedRank :: PublicInfo -> Color -> Number
achievedRank pub k = case IM.lookup (fromEnum k) (played pub) of
Just n -> n
#ifdef DEBUG
Nothing | numColors (rule $ gameSpec pub) <= k -> error "requesting invalid color."
| otherwise -> error "PublicInfo is not initialized."
#else
Nothing -> Empty
#endif
data Result = None
| Discard Card | Success Card | Fail Card deriving (Read, Show, Eq, Generic)
data PrivateView = PV { publicView :: PublicInfo
, handsPV :: [[Card]]
} deriving (Read, Show, Eq, Generic)
invisibleBag :: PrivateView
-> IM.IntMap Int
invisibleBag pv = foldr (IM.update (Just . pred)) (nonPublic $ publicView pv) $ map cardToInt $ concat $ [ C c n | (Just c, Just n) <- head $ givenHints $ publicView pv ] : handsPV pv
prettyPV :: Verbosity -> PrivateView -> String
prettyPV v pv@PV{publicView=pub} = prettyPI pub ++ "\nMy hand:\n"
++ concat (replicate (length myHand) " __") ++ "\n"
++ concat (replicate (length myHand) "|**") ++ "|\n"
++ (if markHints v then showHintLine myHand else "")
++ concat [ '+':(if markChops v && d `elem` map fst (concat $ take 1 $ chopss pub myHand) then ('X':) else shows d)
(if markObviouslyUseless v && isObviouslyUseless pub h then "." else
if markObviouslyPlayable v && isObviouslyPlayable pv h then "^" else "-") | (d,h) <- zip [0..] myHand ]
++ concat (zipWith3 (prettyHand v pub (ithPlayer $ numPlayers $ gameSpec pub)) [1..] (handsPV pv) $ tail $ givenHints pub)
where myHand = head (givenHints pub)
prettySt ithP st@St{publicState=pub} = prettyPI pub ++ concat (zipWith3 (prettyHand verbose pub (ithP $ numPlayers $ gameSpec pub)) [0..] (hands st) $ givenHints pub)
verbose = V{warnCritical=True,markUseless=True,markPlayable=True,markObviouslyUseless=True,markObviouslyPlayable=True,markHints=True,markChops=True}
prettyHand :: Verbosity -> PublicInfo -> (Int->String) -> Int -> [Card] -> [Marks] -> String
prettyHand v pub ithPnumP i cards hl = "\n\n" ++ ithPnumP i ++ " hand:\n"
++ concat [ 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 [ '|':show card | card <- cards ] ++"|\n"
++ (if markHints v then showHintLine hl else "")
++ concat [ '+':(if markChops v && map fst (take 1 $ chops pub hl) == [d] then ('X':) else ('-':))
(if markObviouslyUseless v && isObviouslyUseless pub h then "." else
if markObviouslyPlayable v && isMoreObviouslyPlayable pub h then "^" else "-") | (d,h) <- zip [0..] hl ]
showHintLine :: [Marks] -> String
showHintLine hl = '|' : concat [ maybe ' ' (head . show) mc : maybe ' ' (head . show . fromEnum) mk : "|" | (mc,mk) <- hl] ++ "\n"
data Verbosity = V { warnCritical :: Bool
, markUseless :: Bool
, markPlayable :: Bool
, markObviouslyUseless :: Bool
, markObviouslyPlayable :: Bool
, markChops :: Bool
, markHints :: Bool
} deriving (Read, Show, Eq, Generic)
prettyPI pub
= let
showDeck 0 = if prolong $ rule $ gameSpec pub then "Deck: 0, " else "Deck: 0 (" ++ shows (fromJust $ deadline pub) " turn(s) left), "
showDeck 1 = "Deck: 1, "
showDeck n = "Deck: " ++ shows n ", "
in "Turn: "++ shows (turn pub) ", " ++ showDeck (pileNum pub) ++ "Lives: " ++ shows (lives pub) ", Hints: " ++ shows (hintTokens pub) ";\n\n"
++ "played:" ++ concat [ " " ++ concat [ show $ C c k | k <- [K1 .. achievedRank pub c]] | c <- [minBound .. Multicolor] ]
++ "\ndropped: " ++ concat [ '|' : concat (replicate n $ show $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ] ++"|\n"
view :: State -> PrivateView
view st = PV {publicView = publicState st,
handsPV = tail $ hands st}
main = selfplay defaultGS
selfplay gs
= do g <- newStdGen
((finalSituation,_),_) <- start gs [stdio] g
putStrLn $ prettyEndGame finalSituation
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 ys xs = let len = length xs
len2 =len `div` 2
in reverse (drop len2 ys) ++ xs ++ drop (len - len2) ys
start :: (RandomGen g, Monad m, Strategies ps m) =>
GameSpec -> ps -> g -> m (((EndGame, [State], [Move]), ps), g)
start gs players gen = let
(st, g) = createGame gs gen
in fmap (\e -> (e,g)) $ run [st] [] players
run :: (Monad m, Strategies ps m) => [State] -> [Move] -> ps -> m ((EndGame, [State], [Move]), ps)
run states moves players = do ((mbeg, sts, mvs), ps) <- runARound (\sts@(st:_) mvs -> let myOffset = turn (publicState st) in broadcast (zipWith rotate [-myOffset, 1-myOffset ..] sts) mvs players (myOffset `mod` numPlayers (gameSpec $ publicState st)) >> return ()) states moves players
case mbeg of Nothing -> run sts mvs ps
Just eg -> return ((eg, sts, mvs), ps)
class Monad m => Strategy p m where
strategyName :: m p -> m String
move :: [PrivateView]
-> [Move]
-> p
-> m (Move, p)
observe :: [PrivateView]
-> [Move]
-> p
-> m ()
observe _pvs _moves st = return ()
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
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}
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)
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 [] = 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 (map view states) moves p) >> return (map (rotate 1) states, pred ofs)
broadcast states moves (p:ps) ofs = when (ofs/=0) (observe (map view states) moves p) >> broadcast (map (rotate 1) states) moves ps (pred ofs)
runATurn :: (Strategy p m, Monad m) => [State] -> [Move] -> p -> m ((Maybe EndGame, [State], [Move]), p)
runATurn states moves p = let alg = move (map view $ zipWith rotate [0..] states) moves p in
do (mov, p') <- alg
case proceed (head states) mov of
Nothing -> do name <- strategyName (fmap snd alg)
error $ show mov ++ " by " ++ name ++ ": invalid move!"
Just st -> let nxt = rotate 1 st
in return ((checkEndGame $ publicState nxt, nxt:states, mov:moves), p')
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@(v:_) 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
return (mv, Verbose p' verb)
observe _ [] _ = return ()
observe (v:_) (m:_) (Verbose _ verb) = liftIO $ putStrLn $ what'sUp1 verb v m
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 verb v m = replicate 20 '-' ++ '\n' :
showTrial (const "") undefined v m ++ '\n' :
replicate 20 '-' ++ '\n' :
prettyPV verb v
recentEvents ithP vs@(v:_) ms = unlines $ reverse $ zipWith3 (showTrial $ ithP nump) [pred nump, nump-2..0] vs ms
where nump = numPlayers $ gameSpec $ publicView v
showTrial ithP i v m = ithP i ++ " move: " ++ replicate (length (ithP 2) - length (ithP i)) ' ' ++ show m ++
case result $ publicView v of Discard c -> ", which revealed "++shows c "."
Success c -> ", which succeeded revealing "++shows c "."
Fail c -> ", which failed revealing " ++ shows c "."
_ -> "."
ithPlayer _ 0 = "My"
ithPlayer _ i = "The " ++ ith i ++"next player's"
ith 1 = ""
ith 2 = "2nd "
ith 3 = "3rd "
ith i = shows i "th "
ithPlayerFromTheLast nump j = "The " ++ ith (nump-j) ++"last player's"
type STDIO = Verbose Blind
stdio = Verbose Blind verbose
data Blind = Blind
instance (MonadIO m) => Strategy Blind m where
strategyName p = return "Blind"
move (v:_) _ _ = do mov <- liftIO $ repeatReadingAMoveUntilSuccess stdin stdout v
return (mov, Blind)
data ViaHandles = VH {hin :: Handle, hout :: Handle, verbVH :: Verbosity}
instance (MonadIO m) => Strategy ViaHandles m where
strategyName p = 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
createGame :: RandomGen g => GameSpec -> g -> (State, g)
createGame gs gen = splitCons (numPlayers gs) [] shuffled
where splitCons 0 hnds stack
= (St {publicState = PI {gameSpec = gs,
pileNum = initialPileNum gs,
played = IM.fromAscList [ (i, Empty) | i <- [0 .. pred $ numColors $ rule gs] ],
discarded = IM.fromList [ (cardToInt $ C i k, 0) | i <- take (numColors $ rule gs) [White .. Multicolor],
k <- [K1 ..K5] ],
nonPublic = cardMap $ rule gs,
turn = 0,
lives = numBlackTokens $ rule gs,
hintTokens = 8,
deadline = Nothing,
givenHints = replicate (numPlayers gs) $ replicate (numPlayerHand gs) (Nothing, Nothing),
result = None
},
pile = stack,
hands = hnds
}, g)
splitCons n hnds stack = case splitAt (numPlayerHand gs) stack of (tk,dr) -> splitCons (pred n) (tk:hnds) dr
(shuffled, g) = shuffle (cardBag $ rule gs) gen
numAssoc = zip [K1 ..K5] [3,2,2,2,1]
cardAssoc :: Rule -> [(Card,Int)]
cardAssoc rule = take (5 * numColors rule) $
[ (C i k, n) | i <- [White .. pred Multicolor], (k,n) <- numAssoc ] ++ [ (C Multicolor k, n) | (k, n) <- zip [K1 ..K5] (numMulticolors rule) ]
cardBag rule = concat [ replicate n c | (c,n) <- cardAssoc rule ]
cardMap rule = IM.fromList [ (cardToInt c, n) | (c,n) <- cardAssoc rule ]
shuffle :: RandomGen g => [c] -> g -> ([c], g)
shuffle xs = shuf [] xs $ length xs
shuf result _ 0 gen = (result, gen)
shuf result xs n gen = let (i, g) = randomR (0, pred n) gen
(nth,rest) = pickNth i xs
in shuf (nth:result) rest (pred n) g
isMoveValid :: PrivateView -> Move -> Bool
isMoveValid PV{publicView=pub} (Drop ix) = hintTokens pub < 8 && length (head $ givenHints pub) > ix && ix >= 0
isMoveValid PV{publicView=pub} (Play ix) = length (head $ givenHints pub) > ix && ix >= 0
isMoveValid PV{publicView=pub,handsPV=tlHands} (Hint hintedpl eck)
= hintTokens pub > 0 &&
hintedpl > 0 && hintedpl < numPlayers (gameSpec pub) &&
not (null $ filter willBeHinted (tlHands !! pred hintedpl))
where willBeHinted :: Card -> Bool
willBeHinted = either (\c -> (==c).color) (\k -> (==k).number) eck
pickNth n xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++dr)
replaceNth n x xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++x:dr)
updateNth n f xs = case splitAt n xs of (tk,nth:dr) -> (nth,tk++f nth:dr)
proceed :: State -> Move -> Maybe State
proceed st@(St{publicState=pub@PI{gameSpec=gS}}) mv = if (isMoveValid (view st) mv) then return (prc mv) else Nothing where
(nth, droppedHand) = pickNth (index mv) playersHand where playersHand = head $ hands st
(_ , droppedHint) = pickNth (index mv) playersHint where playersHint = head $ givenHints pub
(nextHand,nextHint,nextPile, nextPileNum) = case pile st of [] -> (droppedHand, droppedHint, [], 0)
d:ps -> (d:droppedHand, (Nothing,Nothing):droppedHint, ps, pred $ pileNum pub)
nextHands = nextHand : tail (hands st)
nextHints = nextHint : tail (givenHints pub)
nextDeadline = case deadline pub of Nothing | nextPileNum==0 && not (prolong $ rule $ gameSpec pub) -> Just $ numPlayers gS
| otherwise -> Nothing
Just i -> Just $ pred i
prc (Drop _) = st{pile = nextPile,
hands = nextHands,
publicState = pub{pileNum = nextPileNum,
discarded = IM.update (Just . succ) (cardToInt nth) $ discarded pub,
nonPublic = IM.update (Just . pred) (cardToInt nth) $ nonPublic pub,
turn = succ $ turn pub,
hintTokens = succ $ hintTokens pub,
givenHints = nextHints,
deadline = 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}}
| otherwise = st{pile = nextPile,
hands = nextHands,
publicState = pub{pileNum = nextPileNum,
played = IM.update (Just . succ) (fromEnum $ color nth) (played pub),
nonPublic = IM.update (Just . pred) (cardToInt nth) $ nonPublic pub,
turn = succ $ turn pub,
hintTokens = if hintTokens pub < 8 && number nth == K5 then succ $ hintTokens pub else hintTokens pub,
givenHints = nextHints,
deadline = 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),
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)
rotate :: Int -> State -> State
rotate num st@(St{publicState=pub@PI{gameSpec=gS}}) = st{hands = rotateList $ hands st,
publicState = pub{givenHints = rotateList $ givenHints pub}}
where rotateList xs = case splitAt (num `mod` numPlayers gS) xs of (tk,dr) -> dr++tk
data EndGame = Failure | Soso Int | Perfect deriving (Show,Read,Eq,Generic)
checkEndGame :: PublicInfo -> Maybe EndGame
checkEndGame pub | lives pub == 0 = Just Failure
| all (==K5) [ achievedRank pub k | k <- colors pub ] = Just Perfect
| deadline pub == Just 0 = Just $ Soso $ IM.foldr (+) 0 $ fmap fromEnum $ played pub
| hintTokens pub == 0 && null (head $ givenHints pub) = Just Failure
| otherwise = Nothing