module Search.Search (search, emptySearchResult, SearchResult(..)) where

import           AppPrelude

import           Evaluation.Evaluation
import           Models.Command
import           Models.Move
import           Models.Position
import           Models.Score
import           MoveGen.MakeMove
import           MoveGen.MoveQueries
import           MoveGen.PositionQueries
import           Search.MoveOrdering
import           Search.Parameters
import           Search.Perft
import           Search.Quiescence
import           Search.TimeManagement
import qualified Utils.KillersTable       as KillersTable
import           Utils.KillersTable       (KillersTable)
import qualified Utils.TranspositionTable as TEntry (TEntry (..))
import qualified Utils.TranspositionTable as TTable
import           Utils.TranspositionTable (TEntry (TEntry), TTable)

import           Control.Concurrent
import           Control.Monad.State
import           Data.Time.Clock.System


-- Features:
-- - Iterative deepening

search
  :: (?killersTable :: KillersTable, ?tTable :: TTable,
     ?opts :: EngineOptions, ?age :: Age)
  => SearchOptions -> IORef SearchResult -> Position -> IO ()
search :: (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?age::Depth) =>
SearchOptions -> IORef SearchResult -> Position -> IO ()
search searchOpts :: SearchOptions
searchOpts@SearchOptions{Bool
[UnknownMove]
Maybe Int
Maybe Word64
Depth
searchMoves :: [UnknownMove]
infinite :: Bool
targetDepth :: Depth
moveTime :: Maybe Int
whiteTime :: Maybe Int
whiteIncrement :: Maybe Int
blackTime :: Maybe Int
blackIncrement :: Maybe Int
movesUntilNextTime :: Maybe Int
findMate :: Maybe Int
maxNodes :: Maybe Word64
$sel:searchMoves:SearchOptions :: SearchOptions -> [UnknownMove]
$sel:infinite:SearchOptions :: SearchOptions -> Bool
$sel:targetDepth:SearchOptions :: SearchOptions -> Depth
$sel:moveTime:SearchOptions :: SearchOptions -> Maybe Int
$sel:whiteTime:SearchOptions :: SearchOptions -> Maybe Int
$sel:whiteIncrement:SearchOptions :: SearchOptions -> Maybe Int
$sel:blackTime:SearchOptions :: SearchOptions -> Maybe Int
$sel:blackIncrement:SearchOptions :: SearchOptions -> Maybe Int
$sel:movesUntilNextTime:SearchOptions :: SearchOptions -> Maybe Int
$sel:findMate:SearchOptions :: SearchOptions -> Maybe Int
$sel:maxNodes:SearchOptions :: SearchOptions -> Maybe Word64
..} IORef SearchResult
resultRef Position
pos = do
  SystemTime
startTime <- IO SystemTime
getSystemTime
  IORef Word64
nodesRef <- Word64 -> IO (IORef Word64)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Word64
0
  let ?nodes = ?nodes::IORef Word64
IORef Word64
nodesRef
  Maybe Word64 -> IO () -> IO ()
maybeTimeout Maybe Word64
timeToMove (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Depth -> IO Bool) -> [Depth] -> IO ()
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m ()
untilM ((?nodes::IORef Word64, ?opts::EngineOptions,
 ?killersTable::KillersTable, ?age::Depth, ?tTable::TTable) =>
SystemTime -> IORef Word64 -> Depth -> IO Bool
SystemTime -> IORef Word64 -> Depth -> IO Bool
go SystemTime
startTime IORef Word64
nodesRef) [Depth
1 .. Depth
targetDepth]
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
infinite (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound
  where
    timeToMove :: Maybe Word64
timeToMove =
      (Word64 -> Bool) -> Maybe Word64 -> Maybe Word64
forall a. (a -> Bool) -> Maybe a -> Maybe a
maybeFilter (Bool -> Word64 -> Bool
forall a b. a -> b -> a
const (Bool -> Word64 -> Bool) -> Bool -> Word64 -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
infinite) (Maybe Word64 -> Maybe Word64) -> Maybe Word64 -> Maybe Word64
forall a b. (a -> b) -> a -> b
$ SearchOptions -> Position -> Maybe Word64
getMoveTime SearchOptions
searchOpts Position
pos

    go :: SystemTime -> IORef Word64 -> Depth -> IO Bool
go SystemTime
startTime IORef Word64
nodesRef Depth
depth = do
      SearchResult
result  <- (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
getNodeResult Score
initialAlpha Score
initialBeta Depth
depth Depth
0 Position
pos
      SystemTime
endTime <- IO SystemTime
getSystemTime
      Word64
nodes   <- IORef Word64 -> IO Word64
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Word64
nodesRef
      let bestMove :: Maybe Move
bestMove = SearchResult
result.bestMove Maybe Move -> Maybe Move -> Maybe Move
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Move] -> Maybe (Element [Move])
forall mono. MonoFoldable mono => mono -> Maybe (Element mono)
headMay (Position -> [Move]
allMoves Position
pos)
          result' :: SearchResult
result'  = SearchResult
result {bestMove = bestMove}
      Depth -> Word64 -> Word64 -> SearchResult -> IO ()
printSearchInfo Depth
depth Word64
nodes (SystemTime
endTime SystemTime -> SystemTime -> Word64
|-| SystemTime
startTime) SearchResult
result'
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Move -> Bool
forall mono. MonoFoldable mono => mono -> Bool
null Maybe Move
bestMove) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef SearchResult -> SearchResult -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef SearchResult
resultRef SearchResult
result'
      Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SystemTime -> SystemTime -> Maybe Word64 -> Bool
isTimeOver SystemTime
endTime SystemTime
startTime Maybe Word64
timeToMove
            Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
infinite Bool -> Bool -> Bool
&& Position -> Bool
hasSingleMove Position
pos
            Bool -> Bool -> Bool
|| (Element (Maybe Word64) -> Bool) -> Maybe Word64 -> Bool
forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
any (Word64
nodes >=) Maybe Word64
maxNodes
            Bool -> Bool -> Bool
|| Position -> Bool
isDraw Position
pos
            Bool -> Bool -> Bool
|| Score -> GameResult
getGameResult SearchResult
result.score GameResult -> [GameResult] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [GameResult
Victory, GameResult
Defeat])


-- Features:
-- - Transposition table score caching
-- - Search extensions (Check, Single move)

negamax
  :: (?killersTable :: KillersTable, ?tTable :: TTable,
     ?opts :: EngineOptions, ?nodes :: IORef Word64, ?age :: Age)
  => Score -> Score -> Depth -> Ply -> Position -> IO SearchResult
negamax :: (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
negamax !Score
alpha !Score
beta !Depth
depth !Depth
ply Position
pos

  | Position -> Bool
isDefeat Position
pos =
    SearchResult -> IO SearchResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SearchResult -> IO SearchResult)
-> SearchResult -> IO SearchResult
forall a b. (a -> b) -> a -> b
$! Score -> SearchResult
emptySearchResult Score
minScore

  | Depth
ply Depth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
> Depth
0 Bool -> Bool -> Bool
&& Position -> Bool
isDraw Position
pos =
    SearchResult -> IO SearchResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SearchResult -> IO SearchResult)
-> SearchResult -> IO SearchResult
forall a b. (a -> b) -> a -> b
$! Score -> SearchResult
emptySearchResult Score
0

  | Depth
ply Depth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
> Depth
0 Bool -> Bool -> Bool
&& Position -> Bool
isWonEndgame Position
pos =
    SearchResult -> IO SearchResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SearchResult -> IO SearchResult)
-> SearchResult -> IO SearchResult
forall a b. (a -> b) -> a -> b
$! Score -> SearchResult
emptySearchResult (Score
maxScore Score -> Score -> Score
forall a. Num a => a -> a -> a
- Score
1000)

  | Bool
otherwise = do
  Maybe (Score, Maybe Move)
ttResult <- IO (Maybe (Score, Maybe Move)) -> IO (Maybe (Score, Maybe Move))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Score, Maybe Move)) -> IO (Maybe (Score, Maybe Move)))
-> IO (Maybe (Score, Maybe Move)) -> IO (Maybe (Score, Maybe Move))
forall a b. (a -> b) -> a -> b
$ (?tTable::TTable, ?opts::EngineOptions) =>
Score -> Score -> Depth -> ZKey -> IO (Maybe (Score, Maybe Move))
Score -> Score -> Depth -> ZKey -> IO (Maybe (Score, Maybe Move))
TTable.lookupScore Score
alpha Score
beta Depth
extendedDepth ZKey
zKey
  case Maybe (Score, Maybe Move)
ttResult of
    Just (!Score
score, !Maybe Move
bestMove) -> SearchResult -> IO SearchResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SearchResult -> IO SearchResult)
-> SearchResult -> IO SearchResult
forall a b. (a -> b) -> a -> b
$! Score -> Maybe Move -> Maybe Move -> SearchResult
SearchResult Score
score Maybe Move
bestMove Maybe Move
forall a. Maybe a
Nothing
    Maybe (Score, Maybe Move)
Nothing -> (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score
-> Score -> Depth -> Depth -> ZKey -> Position -> IO SearchResult
Score
-> Score -> Depth -> Depth -> ZKey -> Position -> IO SearchResult
cacheNodeResult Score
alpha Score
beta Depth
extendedDepth Depth
ply ZKey
zKey Position
pos
  where
    zKey :: ZKey
zKey = Position -> ZKey
getZobristKey Position
pos
    extendedDepth :: Depth
extendedDepth =
      if Position -> Bool
isKingInCheck Position
pos Bool -> Bool -> Bool
|| (Position -> Bool
hasSingleMove Position
pos Bool -> Bool -> Bool
&& Depth
ply Depth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
< Depth
30)
      then Depth
depth Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ Depth
1
      else Depth
depth


cacheNodeResult
  :: (?killersTable :: KillersTable, ?tTable :: TTable,
     ?opts :: EngineOptions, ?nodes :: IORef Word64, ?age :: Age)
  => Score -> Score -> Depth -> Ply -> ZKey -> Position -> IO SearchResult
cacheNodeResult :: (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score
-> Score -> Depth -> Depth -> ZKey -> Position -> IO SearchResult
cacheNodeResult !Score
alpha !Score
beta !Depth
depth !Depth
ply !ZKey
zKey Position
pos = do
  IORef Word64 -> (Word64 -> Word64) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' ?nodes::IORef Word64
IORef Word64
?nodes (Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)
  searchResult :: SearchResult
searchResult@SearchResult {Score
Maybe Move
$sel:bestMove:SearchResult :: SearchResult -> Maybe Move
score :: Score
bestMove :: Maybe Move
ponderMove :: Maybe Move
$sel:score:SearchResult :: SearchResult -> Score
$sel:ponderMove:SearchResult :: SearchResult -> Maybe Move
..} <- (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
getNodeResult Score
alpha Score
beta Depth
depth Depth
ply Position
pos
  let
    !nodeType :: NodeType
nodeType = Score -> Score -> Score -> NodeType
getNodeType Score
alpha Score
beta Score
score
    !ttScore :: Score
ttScore = case NodeType
nodeType of
      NodeType
PV  -> Score
score
      NodeType
Cut -> Score
beta
      NodeType
All -> Score
alpha
    !newTEntry :: TEntry
newTEntry = TEntry {
        $sel:depth:TEntry :: Depth
TEntry.depth      = Depth
depth
      , $sel:bestMove:TEntry :: Maybe Move
TEntry.bestMove   = Maybe Move
bestMove
      , $sel:score:TEntry :: Score
TEntry.score      = Score
ttScore
      , $sel:nodeType:TEntry :: NodeType
TEntry.nodeType   = NodeType
nodeType
      , $sel:zobristKey:TEntry :: ZKey
TEntry.zobristKey = ZKey
zKey
      , $sel:age:TEntry :: Depth
TEntry.age        = ?age::Depth
Depth
?age
    }
  (?tTable::TTable, ?opts::EngineOptions) => ZKey -> TEntry -> IO ()
ZKey -> TEntry -> IO ()
TTable.insert ZKey
zKey TEntry
newTEntry
  SearchResult -> IO SearchResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SearchResult
searchResult


-- Features:
-- - Quiescence search
-- - Null move prunning
-- - Futility prunning

getNodeResult
  :: (?killersTable :: KillersTable, ?tTable :: TTable,
     ?opts :: EngineOptions, ?nodes :: IORef Word64, ?age :: Age)
  => Score -> Score -> Depth -> Ply -> Position -> IO SearchResult
getNodeResult :: (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
getNodeResult !Score
alpha !Score
beta !Depth
depth !Depth
ply Position
pos

  | Depth
depth Depth -> Depth -> Bool
forall a. Eq a => a -> a -> Bool
== Depth
0
  Bool -> Bool -> Bool
|| Depth
depth Depth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
<= Depth
3
    Bool -> Bool -> Bool
&& Bool -> Bool
not (Position -> Bool
isKingInCheck Position
pos)
    Bool -> Bool -> Bool
&& Int -> Int -> Int -> Bool
inRange (-Int
1000) Int
1000 (Score -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Score
staticEval)
    Bool -> Bool -> Bool
&& Score
staticEval Score -> Score -> Score
forall a. Num a => a -> a -> a
+ Score
futilityMargin Score -> Score -> Bool
forall a. Ord a => a -> a -> Bool
<= Score
alpha =
    Score -> SearchResult
emptySearchResult (Score -> SearchResult) -> IO Score -> IO SearchResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (?nodes::IORef Word64) =>
Score -> Score -> Depth -> Position -> IO Score
Score -> Score -> Depth -> Position -> IO Score
quiesceSearch Score
alpha Score
beta Depth
0 Position
pos

  | Bool
otherwise = do
    Maybe Score
nullMoveScore <- (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score -> Depth -> Depth -> Position -> IO (Maybe Score)
Score -> Depth -> Depth -> Position -> IO (Maybe Score)
getNullMoveScore Score
beta Depth
depth Depth
ply Position
pos
    if (Element (Maybe Score) -> Bool) -> Maybe Score -> Bool
forall mono.
MonoFoldable mono =>
(Element mono -> Bool) -> mono -> Bool
any (Score -> Score -> Bool
forall a. Ord a => a -> a -> Bool
>= Score
beta) Maybe Score
nullMoveScore
      then SearchResult -> IO SearchResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SearchResult -> IO SearchResult)
-> SearchResult -> IO SearchResult
forall a b. (a -> b) -> a -> b
$! Score -> SearchResult
emptySearchResult Score
beta
      else (?nodes::IORef Word64, ?opts::EngineOptions,
 ?killersTable::KillersTable, ?age::Depth, ?tTable::TTable) =>
([Move], [Move]) -> IO SearchResult
([Move], [Move]) -> IO SearchResult
traverseMoves (([Move], [Move]) -> IO SearchResult)
-> IO ([Move], [Move]) -> IO SearchResult
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions) =>
Depth -> Depth -> Position -> IO ([Move], [Move])
Depth -> Depth -> Position -> IO ([Move], [Move])
getSortedMoves Depth
depth Depth
ply Position
pos

  where
    staticEval :: Score
staticEval          = Position -> Score
evaluatePosition Position
pos
    !futilityMargin :: Score
futilityMargin     = Vector Score
futilityMargins Vector Score -> Int -> Score
forall a. Storable a => Vector a -> Int -> a
!! (Depth -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Depth
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
    traverseMoves :: ([Move], [Move]) -> IO SearchResult
traverseMoves ([Move], [Move])
moves = do
      let movesSearch :: SearchM (Maybe Score)
movesSearch   = (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score
-> Depth
-> Depth
-> ([Move], [Move])
-> Position
-> SearchM (Maybe Score)
Score
-> Depth
-> Depth
-> ([Move], [Move])
-> Position
-> SearchM (Maybe Score)
getMovesScore Score
beta Depth
depth Depth
ply ([Move], [Move])
moves Position
pos
      (!Maybe Score
score, !SearchResult
searchResult) <-
        SearchM (Maybe Score)
-> SearchResult -> IO (Maybe Score, SearchResult)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT SearchM (Maybe Score)
movesSearch (Score -> SearchResult
emptySearchResult Score
alpha)
      let
        !newAlpha :: Score
newAlpha = SearchResult
searchResult.score
        !newScore :: Score
newScore = Score -> Maybe Score -> Score
forall a. a -> Maybe a -> a
fromMaybe Score
newAlpha Maybe Score
score
      SearchResult -> IO SearchResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SearchResult -> IO SearchResult)
-> SearchResult -> IO SearchResult
forall a b. (a -> b) -> a -> b
$! SearchResult
searchResult {score = newScore}


getMovesScore
  :: (?killersTable :: KillersTable, ?tTable :: TTable,
    ?opts :: EngineOptions, ?nodes :: IORef Word64, ?age :: Age)
  => Score -> Depth -> Ply -> ([Move], [Move]) -> Position
  -> SearchM (Maybe Score)
getMovesScore :: (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score
-> Depth
-> Depth
-> ([Move], [Move])
-> Position
-> SearchM (Maybe Score)
getMovesScore !Score
beta !Depth
depth !Depth
ply ([Move]
mainMoves, [Move]
reducedMoves) Position
pos = do
  Maybe Score
mainSearchScore <- SearchM (Maybe Score)
mainMovesSearch
  SearchM (Maybe Score)
-> (Score -> SearchM (Maybe Score))
-> Maybe Score
-> SearchM (Maybe Score)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SearchM (Maybe Score)
reducedMovesSearch (Maybe Score -> SearchM (Maybe Score)
forall a. a -> StateT SearchResult IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Score -> SearchM (Maybe Score))
-> (Score -> Maybe Score) -> Score -> SearchM (Maybe Score)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Score -> Maybe Score
forall a. a -> Maybe a
Just) Maybe Score
mainSearchScore

  where
    mainMovesSearch :: SearchM (Maybe Score)
mainMovesSearch       = (?nodes::IORef Word64, ?opts::EngineOptions,
 ?killersTable::KillersTable, ?age::Depth, ?tTable::TTable) =>
Bool -> [Move] -> SearchM (Maybe Score)
Bool -> [Move] -> SearchM (Maybe Score)
movesSearch Bool
False [Move]
mainMoves
    reducedMovesSearch :: SearchM (Maybe Score)
reducedMovesSearch    = (?nodes::IORef Word64, ?opts::EngineOptions,
 ?killersTable::KillersTable, ?age::Depth, ?tTable::TTable) =>
Bool -> [Move] -> SearchM (Maybe Score)
Bool -> [Move] -> SearchM (Maybe Score)
movesSearch Bool
True  [Move]
reducedMoves
    movesSearch :: Bool -> [Move] -> SearchM (Maybe Score)
movesSearch Bool
isReduced =
      (Int -> Move -> SearchM (Maybe Score))
-> [Move] -> SearchM (Maybe Score)
forall (m :: * -> *) a b.
Monad m =>
(Int -> a -> m (Maybe b)) -> [a] -> m (Maybe b)
findTraverseIndex ((?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score
-> Depth
-> Depth
-> Bool
-> Position
-> Int
-> Move
-> SearchM (Maybe Score)
Score
-> Depth
-> Depth
-> Bool
-> Position
-> Int
-> Move
-> SearchM (Maybe Score)
getMoveScore Score
beta Depth
depth Depth
ply Bool
isReduced Position
pos)


-- Features:
-- - Principal Variation Search
-- - Late Move Reductions

getMoveScore
  :: (?killersTable :: KillersTable, ?tTable :: TTable,
     ?opts :: EngineOptions, ?nodes :: IORef Word64, ?age :: Age)
  => Score -> Depth -> Ply -> Bool -> Position -> Int -> Move -> SearchM (Maybe Score)
getMoveScore :: (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score
-> Depth
-> Depth
-> Bool
-> Position
-> Int
-> Move
-> SearchM (Maybe Score)
getMoveScore !Score
beta !Depth
depth !Depth
ply !Bool
isReduced Position
pos !Int
mvIdx !Move
mv = do
  SearchResult {$sel:score:SearchResult :: SearchResult -> Score
score = Score
alpha} <- StateT SearchResult IO SearchResult
forall s (m :: * -> *). MonadState s m => m s
get
  if | Score
alpha Score -> Score -> Bool
forall a. Ord a => a -> a -> Bool
> Score
0 Bool -> Bool -> Bool
&& Position -> Bool
isNotWinnable Position
pos -> Maybe Score -> SearchM (Maybe Score)
forall a. a -> StateT SearchResult IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Score
forall a. Maybe a
Nothing
     | Bool
isReduced Bool -> Bool -> Bool
|| Int
mvIdx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0         -> SearchM (Maybe Score)
nullWindowSearch
     | Bool
otherwise                      -> SearchM (Maybe Score)
fullSearch
  where
    !lmrDepth :: Depth
lmrDepth
      | Bool
isReduced Bool -> Bool -> Bool
&& Bool
quietMove = Int -> Depth -> Depth
getLmrDepth Int
mvIdx Depth
depth
      | Bool
otherwise             = Depth
depth

    quietMove :: Bool
quietMove = Move -> Position -> Bool
isQuietMove Move
mv Position
pos

    nullWindowSearch :: SearchM (Maybe Score)
nullWindowSearch = do
     st :: SearchResult
st@SearchResult {$sel:score:SearchResult :: SearchResult -> Score
score = Score
alpha} <- StateT SearchResult IO SearchResult
forall s (m :: * -> *). MonadState s m => m s
get
     SearchResult {Score
$sel:score:SearchResult :: SearchResult -> Score
score :: Score
score} <- Score -> Score -> StateT SearchResult IO SearchResult
forall {m :: * -> *}.
(MonadIO m, ?nodes::IORef Word64, ?opts::EngineOptions,
 ?killersTable::KillersTable, ?age::Depth, ?tTable::TTable) =>
Score -> Score -> m SearchResult
getScore Score
alpha (Score
alpha Score -> Score -> Score
forall a. Num a => a -> a -> a
+ Score
1)
     SearchResult -> StateT SearchResult IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put SearchResult
st
     if Score
score Score -> Score -> Bool
forall a. Ord a => a -> a -> Bool
> Score
alpha
       then SearchM (Maybe Score)
fullSearch
       else Maybe Score -> SearchM (Maybe Score)
forall a. a -> StateT SearchResult IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Score
forall a. Maybe a
Nothing

    fullSearch :: SearchM (Maybe Score)
fullSearch = do
      SearchResult {$sel:score:SearchResult :: SearchResult -> Score
score = Score
alpha} <- StateT SearchResult IO SearchResult
forall s (m :: * -> *). MonadState s m => m s
get
      SearchResult{Score
Maybe Move
$sel:bestMove:SearchResult :: SearchResult -> Maybe Move
$sel:score:SearchResult :: SearchResult -> Score
$sel:ponderMove:SearchResult :: SearchResult -> Maybe Move
score :: Score
bestMove :: Maybe Move
ponderMove :: Maybe Move
..} <- Score -> Score -> StateT SearchResult IO SearchResult
forall {m :: * -> *}.
(MonadIO m, ?nodes::IORef Word64, ?opts::EngineOptions,
 ?killersTable::KillersTable, ?age::Depth, ?tTable::TTable) =>
Score -> Score -> m SearchResult
getScore Score
alpha Score
beta
      let nodeType :: NodeType
nodeType    = Score -> Score -> Score -> NodeType
getNodeType Score
alpha Score
beta Score
score
      !Maybe Score
newScore <- (?killersTable::KillersTable) =>
Score
-> Score
-> Depth
-> NodeType
-> Move
-> Maybe Move
-> Position
-> SearchM (Maybe Score)
Score
-> Score
-> Depth
-> NodeType
-> Move
-> Maybe Move
-> Position
-> SearchM (Maybe Score)
advanceState Score
beta Score
score Depth
ply NodeType
nodeType Move
mv Maybe Move
bestMove Position
pos
      Maybe Score -> SearchM (Maybe Score)
forall a. a -> StateT SearchResult IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Score
newScore

    getScore :: Score -> Score -> m SearchResult
getScore !Score
alpha' !Score
beta' = IO SearchResult -> m SearchResult
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO SearchResult -> m SearchResult)
-> IO SearchResult -> m SearchResult
forall a b. (a -> b) -> a -> b
$ (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
getNegamaxScore Score
alpha' Score
beta' Depth
lmrDepth Depth
ply (Move -> Position -> Position
makeMove Move
mv Position
pos)


getNullMoveScore
  :: (?killersTable :: KillersTable, ?tTable :: TTable,
     ?opts :: EngineOptions, ?nodes :: IORef Word64, ?age :: Age)
  => Score -> Depth -> Ply -> Position -> IO (Maybe Score)
getNullMoveScore :: (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score -> Depth -> Depth -> Position -> IO (Maybe Score)
getNullMoveScore !Score
beta !Depth
depth !Depth
ply Position
pos

  | Depth
depth Depth -> Depth -> Bool
forall a. Ord a => a -> a -> Bool
> Depth
r Bool -> Bool -> Bool
&& Bool -> Bool
not (Position -> Bool
isKingInCheck Position
pos)
              Bool -> Bool -> Bool
&& Bool -> Bool
not (Position -> Bool
isEndgame Position
pos) = do
    SearchResult {Score
Maybe Move
$sel:bestMove:SearchResult :: SearchResult -> Maybe Move
$sel:score:SearchResult :: SearchResult -> Score
$sel:ponderMove:SearchResult :: SearchResult -> Maybe Move
score :: Score
bestMove :: Maybe Move
ponderMove :: Maybe Move
..} <- (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
getNegamaxScore Score
alpha Score
beta Depth
reducedDepth Depth
ply
                                       (Position -> Position
makeNullMove Position
pos)
    Maybe Score -> IO (Maybe Score)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Score -> IO (Maybe Score))
-> Maybe Score -> IO (Maybe Score)
forall a b. (a -> b) -> a -> b
$ Score -> Maybe Score
forall a. a -> Maybe a
Just Score
score

  | Bool
otherwise = Maybe Score -> IO (Maybe Score)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Score
forall a. Maybe a
Nothing

  where
    reducedDepth :: Depth
reducedDepth = Depth
depth Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
- Depth
r
    alpha :: Score
alpha        = Score
beta Score -> Score -> Score
forall a. Num a => a -> a -> a
- Score
1
    r :: Depth
r            = Depth
2


getNegamaxScore
  :: (?killersTable :: KillersTable, ?tTable :: TTable,
     ?opts :: EngineOptions, ?nodes :: IORef Word64, ?age :: Age)
  => Score -> Score -> Depth -> Ply -> Position -> IO SearchResult
getNegamaxScore :: (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
getNegamaxScore !Score
alpha !Score
beta !Depth
depth !Depth
ply !Position
pos = do
  SearchResult
result <- (?killersTable::KillersTable, ?tTable::TTable,
 ?opts::EngineOptions, ?nodes::IORef Word64, ?age::Depth) =>
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
Score -> Score -> Depth -> Depth -> Position -> IO SearchResult
negamax (-Score
beta) (-Score
alpha) (Depth
depth Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
- Depth
1) (Depth
ply Depth -> Depth -> Depth
forall a. Num a => a -> a -> a
+ Depth
1) Position
pos
  SearchResult -> IO SearchResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SearchResult -> IO SearchResult)
-> SearchResult -> IO SearchResult
forall a b. (a -> b) -> a -> b
$ SearchResult
result {score = - result.score}


advanceState :: (?killersTable :: KillersTable)
  => Score -> Score -> Ply -> NodeType -> Move -> Maybe Move -> Position
  -> SearchM (Maybe Score)
advanceState :: (?killersTable::KillersTable) =>
Score
-> Score
-> Depth
-> NodeType
-> Move
-> Maybe Move
-> Position
-> SearchM (Maybe Score)
advanceState !Score
beta !Score
score !Depth
ply !NodeType
nodeType !Move
mv !Maybe Move
enemyMv Position
pos =
  case NodeType
nodeType of
    NodeType
PV  -> SearchResult -> StateT SearchResult IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put SearchResult
searchResult
            StateT SearchResult IO () -> Maybe Score -> SearchM (Maybe Score)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe Score
forall a. Maybe a
Nothing
    NodeType
Cut -> SearchResult -> StateT SearchResult IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put SearchResult
searchResult
            StateT SearchResult IO ()
-> StateT SearchResult IO () -> StateT SearchResult IO ()
forall a b.
StateT SearchResult IO a
-> StateT SearchResult IO b -> StateT SearchResult IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO () -> StateT SearchResult IO ()
forall a. IO a -> StateT SearchResult IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((?killersTable::KillersTable) => Depth -> Position -> Move -> IO ()
Depth -> Position -> Move -> IO ()
KillersTable.insert Depth
ply Position
pos Move
mv)
            StateT SearchResult IO () -> Maybe Score -> SearchM (Maybe Score)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Score -> Maybe Score
forall a. a -> Maybe a
Just Score
beta
    NodeType
All -> Maybe Score -> SearchM (Maybe Score)
forall a. a -> StateT SearchResult IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Score
forall a. Maybe a
Nothing
    where
      !searchResult :: SearchResult
searchResult = Score -> Maybe Move -> Maybe Move -> SearchResult
SearchResult Score
score (Move -> Maybe Move
forall a. a -> Maybe a
Just Move
mv) Maybe Move
enemyMv


getGameResult :: Score -> GameResult
getGameResult :: Score -> GameResult
getGameResult Score
score
  | Score
score Score -> Score -> Bool
forall a. Eq a => a -> a -> Bool
== Score
maxScore = GameResult
Victory
  | Score
score Score -> Score -> Bool
forall a. Eq a => a -> a -> Bool
== Score
minScore = GameResult
Defeat
  | Bool
otherwise        = GameResult
InProgress


printSearchInfo :: Depth -> Word64 -> MicroSeconds -> SearchResult -> IO ()
printSearchInfo :: Depth -> Word64 -> Word64 -> SearchResult -> IO ()
printSearchInfo Depth
depth Word64
nodes Word64
elapsedTime SearchResult{Score
Maybe Move
$sel:bestMove:SearchResult :: SearchResult -> Maybe Move
$sel:score:SearchResult :: SearchResult -> Score
$sel:ponderMove:SearchResult :: SearchResult -> Maybe Move
score :: Score
bestMove :: Maybe Move
ponderMove :: Maybe Move
..} = do
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn (Text
"info"
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" depth " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Depth -> Text
forall a. Show a => a -> Text
tshow Depth
depth
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" score " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
showScore
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" nodes " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
nodes
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" nps "   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
nps
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" time "  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word64 -> Text
forall a. Show a => a -> Text
tshow Word64
timeMillis
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" pv "    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall seq. (Element seq ~ Text, MonoFoldable seq) => seq -> Text
forall t seq.
(Textual t, Element seq ~ t, MonoFoldable seq) =>
seq -> t
unwords (Move -> Text
forall a. Show a => a -> Text
tshow (Move -> Text) -> [Move] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Move]
pv))
  Handle -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> m ()
hFlush Handle
stdout
  where
    nps :: Word64
nps        = Word64
nodes Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1_000_000 Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
elapsedTime
    timeMillis :: Word64
timeMillis = Word64
elapsedTime Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
1_000
    pv :: [Move]
pv         = [Maybe Move] -> [Move]
forall (f :: * -> *) t.
(IsSequence (f (Maybe t)), Functor f,
 Element (f (Maybe t)) ~ Maybe t) =>
f (Maybe t) -> f t
catMaybes [Maybe Move
bestMove, Maybe Move
ponderMove]
    showScore :: Text
showScore = case Score -> GameResult
getGameResult Score
score of
      GameResult
InProgress -> Text
"cp "   Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Score -> Text
forall a. Show a => a -> Text
tshow Score
score
      GameResult
Victory    -> Text
"mate " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow @Int Int
1
      GameResult
Defeat     -> Text
"mate " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow @Int (-Int
1)


emptySearchResult :: Score -> SearchResult
emptySearchResult :: Score -> SearchResult
emptySearchResult Score
score = Score -> Maybe Move -> Maybe Move -> SearchResult
SearchResult Score
score Maybe Move
forall a. Maybe a
Nothing Maybe Move
forall a. Maybe a
Nothing


data SearchResult = SearchResult {
    SearchResult -> Score
score      :: Score
  , SearchResult -> Maybe Move
bestMove   :: Maybe Move
  , SearchResult -> Maybe Move
ponderMove :: Maybe Move
}


data GameResult
  = InProgress
  | Victory
  | Defeat
  deriving (GameResult -> GameResult -> Bool
(GameResult -> GameResult -> Bool)
-> (GameResult -> GameResult -> Bool) -> Eq GameResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GameResult -> GameResult -> Bool
== :: GameResult -> GameResult -> Bool
$c/= :: GameResult -> GameResult -> Bool
/= :: GameResult -> GameResult -> Bool
Eq)


type SearchM = StateT SearchResult IO