hanabi-dealer 0.10.2.0 → 0.11.0.1
raw patch · 7 files changed
+384/−89 lines, 7 files
Files
- ChangeLog.md +14/−0
- Game/Hanabi.hs +144/−61
- Game/Hanabi/Client.hs +3/−3
- Game/Hanabi/Strategies/EndGameSearch.hs +34/−15
- Game/Hanabi/Strategies/SimpleStrategy.hs +11/−7
- examples/exampleStrategy.lhs +176/−0
- hanabi-dealer.cabal +2/−3
ChangeLog.md view
@@ -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)
Game/Hanabi.hs view
@@ -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) -- <reverse numMulticolors> .|. 11111022222022222022222033333 in base 4+packedNumEachCard gs = mask (numColors (rule gs)) .&. (0x1552AA2AA2AA3FF .|. (pack4 (numMulticolors $ rule gs) `shiftL` 10)) -- mask .&. (<reverse numMulticolors> .|. 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).
Game/Hanabi/Client.hs view
@@ -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
Game/Hanabi/Strategies/EndGameSearch.hs view
@@ -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.
Game/Hanabi/Strategies/SimpleStrategy.hs view
@@ -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
+ examples/exampleStrategy.lhs view
@@ -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}
hanabi-dealer.cabal view
@@ -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