{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, TemplateHaskell, RecordWildCards, CPP #-} module Game.Hanabi.Strategies.AppendDSL where import Game.Hanabi hiding (main) import System.Random import Data.List(sortOn, tails) import Data.Maybe(fromJust) import Data.Bits import Control.Monad(liftM2, mplus, mzero) import Data.Functor.Identity import Data.Array(bounds) import Game.Hanabi.Strategies.SimpleStrategy(Simple(S)) import Game.Hanabi.Strategies.StatefulStrategy import Game.Hanabi.Strategies.AdaptiveLMC import MagicHaskeller import MagicHaskeller.ProgGenSF(mkTrieOptSFIO) import MagicHaskeller.ProgramGenerator hiding (tails) import MagicHaskeller.MyCheck -- import GHC.Conc(numCapabilities) import System.IO(stderr, hPutStrLn) import Control.Concurrent(rtsSupportsBoundThreads, getNumCapabilities, setNumCapabilities) -- import Game.Hanabi.FFI(getHardwareConcurrency) data BigTable = BT { markUnhintedCritical :: Maybe Move, keep21 :: Maybe Move, colorMarkUnmarkedPlayable :: Maybe Move -- ^ Mark the color of a (not obviously) playable card -- if it is not marked yet -- but be cautious not to color-mark newer cards. -- refrain marking if I have a playable card with the same color , colorMarkNumberMarkedPlayable :: Maybe Move -- ^ Mark the color if a (not obviously) playable card is only rank-marked, -- but refrain marking if I have a playable card with the same color , colorMarkPlayable5 :: Maybe Move, removeDuplicate :: Maybe Move, numberMarkPlayable :: Maybe Move -- ^ Mark the rank if a (not obviously) playable card is not rank-marked, -- but refrain marking if I have a playable card with the same color. , numberMarkPlayable5 :: Maybe Move, numberMarkUselessIfInformative :: Maybe Move, numberMarkUncriticalIfInformative :: Maybe Move, colorMarkUselessIfInformative :: Maybe Move, colorMarkUncriticalIfInformative :: Maybe Move, numberMarkUnmarked :: Maybe Move, numberMarkNumberUnmarked :: Maybe Move, colorMarkColorUnmarked :: Maybe Move, pass :: Maybe Move, hailMary :: Maybe Move, playPlayable :: Maybe Move -- ^ Play a playable card. Prioritize those that are not publicly playable. , playPlayable5 :: Maybe Move, dropUselessCard :: Maybe Move, dropSafe :: Maybe Move, dropPossiblyUncritical :: Maybe Move, makePositionalDrop :: Maybe Move, dropChopUnlessDoubleDrop :: Maybe Move, noDeck :: Bool, spareDeck :: Bool, enoughDeck :: Bool, livesBT :: Int, hintsBT :: Int } bt = $(p [| (markUnhintedCritical :: BigTable -> Maybe Move, keep21 :: BigTable -> Maybe Move, colorMarkUnmarkedPlayable :: BigTable -> Maybe Move , colorMarkNumberMarkedPlayable :: BigTable -> Maybe Move , colorMarkPlayable5 :: BigTable -> Maybe Move, removeDuplicate :: BigTable -> Maybe Move, numberMarkPlayable :: BigTable -> Maybe Move , numberMarkPlayable5 :: BigTable -> Maybe Move, numberMarkUselessIfInformative :: BigTable -> Maybe Move, numberMarkUncriticalIfInformative :: BigTable -> Maybe Move, colorMarkUselessIfInformative :: BigTable -> Maybe Move, colorMarkUncriticalIfInformative :: BigTable -> Maybe Move, numberMarkUnmarked :: BigTable -> Maybe Move, numberMarkNumberUnmarked :: BigTable -> Maybe Move, colorMarkColorUnmarked :: BigTable -> Maybe Move, pass :: BigTable -> Maybe Move, hailMary :: BigTable -> Maybe Move, playPlayable :: BigTable -> Maybe Move , playPlayable5 :: BigTable -> Maybe Move, dropUselessCard :: BigTable -> Maybe Move, dropSafe :: BigTable -> Maybe Move, dropPossiblyUncritical :: BigTable -> Maybe Move, makePositionalDrop :: BigTable -> Maybe Move, dropChopUnlessDoubleDrop :: BigTable -> Maybe Move, noDeck :: BigTable -> Bool, spareDeck :: BigTable -> Bool, enoughDeck :: BigTable -> Bool, livesBT :: BigTable -> Int, hintsBT :: BigTable -> Int ) |]) prepare :: [PrivateView] -> [Move] -> BigTable prepare (pv:pvs) mvs = 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 colorHint pl = Hint pl . Left . color rankHint pl = Hint pl . Right . rank isMarked = isHinted . marks isUnmarked = not . isMarked nextPlayersUnmarked = filter (isUnmarked . getAnn) nextPlayer getAnn (_,_,ann) = ann getCard (_,c,_) = c nitchimo anns = length (filter (\ann -> isMarked ann && not (isObviouslyUncritical pub (possibilities ann) || isObviouslyPlayable pub (possibilities ann))) anns) 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 _)}) <- 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. lenUnhintedNon2 = length [ t | t@(_, c@(C _ n), _) <- nextPlayersUnmarked, n/=K2 || isUseless pub c ] havePlayableCardWithTheSameColor c = or [ isDefinitelyPlayable pv ann | (_,ann@Ann{marks=(Just d,_)}) <- myHand, c==d ] numberMarkIfInformative cond = mr [ rankHint 1 d | (_,d,Ann{marks=(Just _,Nothing),possibilities=p}) <- nextPlayer, not $ cond pub p, cond pub (p .&. rankToQit (rank d)) ] colorMarkIfInformative cond = mr [ colorHint 1 d | (i,d,Ann{marks=(Nothing,Just _),possibilities=p}) <- reverse nextPlayer, not $ cond pub p, cond pub (p .&. colorToQit (color d)), isNewestOfColor i d ] -- but be cautious not to color-mark newer cards. sndlastUnusualChop = drop 1 $ concat $ map reverse $ obviousChopss sndlastpub sndlastAnns lastpub = publicView (head pvs) lastAnns = last (annotations lastpub) sndlastpub = publicView (head $ tail pvs) sndlastAnns = last $ init (annotations sndlastpub) dropChop = [ Drop i | i:_ <- definiteChopss pv myAnns ] current = currentScore pub achievable = seeminglyAchievableScore pub continue = prolong (Game.Hanabi.rule $ gameSpec pub) mr xs = mkRule pv xs Nothing in BT { markUnhintedCritical = mr [ if isColorMarkable (color te) then colorHint 1 te else rankHint 1 te | (_ix, te, _) <- reverse nextPlayersUnmarked, isCritical pub te ], keep21 = mr [ rankHint 1 te | (_ix, te@(C c k), _) <- reverse nextPlayersUnmarked, k <= K2, keptCards pub te <= 2, not $ isUseless pub te, not $ isPlayable pub te && havePlayableCardWithTheSameColor c ], colorMarkUnmarkedPlayable = mr [ colorHint 1 d | (i,d,ann) <- markCandidates, -- Mark the color ff a (not obviously) playable card isUnmarked ann, -- if it is not marked yet 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 = mr [ colorHint 1 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 ], colorMarkPlayable5 = mr [ colorHint 1 d | (_,d,Ann{marks=(Nothing, Just K5)}) <- markCandidates ], removeDuplicate = mr [ Drop i | (i,Ann{marks=m}):xs <- tails [ anned | anned@(_,Ann{marks=(Just _, Just _)}) <- reverse myHand ], m `elem` [ m' | (_, Ann{marks=m'}) <- xs ] ], numberMarkPlayable = mr [ rankHint 1 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 ], numberMarkPlayable5 = mr [ Hint 1 $ Right K5 | (_, C _ K5, Ann{marks=(_, Nothing)}) <- markCandidates ], numberMarkUselessIfInformative = numberMarkIfInformative isObviouslyUseless, numberMarkUncriticalIfInformative = numberMarkIfInformative isObviouslyUncritical, colorMarkUselessIfInformative = colorMarkIfInformative isObviouslyUseless, colorMarkUncriticalIfInformative = colorMarkIfInformative isObviouslyUncritical, numberMarkUnmarked = mr [ rankHint 1 d | (_,d,_) <- nextPlayersUnmarked, not $ isUseless pub d ], numberMarkNumberUnmarked = mr [ rankHint 1 d | (_,d,Ann{marks=(Just _, Nothing),possibilities=p}) <- nextPlayer, not $ isObviouslyUseless pub p ], colorMarkColorUnmarked = mr [ colorHint 1 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. pass = case span (\(_,_,ann) -> isMarked ann) nextPlayer of (tk,dr) -> mr $ [ rankHint 1 d | (_,d,_) <- tk, rank d `notElem` [ rank c | (_,c,_) <- dr ] ] ++ [ colorHint 1 d | (_,d,_) <- tk, color d `notElem` [ color c | (_,c,_) <- dr ] ], hailMary = mr $ case filter (not . isDefinitelyUnplayable pv . snd) myHand of ts -> map (Play . fst) ts, playPlayable = mr $ case span (isObviouslyPlayable pub . possibilities . snd) $ filter (isDefinitelyPlayable pv . snd) myHand of (ob,nob) -> map (Play . fst) $ nob++ob, -- Play a playable card. Prioritize those that are not publicly playable. playPlayable5 = mr [ Play i | (i,ann@Ann{marks=(_,Just K5)}) <- myHand, isDefinitelyPlayable pv ann ], dropUselessCard = mr [ Drop i | (i,ann@Ann{possibilities=p}) <- reverse myHand, isDefinitelyUseless pv ann && isMarked ann || isObviouslyUseless pub p ], dropSafe = mr [ Drop i | (i,ann) <- reverse myHand, isDefinitelyUncritical pv ann ], dropPossiblyUncritical = mr [ Drop i | (i,ann) <- reverse myHand, not $ isDefinitelyCritical pv ann ], makePositionalDrop = let chops = concat $ map reverse $ obviousChopss pub myAnns hints = hintTokens pub discarded (Discard _) = True discarded (Fail _) = True discarded _ = False in case mvs of -- This assumes the last teammate marks a critical card if there is. Hint _ (Right _) : _ -> Nothing -- refrain if the last move was rank-mark in order to avoid dropping a critical card. This condition can be relaxed. -- Drop i : _ | not $ isDefinitelyUseless (head pvs) $ lastAnns !! i -> id -- refrain if the last move was Drop in order to avoid double-drop-like situation. This condition can be relaxed. mv : _ | discarded (result pub) && not (isDefinitelyUseless pv $ lastAnns !! index mv) -> Nothing -- refrain if the last move was Drop in order to avoid double-drop-like situation. This condition can be relaxed. _ : Drop i : _ | i `elem` sndlastUnusualChop -> Nothing -- avoid consecutive positional drop. This condition can be relaxed. _ | hints >= 2 && hints <= 6 && turn pub >= 7 && not (null chops) -> mr [Drop i | ( (i,card,Ann{possibilities=p}), mann) <- zip nextPlayer myAnns, isUnmarked mann, not (isDefinitelyCritical pv mann || isDefinitelyPlayable pv mann), head chops /= i, isPlayable pub card, not $ isObviouslyPlayable pub p] | otherwise -> Nothing, dropChopUnlessDoubleDrop = case mvs of _ : Drop i : _ | i `elem` sndlastUnusualChop -> Nothing -- avoid dropping after positional drop. This condition can be relaxed. _ -> mr [ Drop i | is@(i:_) <- take 1 $ map reverse $ definiteChopss pv myAnns, not $ isDoubleDrop pv (result pub) is $ myAnns !! i ], noDeck = not (continue || 0 < pileNum pub), spareDeck = continue || achievable - current < pileNum pub + 2, enoughDeck = continue || achievable - current < pileNum pub, livesBT = lives pub, hintsBT = hintTokens pub } iF :: Bool -> a -> a -> a iF a b c = if a then b else c other = $(p [|(iF :: (->) Bool (Maybe Move -> Maybe Move -> Maybe Move), mplus :: Maybe Move -> Maybe Move -> Maybe Move, 0::Int,1::Int,2::Int,3::Int,4::Int,5::Int,6::Int,7::Int,8::Int, (<=) :: Int->Int->Bool -- , hintTokens :: PublicInfo -> Int -- , lives :: PublicInfo -> Int )|]) wrap :: (BigTable -> Maybe Move) -> [PrivateView] -> [Move] -> Move wrap = \fun pvs@(pv:_) mvs -> fromJust $ fun (prepare pvs mvs) `mplus` mkRule pv ([Hint 1 $ Right n | n <- [K1 .. K5]] ++ [ Drop i | i <- [4,3..0] ] ++ [Play 0]) Nothing -- wrapper = $(p [| wrapper :: (BigTable -> Maybe Move -> Maybe Move) -> [PrivateView] -> [Move] -> Move |]) instinct = (bt ++ other -- ++ $(p [| (,) :: Int -> (BigTable -> Maybe Move -> Maybe Move) -> (Int, BigTable -> Maybe Move -> Maybe Move)|]) ) : replicate 94 [] {- common :: Common common = initCommon options{tv1=True,nrands=repeat 20,MagicHaskeller.LibTH.timeout=Just 20000} $ concat instinct instinctDyn = map (map (primitiveToDynamic $ tcl common)) instinct -} -- mkPgInstinct :: IO ProgGen -- mkPgInstinct = mkPGXOptIO options{tv1=False,nrands=repeat 20,timeout=Just 20000} [] [] instinct [] mkPgInst :: (RandomGen g, Strategies ps Identity) => [[Primitive]] -> GameSpec -> ps -> g -> IO ProgGenSF mkPgInst inst gs ps g = mkPGXOptsExt (\tcl -> [("Move", $(dynamic [|tcl|] [| compare :: Move -> Move -> Ordering |]))] : repeat []) (\tcl -> [("Move", $(dynamic [|tcl|] [| arbitraryMove gs :: Gen Move |])), ("BigTable", $(dynamic [|tcl|] [| arbitraryBTs :: Gen BigTable |])) ] : repeat []) (\tcl -> [("Move", $(dynamic [|tcl|] [| coarbitraryMove :: Move -> Gen x -> Gen x |]))] : repeat []) mkTrieOptSFIO options{tv0=True,nrands=repeat 20,timeout=Nothing} [] [] inst [] where arbitraryBTs = Gen $ \s gen -> case randomR (0,s*50) gen of (i,_) -> shuffledBTss !! i (g1,g2) = split g btss = runIdentity $ generateBTss gs ps g1 shuffledBTss = shuffleEvery50Games g2 btss arbitraryMove :: GameSpec -> Gen Move arbitraryMove gs@GS{numPlayers=np, rule=rl} = do b <- arbitraryR (0,2) case b::Int of 0 -> fmap Drop $ arbitraryR (0, pred $ funPlayerHand rl !! (np + 2)) 1 -> fmap Play $ arbitraryR (0,4) 2 -> liftM2 Hint (arbitraryR (1, pred np)) (arbitraryEither (fmap toEnum $ arbitraryR (0, pred $ numColors rl)) (fmap toEnum $ arbitraryR (1,5))) coarbitraryMove :: Coarb Move b coarbitraryMove (Drop i) = coarbitraryBool True . coarbitraryBool True . coarbitraryBool (testBit i 0) . coarbitraryBool (testBit i 1) . coarbitraryBool (testBit i 2) coarbitraryMove (Play i) = coarbitraryBool True . coarbitraryBool False . coarbitraryBool (testBit i 0) . coarbitraryBool (testBit i 1) . coarbitraryBool (testBit i 2) coarbitraryMove (Hint p (Left c)) = coarbitraryBool False . coarbitraryBool True . coarbitraryBool (testBit i 0) . coarbitraryBool (testBit i 1) . coarbitraryBool (testBit i 2) where i = fromEnum c coarbitraryMove (Hint p (Right r)) = coarbitraryBool False . coarbitraryBool False . coarbitraryBool (testBit i 0) . coarbitraryBool (testBit i 1) . coarbitraryBool (testBit i 2) where i = fromEnum r -- This is written for general monads, but since the generated [BigTable] is infinite, the monad should be Identity or IO through unsafeInterleaveIO or so. generateBTss :: (RandomGen g, Monad m, Strategies ps m) => GameSpec -> ps -> g -> m [[BigTable]] generateBTss gs ps gen = do (((_, sts, mvs), qs), g) <- start gs [] ps gen btss <- generateBTss gs qs g return $ zipWith prepare (tails $ viewStates sts) (tails mvs) : btss shuffleEvery50Games :: RandomGen g => g -> [[BigTable]] -> [BigTable] shuffleEvery50Games g0 xss = case splitAt 50 xss of (tk,dr) -> case shuffle (concat tk) g0 of (bts,g1) -> bts ++ shuffleEvery50Games g1 dr #ifdef DEBUG data Sless = Sl String ([PrivateView] -> [Move] -> Move) instance Monad m => Strategy Sless m where strategyName m = m >>= \ (Sl name _) -> return $ "Stateless " ++ name move pvs mvs sl@(Sl n f) = return (f pvs mvs, sl) #else data Sless = Sl ([PrivateView] -> [Move] -> Move) instance Monad m => Strategy Sless m where strategyName ms = return "Stateless strategy" move pvs mvs sl@(Sl f) = return (f pvs mvs, sl) #endif -- example simple strategy that can be used for debugging simpleSl :: Sless simpleSl = Sl #ifdef DEBUG "simple" #endif $ wrap $ \bt -> markUnhintedCritical bt `mplus` colorMarkUnmarkedPlayable bt `mplus` playPlayable bt `mplus` dropUselessCard bt `mplus` dropChopUnlessDoubleDrop bt `mplus` dropSafe bt testSl :: Sless testSl = Sl #ifdef DEBUG "simple" #endif $ wrap $ \bt -> markUnhintedCritical bt `mplus` playPlayable bt `mplus` dropChopUnlessDoubleDrop bt simpleInstinct :: [[Primitive]] simpleInstinct = $(p [| (mplus :: Maybe Move -> Maybe Move -> Maybe Move, markUnhintedCritical :: BigTable -> Maybe Move, colorMarkUnmarkedPlayable :: BigTable -> Maybe Move, playPlayable :: BigTable -> Maybe Move, dropUselessCard :: BigTable -> Maybe Move, dropChopUnlessDoubleDrop :: BigTable -> Maybe Move, dropSafe :: BigTable -> Maybe Move ) |]) : replicate 94 [] verySimpleInstinct :: [[Primitive]] verySimpleInstinct = $(p [| (\bt -> markUnhintedCritical bt `mplus` colorMarkUnmarkedPlayable bt `mplus` playPlayable bt `mplus` dropUselessCard bt `mplus` dropChopUnlessDoubleDrop bt `mplus` dropSafe bt) :: BigTable -> Maybe Move |]) : replicate 94 [] data MHLimit = Infinite -- ^ no limit | Depth Int -- ^ bound by the depth. Safe option when the cardinality of the set of possible programs is unknown. | MaxNumProgs Int -- ^ bound by the number of programs. Maybe good for incremental learning. | ProgsPerDepth Int -- ^ (just for backward compatibility) deriving (Eq, Show, Read) data ParamsADSL = PADSL { paramsALMC :: ParamsALMC , probToStay :: Double , mhLimit :: MHLimit } deriving (Eq, Show, Read) mkAdaptiveLMC :: RandomGen g => ParamsADSL -> [[Primitive]] -> g -> IO (AdaptiveLMC g (Stateful Sless)) mkAdaptiveLMC PADSL{..} inst gen = do numC <- getNumCapabilities -- hPutStrLn stderr $ "rtsSupportsBoundThreads = "++shows rtsSupportsBoundThreads ", and current numCapabilities = " ++ show numC newNumC <- if rtsSupportsBoundThreads then do nnc <- if numCap paramsALMC > 0 then return $ numCap paramsALMC else return numC -- if numC > 1 then return numC else fmap (\c -> succ c `div` 2) getHardwareConcurrency -- If it is set to more than 1, respect it. Otherwise, ceiling (hardwareConcurrency/2) may be a good default. setNumCapabilities nnc return nnc else return 1 -- GHCJS fails when setNumCapabilities is executed. let (g1,g2) = split gen pg <- mkPgInst inst defaultGS [sfs $ S True] g1 let progss = everythingF pg False :: Every (BigTable -> Maybe Move) -- = [[(TH.Exp, (Int, BigTable -> Maybe Move))]] -- let genStrss = map (\progs -> [ (e, SF {guessColorToPlay = testBit n 0, guessPositionalDrop = testBit n 1, baseStrategy = Sl f, []}) | (e,(n,f)) <- progs, n<4 ]) progss :: [[(TH.Exp, Stateful Sless)]] let genStrss = map (\progs -> [ SF {guessColorToPlay = c, guessPositionalDrop = p, #ifdef DEBUG baseStrategy = Sl (pprint e) $ wrap f, #else baseStrategy = Sl $ wrap f, #endif anns=[]} | (e,f) <- progs, c<-[False,True], p <- [False,True] ]) progss :: [[Stateful Sless]] let suggested = sfs $ Sl #ifdef DEBUG "suggested" #endif $ \ps ms -> fst $ runIdentity $ move ps ms $ S True let dropped = dropWhile null genStrss strMx = case mhLimit of Infinite -> dropped Depth d -> filter (not.null) $ take d dropped MaxNumProgs mnp -> filter (not.null) $ take (length $ takeWhilePlus ( filter (not.null) $ takeWhilePlus ((