diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,19 @@ # Revision history for hanabi-dealer + ## 0.11.0.1 -- 2021-01-17 + + * introduce the "suggested strategy" argument to egl and egml for efficiency reasons + This changes the API. + + * rename EndGameStrategy etc. to EndGameOld etc. + This changes the API. + + * prioritize Hanabi.validMoves + This changes what it returns. + + * add some rules to SimpleStrategy + And it is far from being simple now. + ## 0.10.2.0 -- 2020-09-24 * make the client library buildable with JSaddle + GHC + GUI (though unstable) diff --git a/Game/Hanabi.hs b/Game/Hanabi.hs --- a/Game/Hanabi.hs +++ b/Game/Hanabi.hs @@ -18,7 +18,7 @@ -- ** 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, endGameMove, EndGameStrategy(..), EndGameMirrorStrategy(..), egms, EndGameLite(..), egl, EndGameMirrorLite(..), egml, + 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, @@ -261,8 +261,12 @@ 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 = 0x1552AA2AA2AA3FF .|. (pack4 (numMulticolors $ rule gs) `shiftL` 10) -- .|. 11111022222022222022222033333 in base 4 +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) @@ -461,38 +465,38 @@ 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 (EGS f p ps)@ may cause an error if @p@ can choose an invalid move. -data EndGameStrategy p ps = EGS {fromWhen::PublicInfo->Bool, myUsualStrategy::p, otherPlayers::ps} +-- @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 (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) +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 (EGMS (EGS f p ps))@ may cause an error if @p@ can choose an invalid move. -data EndGameMirrorStrategy p = EGMS (EndGameStrategy p [EndGameMirrorStrategy p]) -egms :: (PublicInfo -> Bool) -- ^ from when to start the endgame search +-- @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 - -> EndGameMirrorStrategy p -egms from p nump = egms where egms = EGMS (EGS from p $ replicate (pred nump) egms) + -> EndGameMirrorOld p +egmo from p nump = egmo where egmo = EGMO (EGO from p $ replicate (pred nump) egmo) -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') +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') -endGameMove :: (Monad m, Strategies ps m) => +endGameMoveOld :: (Monad m, Strategies ps m) => [PrivateView] -- ^ view history -> [Move] -- ^ move history -> ps -> [Move] -- ^ move candidates. More promising moves appear earlier. -> m Move -endGameMove pvs@(pv:tlpvs) mvs ps candidates = do +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 @@ -503,10 +507,25 @@ Just k -> k -- Stop search when the best possible score is found. 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).rank) eck) (tlHands !! pred hintedpl)) ] ++) else id) (if hints < 8 then (map Drop [0 .. pred myHandSize]) else []) - where myHandSize = length (head $ annotations pub) - +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 @@ -518,32 +537,34 @@ 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 p = EGML (EndGameLite p [EndGameMirrorLite p]) +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 p -egml from p nump = egms where egms = EGML (egl from p $ replicate (pred nump) egms) + -> EndGameMirrorLite sp p +egml from sp p nump = egmo where egmo = EGML (egl from sp p $ replicate (pred nump) egmo) -instance (Monad m, Strategy p m) => Strategy (EndGameMirrorLite p) m where +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 p ps = EGL f p ps M.empty +egl f sp p ps = EGL f sp p ps M.empty --- | @'EGL' f p ps memory@ 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@. -data EndGameLite p ps = EGL {fromWhenL::PublicInfo->Bool, myUsualStrategyL::p, otherPlayersL::ps, memory :: M.Map Key ([Move],[([State],ps,Int)])} +-- | @'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 p m, Strategies ps m) => Strategy (EndGameLite p ps) m where +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 p ps memory) + 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 p - return (m, EGL f p ps mp) + (_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 ] @@ -556,9 +577,9 @@ -> p -- ^ default (recommended) strategy -> m (Int, (M.Map Key ([Move], [([State],ps,Int)]), Move)) endGameMoveLite statess pvs@(pv:_) mvs p = do - (defaultMove, _) <- move pvs mvs p + (defaultMove, q) <- move pvs mvs p let candidateMoves = defaultMove : delete defaultMove (validMoves pv) - tups <- mapM (evalMoveLite statess mvs p) candidateMoves + 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 @@ -568,7 +589,7 @@ 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 + 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 @@ -595,13 +616,27 @@ 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 @@ -619,7 +654,34 @@ 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 @@ -1067,45 +1129,59 @@ 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@(St{publicState=pub@PI{gameSpec=gS}}) mv = if (isMoveValid (view st) mv) then return (prc mv) else Nothing where - - -- only used by Drop and Play +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 pile st of [] -> ( droppedHand, droppedAnn, [], 0) + (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 - prc (Drop _) = st{pile = nextPile, - hands = nextHands, - publicState = pub{pileNum = nextPileNum, + 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}} - 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, - 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) - prc (Hint hintedpl eik) = st{publicState = pub{hintTokens = pred $ hintTokens pub, + 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 @@ -1119,6 +1195,13 @@ 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). diff --git a/Game/Hanabi/Client.hs b/Game/Hanabi/Client.hs --- a/Game/Hanabi/Client.hs +++ b/Game/Hanabi/Client.hs @@ -530,17 +530,17 @@ [text $ S.pack $ "(" ++ shows current " / " ++ shows achievable ")"], text $ S.pack ": ", -- span_ [] [ span_ [] $ text (S.pack "|") : [ renderCardInline verb pub $ C c k | k <- [K1 .. playedMax] ] ++ map (text . S.pack) (replicate (possible - fromEnum playedMax) "__" ++ replicate (5 - possible) "XX") - span_ [style_ $ M.fromList [("font-family", "monospace"),("font-size", "3vmin")]] $ [ span_ [] $ text (S.pack "|") : renderCardsInline verb pub c [K1 .. playedMax] : map (text . S.pack) (replicate (possible - fromEnum playedMax) "_" ++ replicate (5 - possible) "X") + span_ [style_ $ M.fromList [("font-family", "monospace"),("font-size", "3vmin")]] $ [ span_ [] $ text (S.pack " ") : renderCardsInline verb pub c [K1 .. playedMax] : map (text . S.pack) (replicate (possible - fromEnum playedMax) "_" ++ replicate (5 - possible) "X") | c <- colors pub , let playedMax = achievedRank pub c possible = fromEnum $ bestPossibleRank pub c - ] ++ [text $ S.pack "|"] + ] ], div_ [] [ text $ S.pack $ "dropped: ", -- span_ [] [ span_ [] $ text (S.pack "|") : (replicate n $ renderCardInline verb pub $ intToCard ci) | (ci, n) <- IM.toList $ discarded pub ], - span_ [style_ $ M.fromList [("font-family", "monospace"),("font-size", "3vmin")]] $ [ span_ [] [text (S.pack "|"), renderCardsInline verb pub c (replicate n r)] | c <- colors pub, r <- [K1 .. maxBound], let n = discarded pub $ C c r, n>0 ] ++ [text $ S.pack "|"] + span_ [style_ $ M.fromList [("font-family", "monospace"),("font-size", "3vmin")]] $ [ span_ [] [text (S.pack " "), renderCardsInline verb pub c (replicate n r)] | c <- colors pub, r <- [K1 .. maxBound], let n = discarded pub $ C c r, n>0 ] ] ] where current = currentScore pub diff --git a/Game/Hanabi/Strategies/EndGameSearch.hs b/Game/Hanabi/Strategies/EndGameSearch.hs --- a/Game/Hanabi/Strategies/EndGameSearch.hs +++ b/Game/Hanabi/Strategies/EndGameSearch.hs @@ -1,28 +1,47 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, CPP #-} module Game.Hanabi.Strategies.EndGameSearch where import Game.Hanabi hiding (main) import Game.Hanabi.Strategies.Stateless hiding (main) import Game.Hanabi.Strategies.SimpleStrategy hiding (main) import System.Random + +-- x #define EXACT + -- A strategy with endgame search -data EndGameSearch = EG +#ifdef EXACT +data EndGameSearch = EG | EGS (EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [EndGameMirrorLite Stateless Stateless])) +mkEG :: Int -> EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [EndGameMirrorLite Stateless Stateless]) +#else +data EndGameSearch = EG | EGS (EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [Stateless])) +mkEG :: Int -> EndGameMirrorLite Stateless (EndGameLite Stateless Stateless [Stateless]) +#endif +mkEG nump = + -- assumeOthersAre SL SL + -- searchExhaustivelyLite SL +#ifdef EXACT + searchExhaustivelyLite $ assumeOthers SL $ searchExhaustivelyLite SL -- This is more exact, but sometimes prohibitively time-consuming. +#else + searchExhaustivelyLite $ assumeOthers SL SL +#endif + -- searchExhaustively SL + -- assumeOthersAreSL SL + -- searchExhaustively $ assumeOthersAreSL SL + where + searchExhaustivelyLite :: s -> EndGameMirrorLite Stateless s + searchExhaustivelyLite fallback = egml (\pub -> pileNum pub == 0) SL fallback nump + assumeOthers fallback other = egl (\pub -> pileNum pub <= 1) SL fallback $ replicate (pred nump) other + searchExhaustively fallback = egmo (\pub -> pileNum pub == 0) fallback nump + assumeOthersAreSL fallback = EGO (\pub -> pileNum pub <= 1 && hintTokens pub <= 2) fallback $ replicate (pred nump) SL +-- assumeOthersAreSL fallback = EGO (\pub -> pileNum pub <=2 && hintTokens pub <= 4) fallback $ replicate (pred nump) SL +-- assumeOthersAreSL fallback = EGO (\pub -> pileNum pub + hintTokens pub < 4) fallback $ replicate (pred nump) SL instance (Monad m) => Strategy EndGameSearch m where strategyName ms = return "EndGame" - move pvs@(pv:_) mvs EG = do (m, _) <- -- move (sontakuColorHint pvs mvs) mvs $ assumeOthersAreSLLite SL - -- move (sontakuColorHint pvs mvs) mvs $ searchExhaustivelyLite SL - move (sontakuColorHint pvs mvs) mvs $ searchExhaustivelyLite $ assumeOthersAreSLLite SL - -- move (sontakuColorHint pvs mvs) mvs $ searchExhaustively SL - -- move (sontakuColorHint pvs mvs) mvs $ assumeOthersAreSL SL - -- move (sontakuColorHint pvs mvs) mvs $ searchExhaustively $ assumeOthersAreSL SL - return (m, EG) - where searchExhaustivelyLite fallback = egml (\pub -> pileNum pub == 0) fallback (numPlayers $ gameSpec $ publicView pv) - assumeOthersAreSLLite fallback = egl (\pub -> pileNum pub <= 1) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL - searchExhaustively fallback = egms (\pub -> pileNum pub == 0) fallback (numPlayers $ gameSpec $ publicView pv) - assumeOthersAreSL fallback = EGS (\pub -> pileNum pub <= 1 && hintTokens pub <= 2) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL --- assumeOthersAreSL fallback = EGS (\pub -> pileNum pub <=2 && hintTokens pub <= 4) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL --- assumeOthersAreSL fallback = EGS (\pub -> pileNum pub + hintTokens pub < 4) fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL + move pvs@(pv:_) mvs EG = do (m, e') <- move (sontakuColorHint pvs mvs) mvs $ mkEG $ numPlayers $ gameSpec $ publicView pv + return (m, EGS e') + move pvs@(pv:_) mvs (EGS e) = do (m, e') <- move (sontakuColorHint pvs mvs) mvs e + return (m, if pileNum (publicView pv) > 1 then EG else EGS e') main = do g <- newStdGen ((eg,_),_) <- start defaultGS [] ([EG], [stdio]) g -- Play it with standard I/O (human player). -- ((eg,_),_) <- start defaultGS [peek] [EG, EG] g -- Play it with itself. diff --git a/Game/Hanabi/Strategies/SimpleStrategy.hs b/Game/Hanabi/Strategies/SimpleStrategy.hs --- a/Game/Hanabi/Strategies/SimpleStrategy.hs +++ b/Game/Hanabi/Strategies/SimpleStrategy.hs @@ -3,7 +3,7 @@ import Game.Hanabi hiding (main) import System.Random import Data.Maybe(isNothing) -import Data.List(sortOn) +import Data.List(sortOn, tails) import Data.Bits(bit) -- An example of a simple and stupid strategy. @@ -24,14 +24,17 @@ isNewestOfColor i d = null [ () | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == color d, j < i ] -- True if there is no newer rank-unmarked card of the same color in nextPlayer. markCandidates = filter (\(_,card,ann) -> isPlayable pub card && not (isObviouslyPlayable pub $ possibilities ann)) $ reverse nextPlayer -- Playable cards that are not enough hinted, old to new. markUnhintedCritical = take 1 [ Hint 1 (if isColorMarkable (color te) then Left $ color te else Right $ rank te) | (_ix, te, ann) <- reverse nextPlayer, not (isHinted $ marks ann), isCritical pub te ] - keep2 = take 1 [ Hint 1 $ Right $ K2 | (_ix, te@(C _ K2), ann) <- reverse nextPlayer, not (isHinted $ marks ann), not $ isUseless pub te ] - unhintedNon2 = [ t | t@(_, C c n, ann) <- nextPlayer, n/=K2, not $ isHinted $ marks ann ] + keep2 = take 1 [ Hint 1 $ Right K2 | (_ix, te@(C c K2), ann) <- reverse nextPlayer, not (isHinted $ marks ann), not $ isUseless pub te, not $ isPlayable pub te && havePlayableCardWithTheSameColor c ] + unhintedNon2 = [ t | t@(_, c@(C _ n), ann) <- nextPlayer, n/=K2 || isUseless pub c, not $ isHinted $ marks ann ] colorMarkUnmarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{marks=(Nothing, Nothing)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is not marked isNewestOfColor i d, -- but be cautious not to color-mark newer cards. not $ havePlayableCardWithTheSameColor $ color d ] -- refrain marking if I have a playable card with the same color colorMarkNumberMarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (_,d,Ann{marks=(Nothing, Just _)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is only rank-marked. not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color ] + removeDuplicate = take 1 [ Drop i | (i,Ann{marks=m}):xs <- tails [ anned | anned@(_,Ann{marks=(Just _, Just _)}) <- myHand ], + m `elem` [ m' | (_, Ann{marks=m'}) <- xs ] + ] numberMarkPlayable = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(_, Nothing)}) <- markCandidates, -- Mark the rank if a (not obviously) playable card is not rank-marked. not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color ] @@ -54,7 +57,7 @@ where i = length $ takeWhile ((/=Just c) . fst . marks) $ head $ annotations $ publicView pv -- (This should also be rewritten using list comprehension.) _ -> [] sontakuPositionalDrop = case mvs of - Drop i : _ | i `notElem` unusualChops -> [] -- It is not a positional drop if nothing is unusual. + Drop i : _ | i `notElem` unusualChops || length myAnns <= i -> [] -- It is not a positional drop if nothing is unusual or the corresponding card does not exist. | not $ isDefinitelyUnplayable pv (myAnns!!i) -> [Play i] | otherwise -> [Drop i] -- if by no means it is playable, it means "drop it" (unless there are 8 hints), even if isDefinitelyCritical. where lastpub = publicView (head pvs) @@ -65,14 +68,15 @@ dropChop = [ Drop i | i:_ <- take 1 $ definiteChopss pv myAnns ] current = currentScore pub achievable = seeminglyAchievableScore pub + noDeck = pileNum pub == 0 && not (prolong (Game.Hanabi.rule $ gameSpec pub)) enoughDeck = prolong (Game.Hanabi.rule $ gameSpec pub) || achievable - current < pileNum pub mov = head $ filter (isMoveValid pv) $ sontakuPositionalDrop - ++ markUnhintedCritical + ++ (if noDeck then playPlayable5 else markUnhintedCritical) ++ (if hintTokens pub >= 2 || not enoughDeck then colorMarkUnmarkedPlayable else []) ++ (if hintTokens pub >= 4 then colorMarkNumberMarkedPlayable ++ numberMarkPlayable ++ if length unhintedNon2 >= 2 then keep2 else [] else []) -- Do one of these only when there are spare hint tokens. - ++ playPlayable5 - ++ (if enoughDeck then dropUselessCard else []) -- Drop a useless card unless endgame is approaching. + ++ (if noDeck then markUnhintedCritical else playPlayable5) + ++ (if enoughDeck then removeDuplicate ++ dropUselessCard else []) -- Drop a useless card unless endgame is approaching. ++ take 1 [ Play i | (i,ann) <- myHand, isDefinitelyPlayable pv ann ] -- Play a playable card ++ sontakuColorMark -- guess the meaning of the last move, and believe it. ++ dropChopUnlessDoubleDrop diff --git a/examples/exampleStrategy.lhs b/examples/exampleStrategy.lhs new file mode 100644 --- /dev/null +++ b/examples/exampleStrategy.lhs @@ -0,0 +1,176 @@ +#!/bin/sh +cabal install --flags=jsaddle miso # This is important: unregister beforehand if already built without the jsaddle flag. +cabal install --flags=jsaddle hanabi-dealer +cabal exec runghc -- $0 & +firefox "localhost:8080" +exit + + +This is an example strategy module, which is actually the same as EndGameSearch, but is self-contained and thus can freely be edited in every detail. + +\begin{code} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +import Game.Hanabi.VersionInfo +import Game.Hanabi.Client +import Game.Hanabi hiding (main) +import Data.Maybe(isNothing) +import Data.List(sortOn, tails) +import Data.Bits(bit, (.&.)) +import qualified Data.IntMap as IM + +import Game.Hanabi.Strategies.EndGameSearch hiding (main) +\end{code} + +The following is a renamed copy of EndGameSearch.hs. + +\begin{code} +-- An example strategy, which is actually a simplified version of EndGameSearch +data Example = ES + +instance (Monad m) => Strategy Example m where + strategyName ms = return "Example" + move pvs@(pv:_) mvs ES = do (m, _) <- move (sontakuColorHint pvs mvs) mvs $ searchExhaustivelyLite $ assumeOthersAreSLLite SL + return (m, ES) + where searchExhaustivelyLite fallback = egml (\pub -> pileNum pub == 0) SL fallback (numPlayers $ gameSpec $ publicView pv) + assumeOthersAreSLLite fallback = egl (\pub -> pileNum pub <= 1) SL fallback $ replicate (pred $ numPlayers $ gameSpec $ publicView pv) SL +\end{code} + +The following is a copy of Stateless.hs. + +\begin{code} +-- A stateless implementation of Stateful +data Stateless = SL + +lookupOn :: Eq b => (a -> b) -> a -> [a] -> [a] +lookupOn fun key xs = [ result | result <- xs, fun key == fun result ] + +sontakuColorHint :: [PrivateView] -> [Move] -> [PrivateView] +sontakuColorHint pvs@(pv:_) mvs = let + consistentGuess = [ case lookupOn ixDeck realAnn hintedAnns of + guessedAnn:_ -> guessedAnn + _ -> realAnn + | realAnn <- myAnns ] + hintedAnns = [ ann{possibilities = (currentColPos, newNumberPos)} + | Ann{ixDeck=ix, marks=(Just c, Nothing), possibilities=(currentColPos, currentNumPos)} <- myAnns + , (p,pvInQ,c) <- take 1 [ (p,pvq,c) | (p, pvq, Hint q (Left d)) <- zip3 [1..] pvs mvs, + c==d && p `mod` numPlayers (gameSpec pub) == q ] + , let pubInQ = publicView pvInQ + myAnnsInQ = head $ annotations pubInQ + , not $ or [ isObviouslyPlayable pubInQ m | Ann{marks=(Just i, _),possibilities=m} <- myAnnsInQ, c==i ] -- Exclude if there is a playable card with the color. + + , ann <- take 1 [ ann | ann@Ann{marks=(Just i,_)} <- myAnnsInQ, c==i ] + , let newNumberPos = bit $ rankToBitPos (succ $ achievedRank pubInQ c) -- This is undefined when achievedRank pub c == K5, but then isDefinitelyUnplayable pv ann should be True. + , ixDeck ann == ix + + , not $ isDefinitelyUnplayable pvInQ ann + , newNumberPos .&. currentNumPos /= 0 ] + pub = publicView pv + myAnns = head $ annotations pub + in pv{publicView=pub{annotations=consistentGuess : tail (annotations pub)}} : tail pvs + +instance Monad m => Strategy Stateless m where + strategyName ms = return "Stateless" + move pvs@(pv:_) mvs SL = move (sontakuColorHint pvs mvs) mvs S >>= \(mov,S) -> return (mov, SL) +\end{code} + +The following is a copy of SimpleStrategy.hs. + +\begin{code} +-- An example of a simple and stupid strategy. +data Simple = S + +instance Monad m => Strategy Simple m where + strategyName ms = return "Stupid example strategy" + move (pv:pvs) mvs s = let + pub = publicView pv + nextPlayersHand = head $ handsPV pv ::[Card] + nextPlayersAnns = annotations pub !! 1 + nextPlayer = zip3 [0..] nextPlayersHand nextPlayersAnns + myAnns = head $ annotations pub + myHand = zip [0..] myAnns + numHand = length myAnns + isColorMarkable col = isPlayable pub (head [ c | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == col ]) + || any (isPlayable pub) [ c | (j,c,Ann{marks=(Nothing,Just num)}) <- nextPlayer, color c == col ] + isNewestOfColor i d = null [ () | (j,c,Ann{marks=(_,Nothing)}) <- nextPlayer, color c == color d, j < i ] -- True if there is no newer rank-unmarked card of the same color in nextPlayer. + markCandidates = filter (\(_,card,ann) -> isPlayable pub card && not (isObviouslyPlayable pub $ possibilities ann)) $ reverse nextPlayer -- Playable cards that are not enough hinted, old to new. + markUnhintedCritical = take 1 [ Hint 1 (if isColorMarkable (color te) then Left $ color te else Right $ rank te) | (_ix, te, ann) <- reverse nextPlayer, not (isHinted $ marks ann), isCritical pub te ] + keep2 = take 1 [ Hint 1 $ Right K2 | (_ix, te@(C c K2), ann) <- reverse nextPlayer, not (isHinted $ marks ann), not $ isUseless pub te, not $ isPlayable pub te && havePlayableCardWithTheSameColor c ] + unhintedNon2 = [ t | t@(_, c@(C _ n), ann) <- nextPlayer, n/=K2 || isUseless pub c, not $ isHinted $ marks ann ] + colorMarkUnmarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{marks=(Nothing, Nothing)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is not marked + isNewestOfColor i d, -- but be cautious not to color-mark newer cards. + not $ havePlayableCardWithTheSameColor $ color d ] -- refrain marking if I have a playable card with the same color + colorMarkNumberMarkedPlayable = take 1 [ Hint 1 $ Left $ color d | (_,d,Ann{marks=(Nothing, Just _)}) <- markCandidates, -- Mark the color if a (not obviously) playable card is only rank-marked. + not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color + ] + removeDuplicate = take 1 [ Drop i | (i,Ann{marks=m}):xs <- tails [ anned | anned@(_,Ann{marks=(Just _, Just _)}) <- myHand ], + m `elem` [ m' | (_, Ann{marks=m'}) <- xs ] + ] + numberMarkPlayable = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(_, Nothing)}) <- markCandidates, -- Mark the rank if a (not obviously) playable card is not rank-marked. + not $ havePlayableCardWithTheSameColor $ color d -- refrain marking if I have a playable card with the same color + ] + havePlayableCardWithTheSameColor c = or [ isDefinitelyPlayable pv ann | (_,ann@Ann{marks=(Just d,_)}) <- myHand, c==d ] + numberMarkUselessIfInformative = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{possibilities=p@(pc, _)}) <- nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (pc, bit $ rankToBitPos (rank d)) ] + colorMarkUselessIfInformative = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{possibilities=p@(_, pn)}) <- reverse nextPlayer, not $ isObviouslyUseless pub p, isObviouslyUseless pub (bit $ colorToBitPos (color d), pn), + isNewestOfColor i d ] -- but be cautious not to color-mark newer cards. + numberMarkUnmarked = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(Nothing, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ] + numberMarkNumberUnmarked = take 1 [ Hint 1 $ Right $ rank d | (_,d,Ann{marks=(Just _, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ] + colorMarkColorUnmarked = take 1 [ Hint 1 $ Left $ color d | (i,d,Ann{marks=(Nothing, Just _),possibilities=p}) <- reverse nextPlayer, not $ isObviouslyUseless pub p, + isNewestOfColor i d ] -- but be cautious not to color-mark newer cards. + playPlayable5 = take 1 [ Play i | (i,ann@Ann{marks=(_,Just K5)}) <- myHand, isDefinitelyPlayable pv ann ] + dropUselessCard = take 1 [ Drop i | hintTokens pub < 7, (i,ann) <- reverse myHand, isDefinitelyUseless pv ann ] + dropSafe = take 1 [ Drop i | (i,ann) <- reverse myHand, isDefinitelyUncritical pv ann ] + dropPossiblyUncritical = take 1 [ Drop i | (i,ann) <- reverse myHand, not $ isDefinitelyCritical pv ann ] + sontakuColorMark = case mvs of -- When the last move is color mark, + Hint 1 (Left c) : _ | isDefinitelyUseless pv (myAnns!!i) -> [Drop i] -- If the first color-marked is obviously useless, drop it. + | isDefinitelyUnplayable pv (myAnns!!i) -> [] -- If the first color-marked is unplayable for now, ignore it. + | otherwise -> [Play i] -- Otherwise, it means "Play!" + where i = length $ takeWhile ((/=Just c) . fst . marks) $ head $ annotations $ publicView pv -- (This should also be rewritten using list comprehension.) + _ -> [] + sontakuPositionalDrop = case mvs of + Drop i : _ | i `notElem` unusualChops || length myAnns <= i -> [] -- It is not a positional drop if nothing is unusual or the corresponding card does not exist. + | not $ isDefinitelyUnplayable pv (myAnns!!i) -> [Play i] + | otherwise -> [Drop i] -- if by no means it is playable, it means "drop it" (unless there are 8 hints), even if isDefinitelyCritical. + where lastpub = publicView (head pvs) + lastAnns = last (annotations lastpub) + unusualChops = drop 1 $ concat $ map reverse $ obviousChopss lastpub lastAnns + _ -> [] + dropChopUnlessDoubleDrop = [ Drop i | is@(i:_) <- take 1 $ map reverse $ definiteChopss pv myAnns, not $ isDoubleDrop pv (result pub) is $ myAnns !! i ] + dropChop = [ Drop i | i:_ <- take 1 $ definiteChopss pv myAnns ] + current = currentScore pub + achievable = seeminglyAchievableScore pub + noDeck = pileNum pub == 0 && not (prolong (Game.Hanabi.rule $ gameSpec pub)) + enoughDeck = prolong (Game.Hanabi.rule $ gameSpec pub) || achievable - current < pileNum pub + mov = head $ filter (isMoveValid pv) $ + sontakuPositionalDrop + ++ (if noDeck then playPlayable5 else markUnhintedCritical) + ++ (if hintTokens pub >= 2 || not enoughDeck then colorMarkUnmarkedPlayable else []) + ++ (if hintTokens pub >= 4 then colorMarkNumberMarkedPlayable ++ numberMarkPlayable ++ if length unhintedNon2 >= 2 then keep2 else [] else []) -- Do one of these only when there are spare hint tokens. + ++ (if noDeck then markUnhintedCritical else playPlayable5) + ++ (if enoughDeck then removeDuplicate ++ dropUselessCard else []) -- Drop a useless card unless endgame is approaching. + ++ take 1 [ Play i | (i,ann) <- myHand, isDefinitelyPlayable pv ann ] -- Play a playable card + ++ sontakuColorMark -- guess the meaning of the last move, and believe it. + ++ dropChopUnlessDoubleDrop + ++ colorMarkUnmarkedPlayable ++ colorMarkNumberMarkedPlayable ++ numberMarkPlayable ++ dropUselessCard ++ keep2 + ++ colorMarkUselessIfInformative + ++ numberMarkUselessIfInformative + ++ colorMarkColorUnmarked ++ numberMarkNumberUnmarked + ++ numberMarkUnmarked + ++ [Hint 1 $ Right n | n <- [K1 .. K5]] + ++ dropSafe -- drop the oldest 'safe to drop' card + ++ dropChop +-- ++ dropPossiblyUncritical -- This may not be a good idea. See Haddock comment on Hanabi.isDefinitelyCritical. + ++ reverse [ Drop i | (i,_) <- sortOn (\(_,Ann{marks=(_,mb)}) -> fmap fromEnum mb) myHand ] + in return (mov, s) +\end{code} + +The main function. + +\begin{code} +main = client defOpt{strategies=strs} + +-- strs :: [(String, IO (DynamicStrategy IO))] +strs = [ + ("Strategy with end game search", return $ mkDS "Strategy with end game search" EG), + ("example strategy", return $ mkDS "example strategy" ES) + ] +\end{code} diff --git a/hanabi-dealer.cabal b/hanabi-dealer.cabal --- a/hanabi-dealer.cabal +++ b/hanabi-dealer.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.10.2.0 +version: 0.11.0.1 -- A short (one-line) description of the package. synopsis: Hanabi card game @@ -43,8 +43,7 @@ -- Extra files to be distributed with the package, such as examples or a -- README. -extra-source-files: ChangeLog.md --- , examples/SimpleStrategy.hs -- This is moved to Game.Hanabi.Strategies.SimpleStrategy +extra-source-files: ChangeLog.md, examples/exampleStrategy.lhs -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.10