{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, Safe, DeriveGeneric, RecordWildCards #-}
module Game.Hanabi(
main, selfplay, start, createGame, startFromCards, createGameFromCards, run, createDeck,
prettyEndGame, isMoveValid, checkEndGame, help,
Strategies, Strategy(..), StrategyDict(..), mkSD, DynamicStrategy, mkDS, mkDS', Verbose(..), STDIO, stdio, Blind, ViaHandles(..), Verbosity(..), verbose, quiet, Replay(..),
Peeker, peek,
GameSpec(..), defaultGS, Rule(..), defaultRule, isRuleValid, makeRuleValid, colors, handSize, setHandSize,
Move(..), Index, State(..), PrivateView(..), PublicInfo(..), Result(..), EndGame(..),
Card(..), Color(..), Number(..), Marks, Possibilities, Annotation(..), cardToInt, intToCard, readsColorChar, readsNumberChar, colorToBitPos, numberToBitPos,
isCritical, isUseless, bestPossibleRank, achievedRank, isPlayable, isHinted, currentScore, seeminglyAchievableScore, moreStrictlyAchievableScore, achievableScore,
definitely, obviously,
isMoreObviouslyUseless, isObviouslyUseless, isDefinitelyUseless, isDefinitelyUncritical, isDefinitelyCritical, isMoreObviouslyPlayable, isObviouslyPlayable, isDefinitelyPlayable, isObviouslyUnplayable, isDefinitelyUnplayable, obviousChopss, definiteChopss, isDoubleDrop, possibleCards, endGameMove, EndGameStrategy(..), EndGameMirrorStrategy(..), egms, EndGameLite(..), egl, EndGameMirrorLite(..), egml,
tryMove, (|||), ifA,
givenHints, possibilities_until_Ver0720,
what'sUp, what'sUp1, ithPlayer, recentEvents, prettyPI, prettySt, ithPlayerFromTheLast, view, replaceNth, shuffle, showPossibilities, showColorPossibilities, showNumberPossibilities, showTrial, showDeck) where
import qualified Data.IntMap as IM
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 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, Ord, 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 .. Multicolor]] of
Nothing -> []
Just i -> [(i, str)]
readsColorChar [] = []
readsNumberChar :: ReadS Number
readsNumberChar xs = [ (toEnum d, rest) | (d, rest) <- reads xs, d<=5 ]
data Card = C {color :: Color, number :: Number} 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) <- readsNumberChar xs]
readList xs = case reads xs of [] -> [([],xs)]
[(c,ys)] -> [ (c:cs, zs) | (cs,zs) <- readList ys ]
cardToInt :: Card -> Int
cardToInt c = fromEnum (color c) * (succ $ fromEnum (maxBound::Number)) + fromEnum (number c)
intToCard :: Int -> Card
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, 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
| 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
, earlyQuit :: Bool
, numMulticolors :: [Int]
} 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..]]
defaultRule :: Rule
defaultRule = R { numBlackTokens = 3
, funPlayerHand = [5,5]++take 8 (repeat 4)
, numColors = 5
, prolong = False
, earlyQuit = False
, numMulticolors = replicate 5 0
}
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)
data State = St { publicState :: PublicInfo
, pile :: [(Card,Annotation)]
, 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
, annotations :: [[Annotation]]
, result :: Result
} 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
type Marks = (Maybe Color, Maybe Number)
type Possibilities = (Int, Int)
colorToBitPos :: Color -> Int
colorToBitPos i = 5 - fromEnum i
numberToBitPos :: Number -> Int
numberToBitPos k = 5 - fromEnum k
data Annotation = Ann {ixDeck :: Int
, marks :: Marks
, 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 ]
bestPossibleRank :: PublicInfo -> Color -> Number
bestPossibleRank pub iro = toEnum $ length $ takeWhile (/=0) $ zipWith subtract (numEachCard (gameSpec pub) iro)
(map ((discarded pub IM.!) . cardToInt . C iro) [K1 .. K5])
numEachCard :: GameSpec -> Color -> [Int]
numEachCard 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) == (numEachCard (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 _ _ = False
isMoreObviouslyPlayable :: PublicInfo -> Marks -> Bool
isMoreObviouslyPlayable pub = iOP (nonPublic pub) pub
obviously :: (PublicInfo -> Card -> Bool) -> PublicInfo -> Possibilities -> Bool
obviously predicate pub (pc,pn) = all (\card -> (nonPublic pub IM.! cardToInt card) == 0 || predicate pub card)
[ C color number | color <- colorPossibilities pc, number <- numberPossibilities pn ]
isObviouslyPlayable :: PublicInfo -> Possibilities -> Bool
isObviouslyPlayable = obviously isPlayable
isObviouslyUnplayable :: PublicInfo -> Possibilities -> Bool
isObviouslyUnplayable = obviously (\pub -> not . isPlayable pub)
definitely :: (PrivateView -> Card -> Bool) -> PrivateView -> Annotation -> Bool
definitely predicate pv ann = all (predicate pv) $ possibleCards pv ann
isDefinitelyPlayable :: PrivateView -> Annotation -> Bool
isDefinitelyPlayable = definitely (isPlayable . publicView)
isDefinitelyUnplayable :: PrivateView -> Annotation -> Bool
isDefinitelyUnplayable = definitely (\pv -> not . isPlayable (publicView pv))
isDefinitelyUncritical :: PrivateView -> Annotation -> Bool
isDefinitelyUncritical = definitely (\pv -> not . isCritical (publicView pv))
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]
possibleCards pv Ann{possibilities = (pc,pn)} = [ card | color <- colorPossibilities pc, number <- numberPossibilities pn, let card = C color number, (invisibleBag pv IM.! cardToInt card) /= 0 ]
where pub = publicView pv
iOP :: IM.IntMap Int -> PublicInfo -> (Maybe Color, Maybe Number) -> Bool
iOP _ pub (Just c, Just n) = isPlayable pub $ C c n
iOP bag pub (Nothing,Just n) = all (\card -> (bag IM.! cardToInt card) == 0 || isPlayable pub card) [ C color n | color <- colors pub ]
iOP _ _ _ = False
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))
choppiri :: [Marks] -> [(Index, Marks)]
choppiri = reverse . filter (not . isHinted . snd) . zip [0..]
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 :: PublicInfo -> [Annotation] -> [Index]
chops pub anns = concat $ map reverse $ obviousChopss pub anns
isDoubleDrop :: PrivateView -> Result -> [Index] -> Annotation -> Bool
isDoubleDrop pv@PV{publicView=pub} (Discard c@C{..}) [_i] Ann{possibilities=(pc,pn)} = not (any ((==(Just color, Just number)).marks) myAnns) &&
isCritical pub c &&
color `elem` colorPossibilities pc &&
number `elem` numberPossibilities pn &&
(invisibleBag pv IM.! cardToInt c) > 0
where myAnns = head $ annotations pub
isDoubleDrop _pv _lastresult _chopset _anns = False
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
currentScore :: PublicInfo -> Int
currentScore pub = sum [ fromEnum $ achievedRank pub k | k <- colors pub ]
seeminglyAchievableScore :: PublicInfo -> Int
seeminglyAchievableScore pub = sum [ fromEnum $ bestPossibleRank pub k | k <- colors pub ]
achievableScore :: PublicInfo -> Int
achievableScore = seeminglyAchievableScore
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
data Result = None
| Discard {revealed::Card} | Success {revealed::Card} | Fail {revealed::Card} deriving (Read, Show, Eq, Generic)
data PrivateView = PV { publicView :: PublicInfo
, handsPV :: [[Card]]
, invisibleBag :: IM.IntMap Int
} deriving (Generic)
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 :: 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 :: [PublicInfo] -> [Move] -> State -> [State]
stateToStateHistory [] [] st = [st]
stateToStateHistory (pi:pis) (mv:mvs) st = st : stateToStateHistory pis mvs (rotate (-1) $ recede pi mv st)
data EndGameStrategy p ps = EGS {fromWhen::PublicInfo->Bool, myUsualStrategy::p, otherPlayers::ps}
instance (Monad m, Strategy p m, Strategies ps m) => Strategy (EndGameStrategy p ps) m where
strategyName ms = return "EndGameStrategy"
move pvs@(pv:_) mvs str@(EGS f p ps) | f (publicView pv) = do (defaultMove, _) <- move pvs mvs p
m <- endGameMove pvs mvs (ps, [EGS f p ps]) $ defaultMove : delete defaultMove (validMoves pv)
return (m,str)
| otherwise = do (m,_) <- move pvs mvs p
return (m,str)
data EndGameMirrorStrategy p = EGMS (EndGameStrategy p [EndGameMirrorStrategy p])
egms :: (PublicInfo -> Bool)
-> p
-> Int
-> EndGameMirrorStrategy p
egms from p nump = egms where egms = EGMS (EGS from p $ replicate (pred nump) egms)
instance (Monad m, Strategy p m) => Strategy (EndGameMirrorStrategy p) m where
strategyName ms = return "EndGameMirrorStrategy"
move pvs mvs (EGMS egs) = do (m, egs') <- move pvs mvs egs
return (m, EGMS egs')
endGameMove :: (Monad m, Strategies ps m) =>
[PrivateView]
-> [Move]
-> ps
-> [Move]
-> m Move
endGameMove 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
return $ case lookup (achievable * length states) asc of Nothing -> snd $ maximumBy (compare `on` fst) $ reverse asc
Just k -> k
validMoves :: PrivateView -> [Move]
validMoves pv@PV{publicView=pub@PI{gameSpec=gs,hintTokens=hints},handsPV=tlHands}
= map Play [0 .. pred myHandSize] ++ (if hints > 0 then ([ Hint hintedpl eck | hintedpl <- [1 .. numPlayers gs - 1], eck <- map Left (colors pub) ++ map Right [K1 .. K5], not (null $ filter (either (\c -> (==c).color) (\k -> (==k).number) eck) (tlHands !! pred hintedpl)) ] ++) else id) (if hints < 8 then (map Drop [0 .. pred myHandSize]) else [])
where myHandSize = length (head $ annotations pub)
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,_,_),_),n) -> n * egToInt pub eg)) $ mapM (\(st,n) -> fmap (\a->(a,n)) $ tryAMove (stateToStateHistory pubs mvs st) mvs ps mv) states
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 -> fail $ 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)
data EndGameMirrorLite p = EGML (EndGameLite p [EndGameMirrorLite p])
egml :: (PublicInfo -> Bool)
-> p
-> Int
-> EndGameMirrorLite p
egml from p nump = egms where egms = EGML (egl from p $ replicate (pred nump) egms)
instance (Monad m, Strategy p m) => Strategy (EndGameMirrorLite 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 p ps = EGL f p ps M.empty
data EndGameLite p ps = EGL {fromWhenL::PublicInfo->Bool, myUsualStrategyL::p, otherPlayersL::ps, memory :: M.Map Key ([Move],[([State],ps,Int)])}
type Key = (Maybe Card, [Marks], [Move], [Card])
instance (Monad m, Strategy p m, Strategies ps m) => Strategy (EndGameLite p ps) m where
strategyName ms = return "EndGameLite"
move pvs mvs str@(EGL f 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 p
return (m, EGL f 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)]
-> [PrivateView]
-> [Move]
-> p
-> m (Int, (M.Map Key ([Move], [([State],ps,Int)]), Move))
endGameMoveLite statess pvs@(pv:_) mvs p = do
(defaultMove, _) <- move pvs mvs p
let candidateMoves = defaultMove : delete defaultMove (validMoves pv)
tups <- mapM (evalMoveLite statess mvs p) candidateMoves
let asc = zipWith (\(mp, score) mv -> (score, (mp,mv))) tups candidateMoves
pub = publicView pv
achievable = sum [ n | (_,_,n) <- statess ] * moreStrictlyAchievableScore pub
return $ case lookup achievable asc of Nothing -> maximumBy (compare `on` fst) $ reverse asc
Just k -> (achievable, k)
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 <- mapM (\sts ->tryAMoveARound sts mvs mov) statess
let pub = publicState st
instantScore = sum [ egToInt pub eg * n | ((Just eg, _, _), _, 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)])
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
headC :: [Card] -> Card
headC = foldr const $ C Multicolor Empty
resToMbC :: Result -> Maybe Card
resToMbC None = Nothing
resToMbC r = Just $ revealed r
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 -> fail $ 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} = [ c | (k,v) <- IM.toList inv, c <- replicate v $ intToCard k ]
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 (numberToBitPos k)) /= 0, (hand, deck) <- possiblePerms anns $ delete card cards ]
mkPV :: PublicInfo -> [[Card]] -> PrivateView
mkPV pub hs = PV pub hs $ foldr (IM.update (Just . pred)) (nonPublic pub) $ map cardToInt $ concat $ [ C c n | Ann{marks=(Just c, Just n)} <- head $ annotations pub ] : hs
prettyPV :: Verbosity -> PrivateView -> String
prettyPV v pv@PV{publicView=pub} = prettyPI pub ++ "\nYour hand:\n"
++ concat (replicate (length myAnn) $ wrap "+--+") ++ "\n"
++ concat (replicate (length myAnn) $ wrap "|**|") ++ "\n"
++ (if markHints v then showHintLine wrap $ map marks myAnn else "")
++ 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 [ 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 "")
++ 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 = 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 [ showNumberPossibilities ns ++" " | (_,ns) <- ps]
showColorPossibilities, showNumberPossibilities :: Int -> String
showColorPossibilities = reverse . showPossibilities ' ' colorkeys
showNumberPossibilities = reverse . showPossibilities ' ' "54321 "
colorkeys :: String
colorkeys = map (head . show) [maxBound, pred maxBound .. minBound::Color]
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]
colorPossibilities = concat . showPossibilities [] (map (:[]) [maxBound, pred maxBound .. minBound])
numberPossibilities :: Int -> [Number]
numberPossibilities = concat . showPossibilities [] (map (:[]) [K5,K4 .. K1])
data Verbosity = V { warnCritical :: Bool
, markUseless :: Bool
, markPlayable :: Bool
, markObviouslyUseless :: Bool
, markObviouslyPlayable :: Bool
, markChops :: Bool
, warnDoubleDrop:: Bool
, markHints :: Bool
, markPossibilities :: Bool
} deriving (Read, Show, Eq, Generic)
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 n $ show $ intToCard ci) | (ci,n) <- IM.toList $ discarded pub ] ++"|\n"
view :: State -> PrivateView
view st = mkPV (publicState st) (tail $ hands st)
main :: IO ()
main = selfplay defaultGS
selfplay :: GameSpec -> IO ()
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 :: [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 :: (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 :: (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)
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 _ _ _ [] = 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!"
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@(_:_) 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 :: 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 :: GameSpec -> [Card] -> State
createGameFromCards gs cards = splitCons (numPlayers gs) [] [ (c, initAnn gs i) | (c,i) <- zip cards [0..] ]
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,
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)
createGame gs gen = (createGameFromCards gs shuffled, g) where
(shuffled, g) = createDeck (rule gs) gen
createDeck :: RandomGen g => Rule -> g -> ([Card], g)
createDeck r gen = shuffle (cardBag r) gen
numAssoc :: [(Number, Int)]
numAssoc = zip [K1 ..K5] [3,2,2,2,1]
cardAssoc :: Rule -> [(Card,Int)]
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 ]
cardMap :: Rule -> IM.IntMap Int
cardMap rule = IM.fromList [ (cardToInt c, n) | (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 :: 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) &&
not (null $ filter willBeHinted (tlHands !! pred hintedpl))
where willBeHinted :: Card -> Bool
willBeHinted = either (\c -> (==c).color) (\k -> (==k).number) 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 :: Int -> (a -> a) -> [a] -> (a, [a])
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
(_ , droppedAnn) = pickNth (index mv) playersAnn where playersAnn = head $ annotations pub
(nextHand,nextAnn,nextPile, nextPileNum) = case pile st of [] -> ( droppedHand, droppedAnn, [], 0)
d:ps -> (fst d : droppedHand, snd d : droppedAnn, ps, pred $ pileNum pub)
nextHands = nextHand : tail (hands st)
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
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,
annotations = nextAnns,
deadline = nextDeadline,
result = Discard nth}}
prc (Play i) | failure = let newst@St{publicState=newpub} = prc (Drop i) in newst{publicState=newpub{hintTokens = hintTokens pub, lives = pred $ lives pub, result = Fail nth}}
| 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,
annotations = nextAnns,
deadline = nextDeadline,
result = Success nth}}
where failure = not $ isPlayable pub nth
prc (Hint hintedpl eik) = st{publicState = pub{hintTokens = pred $ hintTokens pub,
turn = succ $ turn pub,
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 = numberToBitPos k
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
data EndGame = Failure | Soso Int | Perfect deriving (Show,Read,Eq,Generic)
egToInt _ Failure = 0
egToInt _ (Soso n) = n
egToInt pub Perfect = 5 * numColors (rule $ gameSpec pub)
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 ||
(earlyQuit (rule $ gameSpec pub) && currentScore pub == seeminglyAchievableScore pub)
= Just $ Soso $ IM.foldr (+) 0 $ fmap fromEnum $ played pub
| hintTokens pub == 0 && null (head $ annotations pub) = Just Failure
| otherwise = Nothing