module BishBosh.Search.AlphaBeta(
extractSelectedTurns,
negaMax,
) where
import BishBosh.Model.Game((=~))
import Control.Arrow((&&&))
import qualified BishBosh.Component.Move as Component.Move
import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove
import qualified BishBosh.Component.Turn as Component.Turn
import qualified BishBosh.Data.Exception as Data.Exception
import qualified BishBosh.Evaluation.PositionHashQuantifiedGameTree as Evaluation.PositionHashQuantifiedGameTree
import qualified BishBosh.Evaluation.QuantifiedGame as Evaluation.QuantifiedGame
import qualified BishBosh.Input.SearchOptions as Input.SearchOptions
import qualified BishBosh.Model.Game as Model.Game
import qualified BishBosh.Search.DynamicMoveData as Search.DynamicMoveData
import qualified BishBosh.Search.KillerMoves as Search.KillerMoves
import qualified BishBosh.Search.SearchState as Search.SearchState
import qualified BishBosh.Search.Transpositions as Search.Transpositions
import qualified BishBosh.Search.TranspositionValue as Search.TranspositionValue
import qualified BishBosh.State.InstancesByPosition as State.InstancesByPosition
import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour
import qualified Control.Exception
import qualified Control.Monad.Reader
import qualified Data.Maybe
import qualified Data.Tree
data Result x y positionHash criterionValue weightedMean = MkResult {
getDynamicMoveData :: Search.DynamicMoveData.DynamicMoveData x y positionHash,
getQuantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean,
getNMovesEvaluated :: Component.Move.NMoves
}
extractSelectedTurns
:: Component.Move.NPlies
-> Result x y positionHash criterionValue weightedMean
-> (Search.DynamicMoveData.DynamicMoveData x y positionHash, [Component.Turn.Turn x y], Component.Move.NMoves)
extractSelectedTurns nPlies MkResult {
getDynamicMoveData = dynamicMoveData,
getQuantifiedGame = quantifiedGame,
getNMovesEvaluated = nMovesEvaluated
} = (
dynamicMoveData,
Evaluation.QuantifiedGame.getLatestTurns nPlies quantifiedGame,
nMovesEvaluated
)
updateKillerMoves
:: (Ord x, Ord y)
=> Model.Game.Game x y
-> Search.DynamicMoveData.Transformation x y positionHash
updateKillerMoves game
| Just lastTurn <- Model.Game.maybeLastTurn game = if Component.Turn.isCapture lastTurn
then id
else Search.DynamicMoveData.updateKillerMoves . Search.KillerMoves.insert (
State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game
) $ Search.DynamicMoveData.mkKillerMoveKeyFromTurn lastTurn
| otherwise = Control.Exception.throw $ Data.Exception.mkNullDatum "BishBosh.Search.AlphaBeta.updateKillerMoves:\tzero turns have been made."
findTranspositionTerminalQuantifiedGame :: (
Eq x,
Eq y,
Num weightedMean
)
=> Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean
-> Search.TranspositionValue.Value (Component.Move.Move x y)
-> Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean
findTranspositionTerminalQuantifiedGame positionHashQuantifiedGameTree transpositionValue = Data.Maybe.maybe (
Control.Exception.throw $ Data.Exception.mkSearchFailure "BishBosh.Search.AlphaBeta.findTranspositionTerminalQuantifiedGame:\tEvaluation.PositionHashQuantifiedGameTree.traceMatchingMoves failed."
) (
(
if even $ Search.TranspositionValue.inferSearchDepth transpositionValue
then Evaluation.QuantifiedGame.negateFitness
else id
) . Evaluation.PositionHashQuantifiedGameTree.getQuantifiedGame . last
) . Evaluation.PositionHashQuantifiedGameTree.traceMatchingMoves positionHashQuantifiedGameTree $ Search.TranspositionValue.getMoves transpositionValue
updateTranspositions :: (
Eq x,
Eq y,
Num weightedMean,
Ord positionHash,
Ord weightedMean
)
=> Search.TranspositionValue.IsOptimal
-> Component.Move.NPlies
-> positionHash
-> [Component.Turn.Turn x y]
-> Evaluation.PositionHashQuantifiedGameTree.PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean
-> Search.DynamicMoveData.Transformation x y positionHash
updateTranspositions isOptimal nPlies positionHash turns positionHashQuantifiedGameTree = Search.DynamicMoveData.updateTranspositions $ Search.Transpositions.insert (
Evaluation.QuantifiedGame.getFitness . findTranspositionTerminalQuantifiedGame positionHashQuantifiedGameTree
) positionHash . Search.TranspositionValue.mkValue isOptimal nPlies $ map (
Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove
) turns
negaMax :: (
Enum x,
Enum y,
Eq criterionValue,
Num weightedMean,
Ord weightedMean,
Ord positionHash,
Ord x,
Ord y
)
=> Input.SearchOptions.SearchDepth
-> Search.SearchState.SearchState x y positionHash criterionValue weightedMean
-> Input.SearchOptions.Reader (Result x y positionHash criterionValue weightedMean)
negaMax initialSearchDepth initialSearchState = do
maybeMinimumTranspositionSearchDepth <- Control.Monad.Reader.asks Input.SearchOptions.maybeMinimumTranspositionSearchDepth
recordKillerMoves <- Control.Monad.Reader.asks Input.SearchOptions.recordKillerMoves
trapRepeatedPositions <- Control.Monad.Reader.asks Input.SearchOptions.getTrapRepeatedPositions
let
descend (maybeAlphaQuantifiedGame, maybeBetaQuantifiedGame) searchDepth searchState
| searchDepth == 0 || Model.Game.isTerminated game = MkResult {
getDynamicMoveData = dynamicMoveData,
getQuantifiedGame = Evaluation.QuantifiedGame.negateFitness quantifiedGame,
getNMovesEvaluated = 1
}
| useTranspositions
, Just transpositionValue <- Search.Transpositions.find positionHash $ Search.DynamicMoveData.getTranspositions dynamicMoveData
, let
selectMax'' = selectMax' $ Data.Maybe.fromMaybe (
Control.Exception.throw $ Data.Exception.mkSearchFailure "BishBosh.Search.AlphaBeta.negaMax.descend:\tEvaluation.PositionHashQuantifiedGameTree.promoteMatchingMoves failed."
) . Evaluation.PositionHashQuantifiedGameTree.promoteMatchingMoves (Search.TranspositionValue.getMoves transpositionValue)
= if Search.TranspositionValue.inferSearchDepth transpositionValue < searchDepth
then selectMax''
else let
transposedQuantifiedGame = findTranspositionTerminalQuantifiedGame positionHashQuantifiedGameTree transpositionValue
in if Search.TranspositionValue.getIsOptimal transpositionValue
then MkResult {
getDynamicMoveData = dynamicMoveData,
getQuantifiedGame = Control.Exception.assert (transposedQuantifiedGame == getQuantifiedGame selectMax'') transposedQuantifiedGame,
getNMovesEvaluated = 0
}
else Data.Maybe.maybe selectMax'' (
\betaQuantifiedGame -> if Evaluation.QuantifiedGame.compareFitness transposedQuantifiedGame betaQuantifiedGame /= LT
then MkResult {
getDynamicMoveData = dynamicMoveData,
getQuantifiedGame = Control.Exception.assert (betaQuantifiedGame == getQuantifiedGame selectMax'') betaQuantifiedGame,
getNMovesEvaluated = 0
}
else selectMax''
) maybeBetaQuantifiedGame
| otherwise = selectMax' id
where
(positionHashQuantifiedGameTree, dynamicMoveData) = Search.SearchState.getPositionHashQuantifiedGameTree &&& Search.SearchState.getDynamicMoveData $ searchState
useTranspositions = Data.Maybe.maybe False (searchDepth >=) maybeMinimumTranspositionSearchDepth
(positionHash, quantifiedGame) = Evaluation.PositionHashQuantifiedGameTree.getRootPositionHash &&& Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame $ positionHashQuantifiedGameTree
game = Evaluation.QuantifiedGame.getGame quantifiedGame
(nPlies, nDistinctPositions) = State.TurnsByLogicalColour.getNPlies . Model.Game.getTurnsByLogicalColour &&& State.InstancesByPosition.getNDistinctPositions . Model.Game.getInstancesByPosition $ game
selectMax' forestSorter = selectMax dynamicMoveData maybeAlphaQuantifiedGame . forestSorter . (
if recordKillerMoves
then Evaluation.PositionHashQuantifiedGameTree.sortNonCaptureMoves (
Search.KillerMoves.sortByHistoryHeuristic (
Model.Game.getNextLogicalColour game
) (
Search.DynamicMoveData.mkKillerMoveKeyFromTurn . Evaluation.QuantifiedGame.getLastTurn . Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame'
) $ Search.DynamicMoveData.getKillerMoves dynamicMoveData
)
else id
) . Data.Tree.subForest $ Evaluation.PositionHashQuantifiedGameTree.deconstruct positionHashQuantifiedGameTree
selectMax dynamicMoveData' maybeAlphaQuantifiedGame' (node : remainingNodes)
| trapRepeatedPositions
, nDistinctPositions >= State.InstancesByPosition.leastCyclicPlies
, State.InstancesByPosition.getNDistinctPositions (
Model.Game.getInstancesByPosition . Evaluation.QuantifiedGame.getGame $ Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame' node
) == nDistinctPositions = selectMax dynamicMoveData' maybeAlphaQuantifiedGame' remainingNodes
| Just betaQuantifiedGame <- maybeBetaQuantifiedGame
, let fitnessComparedWithBeta = Evaluation.QuantifiedGame.compareFitness quantifiedGame'' betaQuantifiedGame
, fitnessComparedWithBeta /= LT = result'' {
getDynamicMoveData = let
game'' = Evaluation.QuantifiedGame.getGame quantifiedGame''
in (
if recordKillerMoves && not (
fitnessComparedWithBeta == EQ && game'' =~ Evaluation.QuantifiedGame.getGame betaQuantifiedGame
)
then updateKillerMoves game''
else id
) dynamicMoveData'',
getQuantifiedGame = betaQuantifiedGame
}
| otherwise = addNMovesToResult (
getNMovesEvaluated result''
) $ let
isFitter = Data.Maybe.maybe True (
(== GT) . Evaluation.QuantifiedGame.compareFitness quantifiedGame''
) maybeAlphaQuantifiedGame'
in selectMax (
(
if useTranspositions && isFitter
then updateTranspositions False nPlies positionHash (
Evaluation.QuantifiedGame.getLatestTurns nPlies quantifiedGame''
) positionHashQuantifiedGameTree
else id
) dynamicMoveData''
) (
if isFitter
then Just quantifiedGame''
else maybeAlphaQuantifiedGame'
) remainingNodes
where
result''@MkResult {
getDynamicMoveData = dynamicMoveData'',
getQuantifiedGame = quantifiedGame''
} = negateFitnessOfResult . descend (
curry Evaluation.QuantifiedGame.negateInterval maybeAlphaQuantifiedGame' maybeBetaQuantifiedGame
) (
pred searchDepth
) $ Search.SearchState.mkSearchState (
Evaluation.PositionHashQuantifiedGameTree.fromBarePositionHashQuantifiedGameTree node
) dynamicMoveData'
selectMax dynamicMoveData' maybeAlphaQuantifiedGame' _ = MkResult {
getDynamicMoveData = dynamicMoveData',
getQuantifiedGame = Data.Maybe.fromMaybe (
Data.Maybe.fromMaybe (
Control.Exception.throw $ Data.Exception.mkResultUndefined "BishBosh.Search.AlphaBeta.negaMax.selectMax:\tneither alpha nor beta is defined."
) maybeBetaQuantifiedGame
) maybeAlphaQuantifiedGame',
getNMovesEvaluated = 0
}
return . (
\result@MkResult {
getDynamicMoveData = dynamicMoveData,
getQuantifiedGame = quantifiedGame
} -> let
positionHashQuantifiedGameTree = Search.SearchState.getPositionHashQuantifiedGameTree initialSearchState
nPlies = State.TurnsByLogicalColour.getNPlies . Model.Game.getTurnsByLogicalColour . Evaluation.QuantifiedGame.getGame $ Evaluation.PositionHashQuantifiedGameTree.getRootQuantifiedGame positionHashQuantifiedGameTree
in result {
getDynamicMoveData = updateTranspositions True nPlies (
Evaluation.PositionHashQuantifiedGameTree.getRootPositionHash positionHashQuantifiedGameTree
) (
Evaluation.QuantifiedGame.getLatestTurns nPlies quantifiedGame
) positionHashQuantifiedGameTree dynamicMoveData
}
) $ descend Evaluation.QuantifiedGame.unboundedInterval initialSearchDepth initialSearchState
type Transformation x y positionHash criterionValue weightedMean = Result x y positionHash criterionValue weightedMean -> Result x y positionHash criterionValue weightedMean
negateFitnessOfResult :: Num weightedMean => Transformation x y positionHash criterionValue weightedMean
negateFitnessOfResult result@MkResult { getQuantifiedGame = quantifiedGame } = result {
getQuantifiedGame = Evaluation.QuantifiedGame.negateFitness quantifiedGame
}
addNMovesToResult :: Component.Move.NMoves -> Transformation x y positionHash criterionValue weightedMean
addNMovesToResult nMoves result@MkResult { getNMovesEvaluated = nMovesEvaluated } = Control.Exception.assert (nMoves > 0) result {
getNMovesEvaluated = nMoves + nMovesEvaluated
}