hcheckers-0.1.0.0: src/AI/AlphaBeta.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-
- This module contains an implementation of alpha-beta-pruning algorithm
- with small improvements.
-}
module AI.AlphaBeta
( runAI, scoreMove
) where
import Control.Monad
import Control.Monad.State
import Control.Monad.Except
import Control.Concurrent.STM
import qualified Data.Map as M
import Data.Maybe
import Data.Default
import Data.List (sortOn)
import Data.Text.Format.Heavy
import Data.Aeson
import System.Log.Heavy
import System.Log.Heavy.TH
import System.Clock
import Core.Types
import Core.Board
import Core.Parallel
import Core.Logging
import qualified Core.Monitoring as Monitoring
import AI.AlphaBeta.Types
import AI.AlphaBeta.Cache
instance FromJSON AlphaBetaParams where
parseJSON = withObject "AlphaBetaParams" $ \v -> AlphaBetaParams
<$> v .: "depth"
<*> v .:? "start_depth"
<*> v .:? "max_combination_depth" .!= 8
<*> v .:? "dynamic_depth" .!= abDynamicDepth def
<*> v .:? "deeper_if_bad" .!= False
<*> v .:? "moves_bound_low" .!= 4
<*> v .:? "moves_bound_high" .!= 8
<*> v .:? "time"
instance (GameRules rules, Evaluator eval) => GameAi (AlphaBeta rules eval) where
type AiStorage (AlphaBeta rules eval) = AICacheHandle rules eval
createAiStorage ai = do
cache <- loadAiCache scoreMove ai
return cache
saveAiStorage (AlphaBeta params rules _) cache = do
-- saveAiCache rules params cache
return ()
chooseMove ai storage gameId side board = do
(moves, _) <- runAI ai storage gameId side board
-- liftIO $ atomically $ writeTVar (aichCurrentCounts storage) $ calcBoardCounts board
return moves
updateAi ai@(AlphaBeta _ rules eval) json =
case fromJSON json of
Error _ -> ai
Success params -> AlphaBeta params rules (updateEval eval json)
aiName _ = "default"
-- | Calculate score of one possible move.
scoreMove :: (GameRules rules, Evaluator eval) => ScoreMoveInput rules eval -> Checkers (PossibleMove, Score)
scoreMove (ScoreMoveInput {..}) = do
let AlphaBeta params rules eval = smiAi
score <- Monitoring.timed "ai.score.move" $ do
let board' = applyMoveActions (pmResult smiMove) smiBoard
score <- doScore rules eval smiCache params smiGameId (opposite smiSide) smiDepth board' smiAlpha smiBeta
`catchError` (\(e :: Error) -> do
$info "doScore: move {}, depth {}: {}" (show smiMove, dpTarget smiDepth, show e)
throwError e
)
$info "Check: {} (depth {}) => {}" (show smiMove, dpTarget smiDepth, show score)
return score
return (smiMove, score)
rememberScoreShift :: AICacheHandle rules eval -> GameId -> ScoreBase -> Checkers ()
rememberScoreShift handle gameId shift = liftIO $ atomically $ do
shifts <- readTVar (aichLastMoveScoreShift handle)
let shifts' = M.insert gameId shift shifts
writeTVar (aichLastMoveScoreShift handle) shifts'
getLastScoreShift :: AICacheHandle rules eval -> GameId -> Checkers (Maybe ScoreBase)
getLastScoreShift handle gameId = liftIO $ atomically $ do
shifts <- readTVar (aichLastMoveScoreShift handle)
return $ M.lookup gameId shifts
getPossibleMoves :: GameRules rules => AICacheHandle rules eval -> Side -> Board -> Checkers [PossibleMove]
getPossibleMoves handle side board = Monitoring.timed "ai.possible_moves.duration" $ do
let rules = aichRules handle
Monitoring.increment "ai.possible_moves.calls"
return $ possibleMoves rules side board
-- (result, hit) <- liftIO $ do
-- let memo = aichPossibleMoves handle
-- let rules = aichRules handle
-- let moves = possibleMoves rules side board
-- mbItem <- lookupBoardMap memo board
-- case mbItem of
-- Nothing -> do
-- let value = case side of
-- First -> (Just moves, Nothing)
-- Second -> (Nothing, Just moves)
-- putBoardMap memo board value
-- return (moves, False)
-- Just (Just cachedMoves, _) | side == First -> return (cachedMoves, True)
-- Just (_, Just cachedMoves) | side == Second -> return (cachedMoves, True)
-- Just (mbMoves1, mbMoves2) -> do
-- let value
-- | side == First = (Just moves, mbMoves2)
-- | otherwise = (mbMoves1, Just moves)
-- putBoardMap memo board value
-- return (moves, False)
-- if hit
-- then Monitoring.increment "ai.possible_moves.hit"
-- else Monitoring.increment "ai.possible_moves.miss"
-- return result
-- | General driver / controller for Alpha-Beta prunning algorithm.
-- This method is responsible in running scoreAB method on all possible moves
-- and selecting the best move.
--
-- This is done, in general, in three stages:
--
-- 1. Preselect. From all possible moves, select ones that look good at a first glance.
-- This logic can be used to make AI work faster, but it obviously can miss some moves
-- that are not so good from a first glance, but are very good from the second glance.
--
-- 2. Depth-wise loop. Score all moves with specified depth. If there is still time, then
-- score them again with better depth. Repeat until there is still time.
-- Each iteration can be interrupted by TimeExhaused exception.
-- If last iteration was not interrupted, then use results of last iteration.
-- If last iteration was interrputed, then merge results of last iteration with results
-- of previous one: for moves that we was not able to calculate with better depth,
-- use results with previous depth.
-- If timeout is not specified, then only one iteration is executed, without timeout.
-- The depth to start with should not be very big, so that we should be always able to
-- calculate all moves with at least start depth. Neither should it be too small,
-- otherwise we would re-calculate the same for many times.
--
-- 3. Width-wise loop. This is performed within each depth iteration.
-- Specifics of alpha-beta prunning algorithm is so that the lesser
-- (alpha, beta) range is provided at start, the faster algorithm works; however,
-- in case real score is outside of these bounds, it will return eiter alpha or beta
-- value instead of real score value. So, we do the following:
--
-- * Select initial "width range", which is range of scores (alpha, beta). This range
-- is selected based on evaluation of current board with zero depth, plus-minus some
-- small delta.
-- Run scoreAB in that range.
-- * If values returned by scoreAB are within selected initial range, then everything is
-- okay: we just select the best of returned values.
-- * If exactly one move seems to bee "too good", i.e. corresponding result of scoreAB
-- equals to alpha/beta (depending on side), then we do not bother about it's exact
-- score: we should do that move anyway.
-- * If there are more than one "too good" moves, then we should select the next interval
-- (alpha, beta), and run the next iteration only on that moves that seem to be "too good".
-- * If all moves seem to be "too bad", then we should select the previous interval of
-- (alpha, beta), and run the next iteration on all moves in that interval.
-- * It is possible (not very likely, but possible) that real score of some moves equals
-- exactly to alpha or beta bound that we selected on some iteration. To prevent switching
-- between "better" and "worther" intervals forwards and backwards indefinitely, we
-- introduce a restriction: if we see that scoreAB returned the bound value, but we have
-- already considered the interval on that side, then we know that the real score equals
-- exactly to the bound.
--
runAI :: (GameRules rules, Evaluator eval)
=> AlphaBeta rules eval
-> AICacheHandle rules eval
-> GameId
-> Side
-> Board
-> Checkers AiOutput
runAI ai@(AlphaBeta params rules eval) handle gameId side board = do
preOptions <- preselect
options <- depthDriver preOptions
output <- select options
let bestScore = sNumeric $ snd output
let shift = bestScore - sNumeric score0
rememberScoreShift handle gameId shift
return output
where
maximize = side == First
minimize = not maximize
betterThan s1 s2
| maximize = s1 > s2
| otherwise = s1 < s2
worseThan s1 s2 = not (betterThan s1 s2)
preselect =
getPossibleMoves handle side board
-- preselect :: Checkers [PossibleMove]
-- preselect = do
-- moves <- getPossibleMoves handle side board
-- if length moves <= abMovesHighBound params
-- then return moves
-- else do
-- let simple = DepthParams {
-- dpTarget = 2
-- , dpCurrent = -1
-- , dpMax = 4
-- , dpMin = 2
-- , dpForcedMode = False
-- }
-- $info "Preselecting; number of possible moves = {}, depth = {}" (length moves, dpTarget simple)
-- options <- scoreMoves' moves simple (loose, win)
-- let key = if maximize
-- then negate . snd
-- else snd
-- let sorted = sortOn key options
-- bestOptions = take (abMovesHighBound params) sorted
-- let result = map fst sorted
-- $debug "Pre-selected options: {}" (Single $ show result)
-- return result
depthDriver :: [PossibleMove] -> Checkers DepthIterationOutput
depthDriver moves =
case abBaseTime params of
Nothing -> do
(result, _) <- go (params, moves, Nothing)
return result
Just time -> repeatTimed' "runAI" time goTimed (params, moves, Nothing)
goTimed :: DepthIterationInput
-> Checkers (DepthIterationOutput, Maybe DepthIterationInput)
goTimed (params, moves, prevResult) = do
ret <- tryC $ go (params, moves, prevResult)
case ret of
Right result -> return result
Left TimeExhaused ->
case prevResult of
Just result -> return (result, Nothing)
Nothing -> return ([(move, 0) | move <- moves], Nothing)
Left err -> throwError err
go :: DepthIterationInput
-> Checkers (DepthIterationOutput, Maybe DepthIterationInput)
go (params, moves, prevResult) = do
let depth = abDepth params
if length moves <= 1 -- Just one move possible
then do
$info "There is only one move possible; just do it." ()
return ([(move, score0) | move <- moves], Nothing)
else do
let var = aichData handle
$info "Selecting a move. Side = {}, depth = {}, number of possible moves = {}" (show side, depth, length moves)
dp <- updateDepth params moves $ DepthParams {
dpInitialTarget = depth
, dpTarget = depth
, dpCurrent = -1
, dpMax = abCombinationDepth params + depth
, dpMin = fromMaybe depth (abStartDepth params)
, dpStaticMode = False
, dpForcedMode = False
}
let needDeeper = abDeeperIfBad params && score0 `worseThan` 0
let dp'
| needDeeper = dp {
dpTarget = min (dpMax dp) (dpTarget dp + 1)
}
| otherwise = dp
result <- widthController True True prevResult moves dp' =<< initInterval
-- In some corner cases, there might be 1 or 2 possible moves,
-- so the timeout would allow us to calculate with very big depth;
-- too big depth does not decide anything in such situations.
if depth < 50
then do
let params' = params {abDepth = depth + 1, abStartDepth = Nothing}
return (result, Just (params', moves, Just result))
else return (result, Nothing)
score0 = evalBoard eval First board
-- | Initial (alpha, beta) interval
initInterval :: Checkers (Score, Score)
initInterval = do
let delta = 1
-- | abs score0 < 4 = 1
-- | abs score0 < 8 = 2
-- | otherwise = 4
mbPrevShift <- getLastScoreShift handle gameId
case mbPrevShift of
Nothing -> do
let alpha = score0 - delta
beta = score0 + delta
$debug "Score0 = {}, delta = {} => initial interval ({}, {})" (score0, delta, alpha, beta)
return (alpha, beta)
Just shift -> do
let (alpha, beta)
| shift >= 0 = (score0 - delta, score0 + (Score shift 0) + delta)
| otherwise = (score0 + (Score shift 0) - delta, score0 + delta)
$debug "Score0 = {}, delta = {}, shift in previous move = {} => initial interval ({}, {})"
(score0, delta, shift, alpha, beta)
return (alpha, beta)
selectScale :: Score -> ScoreBase
selectScale s
| s > 10000 = 1000
| s > 1000 = 10
| s > 100 = 5
| otherwise = 2
nextInterval :: (Score, Score) -> (Score, Score)
nextInterval (alpha, beta) =
let width = (beta - alpha)
width' = selectScale width `scaleScore` width
alpha' = prevScore alpha
beta' = nextScore beta
in if maximize
then (beta', max beta' (beta' + width'))
else (min alpha' (alpha' - width'), alpha')
prevInterval :: (Score, Score) -> (Score, Score)
prevInterval (alpha, beta) =
let width = (beta - alpha)
width' = selectScale width `scaleScore` width
alpha' = prevScore alpha
beta' = nextScore beta
in if minimize
then (beta', max beta' (beta' + width'))
else (min alpha' (alpha' - width'), alpha')
widthController :: Bool -- ^ Allow to shift (alpha,beta) segment to bigger values?
-> Bool -- ^ Allow to shift (alpha,beta) segment to lesser values?
-> Maybe DepthIterationOutput -- ^ Results of previous depth iteration
-> [PossibleMove]
-> DepthParams
-> (Score, Score) -- ^ (Alpha, Beta)
-> Checkers DepthIterationOutput
widthController allowNext allowPrev prevResult moves dp interval@(alpha,beta) =
if alpha == beta
then do
$info "Empty scores interval: [{}]. We have to think that all moves have this score." (Single alpha)
return [(move, alpha) | move <- moves]
else do
results <- widthIteration prevResult moves dp interval
let (good, badScore, badMoves) = selectBestEdge interval moves results
(bestMoves, bestResults) = unzip good
if length badMoves == length moves
then
if allowPrev
then do
let interval' = prevInterval interval
$info "All moves are `too bad'; consider worse scores interval: [{} - {}]" interval'
widthController False True prevResult badMoves dp interval'
else do
$info "All moves are `too bad' ({}), but we have already checked worse interval; so this is the real score." (Single badScore)
return [(move, badScore) | move <- moves]
else
case bestResults of
[] -> return results
[_] -> do
$info "Exactly one move is `too good'; do that move." ()
return bestResults
_ ->
if allowNext
then do
let interval'@(alpha',beta') = nextInterval interval
$info "Some moves ({} of them) are `too good'; consider better scores interval: [{} - {}]" (length bestMoves, alpha', beta')
widthController True False prevResult bestMoves dp interval'
else do
$info "Some moves ({} of them) are `too good'; but we have already checked better interval; so this is the real score" (Single $ length bestMoves)
return bestResults
scoreMoves :: [PossibleMove] -> DepthParams -> (Score, Score) -> Checkers [Either Error (PossibleMove, Score)]
scoreMoves moves dp (alpha, beta) = do
let var = aichData handle
let processor = aichProcessor handle
let inputs = [
ScoreMoveInput {
smiAi = ai,
smiCache = handle,
smiGameId = gameId,
smiSide = side,
smiDepth = dp,
smiBoard = board,
smiMove = move,
smiAlpha = alpha,
smiBeta = beta
} | move <- moves ]
process' processor inputs
scoreMoves' :: [PossibleMove] -> DepthParams -> (Score, Score) -> Checkers DepthIterationOutput
scoreMoves' moves dp (alpha, beta) = do
results <- scoreMoves moves dp (alpha, beta)
case sequence results of
Right result -> return result
Left err -> throwError err
widthIteration :: Maybe DepthIterationOutput -> [PossibleMove] -> DepthParams -> (Score, Score) -> Checkers DepthIterationOutput
widthIteration prevResult moves dp (alpha, beta) = do
$info "`- Considering scores interval: [{} - {}], depth = {}" (alpha, beta, dpTarget dp)
results <- scoreMoves moves dp (alpha, beta)
joinResults prevResult results
joinResults :: Maybe DepthIterationOutput -> [Either Error (PossibleMove, Score)] -> Checkers DepthIterationOutput
joinResults Nothing results =
case sequence results of
Right result -> return result
Left err -> throwError err
joinResults (Just prevResults) results = zipWithM joinResult prevResults results
joinResult :: (PossibleMove, Score) -> Either Error (PossibleMove, Score) -> Checkers (PossibleMove, Score)
joinResult prev@(move, score) (Left TimeExhaused) = do
$info "Time exhaused while checking move {}, use result from previous depth: {}" (show move, score)
return prev
joinResult _ (Left err) = throwError err
joinResult _ (Right result) = return result
selectBestEdge (alpha, beta) moves results =
let (good, bad) = if maximize then (beta, alpha) else (alpha, beta)
goodResults = [(move, (goodMoves, score)) | (move, (goodMoves, score)) <- zip moves results, score == good]
badResults = [move | (move, (_, score)) <- zip moves results, score == bad]
in (goodResults, bad, badResults)
select :: DepthIterationOutput -> Checkers AiOutput
select pairs = do
let best = if maximize then maximum else minimum
maxScore = best $ map snd pairs
goodMoves = [move | (move, score) <- pairs, score == maxScore]
return (goodMoves, maxScore)
-- | Calculate score of the board
doScore :: (GameRules rules, Evaluator eval)
=> rules
-> eval
-> AICacheHandle rules eval
-> AlphaBetaParams
-> GameId
-> Side
-> DepthParams
-> Board
-> Score -- ^ Alpha
-> Score -- ^ Beta
-> Checkers Score
doScore rules eval var params gameId side dp board alpha beta = do
initState <- mkInitState
out <- evalStateT (cachedScoreAB var params input) initState
return $ soScore out
where
input = ScoreInput side dp alpha beta board Nothing
mkInitState = do
now <- liftIO $ getTime Monotonic
let timeout = case abBaseTime params of
Nothing -> Nothing
Just sec -> Just $ TimeSpec (fromIntegral sec) 0
return $ ScoreState rules eval gameId [loose] M.empty now timeout
clamp :: Ord a => a -> a -> a -> a
clamp alpha beta score
| score < alpha = alpha
| score > beta = beta
| otherwise = score
-- | Calculate score of the board.
-- This uses the cache. It is called in the recursive call also.
cachedScoreAB :: forall rules eval. (GameRules rules, Evaluator eval)
=> AICacheHandle rules eval
-> AlphaBetaParams
-> ScoreInput
-> ScoreM rules eval ScoreOutput
cachedScoreAB var params input = do
let depth = dpCurrent dp
side = siSide input
board = siBoard input
dp = siDepth input
alpha = siAlpha input
beta = siBeta input
mbItem <- lift $ lookupAiCache params board dp var
mbCached <- case mbItem of
Just item -> do
let score = itemScore item
-- it is possible that this value was put to cache with different
-- values of alpha/beta; but we have to maintain the property of
-- AB-section: alpha <= result <= beta. So here we clamp the value
-- that we got from cache.
case itemBound item of
Exact -> return $ Just $ ScoreOutput (clamp alpha beta score) False
Alpha -> if score <= alpha
then return $ Just $ ScoreOutput alpha False
else return Nothing
Beta -> if score >= beta
then return $ Just $ ScoreOutput beta False
else return Nothing
Nothing -> return Nothing
case mbCached of
Just out -> return out
Nothing -> do
out <- Monitoring.timed "ai.score.board" $ scoreAB var params input
let score = soScore out
bound
| score <= alpha = Alpha
| score >= beta = Beta
| otherwise = Exact
-- we can only put the result to the cache if we know
-- that this score was not clamped by alpha or beta
-- (so this is a real score, not alpha/beta bound)
item = PerBoardData (dpLast dp) score bound Nothing
item' = PerBoardData (dpLast dp) (negate score) bound Nothing
when (bound == Exact && soQuiescene out) $ do
lift $ putAiCache params board item var
lift $ putAiCache params (flipBoard board) item' var
return out
-- | Check if target depth is reached
isTargetDepth :: DepthParams -> Bool
isTargetDepth dp = dpCurrent dp >= dpTarget dp
-- | Increase current depth as necessary.
--
-- If there is only 1 move currently possible, this can increase
-- the target depth, up to dpMax. Such situations mean that there is
-- probably a series of captures going on, which can change situation
-- dramatically. So we want to know the result better (up to the end of
-- the whole combination, if possible) to make our choice.
--
-- If there are a lot of moves possible, this can decrease the
-- target depth, down to dpMin. This is done simply to decrease computation
-- time. This is obviously going to lead to less strong play.
--
-- Otherwise, this just increases dpCurrent by 1.
--
updateDepth :: (Monad m, HasLogging m, MonadIO m) => AlphaBetaParams -> [PossibleMove] -> DepthParams -> m DepthParams
updateDepth params moves dp
| deepen = do
let delta = nMoves - 1
let target = min (dpTarget dp + 1) (dpMax dp - delta)
let indent = replicate (2*dpCurrent dp) ' '
let static = dpCurrent dp > dpInitialTarget dp + abDynamicDepth params
$verbose "{}| there is only one move, increase target depth to {}"
(indent, target)
return $ dp {dpCurrent = dpCurrent dp + 1, dpTarget = target, dpForcedMode = True, dpStaticMode = static}
| nMoves > abMovesHighBound params && isQuiescene moves = do
let target = max (dpCurrent dp + 1) (dpMin dp)
let indent = replicate (2*dpCurrent dp) ' '
$verbose "{}| there are too many moves, decrease target depth to {}"
(indent, target)
return $ dp {dpCurrent = dpCurrent dp + 1, dpTarget = target}
| otherwise = return $ dp {dpCurrent = dpCurrent dp + 1}
where
nMoves = length moves
deepen = if dpCurrent dp <= dpInitialTarget dp
then nMoves <= abMovesLowBound params
else any isCapture moves || any isPromotion moves
isQuiescene :: [PossibleMove] -> Bool
isQuiescene moves = not (any isCapture moves || any isPromotion moves)
-- | Check if timeout is exhaused.
isTimeExhaused :: ScoreM rules eval Bool
isTimeExhaused = do
check <- gets ssTimeout
case check of
Nothing -> return False
Just delta -> do
start <- gets ssStartTime
now <- liftIO $ getTime Monotonic
return $ start + delta <= now
-- | Calculate score for the board.
-- This implements the alpha-beta section algorithm itself.
scoreAB :: forall rules eval. (GameRules rules, Evaluator eval)
=> AICacheHandle rules eval
-> AlphaBetaParams
-> ScoreInput
-> ScoreM rules eval ScoreOutput
scoreAB var params input
| isTargetDepth dp = do
-- target depth is achieved, calculate score of current board directly
evaluator <- gets ssEvaluator
let score0 = evalBoard' evaluator board
$verbose " X Side: {}, A = {}, B = {}, score0 = {}" (show side, show alpha, show beta, show score0)
quiescene <- checkQuiescene
return $ ScoreOutput score0 quiescene
| otherwise = do
evaluator <- gets ssEvaluator
-- first, let "best" be the worse possible value
let best
| dpStaticMode dp = evalBoard' evaluator board
| maximize = alpha
| otherwise = beta
push best
$verbose "{}V Side: {}, A = {}, B = {}" (indent, show side, show alpha, show beta)
rules <- gets ssRules
moves <- lift $ getPossibleMoves var side board
-- this actually means that corresponding side lost.
when (null moves) $
$verbose "{}`—No moves left." (Single indent)
dp' <- updateDepth params moves dp
let prevMove = siPrevMove input
moves' <- sortMoves prevMove moves
out <- iterateMoves (zip [1..] moves') dp'
pop
return out
where
side = siSide input
dp = siDepth input
alpha = siAlpha input
beta = siBeta input
board = siBoard input
evalBoard' :: eval -> Board -> Score
evalBoard' evaluator board = result
where
score = evalBoard evaluator First board
result
| maximize && sNumeric score == sNumeric win = score - Score 0 (fromIntegral $ dpCurrent dp)
| minimize && sNumeric score == sNumeric loose = score + Score 0 (fromIntegral $ dpCurrent dp)
| otherwise = score
checkQuiescene :: ScoreM rules eval Bool
checkQuiescene = do
rules <- gets ssRules
moves <- lift $ getPossibleMoves var (opposite side) board
return $ isQuiescene moves
push :: Score -> ScoreM rules eval ()
push score =
modify $ \st -> st {ssBestScores = score : ssBestScores st}
pop :: ScoreM rules eval ()
pop =
modify $ \st -> st {ssBestScores = tail (ssBestScores st)}
evalMove :: Maybe PossibleMove -> PossibleMove -> ScoreM rules eval Int
evalMove mbPrevMove move = do
let victims = pmVictims move
nVictims = length victims
promotion = if isPromotion move then 1 else 0
attackPrevPiece = case mbPrevMove of
Nothing -> 0
Just prevMove -> if pmEnd prevMove `elem` victims
then 2
else 0
let board' = applyMoveActions (pmResult move) board
let dp0 = dp {dpCurrent = dpTarget dp}
mbCached <- lift $ lookupAiCache params board' dp0 var
let primeVariation = case mbCached of
Nothing -> 0
Just item ->
let score = sNumeric (itemScore item)
scoreSigned = if maximize then score else negate score
in fromIntegral $ 1 + scoreSigned
goodCheck <- getGoodMove (dpCurrent dp)
let good = case goodCheck of
Nothing -> 0
Just (goodMove, goodScore)
| goodMove == move -> if maximize then sNumeric goodScore else negate (sNumeric goodScore)
| otherwise -> 0
return $ nVictims + promotion + attackPrevPiece + primeVariation + fromIntegral good
sortMoves :: Maybe PossibleMove -> [PossibleMove] -> ScoreM rules eval [PossibleMove]
sortMoves mbPrevMove moves =
if length moves >= 4
then do
interest <- mapM (evalMove mbPrevMove) moves
if any (> 0) interest
then return $ map fst $ sortOn (negate . snd) $ zip moves interest
else return moves
else return moves
distance :: PossibleMove -> PossibleMove -> Line
distance prev pm =
let Label col row = aLabel (pmEnd prev)
Label col' row' = aLabel (pmBegin pm)
in abs (col' - col) `max` abs (row' - row)
maximize = side == First
minimize = not maximize
bestStr :: String
bestStr = if maximize
then "Maximum"
else "Minimum"
indent = replicate (2*dpCurrent dp) ' '
getBest =
gets (head . ssBestScores)
setBest :: Score -> ScoreM rules eval ()
setBest best = do
oldBest <- getBest
$verbose "{}| {} for depth {} : {} => {}" (indent, bestStr, dpCurrent dp, show oldBest, show best)
modify $ \st -> st {ssBestScores = best : tail (ssBestScores st)}
rememberGoodMove :: Int -> PossibleMove -> Score -> ScoreM rules eval ()
rememberGoodMove depth move score = do
goodMoves <- gets ssBestMoves
let goodMoves' = case M.lookup depth goodMoves of
Nothing -> M.insert depth (move, score) goodMoves
Just (_, prevScore)
| (maximize && score > prevScore) || (minimize && score < prevScore)
-> M.insert depth (move, score) goodMoves
| otherwise -> goodMoves
modify $ \st -> st {ssBestMoves = goodMoves'}
getGoodMove :: Int -> ScoreM rules eval (Maybe (PossibleMove, Score))
getGoodMove depth = do
goodMoves <- gets ssBestMoves
return $ M.lookup depth goodMoves
opponentMoves :: ScoreM rules eval [PossibleMove]
opponentMoves = do
rules <- gets ssRules
lift $ getPossibleMoves var (opposite side) board
isInteresting move = do
opMoves <- opponentMoves
let victims = concatMap pmVictims opMoves
return $ {- pmBegin move `elem` victims || -} length (pmVictims move) >= 2 || isPromotion move
mkIntervals (alpha, beta) =
let mid = (alpha + beta) `divideScore` 2
in if maximize
then [(alpha, prevScore mid), (mid, beta)]
else [(mid, beta), (alpha, nextScore mid)]
checkMove :: AICacheHandle rules eval -> AlphaBetaParams -> ScoreInput -> PossibleMove -> ScoreM rules eval ScoreOutput
checkMove var params input move = do
let alpha = siAlpha input
beta = siBeta input
width = beta - alpha
intervals <- do
interesting <- isInteresting move
if interesting || width <= 2
then return [(alpha, beta)]
else return $ mkIntervals (alpha, beta)
let inputs = [input {siAlpha = alpha, siBeta = beta} | (alpha, beta) <- intervals]
go inputs
where
go [input] = cachedScoreAB var params input
go (input : inputs) = do
out <- cachedScoreAB var params input
let score = soScore out
if maximize && score >= beta || minimize && score <= alpha
then go inputs
else return out
iterateMoves :: [(Int,PossibleMove)] -> DepthParams -> ScoreM rules eval ScoreOutput
iterateMoves [] _ = do
best <- getBest
$verbose "{}`—All moves considered at this level, return best = {}" (indent, show best)
quiescene <- checkQuiescene
return $ ScoreOutput best quiescene
iterateMoves ((i,move) : moves) dp = do
timeout <- isTimeExhaused
when timeout $ do
-- $info "Timeout exhaused for depth {}." (Single $ dpCurrent dp)
throwError TimeExhaused
$verbose "{}|+Check move of side {}: {}" (indent, show side, show move)
evaluator <- gets ssEvaluator
rules <- gets ssRules
best <- getBest
let input' = input {
siSide = opposite side
, siAlpha = if maximize
then max alpha best
else alpha
, siBeta = if maximize
then beta
else min beta best
, siPrevMove = Just move
, siBoard = applyMoveActions (pmResult move) board
, siDepth = dp
}
out <- cachedScoreAB var params input'
let score = soScore out
$verbose "{}| score for side {}: {}" (indent, show side, show score)
if (maximize && score > best) || (minimize && score < best)
then do
setBest score
if (maximize && score >= beta) || (minimize && score <= alpha)
then do
rememberGoodMove (dpCurrent dp) move score
Monitoring.distribution "ai.section.at" $ fromIntegral i
$verbose "{}`—Return {} for depth {} = {}" (indent, bestStr, dpCurrent dp, show score)
quiescene <- checkQuiescene
return $ ScoreOutput score quiescene
else iterateMoves moves dp
else do
iterateMoves moves dp
instance (Evaluator eval, GameRules rules) => Evaluator (AlphaBeta rules eval) where
evaluatorName (AlphaBeta _ _ eval) = evaluatorName eval
evalBoard (AlphaBeta params rules eval) whoAsks board =
evalBoard eval whoAsks board