packages feed

hanabi-dealer-0.15.1.1: Game/Hanabi/Strategies/AppendDSL.hs

{-# 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 (<mnp) $ scanl1 (+) $ map length dropped) dropped
                ProgsPerDepth ppd -> filter (not.null) $ takeWhilePlus ((<ppd) . length) dropped
          let probs  = mkProbs $ iterate (*(1-probToStay)) probToStay
-- #ifdef DEBUG
--           hPrint stderr $ "length strPool = " ++ show (length strPool)
-- #endif
          return $ LMC { parameters=paramsALMC{numCap=newNumC}
                       , rngLMC=g2
                       , rolloutStrategyLMC = suggested
                       , rolloutStrategiesLMC = repeat $ mkMx strMx
                       , priors = repeat probs
                       , consistentSampleFullStatesLMC=mzero
                       , lastTurn = -1
                       , ready = null (last strMx) `seq` True}

takeWhilePlus pred xs = case span pred xs of (tk, dr) -> tk ++ foldr (\d _->[d]) [] dr