{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE ViewPatterns      #-}
{-|
Module      : Game.Chess.UCI
Description : Universal Chess Interface
Copyright   : (c) Mario Lang, 2021
License     : BSD3
Maintainer  : mlang@blind.guru
Stability   : experimental

The Universal Chess Interface (UCI) is a protocol for communicating with
external Chess engines.
-}
module Game.Chess.UCI (
  -- * Exceptions
  UCIException(..)
  -- * The Engine data type
, Engine, BestMove, name, author
  -- * Starting a UCI engine
, start, start'
  -- * Engine options
, Option(..), options, getOption, setOptionSpinButton, setOptionString
  -- * Manipulating the current game information
, isready
, currentPosition, setPosition, addPly, replacePly
  -- * The Info data type
, Info(..), Score(..), Bounds(..)
  -- * Searching
, search, searching
, SearchParam
, searchmoves, ponder, timeleft, timeincrement, movestogo, movetime, nodes, depth, infinite
, ponderhit
, stop
  -- * Quitting
, quit, quit'
) where

import           Control.Applicative              (Alternative (many, (<|>)),
                                                   optional)
import           Control.Concurrent               (MVar, ThreadId, forkIO,
                                                   killThread, newEmptyMVar,
                                                   putMVar, takeMVar)
import           Control.Concurrent.STM           (TChan, atomically, dupTChan,
                                                   newBroadcastTChanIO,
                                                   writeTChan)
import           Control.Exception                (Exception, handle, throwIO)
import           Control.Monad                    (forM, forever, void)
import           Control.Monad.IO.Class           (MonadIO (..))
import           Data.Attoparsec.ByteString.Char8 (Parser, anyChar, choice,
                                                   decimal, endOfInput,
                                                   manyTill, match, parseOnly,
                                                   satisfy, sepBy, sepBy1,
                                                   signed, skipSpace,
                                                   takeByteString)
import           Data.ByteString.Builder          (Builder, byteString,
                                                   hPutBuilder, intDec,
                                                   integerDec)
import           Data.ByteString.Char8            (ByteString)
import qualified Data.ByteString.Char8            as BS
import           Data.Foldable                    (Foldable (fold, foldl', toList))
import           Data.Functor                     (($>))
import           Data.HashMap.Strict              (HashMap)
import qualified Data.HashMap.Strict              as HashMap
import           Data.IORef                       (IORef, atomicModifyIORef',
                                                   newIORef, readIORef,
                                                   writeIORef)
import           Data.Ix                          (Ix (inRange))
import           Data.List                        (intersperse)
import           Data.STRef                       (modifySTRef, newSTRef,
                                                   readSTRef, writeSTRef)
import           Data.Sequence                    (Seq, ViewR ((:>)), (|>))
import qualified Data.Sequence                    as Seq
import           Data.String                      (IsString (..))
import qualified Data.Vector.Unboxed              as Unboxed
import qualified Data.Vector.Unboxed.Mutable      as Unboxed
import           Game.Chess                       (Color (..), Ply, Position,
                                                   doPly, fromUCI, legalPlies,
                                                   startpos, toFEN, toUCI,
                                                   unsafeDoPly)
import           Numeric.Natural                  (Natural)
import           System.Exit                      (ExitCode)
import           System.IO                        (BufferMode (LineBuffering),
                                                   Handle, hSetBuffering)
import           System.Process                   (CreateProcess (std_in, std_out),
                                                   ProcessHandle,
                                                   StdStream (CreatePipe),
                                                   createProcess,
                                                   getProcessExitCode, proc,
                                                   terminateProcess,
                                                   waitForProcess)
import           Time.Rational                    (KnownDivRat)
import           Time.Units                       (Microsecond, Millisecond,
                                                   Time (unTime), ms, sec,
                                                   timeout, toUnit)

type BestMove = Maybe (Ply, Maybe Ply)

data Engine = Engine {
  Engine -> Handle
inH          :: Handle
, Engine -> Handle
outH         :: Handle
, Engine -> ProcessHandle
procH        :: ProcessHandle
, Engine -> String -> IO ()
outputStrLn  :: String -> IO ()
, Engine -> Maybe ThreadId
infoThread   :: Maybe ThreadId
, Engine -> Maybe ByteString
name         :: Maybe ByteString
, Engine -> Maybe ByteString
author       :: Maybe ByteString
, Engine -> HashMap ByteString Option
options      :: HashMap ByteString Option
, Engine -> MVar ()
isReady      :: MVar ()
, Engine -> IORef Bool
isSearching  :: IORef Bool
, Engine -> TChan [Info]
infoChan     :: TChan [Info]
, Engine -> TChan BestMove
bestMoveChan :: TChan BestMove
, Engine -> IORef (Position, Seq Ply)
game         :: IORef (Position, Seq Ply)
}

-- | Set the starting position and plies of the current game.
setPosition :: (Foldable f, MonadIO m)
            => Engine -> Position -> f Ply
            -> m ()
setPosition :: forall (f :: * -> *) (m :: * -> *).
(Foldable f, MonadIO m) =>
Engine -> Position -> f Ply -> m ()
setPosition e :: Engine
e@Engine{IORef (Position, Seq Ply)
game :: IORef (Position, Seq Ply)
game :: Engine -> IORef (Position, Seq Ply)
game} Position
p f Ply
pl = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Position, Seq Ply)
game ((Position
p, forall a. [a] -> Seq a
Seq.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f Ply
pl),)
  Engine -> IO ()
sendPosition Engine
e

data UCIException = IllegalMove Ply deriving Int -> UCIException -> ShowS
[UCIException] -> ShowS
UCIException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UCIException] -> ShowS
$cshowList :: [UCIException] -> ShowS
show :: UCIException -> String
$cshow :: UCIException -> String
showsPrec :: Int -> UCIException -> ShowS
$cshowsPrec :: Int -> UCIException -> ShowS
Show

instance Exception UCIException

data Command = Name !ByteString
             | Author !ByteString
             | Option !ByteString !Option
             | UCIOk
             | ReadyOK
             | Info [Info]
             | BestMove !BestMove
             deriving (Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show)

data Info = PV !(Unboxed.Vector Ply)
          | Depth !Int
          | SelDepth !Int
          | Elapsed !(Time Millisecond)
          | MultiPV !Int
          | Score !Score (Maybe Bounds)
          | Nodes !Int
          | NPS !Int
          | TBHits !Int
          | HashFull !Int
          | CurrMove !Ply
          | CurrMoveNumber !Int
          | String !ByteString
          deriving (Info -> Info -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Info -> Info -> Bool
$c/= :: Info -> Info -> Bool
== :: Info -> Info -> Bool
$c== :: Info -> Info -> Bool
Eq, Int -> Info -> ShowS
[Info] -> ShowS
Info -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Info] -> ShowS
$cshowList :: [Info] -> ShowS
show :: Info -> String
$cshow :: Info -> String
showsPrec :: Int -> Info -> ShowS
$cshowsPrec :: Int -> Info -> ShowS
Show)

data Score = CentiPawns Int
           | MateIn Int
           deriving (Score -> Score -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Score -> Score -> Bool
$c/= :: Score -> Score -> Bool
== :: Score -> Score -> Bool
$c== :: Score -> Score -> Bool
Eq, Eq Score
Score -> Score -> Bool
Score -> Score -> Ordering
Score -> Score -> Score
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Score -> Score -> Score
$cmin :: Score -> Score -> Score
max :: Score -> Score -> Score
$cmax :: Score -> Score -> Score
>= :: Score -> Score -> Bool
$c>= :: Score -> Score -> Bool
> :: Score -> Score -> Bool
$c> :: Score -> Score -> Bool
<= :: Score -> Score -> Bool
$c<= :: Score -> Score -> Bool
< :: Score -> Score -> Bool
$c< :: Score -> Score -> Bool
compare :: Score -> Score -> Ordering
$ccompare :: Score -> Score -> Ordering
Ord, Int -> Score -> ShowS
[Score] -> ShowS
Score -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Score] -> ShowS
$cshowList :: [Score] -> ShowS
show :: Score -> String
$cshow :: Score -> String
showsPrec :: Int -> Score -> ShowS
$cshowsPrec :: Int -> Score -> ShowS
Show)

data Bounds = UpperBound | LowerBound deriving (Bounds -> Bounds -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Bounds -> Bounds -> Bool
$c/= :: Bounds -> Bounds -> Bool
== :: Bounds -> Bounds -> Bool
$c== :: Bounds -> Bounds -> Bool
Eq, Int -> Bounds -> ShowS
[Bounds] -> ShowS
Bounds -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Bounds] -> ShowS
$cshowList :: [Bounds] -> ShowS
show :: Bounds -> String
$cshow :: Bounds -> String
showsPrec :: Int -> Bounds -> ShowS
$cshowsPrec :: Int -> Bounds -> ShowS
Show)


data Option = CheckBox Bool
            | ComboBox { Option -> ByteString
comboBoxValue :: ByteString, Option -> [ByteString]
comboBoxValues :: [ByteString] }
            | SpinButton { Option -> Int
spinButtonValue, Option -> Int
spinButtonMinBound, Option -> Int
spinButtonMaxBound :: Int }
            | OString ByteString
            | Button
            deriving (Option -> Option -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Option -> Option -> Bool
$c/= :: Option -> Option -> Bool
== :: Option -> Option -> Bool
$c== :: Option -> Option -> Bool
Eq, Int -> Option -> ShowS
[Option] -> ShowS
Option -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Option] -> ShowS
$cshowList :: [Option] -> ShowS
show :: Option -> String
$cshow :: Option -> String
showsPrec :: Int -> Option -> ShowS
$cshowsPrec :: Int -> Option -> ShowS
Show)

instance IsString Option where
  fromString :: String -> Option
fromString = ByteString -> Option
OString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack

command :: Position -> Parser Command
command :: Position -> Parser Command
command Position
pos = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
  [ Parser ByteString ByteString
"id" forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
`kv` Parser Command
name
  , Parser ByteString ByteString
"id" forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
`kv` Parser Command
author
  , Parser ByteString ByteString
"option" forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
`kv` Parser Command
opt
  , Parser ByteString ByteString
"uciok" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Command
UCIOk
  , Parser ByteString ByteString
"readyok" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Command
ReadyOK
  , Parser ByteString ByteString
"info" forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
`kv` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Info] -> Command
Info (forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy1 Parser ByteString Info
infoItem Parser ()
skipSpace)
  , Parser ByteString ByteString
"bestmove" forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
`kv` (Parser ByteString ByteString
"(none)" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> BestMove -> Command
BestMove forall a. Maybe a
Nothing forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Command
bestmove)
  ] forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
 where
  name :: Parser Command
name = ByteString -> Command
Name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"name" Parser ByteString ByteString
takeByteString
  author :: Parser Command
author = ByteString -> Command
Author forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"author" Parser ByteString ByteString
takeByteString
  opt :: Parser Command
opt = do
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString ByteString
"name"
    Parser ()
skipSpace
    ByteString
optName <- String -> ByteString
BS.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
manyTill Parser Char
anyChar (Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
"type")
    Parser ()
skipSpace
    Option
optValue <- Parser ByteString Option
spin forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Option
check forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Option
combo forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Option
str forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Option
button
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> Option -> Command
Option ByteString
optName Option
optValue
  check :: Parser ByteString Option
check =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Option
CheckBox forall a b. (a -> b) -> a -> b
$ Parser ByteString ByteString
"check" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
"default" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
                    (Parser ByteString ByteString
"false" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ByteString
"true" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True)
  spin :: Parser ByteString Option
spin = do
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString ByteString
"spin"
    Parser ()
skipSpace
    Int
value <- Parser ByteString ByteString
"default" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Num a => Parser a -> Parser a
signed forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
    Int
minValue <- Parser ByteString ByteString
"min" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Num a => Parser a -> Parser a
signed forall a. Integral a => Parser a
decimal forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace
    Int
maxValue <- Parser ByteString ByteString
"max" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall a. Num a => Parser a -> Parser a
signed forall a. Integral a => Parser a
decimal
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Option
SpinButton Int
value Int
minValue Int
maxValue
  combo :: Parser ByteString Option
combo = do
    forall (f :: * -> *) a. Functor f => f a -> f ()
void Parser ByteString ByteString
"combo"
    Parser ()
skipSpace
    ByteString
def <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ Parser ByteString ByteString
"default" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
manyTill Parser Char
anyChar Parser ()
var
    ([String]
vars, ByteString
lastVar) <- (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
manyTill Parser Char
anyChar Parser ()
var)
                           forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString ByteString
takeByteString
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> Option
ComboBox ByteString
def (forall a b. (a -> b) -> [a] -> [b]
map String -> ByteString
BS.pack [String]
vars forall a. Semigroup a => a -> a -> a
<> [ByteString
lastVar])
  var :: Parser ()
var = Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
"var" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace
  str :: Parser ByteString Option
str = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Option
OString forall a b. (a -> b) -> a -> b
$
    Parser ByteString ByteString
"string" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
"default" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
takeByteString
  button :: Parser ByteString Option
button = Parser ByteString ByteString
"button" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Option
Button
  infoItem :: Parser ByteString Info
infoItem = Int -> Info
Depth forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"depth" forall a. Integral a => Parser a
decimal
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Info
SelDepth forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"seldepth" forall a. Integral a => Parser a
decimal
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Info
MultiPV forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"multipv" forall a. Integral a => Parser a
decimal
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"score" Parser ByteString Info
score
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Info
Nodes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"nodes" forall a. Integral a => Parser a
decimal
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Info
NPS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"nps" forall a. Integral a => Parser a
decimal
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Info
HashFull forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"hashfull" forall a. Integral a => Parser a
decimal
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Info
TBHits forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"tbhits" forall a. Integral a => Parser a
decimal
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Time Millisecond -> Info
Elapsed forall b c a. (b -> c) -> (a -> b) -> a -> c
. RatioNat -> Time Millisecond
ms forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"time" forall a. Integral a => Parser a
decimal
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"pv" Parser ByteString Info
pv
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"currmove" Parser ByteString Info
currmove
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Info
CurrMoveNumber forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"currmovenumber" forall a. Integral a => Parser a
decimal
         forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Info
String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"string" Parser ByteString ByteString
takeByteString
  score :: Parser ByteString Info
score = do
    Score
s <- forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"cp" (Int -> Score
CentiPawns forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Num a => Parser a -> Parser a
signed forall a. Integral a => Parser a
decimal)
     forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"mate" (Int -> Score
MateIn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Num a => Parser a -> Parser a
signed forall a. Integral a => Parser a
decimal)
    Maybe Bounds
b <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (  Bounds
UpperBound forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ByteString ByteString
"upperbound"
                                forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bounds
LowerBound forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ByteString ByteString
"lowerbound"
                                 )
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Score -> Maybe Bounds -> Info
Score Score
s Maybe Bounds
b
  pv :: Parser ByteString Info
pv = Position -> [String] -> Either String (Vector Ply)
varToVec Position
pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
sepBy Parser ByteString String
mv Parser ()
skipSpace forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right Vector Ply
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Ply -> Info
PV forall a b. (a -> b) -> a -> b
$ Vector Ply
v
    Left String
s  -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to parse move " forall a. Semigroup a => a -> a -> a
<> String
s
  currmove :: Parser ByteString Info
currmove = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Position -> String -> Maybe Ply
fromUCI Position
pos) Parser ByteString String
mv forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Ply
m  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Ply -> Info
CurrMove Ply
m
    Maybe Ply
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to parse move"

  mv :: Parser ByteString String
mv = ByteString -> String
BS.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser (ByteString, a)
match (Parser Char
sq forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char
sq forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ((Char -> Bool) -> Parser Char
satisfy Char -> Bool
p)) where
    sq :: Parser Char
sq = (Char -> Bool) -> Parser Char
satisfy (forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'a', Char
'h')) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Char -> Bool) -> Parser Char
satisfy (forall a. Ix a => (a, a) -> a -> Bool
inRange (Char
'1', Char
'8'))
    p :: Char -> Bool
p Char
'q' = Bool
True
    p Char
'r' = Bool
True
    p Char
'b' = Bool
True
    p Char
'n' = Bool
True
    p Char
_   = Bool
False
  bestmove :: Parser Command
bestmove = do
    String
m <- Parser ByteString String
mv
    Maybe String
ponder <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall {a} {b}.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString ByteString
"ponder" Parser ByteString String
mv)
    case Position -> String -> Maybe Ply
fromUCI Position
pos String
m of
      Just Ply
m' -> case Maybe String
ponder of
        Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. BestMove -> Command
BestMove forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Ply
m', forall a. Maybe a
Nothing)
        Just String
p -> case Position -> String -> Maybe Ply
fromUCI (HasCallStack => Position -> Ply -> Position
doPly Position
pos Ply
m') String
p of
          Just Ply
p' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. BestMove -> Command
BestMove forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Ply
m', forall a. a -> Maybe a
Just Ply
p')
          Maybe Ply
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to parse ponder move " forall a. Semigroup a => a -> a -> a
<> String
p
      Maybe Ply
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to parse best move " forall a. Semigroup a => a -> a -> a
<> String
m
  kv :: Parser ByteString a -> Parser ByteString b -> Parser ByteString b
kv Parser ByteString a
k Parser ByteString b
v = Parser ByteString a
k forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString b
v

varToVec :: Position -> [String] -> Either String (Unboxed.Vector Ply)
varToVec :: Position -> [String] -> Either String (Vector Ply)
varToVec Position
p [String]
xs = forall (f :: * -> *) a.
(Traversable f, Unbox a) =>
(forall s. ST s (f (MVector s a))) -> f (Vector a)
Unboxed.createT forall a b. (a -> b) -> a -> b
$ do
  MVector s Ply
v <- forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
Int -> m (MVector (PrimState m) a)
Unboxed.new forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
xs
  STRef s Int
i <- forall a s. a -> ST s (STRef s a)
newSTRef Int
0
  STRef s Position
pos <- forall a s. a -> ST s (STRef s a)
newSTRef Position
p
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const MVector s Ply
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
xs forall a b. (a -> b) -> a -> b
$ \String
x -> do
    Position
pos' <- forall s a. STRef s a -> ST s a
readSTRef STRef s Position
pos
    case Position -> String -> Maybe Ply
fromUCI Position
pos' String
x of
      Just Ply
pl -> do
        Int
i' <- forall s a. STRef s a -> ST s a
readSTRef STRef s Int
i
        forall (m :: * -> *) a.
(PrimMonad m, Unbox a) =>
MVector (PrimState m) a -> Int -> a -> m ()
Unboxed.write MVector s Ply
v Int
i' Ply
pl
        forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef STRef s Int
i (forall a. Num a => a -> a -> a
+ Int
1)
        forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Position
pos (Position -> Ply -> Position
unsafeDoPly Position
pos' Ply
pl)
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ()
      Maybe Ply
Nothing -> do
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
x

-- | Start a UCI engine with the given executable name and command line arguments.
start :: String -> [String] -> IO (Maybe Engine)
start :: String -> [String] -> IO (Maybe Engine)
start = forall (unit :: Rat).
KnownDivRat unit Microsecond =>
Time unit
-> (String -> IO ()) -> String -> [String] -> IO (Maybe Engine)
start' (RatioNat -> Time Second
sec RatioNat
2) String -> IO ()
putStrLn

-- | Start a UCI engine with the given timeout for initialisation.
--
-- If the engine takes more then the given microseconds to answer to the
-- initialisation request, 'Nothing' is returned and the external process
-- will be terminated.
start' :: KnownDivRat unit Microsecond => Time unit -> (String -> IO ()) -> String -> [String] -> IO (Maybe Engine)
start' :: forall (unit :: Rat).
KnownDivRat unit Microsecond =>
Time unit
-> (String -> IO ()) -> String -> [String] -> IO (Maybe Engine)
start' Time unit
tout String -> IO ()
outputStrLn String
cmd [String]
args = do
  (Just Handle
inH, Just Handle
outH, Maybe Handle
Nothing, ProcessHandle
procH) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess (String -> [String] -> CreateProcess
proc String
cmd [String]
args) {
      std_in :: StdStream
std_in = StdStream
CreatePipe, std_out :: StdStream
std_out = StdStream
CreatePipe
    }
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
inH BufferMode
LineBuffering
  Engine
e <- Handle
-> Handle
-> ProcessHandle
-> (String -> IO ())
-> Maybe ThreadId
-> Maybe ByteString
-> Maybe ByteString
-> HashMap ByteString Option
-> MVar ()
-> IORef Bool
-> TChan [Info]
-> TChan BestMove
-> IORef (Position, Seq Ply)
-> Engine
Engine Handle
inH Handle
outH ProcessHandle
procH String -> IO ()
outputStrLn forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall k v. HashMap k v
HashMap.empty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
       forall a. IO (MVar a)
newEmptyMVar forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIORef Bool
False forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
       forall a. IO (TChan a)
newBroadcastTChanIO forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IO (TChan a)
newBroadcastTChanIO forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
       forall a. a -> IO (IORef a)
newIORef (Position
startpos, forall a. Seq a
Seq.empty)
  Engine -> Builder -> IO ()
send Engine
e Builder
"uci"
  forall (unit :: Rat) (m :: * -> *) a.
(MonadIO m, KnownDivRat unit Microsecond) =>
Time unit -> IO a -> m (Maybe a)
timeout Time unit
tout (Engine -> IO Engine
initialise Engine
e) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Engine
e' -> do
      ThreadId
tid <- IO () -> IO ThreadId
forkIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Engine -> IO ()
infoReader forall a b. (a -> b) -> a -> b
$ Engine
e'
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Engine
e' { infoThread :: Maybe ThreadId
infoThread = forall a. a -> Maybe a
Just ThreadId
tid }
    Maybe Engine
Nothing -> forall (m :: * -> *). MonadIO m => Engine -> m (Maybe ExitCode)
quit Engine
e forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. Maybe a
Nothing

initialise :: Engine -> IO Engine
initialise :: Engine -> IO Engine
initialise c :: Engine
c@Engine{Handle
outH :: Handle
outH :: Engine -> Handle
outH, String -> IO ()
outputStrLn :: String -> IO ()
outputStrLn :: Engine -> String -> IO ()
outputStrLn, IORef (Position, Seq Ply)
game :: IORef (Position, Seq Ply)
game :: Engine -> IORef (Position, Seq Ply)
game} = do
  ByteString
l <- Handle -> IO ByteString
BS.hGetLine Handle
outH
  Position
pos <- forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (Position, Seq Ply)
game
  if ByteString -> Bool
BS.null ByteString
l then Engine -> IO Engine
initialise Engine
c else case forall a. Parser a -> ByteString -> Either String a
parseOnly (Position -> Parser Command
command Position
pos forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput) ByteString
l of
    Left String
_ -> do
      String -> IO ()
outputStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS.unpack forall a b. (a -> b) -> a -> b
$ ByteString
l
      Engine -> IO Engine
initialise Engine
c
    Right (Name ByteString
n) -> Engine -> IO Engine
initialise (Engine
c { name :: Maybe ByteString
name = forall a. a -> Maybe a
Just ByteString
n })
    Right (Author ByteString
a) -> Engine -> IO Engine
initialise (Engine
c { author :: Maybe ByteString
author = forall a. a -> Maybe a
Just ByteString
a })
    Right (Option ByteString
name Option
opt) -> Engine -> IO Engine
initialise (Engine
c { options :: HashMap ByteString Option
options = forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert ByteString
name Option
opt forall a b. (a -> b) -> a -> b
$ Engine -> HashMap ByteString Option
options Engine
c })
    Right Command
UCIOk -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Engine
c
    Right Command
_ -> Engine -> IO Engine
initialise Engine
c

infoReader :: Engine -> IO ()
infoReader :: Engine -> IO ()
infoReader e :: Engine
e@Engine{Maybe ByteString
Maybe ThreadId
Handle
IORef Bool
IORef (Position, Seq Ply)
MVar ()
ProcessHandle
HashMap ByteString Option
TChan [Info]
TChan BestMove
String -> IO ()
game :: IORef (Position, Seq Ply)
bestMoveChan :: TChan BestMove
infoChan :: TChan [Info]
isSearching :: IORef Bool
isReady :: MVar ()
options :: HashMap ByteString Option
author :: Maybe ByteString
name :: Maybe ByteString
infoThread :: Maybe ThreadId
outputStrLn :: String -> IO ()
procH :: ProcessHandle
outH :: Handle
inH :: Handle
game :: Engine -> IORef (Position, Seq Ply)
bestMoveChan :: Engine -> TChan BestMove
infoChan :: Engine -> TChan [Info]
isSearching :: Engine -> IORef Bool
isReady :: Engine -> MVar ()
infoThread :: Engine -> Maybe ThreadId
outputStrLn :: Engine -> String -> IO ()
procH :: Engine -> ProcessHandle
outH :: Engine -> Handle
inH :: Engine -> Handle
options :: Engine -> HashMap ByteString Option
author :: Engine -> Maybe ByteString
name :: Engine -> Maybe ByteString
..} = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
  ByteString
l <- Handle -> IO ByteString
BS.hGetLine Handle
outH
  Position
pos <- forall (m :: * -> *). MonadIO m => Engine -> m Position
currentPosition Engine
e
  case forall a. Parser a -> ByteString -> Either String a
parseOnly (Position -> Parser Command
command Position
pos forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall t. Chunk t => Parser t ()
endOfInput) ByteString
l of
    Left String
err -> String -> IO ()
outputStrLn forall a b. (a -> b) -> a -> b
$ String
err forall a. Semigroup a => a -> a -> a
<> String
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
l
    Right Command
ReadyOK -> forall a. MVar a -> a -> IO ()
putMVar MVar ()
isReady ()
    Right (Info [Info]
i) -> forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan [Info]
infoChan [Info]
i
    Right (BestMove BestMove
bm) -> do
      forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
isSearching Bool
False
      forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan BestMove
bestMoveChan BestMove
bm
    Right Command
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Wait until the engine is ready to take more commands.
isready :: Engine -> IO ()
isready :: Engine -> IO ()
isready e :: Engine
e@Engine{MVar ()
isReady :: MVar ()
isReady :: Engine -> MVar ()
isReady} = do
  Engine -> Builder -> IO ()
send Engine
e Builder
"isready"
  forall a. MVar a -> IO a
takeMVar MVar ()
isReady

send :: Engine -> Builder -> IO ()
send :: Engine -> Builder -> IO ()
send Engine{Handle
inH :: Handle
inH :: Engine -> Handle
inH, ProcessHandle
procH :: ProcessHandle
procH :: Engine -> ProcessHandle
procH} Builder
b = do
  Handle -> Builder -> IO ()
hPutBuilder Handle
inH (Builder
b forall a. Semigroup a => a -> a -> a
<> Builder
"\n")
  ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
procH forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe ExitCode
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just ExitCode
ec -> forall e a. Exception e => e -> IO a
throwIO ExitCode
ec

data SearchParam = SearchMoves [Ply]
                -- ^ restrict search to the specified moves only
                 | Ponder
                -- ^ start searching in pondering mode
                 | TimeLeft Color (Time Millisecond)
                -- ^ time (in milliseconds) left on the clock
                 | TimeIncrement Color (Time Millisecond)
                -- ^ time increment per move in milliseconds
                 | MovesToGo Natural
                -- ^ number of moves to the next time control
                 | MoveTime (Time Millisecond)
                 | MaxNodes Natural
                 | MaxDepth Natural
                 | Infinite
                -- ^ search until 'stop' gets called
                 deriving (SearchParam -> SearchParam -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SearchParam -> SearchParam -> Bool
$c/= :: SearchParam -> SearchParam -> Bool
== :: SearchParam -> SearchParam -> Bool
$c== :: SearchParam -> SearchParam -> Bool
Eq, Int -> SearchParam -> ShowS
[SearchParam] -> ShowS
SearchParam -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SearchParam] -> ShowS
$cshowList :: [SearchParam] -> ShowS
show :: SearchParam -> String
$cshow :: SearchParam -> String
showsPrec :: Int -> SearchParam -> ShowS
$cshowsPrec :: Int -> SearchParam -> ShowS
Show)

searchmoves :: [Ply] -> SearchParam
searchmoves :: [Ply] -> SearchParam
searchmoves = [Ply] -> SearchParam
SearchMoves

ponder :: SearchParam
ponder :: SearchParam
ponder = SearchParam
Ponder

timeleft, timeincrement :: KnownDivRat unit Millisecond
                        => Color -> Time unit -> SearchParam
timeleft :: forall (unit :: Rat).
KnownDivRat unit Millisecond =>
Color -> Time unit -> SearchParam
timeleft Color
c = Color -> Time Millisecond -> SearchParam
TimeLeft Color
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit
timeincrement :: forall (unit :: Rat).
KnownDivRat unit Millisecond =>
Color -> Time unit -> SearchParam
timeincrement Color
c = Color -> Time Millisecond -> SearchParam
TimeIncrement Color
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit

movestogo :: Natural -> SearchParam
movestogo :: Natural -> SearchParam
movestogo = Natural -> SearchParam
MovesToGo

movetime :: KnownDivRat unit Millisecond => Time unit -> SearchParam
movetime :: forall (unit :: Rat).
KnownDivRat unit Millisecond =>
Time unit -> SearchParam
movetime = Time Millisecond -> SearchParam
MoveTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit

nodes, depth :: Natural -> SearchParam
nodes :: Natural -> SearchParam
nodes = Natural -> SearchParam
MaxNodes
depth :: Natural -> SearchParam
depth = Natural -> SearchParam
MaxDepth

infinite :: SearchParam
infinite :: SearchParam
infinite = SearchParam
Infinite

searching :: MonadIO m => Engine -> m Bool
searching :: forall (m :: * -> *). MonadIO m => Engine -> m Bool
searching Engine{IORef Bool
isSearching :: IORef Bool
isSearching :: Engine -> IORef Bool
isSearching} = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef Bool
isSearching

-- | Instruct the engine to begin searching.
search :: MonadIO m
       => Engine -> [SearchParam]
       -> m (TChan BestMove, TChan [Info])
search :: forall (m :: * -> *).
MonadIO m =>
Engine -> [SearchParam] -> m (TChan BestMove, TChan [Info])
search e :: Engine
e@Engine{IORef Bool
isSearching :: IORef Bool
isSearching :: Engine -> IORef Bool
isSearching} [SearchParam]
params = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  (TChan BestMove, TChan [Info])
chans <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TChan a -> STM (TChan a)
dupTChan (Engine -> TChan BestMove
bestMoveChan Engine
e)
                            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. TChan a -> STM (TChan a)
dupTChan (Engine -> TChan [Info]
infoChan Engine
e)
  Engine -> Builder -> IO ()
send Engine
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse Builder
" " forall a b. (a -> b) -> a -> b
$ Builder
"go" forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr SearchParam -> [Builder] -> [Builder]
build forall a. Monoid a => a
mempty [SearchParam]
params
  forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
isSearching Bool
True
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (TChan BestMove, TChan [Info])
chans
 where
  build :: SearchParam -> [Builder] -> [Builder]
build (SearchMoves [Ply]
plies) [Builder]
xs = Builder
"searchmoves" forall a. a -> [a] -> [a]
: (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ply -> String
toUCI forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ply]
plies) forall a. Semigroup a => a -> a -> a
<> [Builder]
xs
  build SearchParam
Ponder [Builder]
xs = Builder
"ponder" forall a. a -> [a] -> [a]
: [Builder]
xs
  build (TimeLeft Color
White (forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rat :: Rat). Time rat -> RatioNat
unTime -> Integer
x)) [Builder]
xs = Builder
"wtime" forall a. a -> [a] -> [a]
: Integer -> Builder
integerDec Integer
x forall a. a -> [a] -> [a]
: [Builder]
xs
  build (TimeLeft Color
Black (forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rat :: Rat). Time rat -> RatioNat
unTime -> Integer
x)) [Builder]
xs = Builder
"btime" forall a. a -> [a] -> [a]
: Integer -> Builder
integerDec Integer
x forall a. a -> [a] -> [a]
: [Builder]
xs
  build (TimeIncrement Color
White (forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rat :: Rat). Time rat -> RatioNat
unTime -> Integer
x)) [Builder]
xs = Builder
"winc" forall a. a -> [a] -> [a]
: Integer -> Builder
integerDec Integer
x forall a. a -> [a] -> [a]
: [Builder]
xs
  build (TimeIncrement Color
Black (forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rat :: Rat). Time rat -> RatioNat
unTime -> Integer
x)) [Builder]
xs = Builder
"binc" forall a. a -> [a] -> [a]
: Integer -> Builder
integerDec Integer
x forall a. a -> [a] -> [a]
: [Builder]
xs
  build (MovesToGo Natural
x) [Builder]
xs = Builder
"movestogo" forall a. a -> [a] -> [a]
: Natural -> Builder
naturalDec Natural
x forall a. a -> [a] -> [a]
: [Builder]
xs
  build (MoveTime (forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rat :: Rat). Time rat -> RatioNat
unTime -> Integer
x)) [Builder]
xs = Builder
"movetime" forall a. a -> [a] -> [a]
: Integer -> Builder
integerDec Integer
x forall a. a -> [a] -> [a]
: [Builder]
xs
  build (MaxNodes Natural
x) [Builder]
xs = Builder
"nodes" forall a. a -> [a] -> [a]
: Natural -> Builder
naturalDec Natural
x forall a. a -> [a] -> [a]
: [Builder]
xs
  build (MaxDepth Natural
x) [Builder]
xs = Builder
"depth" forall a. a -> [a] -> [a]
: Natural -> Builder
naturalDec Natural
x forall a. a -> [a] -> [a]
: [Builder]
xs
  build SearchParam
Infinite [Builder]
xs = Builder
"infinite" forall a. a -> [a] -> [a]
: [Builder]
xs
  naturalDec :: Natural -> Builder
naturalDec = Integer -> Builder
integerDec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger

-- | Switch a ponder search to normal search when the pondered move was played.
ponderhit :: MonadIO m => Engine -> m ()
ponderhit :: forall (m :: * -> *). MonadIO m => Engine -> m ()
ponderhit Engine
e = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Engine -> Builder -> IO ()
send Engine
e Builder
"ponderhit"

-- | Stop a search in progress.
stop :: MonadIO m => Engine -> m ()
stop :: forall (m :: * -> *). MonadIO m => Engine -> m ()
stop Engine
e = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Engine -> Builder -> IO ()
send Engine
e Builder
"stop"

getOption :: ByteString -> Engine -> Maybe Option
getOption :: ByteString -> Engine -> Maybe Option
getOption ByteString
n = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup ByteString
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. Engine -> HashMap ByteString Option
options

-- | Set a spin option to a particular value.
--
-- Bounds are validated.  Make sure you don't set a value which is out of range.
setOptionSpinButton :: MonadIO m => ByteString -> Int -> Engine -> m Engine
setOptionSpinButton :: forall (m :: * -> *).
MonadIO m =>
ByteString -> Int -> Engine -> m Engine
setOptionSpinButton ByteString
n Int
v Engine
c
  | Just (SpinButton Int
_ Int
minValue Int
maxValue) <- ByteString -> Engine -> Maybe Option
getOption ByteString
n Engine
c
  , forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
minValue, Int
maxValue) Int
v
  = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Engine -> Builder -> IO ()
send Engine
c forall a b. (a -> b) -> a -> b
$ Builder
"setoption name " forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
n forall a. Semigroup a => a -> a -> a
<> Builder
" value " forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec Int
v
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Engine
c { options :: HashMap ByteString Option
options = forall k a.
(Eq k, Hashable k) =>
(a -> Maybe a) -> k -> HashMap k a -> HashMap k a
HashMap.update (Int -> Option -> Maybe Option
set Int
v) ByteString
n forall a b. (a -> b) -> a -> b
$ Engine -> HashMap ByteString Option
options Engine
c }
  | Bool
otherwise
  = forall a. HasCallStack => String -> a
error String
"No option with that name or value out of range"
 where
  set :: Int -> Option -> Maybe Option
set Int
val opt :: Option
opt@SpinButton{} = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Option
opt { spinButtonValue :: Int
spinButtonValue = Int
val }

setOptionString :: MonadIO m => ByteString -> ByteString -> Engine -> m Engine
setOptionString :: forall (m :: * -> *).
MonadIO m =>
ByteString -> ByteString -> Engine -> m Engine
setOptionString ByteString
n ByteString
v Engine
e = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Engine -> Builder -> IO ()
send Engine
e forall a b. (a -> b) -> a -> b
$ Builder
"setoption name " forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
n forall a. Semigroup a => a -> a -> a
<> Builder
" value " forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
v
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Engine
e { options :: HashMap ByteString Option
options = forall k a.
(Eq k, Hashable k) =>
(a -> Maybe a) -> k -> HashMap k a -> HashMap k a
HashMap.update (forall {p}. ByteString -> p -> Maybe Option
set ByteString
v) ByteString
n forall a b. (a -> b) -> a -> b
$ Engine -> HashMap ByteString Option
options Engine
e }
 where
  set :: ByteString -> p -> Maybe Option
set ByteString
val p
_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> Option
OString ByteString
val

-- | Return the final position of the currently active game.
currentPosition :: MonadIO m => Engine -> m Position
currentPosition :: forall (m :: * -> *). MonadIO m => Engine -> m Position
currentPosition Engine{IORef (Position, Seq Ply)
game :: IORef (Position, Seq Ply)
game :: Engine -> IORef (Position, Seq Ply)
game} = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HasCallStack => Position -> Ply -> Position
doPly) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (Position, Seq Ply)
game

-- | Add a 'Move' to the game history.
--
-- This function checks if the move is actually legal, and throws a 'UCIException'
-- if it isn't.
addPly :: MonadIO m => Engine -> Ply -> m ()
addPly :: forall (m :: * -> *). MonadIO m => Engine -> Ply -> m ()
addPly e :: Engine
e@Engine{IORef (Position, Seq Ply)
game :: IORef (Position, Seq Ply)
game :: Engine -> IORef (Position, Seq Ply)
game} Ply
m = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Position
pos <- forall (m :: * -> *). MonadIO m => Engine -> m Position
currentPosition Engine
e
  if Ply
m forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Position -> [Ply]
legalPlies Position
pos then forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Ply -> UCIException
IllegalMove Ply
m else do
    forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Position, Seq Ply)
game forall a b. (a -> b) -> a -> b
$ \(Position, Seq Ply)
g -> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Seq a -> a -> Seq a
|> Ply
m) (Position, Seq Ply)
g, ())
    Engine -> IO ()
sendPosition Engine
e

replacePly :: MonadIO m => Engine -> Ply -> m ()
replacePly :: forall (m :: * -> *). MonadIO m => Engine -> Ply -> m ()
replacePly e :: Engine
e@Engine{IORef (Position, Seq Ply)
game :: IORef (Position, Seq Ply)
game :: Engine -> IORef (Position, Seq Ply)
game} Ply
pl = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Position, Seq Ply)
game forall a b. (a -> b) -> a -> b
$ \(Position, Seq Ply)
g ->
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Seq Ply
xs -> case forall a. Seq a -> ViewR a
Seq.viewr Seq Ply
xs of Seq Ply
xs' :> Ply
_ -> Seq Ply
xs') (Position, Seq Ply)
g, ())
  forall (m :: * -> *). MonadIO m => Engine -> Ply -> m ()
addPly Engine
e Ply
pl

sendPosition :: Engine -> IO ()
sendPosition :: Engine -> IO ()
sendPosition e :: Engine
e@Engine{IORef (Position, Seq Ply)
game :: IORef (Position, Seq Ply)
game :: Engine -> IORef (Position, Seq Ply)
game} = forall a. IORef a -> IO a
readIORef IORef (Position, Seq Ply)
game forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Engine -> Builder -> IO ()
send Engine
e forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {c} {t :: * -> *}.
(Monoid c, IsString c, Foldable t) =>
(Position, t Ply) -> c
cmd where
  cmd :: (Position, t Ply) -> c
cmd (Position
p, t Ply
h) = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse c
" " forall a b. (a -> b) -> a -> b
$
    c
"position" forall a. a -> [a] -> [a]
: c
"fen" forall a. a -> [a] -> [a]
: forall a. IsString a => String -> a
fromString (Position -> String
toFEN Position
p) forall a. a -> [a] -> [a]
: forall {a}. IsString a => [Ply] -> [a]
line (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t Ply
h)
  line :: [Ply] -> [a]
line [] = []
  line [Ply]
h  = a
"moves" forall a. a -> [a] -> [a]
: (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ply -> String
toUCI forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ply]
h)

-- | Quit the engine.
quit :: MonadIO m => Engine -> m (Maybe ExitCode)
quit :: forall (m :: * -> *). MonadIO m => Engine -> m (Maybe ExitCode)
quit = forall (unit :: Rat) (m :: * -> *).
(KnownDivRat unit Microsecond, MonadIO m) =>
Time unit -> Engine -> m (Maybe ExitCode)
quit' (RatioNat -> Time Second
sec RatioNat
1)

quit' :: (KnownDivRat unit Microsecond, MonadIO m)
      => Time unit -> Engine -> m (Maybe ExitCode)
quit' :: forall (unit :: Rat) (m :: * -> *).
(KnownDivRat unit Microsecond, MonadIO m) =>
Time unit -> Engine -> m (Maybe ExitCode)
quit' Time unit
t e :: Engine
e@Engine{ProcessHandle
procH :: ProcessHandle
procH :: Engine -> ProcessHandle
procH, Maybe ThreadId
infoThread :: Maybe ThreadId
infoThread :: Engine -> Maybe ThreadId
infoThread} = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall e a. Exception e => (e -> IO a) -> IO a -> IO a
`handle` do
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ThreadId -> IO ()
killThread Maybe ThreadId
infoThread
  Engine -> Builder -> IO ()
send Engine
e Builder
"quit"
  forall (unit :: Rat) (m :: * -> *) a.
(MonadIO m, KnownDivRat unit Microsecond) =>
Time unit -> IO a -> m (Maybe a)
timeout Time unit
t (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
procH) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just ExitCode
ec -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ExitCode
ec
    Maybe ExitCode
Nothing -> ProcessHandle -> IO ()
terminateProcess ProcessHandle
procH forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. Maybe a
Nothing