hanabi-dealer-0.15.1.1: Game/Hanabi/Strategies/AdaptiveLMC.hs
-- A specialized version of LazyMC.hs that supports a lot number of strategies.
{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances, RankNTypes, TupleSections, FlexibleContexts #-}
module Game.Hanabi.Strategies.AdaptiveLMC(AdaptiveLMC(..), ParamsALMC(..), Priority(..), CheckMode(..), mkMx, mkProbs) where
import System.Random
import Control.Monad(MonadPlus(..))
import Data.Functor.Identity
#ifdef TEST
import Test.QuickCheck hiding (shuffle, (.&.))
import Data.List(partition, maximumBy, delete, tails, permutations, transpose, sort)
#else
import Data.List(partition, maximumBy, delete, tails, permutations, transpose)
#endif
import Data.Bits hiding (rotate)
import Data.Function(on)
import Data.Array hiding (index)
import Data.Maybe(isNothing, isJust, fromJust, maybeToList)
import qualified Data.IntMap as IM
import Game.Hanabi
#ifdef MHLMC
import Control.Parallel(par, pseq)
import Control.Parallel.Strategies hiding (Strategy)
import GHC.Conc(numCapabilities)
#endif
-- from package MagicHaskeller
import Control.Monad.Search.Combinatorial
-- only used by the fallback.
import Game.Hanabi.Strategies.EndGameSearch
import Game.Hanabi.Strategies.EndGameLite(egml, egl, EndGameMirrorLite(..), EndGameLite(..))
import Game.Hanabi.Strategies.Stateless
#ifdef DEBUG
import Debug.Trace
#else
trace _ = id
#endif
#if !defined MHLMC
par = flip const
#endif
-- type FullState s = ([State], [s])
-- type BeliefState s = [(FullState s, Probability)]
-- mkPool is a function that helps the user to create the pool of strategies based on the list of lists of strategies that are annotated with the probability with which each list of strategies is selected.
mkProbs :: [Double] -> [Double]
mkProbs = tail . scanl (-) 1
mkMx :: [[s]] -> Matrix s
mkMx = Mx . (++repeat []) -- Matrix defined in package MagciHaskeller assumes an infinite stream of finite lists.
samplePairsOfStatesAndStrategies :: (RandomGen g, Strategy s Identity) => Int -> [Matrix s] -> [[Double]] -> [PrivateView] -> [Move] -> g -> [([State],[s])]
samplePairsOfStatesAndStrategies numC mxs probss pvs mvs gen = case split gen of (g1,g2) -> zip (sampleStatess numC pvs mvs g1) $ sampleStrategiess mxs probss g2
samplesFromArr :: (RandomGen g) => Array Int ss -> g -> [ss]
samplesFromArr arr g = [ arr ! ix | ix <- randomRs (bounds arr) g ]
sampleStrategiess :: (RandomGen g, Strategy s Identity) => [Matrix s] -> [[Double]] -> g -> [[s]]
sampleStrategiess mxs probss gen = transpose $ zipWith3 sampleStrategies mxs probss $ map snd $ iterate (split . fst) $ split gen
-- The Double here is not the probability of selecting the current array but that of going deeper. This decision is for efficiency. So, if the list is finite, it must end with @(some_array,0):[]@
sampleStrategies :: (RandomGen g, Strategy s Identity) => Matrix s -> [Double] -> g -> [s]
sampleStrategies mx probs = sampleStrategies' $ zip [ listArray (1, length ss) ss | ss <- unMx $ removeNils mx ] probs
sampleStrategies' :: (RandomGen g, Strategy s Identity) => [(Array Int s, Double)] -> g -> [s]
sampleStrategies' [] _ = []
sampleStrategies' ts gen = let
(d,g1) = random gen
(strs,_) = case dropWhile (\(_,prob) -> d<prob) ts of
t:_ -> t
[] -> last ts
in case randomR (bounds strs) g1 of (i,g2) -> (strs!i) : sampleStrategies' ts g2 -- Make sure that @indices strs@ is not null when defining the pool!
sampleStatess :: RandomGen g => Int -> [PrivateView] -> [Move] -> g -> [[State]]
#ifdef MHLMC
sampleStatess numC pvs moves g = concat $ para numC $ map (smplsts pvs moves) $ map snd $ iterate (split.fst) $ split g
#else
sampleStatess _ pvs@(pv:tlpvs) moves g = let (s,gen) = sampleState pv g in map (stateToStateHistory (map publicView tlpvs) moves) s ++ sampleStatess numC pvs moves gen
#endif
smplsts :: RandomGen g => [PrivateView] -> [Move] -> g -> [[State]]
smplsts pvs@(pv:tlpvs) moves g = map (stateToStateHistory (map publicView tlpvs) moves) $ fst $ sampleState pv g
-- | 'nSampleStatess' is an eager alternative of sampleStatess.
-- 'nSampleStatess' is not desired because n can be very big and most of the samples would not be actually used, but there are RNGs without good split.
-- @take n $ sampleStatess pvs moves g@ should be used instead in most cases.
nSampleStatess :: RandomGen g =>
Int -- ^ number of samples
-> [PrivateView] -> [Move] -> g -> ([[State]],g)
nSampleStatess 0 pvs moves g = ([],g)
nSampleStatess n pvs@(pv:tlpvs) moves g = let (s,g') = sampleState pv g
(ss,gen) = nSampleStatess (pred n) pvs moves g'
in (map (stateToStateHistory (map publicView tlpvs) moves) s ++ ss, gen)
-- naive alternative
{-
eval :: (Monad m, Strategy s m) => [([State],[s])] -> ([State]->[s]->m (EndGame, [State], [Move])) -> m Int
eval samples run = mapM (\ (sts, ps) -> run sts ps) samples >>= \tups -> return $ sum [ egToNum st eg | (eg,st:_,_) <- tups ]
-}
evals :: [([State],[s])] -> ([State]->[s]->(EndGame, [State], [Move])) -> [Int]
evals samples run = [ egToNum st eg | (sts,ps) <- samples, let (eg,st:_,_) = run sts ps ]
evalALittleQuick :: Int -> Int -> Int -> [Int] -> Int
evalALittleQuick bestPossibleScore bestPossibleMargin sumSoFar [] = sumSoFar
evalALittleQuick bestPossibleScore bestPossibleMargin sumSoFar (score:ss) | newPossibleMargin <= 0 = -1
| otherwise = evalALittleQuick bestPossibleScore newPossibleMargin newSum ss
where newSum = score + sumSoFar
newPossibleMargin = bestPossibleMargin - bestPossibleScore + score
evalQuick :: Int -> Int -> Int -> [Int] -> Int
evalQuick bestPossibleMargin bestPossibleScore sumSoFar [] = sumSoFar
evalQuick bestPossibleMargin bestPossibleScore sumSoFar (score:ss)
| bestPossibleMargin <= 0 = -1
| otherwise = evalQuick (bestPossibleMargin - (bestPossibleScore-score)) bestPossibleScore (score + sumSoFar) ss
-- findBestMove finds the best move based on the average score.
findBestMove :: Int -> Int -> Int -> [([State], [s])] -> (Move -> [State]->[s]-> (EndGame, [State], [Move])) -> (Int, Move) -> [Move] -> (Int, Move)
findBestMove numC achievable bestPossibleScore samples run best [] = best
findBestMove numC achievable bestPossibleScore samples run best@(bestSum, _) (m:ms) = let scores = evals samples $ run m
sumScore = evalQuick (achievable-bestSum) bestPossibleScore 0 $ para numC scores
in findBestMove numC achievable bestPossibleScore samples run (if sumScore > bestSum then (sumScore, m) else best) ms
#ifdef MHLMC
para numC = withStrategy $ parBuffer numC rpar
#else
para _ xs = xs
#endif
evalDecent :: Priority -> Int -> Int -> Int -> Int -> Int -> [Int] -> (Int, Int)
evalDecent pri bestPossibleNumMargin bestPossibleMargin bestPossibleScore numBest sumSoFar [] = (numBest, sumSoFar)
evalDecent AvoidZero bestPossibleNumMargin bestPossibleMargin bestPossibleScore numBest sumSoFar (0:ss) = (0, sumSoFar) -- Further computation is not worthy, but there has to be some valid value.
evalDecent pri bestPossibleNumMargin bestPossibleMargin bestPossibleScore numBest sumSoFar (score:ss)
| bestPossibleNumMargin < 0 || (bestPossibleNumMargin == 0 && bestPossibleMargin <= 0) = (-1, -1)
| score == bestPossibleScore = evalDecent pri bestPossibleNumMargin (bestPossibleMargin - (bestPossibleScore-score)) bestPossibleScore (succ numBest) (score + sumSoFar) ss
| otherwise = evalDecent pri (pred bestPossibleNumMargin) (bestPossibleMargin - (bestPossibleScore-score)) bestPossibleScore numBest (score + sumSoFar) ss
-- findBestMoveDecently is a variant of findBestMove that optimizes ( - <# of failure>, <# of perfect>, <average score>) in the lexicographical order.
findBestMoveDecently :: Int -> Priority -> Int -> Int -> Int -> [([State], [s])] -> (Move -> [State]->[s]-> (EndGame, [State], [Move])) -> ((Int,Int), Move) -> [Move] -> ((Int,Int), Move)
findBestMoveDecently numC pri numSmpls achievable bestPossibleScore samples run best [] = best
findBestMoveDecently numC pri numSmpls achievable bestPossibleScore samples run best@(bestRes@(bestNum,bestSum), _) (m:ms) = let scores = evals samples $ run m
sumScore = evalDecent pri (numSmpls-bestNum) (achievable-bestSum) bestPossibleScore 0 0 $ para numC scores
in findBestMoveDecently numC pri numSmpls achievable bestPossibleScore samples run (if sumScore > bestRes then (sumScore, m) else best) ms
-- In effect, lmcs pri n rr g p ps === glmcs pri n rr g p [ [([p],1)] | p <- ps ]
-- flatlmcs numC pri cm n ov rr g p ps = glmcs numC pri cm n ov rr g p ps $ repeat $ 1 : repeat 0
-- glmcs numC pri cm n ov _rr g p ps probs = LMC (PALMC numC pri cm n ov) g p (map mkMx ps) (map mkProbs probs) mzero IM.empty [] undefined
data ParamsALMC = PALMC { numCap :: Int -- ^ numCapabilities. Unless this is positive, the value from -N RTS option is used.
, priority :: Priority -- This could be (Int->Priority), changing as the number of games increases.
, checkMode :: CheckMode
, numSamplesLMC :: Int
, overwriteMyRollout :: Bool -- ^ if True, overwrite rolloutStrategyLMC with the very first strategy of rolloutStrategiesLMC at the beginning of each game.
-- , rollbackRounds :: Int -- ^ after resampling, how many past rounds to check the consistency with the rollout policy. This is reset to 1 when @move@ is called in the beginning of game, and is not a config value any longer.
}
deriving (Eq, Show, Read)
data AdaptiveLMC g s = LMC { parameters :: ParamsALMC
, rngLMC :: g
, rolloutStrategyLMC :: s
, rolloutStrategiesLMC :: [Matrix s]
, priors :: [[Double]]
, consistentSampleFullStatesLMC :: Matrix ([State],[s]) -- ^ stream of lists of sample full states that are consistent with the game environment and the conjectured teammate policies.
, ixToCard :: IM.IntMap Card
, fixedStateHistory :: [State]
, lastTurn :: Int -- the last turn when move for this agent is executed. This should equal @turn pub - numPlayers (gameSpec pub)@ when move is called. This is useful for identifying who finalized the game within observeEndGame.
, ready :: Bool -- ^ True when initialization is finished, ⊥ otherwise.
}
data Priority = AverageScore -- ^ evaluate only by the average score
| BestScoreRate -- ^ firstly consider the number of cases where the best possible score is achieved, and then consider the average score
| AvoidZero -- ^ firstly avoid Failure and score 0, and then follow BestScoreRate. This is the recommendation if self-play of the rollout policy does not achieve 24 on average.
deriving (Eq, Show, Read)
data CheckMode = FromTheBeginning -- ^ check the consistency of new samples against the full history of the current game. Costly, but exact when checking stateful sample strategies.
| PartiallyObserved -- ^ check the consistency of new samples only against the part of history where unknown cards still exist. This should be enough when assuming that other players are stateless.
deriving (Eq, Show, Read)
annotationToCT4 :: PrivateView -> Annotation -> (Int, CardTo4)
annotationToCT4 pv ann = (ixDeck ann, case marks ann of (Just _, Just _) -> possibilities ann
_ -> possibilities ann .&. invisibleBag pv)
{-
updateIxToCT4 :: Int -> [PrivateView] -> IM.IntMap CardTo4 -> IM.IntMap CardTo4
updateIxToCT4 numP pvs@(pv:_) i2ct4 = let lastResult = result $ pvs !! pred numP
-}
annotationToMbCard :: PrivateView -> Annotation -> [(Int, Card)]
annotationToMbCard pv ann = case marks ann of (Just c, Just r) -> [(ixDeck ann, C c r)]
_ | bit trz == pos -> [(ixDeck ann, qitPosToCard $ trz `div` 2)]
| otherwise -> []
where pos = possibilities ann .&. invisibleBag pv
trz = countTrailingZeros pos
-- updateIxToCard :: Int -> [PrivateView] -> [Move] -> IM.IntMap Card -> IM.IntMap Card
-- updateIxToCard numP pvs mvs i2c = roundToIxToCard numP pvs mvs `union` i2c
roundToIxToCard :: Int -> [PrivateView] -> [Move] -> IM.IntMap Card
roundToIxToCard numP pvs@(pv:_) mvs = let
myRevealed = case drop (pred numP) pvs of
PV{publicView=PI{result=lastResult}} : myLastPV : _ ->
case lastResult of
None -> []
_ -> [(ixDeck $ head (annotations $ publicView myLastPV) !! index myLastMove, revealed lastResult)]
where myLastMove = mvs !! pred numP -- mvs is only used here, for extracting the index of the last move.
_ -> []
myAnns = head $ annotations $ publicView pv
in IM.fromList $ myRevealed ++ (myAnns >>= annotationToMbCard pv) -- fromAscList could be used for the second list with adequate specification.
instance (RandomGen g, Monad m, Strategy s Identity) => Strategy (AdaptiveLMC g s) m where
strategyName ms = return "AdaptiveLMC"
initialize True p = ready p `par` return p
initialize False p = ready p `pseq` return p
observeEndGame iniDeck gh@(eg, state:states, moves) lmc@(LMC (PALMC numC pri cm num ov) gen p mxs probss _cMx i2c fsh lt ready)
| lt < numP = return lmc -- If the game ends before my turn comes, do nothing, (Something can still be learned, but that is not worthy of coding.)
| otherwise = -- trace ("lt = "++show lt) $
do
let q | ov = head $ concat $ unMx $ head filteredMxs
| otherwise = runIdentity $ observeEndGame iniDeck gh p
return $ LMC (PALMC numC pri cm num ov) gen q filteredMxs probss mzero IM.empty [] (-1) ready
where -- ni2c = IM.fromList $ zip [0..] iniDeck
pub = publicState state
numP = numPlayers (gameSpec pub)
predLenFsh | null fsh = -1
| otherwise = turn $ publicState $ last fsh
nonrotatedDeltas = map unzip $ take (turn pub - predLenFsh) $ tails $ zip (zipWith rotate [1..] states) moves
arrOfsPvsMvs = accumArray (flip (:)) [] (0, pred numP) [ (offset, (map view $ map (rotate offset) sts, mvs)) | (sts@(st:_), mvs) <- nonrotatedDeltas, let offset = (turn (publicState st) - lt) `mod` numP ] :: Array Int [([PrivateView], [Move])]
filteredMxs = zipWith filtMx mxs [1..pred numP]
-- This @filtMx@ is the same as that in @move@.
-- filtMx :: Matrix x -> Int -> Matrix x
filtMx mx offset = let hists = arrOfsPvsMvs ! offset in removeLeadingNils $ fps hists mx
where fps hists mx = mx >>= \prog -> foldr ($) (return prog) $ map (pred prog) hists
where -- pred :: s -> ([PrivateView], [Move]) -> Bool
pred str (pvs, mv:mvs) | fst (runIdentity $ move pvs mvs str) == mv = id
| otherwise = delay
move pvs@(pv:_) mvs str@(LMC palmc@(PALMC numC pri cm num ov) gen p mxs probss checkedMx i2c fsh lt ready)
{-
| turn pub < numP || null newcss = do
let (g3,g4) = split g2
let (newrr, newMxs) = if turn pub >= numP then (succ rr,
take (pred numP) $ (
map (\mx -> case mx of
Mx (a:b:vs) | fst (randomR (1, length a) g3) * 2 < limit -- The random number is used to make sure roughly most of the programs are tried at least once.
-> Mx $ (b ++ a) : vs
_ -> mx)
filteredMxs))
else (1, filteredMxs)
let (m, q) = trace "!!!!!!!!!!!!!Fall Back!!!!!!!!!!!!!!!!!!!!!" $
runIdentity $ move pvs mvs p
return (m, LMC pri num newrr g4 sp q newMxs probss (take num alternativeStatess) ni2c nfsh ready)
-}
| otherwise = do
#ifdef DEBUG
(sq,(_i, m)) <- trace ("mcMove") $
trace ("length samples = " ++ show (length $ take num newcss)) $
#else
(sq, m) <-
#endif
mcMove numC pri num (take num newcss) p pvs' mvs
return (m, LMC palmc g2 sq filteredMxs probss (Mx $ newlyCheckedMx ++ repeat []) ni2c nfsh (turn pub) ready)
where
(ni2c, fsh') | turn pub < numP = (IM.empty, [])
| otherwise = (roundToIxToCard numP pvs mvs `IM.union` i2c, fsh)
lenfsh = length fsh'
rpvs = drop lenfsh $ reverse $ tail pvs
cardss = map fromJust $ takeWhile isJust [ mapM (flip IM.lookup ni2c . ixDeck) $ head $ annotations $ publicView pv | pv <- rpvs ]
nonrotatedPartialStates = zipWith (\(PV{publicView=pub, handsPV=hpv}) myHand -> St{publicState=pub, hands=myHand:hpv}) rpvs cardss
nfsh = reverse nonrotatedPartialStates ++ fsh'
lenFshDelta = length nonrotatedPartialStates
-- nrpss = take lenFshDelta $ tails nfsh :: [[State]]
predLenDelta = turn pub - lenFshDelta - lenfsh
deltas = map unzip $ take lenFshDelta $ tails $ zip nfsh $ drop predLenDelta mvs :: [([State], [Move])] -- NB: length mvs == turn pub, though length pvs == succ (turn pub)
arrOfsPvsMvs = accumArray (flip (:)) [] (0, pred numP) [ (offset, (map (view . rotate offset) sts, mvs)) | (sts@(st:_), mvs) <- deltas, let offset = (turn (publicState st) - turn pub) `mod` numP ] :: Array Int [([PrivateView], [Move])]
filteredMxs = zipWith filtMx mxs [1..pred numP]
-- filtMx :: Matrix x -> Int -> Matrix x
filtMx mx offset = let hists = arrOfsPvsMvs ! offset in removeLeadingNils $ fps hists mx
where fps hists mx = mx >>= \prog -> foldr ($) (return prog) $ map (pred prog) hists
where -- pred :: s -> ([PrivateView], [Move]) -> Bool
pred str (pvs, mv:mvs) | fst (runIdentity $ move pvs mvs str) == mv = id
| otherwise = delay
-- newcss :: [([State],[s])]
newcss = concat newlyCheckedMx
(tk,m:_) = splitAt (pred numP) mvs
moves = m : reverse tk
revPVs = reverse $ take numP pvs
agree pv1 pv2 = ((==) `on` (nonPublic . publicView)) pv1 pv2 &&
((==) `on` (map (take 1) . handsPV)) pv1 pv2 &&
((==) `on` (map marks . head . annotations . publicView)) pv1 pv2
viewChecked = do
~(lststs@(lastState:_), lstps) <- checkedMx
states <- Mx $ (:repeat[]) $ take 1 $
foldl (\statss (i,rpv,mov) -> statss >>= \stats@(stat:_) -> map (:stats) (map (rotate 1) $ filter (\st -> isNothing (checkEndGame $ publicState st) && agree rpv (view $ rotate (-i) st)) $ proceeds stat mov)) [lststs] $ zip3 [0..] revPVs moves
return (states, lstps)
checkedCss | turn pub < numP = mzero
| otherwise = do
(states, lstps) <- viewChecked
checkMoves numP numP tailsMoves lstps states
tailsMoves = tails mvs
(tkSamples, drSamples) = splitAt num $ samplePairsOfStatesAndStrategies numC filteredMxs probss pvs mvs g1
phase1 = do (sts,ps) <- Mx $ tkSamples : repeat []
checkMoves ({- rr*numP `min` -} turns) numP tailsMoves ps sts
ph1Depth = succ $ length $ takeWhile null $ unMx phase1
-- newlyCheckedMx :: Matrix ([State],[s])
newlyCheckedMx = head $ dropWhile ((<num) . length . concat) $ map (take ph1Depth . unMx) $ scanl mplus (checkedCss `mplus` phase1) $ para numC $ map (uncurry $ flip $ checkMoves turns numP tailsMoves) drSamples
-- Samples that were not checked within this turn should be abandoned, because the space of possible states is narrowed in the next turn, and most of them can be useless, so newly sampling in the next turn is more efficient.
turns = case cm of FromTheBeginning -> turn pub
PartiallyObserved -> succ predLenDelta
pvs'@(hdpv:tlpvs) = pvs -- [ pv{publicView=pub{gameSpec=gs{rule=r{earlyQuit=True}}}} | pv@PV{publicView=pub@PI{gameSpec=gs@GS{rule=r}}}<- pvs ]
pub = publicView hdpv
numP = numPlayers $ gameSpec pub
(g1,g2) = split gen
alternativeStatess = [ (states, take (pred numP) strs) | (states, strs) <- samplePairsOfStatesAndStrategies numC filteredMxs probss pvs mvs g1 ]
limit = 10000
removeLeadingNils :: Matrix a -> Matrix a
removeLeadingNils (Mx xss) = Mx $ dropWhile null xss
removeNils (Mx xss) = Mx $ filter (not . null) xss
mcMove :: (Monad m, Strategy p Identity) =>
Int
-> Priority
-> Int -- ^ number of samples
-> [([State],[p])] -- ^ possible sample pairs of the state history and the internal memory states of other players' strategies
-> p -- ^ rollout strategy for the player
-> [PrivateView] -- ^ view history
-> [Move] -- ^ move history
#ifdef DEBUG
-> m (p, ((Bool,Int,Int), Move))
#else
-> m (p, Move)
#endif
mcMove numC pri numSmpls smpls p pvs@(pv:_) mvs = do
let (defaultMove, sq) = runIdentity $ move pvs mvs p
let candidateMoves = defaultMove : delete defaultMove (validMoves pv)
let pub = publicView pv
bestPossibleScore = fromIntegral $ moreStrictlyAchievableScore pub
achievable = bestPossibleScore * fromIntegral numSmpls
#ifdef DEBUG
-- This is the naive alternative.
let asc = case pri of AvoidZero ->
map (\m -> let scores = evals smpls (\sts ps -> runIdentity $ fmap fst $ tryAMove sts mvs (ps++[sq]) m)
in ((all (/=0) scores, length $ filter (==bestPossibleScore) scores, sum scores), m)
) candidateMoves :: [((Bool,Int,Int), Move)]
BestScoreRate ->
map (\m -> let scores = evals smpls (\sts ps -> runIdentity $ fmap fst $ tryAMove sts mvs (ps++[sq]) m)
in ((True, length $ filter (==bestPossibleScore) scores, sum scores), m)
) candidateMoves
AverageScore ->
map (\m -> let scores = evals smpls (\sts ps -> runIdentity $ fmap fst $ tryAMove sts mvs (ps++[sq]) m)
in ((True, fromIntegral numSmpls, sum scores), m)
) candidateMoves
achi = (True, fromIntegral numSmpls, achievable)
if trace "if any" $
any ((>achi) . fst) asc then error ("turn = "++show (turn pub) ++ "\n asc = "++show asc++"\n achi = "++show achi) else
trace ("turn = "++show (turn pub) ++ "\n asc = "++show asc++"\n achi = "++show achi) $
return $
(sq,
trace ("defaultMove = "++show defaultMove++", and the result seems "++show (maximumBy (compare `on` fst) $ reverse asc)) $
case lookup achi asc of Nothing -> maximumBy (compare `on` fst) $ reverse asc
Just k -> (achi, k) -- Stop search when the best possible score is found.
)
#else
let best = case pri of AverageScore -> snd $ findBestMove numC achievable bestPossibleScore smpls (\m sts ps -> fst $ runIdentity $ tryAMove sts mvs (ps++[sq]) m) (-1, error "findBestMove: not found: should be undefined" defaultMove) candidateMoves
_ -> snd $ findBestMoveDecently numC pri numSmpls achievable bestPossibleScore smpls (\m sts ps -> fst $ runIdentity $ tryAMove sts mvs (ps++[sq]) m) ((0,-1), error "findBestMoveDecently: not found: should be undefined" defaultMove) candidateMoves
return (sq, best)
#endif
-- | 'tryAMove' tries a 'Move' and then simulate the game to the end, using given 'Strategies'. Running this with empty history, such as @tryAMove [st] [] strs m@ is possible, but that assumes other strategies does not depend on the history.
tryAMove :: (Monad m, Strategy s m) => [State] -> [Move] -> [s] -> Move -> m ((EndGame, [State], [Move]),[s])
tryAMove states@(st:_) mvs strs mov = case proceed st mov of Nothing -> error $ show mov ++ ": invalid move in tryAMove"
Just st -> let nxt = rotate 1 st
in case checkEndGame $ publicState nxt of Nothing -> runSilently (nxt:states) (mov:mvs) strs
Just eg -> return ((eg, nxt:states, mov:mvs), strs)
checkMoves :: (Strategy s Identity) => Int -> Int -> [[Move]] -> [s] -> [State] -> Matrix ([State], [s])
checkMoves turns numP tailsMoves ps states =
let
statess = reverse $ take turns $ tails states
mvss = reverse $ take (pred turns) tailsMoves
pnp = pred numP
(b,qs) = checkMvs numP (length mvss) statess mvss ps -- !!! Exactly speaking, ps should be rotated when @length mvss /= pred turns@ !!!!!!!!!
in b $ return (states, take pnp qs)
checkMvs :: (Strategy s Identity) => Int -> Int -> [[State]] -> [[Move]] -> [s] -> (Matrix a -> Matrix a, [s])
checkMvs _ 0 _ _ qs = (id, qs)
checkMvs numP n (sts:stss) (ms:mss) (p:ps)
| n `mod` numP == 0 || null ms = checkMvs numP (pred n) stss mss (p:ps) -- skip the check if it is in the player's own turn, or it is the first turn.
| otherwise = let
(mv,q) = runIdentity $ move (viewStates sts) (tail ms) p
(restb, rest) = checkMvs numP (pred n) stss mss $ ps ++ [q]
delayer | mv == (head ms) = id
| otherwise = delay
in (delayer . restb, rest) -- Once mv /= head ms, the remaining part would not be computed.