diff --git a/app/cboard.hs b/app/cboard.hs new file mode 100644 --- /dev/null +++ b/app/cboard.hs @@ -0,0 +1,118 @@ +module Main where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.State.Strict +import Data.Char +import Data.IORef +import Data.List +import Data.List.Split +import Game.Chess +import qualified Game.Chess.UCI as UCI +import System.Console.Haskeline hiding (catch, handle) +import System.Exit +import System.Environment + +data S = S { + engine :: UCI.Engine +, mover :: Maybe ThreadId +, hintRef :: IORef (Maybe Move) +} + +main = getArgs >>= \case + [] -> do + putStrLn "Please specify a UCI engine at the command line" + exitWith $ ExitFailure 1 + (cmd:args) -> do + UCI.start cmd args >>= \case + Nothing -> do + putStrLn "Unable to initialise engine, maybe it doesn't speak UCI?" + exitWith $ ExitFailure 2 + Just e -> do + s <- S e Nothing <$> newIORef Nothing + runInputT defaultSettings chessIO `evalStateT` s + exitWith ExitSuccess + +chessIO :: InputT (StateT S IO) () +chessIO = do + externalPrint <- getExternalPrint + e <- lift $ gets engine + hr <- lift $ gets hintRef + tid <- liftIO . forkIO $ doBestMove externalPrint hr e + lift $ modify' $ \s -> s { mover = Just tid } + outputBoard + loop + void . liftIO $ UCI.quit e + +outputBoard :: InputT (StateT S IO) () +outputBoard = do + e <- lift $ gets engine + liftIO $ do + pos <- UCI.currentPosition e + printBoard putStrLn pos + +loop :: InputT (StateT S IO) () +loop = do + e <- lift $ gets engine + getInputLine "> " >>= \case + Nothing -> pure () + Just input + | null input -> loop + | Just position <- fromFEN input -> do + outputStrLn $ toFEN position + loop + | input == "hint" -> do + lift (gets hintRef) >>= liftIO . readIORef >>= \case + Just hint -> outputStrLn $ "Try " <> show hint + Nothing -> outputStrLn "Sorry, no hint available" + loop + | otherwise -> do + liftIO $ do + printUCIException `handle` do + UCI.move e input + UCI.send "go movetime 1000" e + outputBoard + loop + +printBoard :: (String -> IO ()) -> Position -> IO () +printBoard externalPrint pos = externalPrint . init . unlines $ + (map . map) pc (reverse $ chunksOf 8 [A1 .. H8]) + where + pc sq = (if isDark sq then toUpper else toLower) case pieceAt pos sq of + Just (White, Pawn) -> 'P' + Just (White, Knight) -> 'N' + Just (White, Bishop) -> 'B' + Just (White, Rook) -> 'R' + Just (White, Queen) -> 'Q' + Just (White, King) -> 'K' + Just (Black, Pawn) -> 'X' + Just (Black, Knight) -> 'S' + Just (Black, Bishop) -> 'L' + Just (Black, Rook) -> 'T' + Just (Black, Queen) -> 'D' + Just (Black, King) -> 'J' + Nothing | isDark sq -> '.' + | otherwise -> ' ' +doBestMove :: (String -> IO ()) -> IORef (Maybe Move) -> UCI.Engine -> IO () +doBestMove externalPrint hintRef e = forever $ do + (bm, ponder) <- atomically . UCI.readBestMove $ e + UCI.addMove e bm + externalPrint $ "< " <> show bm + UCI.currentPosition e >>= printBoard externalPrint + writeIORef hintRef ponder + +printPV :: (String -> IO ()) -> UCI.Engine -> IO () +printPV externalPrint engine = forever $ do + info <- atomically . UCI.readInfo $ engine + case find isPV info of + Just pv -> externalPrint $ show pv + Nothing -> pure () + where + isPV UCI.PV{} = True + isPV _ = False + +printUCIException :: UCI.UCIException -> IO () +printUCIException e = print e diff --git a/chessIO.cabal b/chessIO.cabal --- a/chessIO.cabal +++ b/chessIO.cabal @@ -4,11 +4,13 @@ -- -- see: https://github.com/sol/hpack -- --- hash: bce4c13865f7d91aaf5bc6807f962a6263a4f6ccd6ccea79504ebac4a9f53f64 +-- hash: 4e2926a2dc0dbb48166ba6817910daed6e92c23dbc6e644942c9ebcfe3922702 name: chessIO -version: 0.0.0.0 -description: A simple chess move generation library +version: 0.1.0.0 +synopsis: Basic chess move generation and UCI client library +description: A simple library for generating legal chess moves. Also includes a module for communication with external processes that speak the UCI (Universal Chess Interface) protocol. On top of that, provides a console frontend program (cboard) that can be used to interactively play against UCI engines. +category: Game homepage: https://github.com/mlang/chessIO#readme bug-reports: https://github.com/mlang/chessIO/issues author: Mario Lang @@ -25,18 +27,49 @@ library exposed-modules: Game.Chess + Game.Chess.UCI other-modules: - Game.Debug Paths_chessIO hs-source-dirs: src - default-extensions: BangPatterns BinaryLiterals DeriveGeneric NamedFieldPuns NumericUnderscores TupleSections ViewPatterns - ghc-options: -Wall -O2 + default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns + ghc-options: -Wall build-depends: - base >=4.8 && <5 + attoparsec + , base >=4.8 && <5 + , bytestring + , megaparsec + , parser-combinators + , process + , stm + , unordered-containers , vector default-language: Haskell2010 +executable cboard + main-is: cboard.hs + other-modules: + Paths_chessIO + hs-source-dirs: + app + default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns + ghc-options: -Wall -threaded + build-depends: + attoparsec + , base >=4.8 && <5 + , bytestring + , chessIO + , haskeline + , megaparsec + , mtl + , parser-combinators + , process + , split + , stm + , unordered-containers + , vector + default-language: Haskell2010 + test-suite perft type: exitcode-stdio-1.0 main-is: Perft.hs @@ -44,13 +77,20 @@ Paths_chessIO hs-source-dirs: test - default-extensions: BangPatterns BinaryLiterals DeriveGeneric NamedFieldPuns NumericUnderscores TupleSections ViewPatterns - ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N -s" + default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns + ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -s" build-depends: - base >=4.8 && <5 + attoparsec + , base >=4.8 && <5 + , bytestring , chessIO , directory + , megaparsec , parallel + , parser-combinators + , process + , stm , time + , unordered-containers , vector default-language: Haskell2010 diff --git a/src/Game/Chess.hs b/src/Game/Chess.hs --- a/src/Game/Chess.hs +++ b/src/Game/Chess.hs @@ -15,32 +15,124 @@ package name chessIO. -} module Game.Chess ( - -- * Representing chess positions - Position, startpos - -- * Converting from/to Forsyth-Edwards-Notation + -- * Chess positions + Color(..), opponent +, Sq(..), isLight, isDark +, PieceType(..) +, Position, startpos, color, pieceAt + -- ** Converting from/to Forsyth-Edwards-Notation , fromFEN, toFEN -- * Chess moves , Move - -- ** Converting from/to algebraic notation used by the Universal Chess Interface -, fromUCI, toUCI - -- ** Validating that a move is actually legal in a given position -, relativeTo + -- ** Converting from/to algebraic notation +, fromSAN, fromUCI, toUCI -- ** Move generation , moves -- ** Executing moves -, applyMove +, applyMove, unsafeApplyMove ) where +import Control.Applicative.Combinators import Data.Bits import Data.Char +import Data.Functor (($>)) import Data.Ix import Data.List import Data.Maybe import Data.Vector.Unboxed (Vector, (!)) +import Data.Void import qualified Data.Vector.Unboxed as Vector import Data.Word +import Text.Megaparsec +import Text.Megaparsec.Char import Text.Read +type Parser = Parsec Void String + +data From = File Int + | Rank Int + | Square Int + deriving (Show) + +san :: Parser (PieceType, Maybe From, Bool, Int, Maybe PieceType, Maybe Char) +san = conv <$> piece + <*> location + <*> optional (optional (char '=') *> promo) + <*> optional (char '+' <|> char '#') where + conv pc (Nothing, Nothing, cap, to) = (pc, Nothing, cap, to,,) + conv pc (Just f, Nothing, cap, to) = (pc, Just (File f), cap, to,,) + conv pc (Nothing, Just r, cap, to) = (pc, Just (Rank r), cap, to,,) + conv pc (Just f, Just r, cap, to) = (pc, Just (Square $ r*8+f), cap, to,,) + piece = char 'N' $> Knight + <|> char 'B' $> Bishop + <|> char 'R' $> Rook + <|> char 'Q' $> Queen + <|> char 'K' $> King + <|> pure Pawn + location = try ((,,,) <$> (Just <$> file) + <*> pure Nothing + <*> capture + <*> square) + <|> try ((,,,) <$> pure Nothing + <*> (Just <$> rank) + <*> capture + <*> square) + <|> try ((,,,) <$> (Just <$> file) + <*> (Just <$> rank) + <*> capture + <*> square) + <|> (,,,) <$> pure Nothing + <*> pure Nothing + <*> capture + <*> square + promo = char 'N' $> Knight + <|> char 'B' $> Bishop + <|> char 'R' $> Rook + <|> char 'Q' $> Queen + capture = option False $ char 'x' $> True + square = frToInt <$> file <*> rank + file = subtract (ord 'a') . ord <$> oneOf ['a'..'h'] + rank = subtract (ord '1') . ord <$> oneOf ['1'..'8'] + frToInt f r = r*8 + f + +fromSAN :: Position -> String -> Either String Move +fromSAN Position{color = White, flags} s + | s `elem` ["O-O", "0-0"] && flags `testMask` crwKs + = Right $ move (fromEnum E1) (fromEnum G1) +fromSAN Position{color = Black, flags} s + | s `elem` ["O-O", "0-0"] && flags `testMask` crbKs + = Right $ move (fromEnum E8) (fromEnum G8) +fromSAN Position{color = White, flags} s + | s `elem` ["O-O-O", "0-0-0"] && flags `testMask` crwQs + = Right $ move (fromEnum E1) (fromEnum C1) +fromSAN Position{color = Black, flags} s + | s `elem` ["O-O-O", "0-0-0"] && flags `testMask` crbQs + = Right $ move (fromEnum E8) (fromEnum C8) +fromSAN pos s = case parse san "" s of + Right (pc, from, capture, to, promo, status) -> + case ms pc from to promo of + [m] -> Right m + [] -> Left "Illegal move" + _ -> Left "Ambiguous move" + Left err -> Left $ errorBundlePretty err + where + ms pc from to prm = filter (f from) $ moves pos where + f (Just (Square from)) (unpack -> (from', to', prm')) = + pAt pos from' == pc && from' == from && to' == to && prm' == prm + f (Just (File ff)) (unpack -> (from', to', prm')) = + pAt pos from' == pc && from' `mod` 8 == ff && to == to' && prm == prm' + f (Just (Rank fr)) (unpack -> (from', to', prm')) = + pAt pos from' == pc && from' `div` 8 == fr && to == to' && prm == prm' + f Nothing (unpack -> (from', to', prm')) = + pAt pos from' == pc && to == to' && prm == prm' + pAt (Position BB{wP, wN, wB, wR, wQ, wK, bP, bN, bB, bR, bQ, bK} _ _ _ _) sq + | (wP .|. bP) `testBit` sq = Pawn + | (wN .|. bN) `testBit` sq = Knight + | (wB .|. bB) `testBit` sq = Bishop + | (wR .|. bR) `testBit` sq = Rook + | (wQ .|. bQ) `testBit` sq = Queen + | otherwise = King + -- | The starting position as given by the FEN string -- "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1". startpos :: Position @@ -48,8 +140,25 @@ fromFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1" data PieceType = Pawn | Knight | Bishop | Rook | Queen | King deriving (Eq, Show) -data Color = White | Black deriving (Eq, Ord, Show) +data Color = White | Black deriving (Eq, Show) + +pieceAt :: Position -> Sq -> Maybe (Color, PieceType) +pieceAt (board -> BB{wP, wN, wB, wR, wQ, wK, bP, bN, bB, bR, bQ, bK}) (fromEnum -> sq) + | wP `testBit` sq = Just (White, Pawn) + | wN `testBit` sq = Just (White, Knight) + | wB `testBit` sq = Just (White, Bishop) + | wR `testBit` sq = Just (White, Rook) + | wQ `testBit` sq = Just (White, Queen) + | wK `testBit` sq = Just (White, King) + | bP `testBit` sq = Just (Black, Pawn) + | bN `testBit` sq = Just (Black, Knight) + | bB `testBit` sq = Just (Black, Bishop) + | bR `testBit` sq = Just (Black, Rook) + | bQ `testBit` sq = Just (Black, Queen) + | bK `testBit` sq = Just (Black, King) + | otherwise = Nothing + opponent :: Color -> Color opponent White = Black opponent Black = White @@ -66,6 +175,11 @@ | A8 | B8 | C8 | D8 | E8 | F8 | G8 | H8 deriving (Bounded, Enum, Eq, Show) +isDark :: Sq -> Bool +isDark (fromEnum -> sq) = (0xaa55aa55aa55aa55 :: Word64) `testBit` sq + +isLight :: Sq -> Bool +isLight = not . isDark data Castling = Kingside | Queenside deriving (Eq, Ord, Show) data BB = BB { wP, wN, wB, wR, wQ, wK :: !Word64 @@ -149,7 +263,7 @@ -- | Convert a position to Forsyth-Edwards-Notation. toFEN :: Position -> String -toFEN (Position bb c flgs hm mn) = intercalate " " [ +toFEN (Position bb c flgs hm mn) = unwords [ intercalate "/" (rank <$> [7,6..0]) , showColor c, showCst (flgs `clearMask` epMask), showEP (flgs .&. epMask), show hm, show mn ] @@ -171,7 +285,7 @@ (r, f) = bitScanForward x `divMod` 8 rank r = concatMap countEmpty $ groupBy (\x y -> x == y && x == ' ') $ charAt r <$> [0..7] - countEmpty xs | head xs == ' ' = if length xs == 8 then "" else show (length xs) + countEmpty xs | head xs == ' ' = show $ length xs | otherwise = xs charAt r f | wP bb `testBit` b = 'P' @@ -196,8 +310,8 @@ occupied :: BB -> Word64 occupied bb = occupiedBy White bb .|. occupiedBy Black bb -empty :: BB -> Word64 -empty = complement . occupied +notOccupied :: BB -> Word64 +notOccupied = complement . occupied foldBits :: (a -> Int -> a) -> a -> Word64 -> a foldBits _ a 0 = a @@ -210,6 +324,9 @@ newtype Move = Move Word16 deriving (Eq) +instance Show Move where + show = toUCI + move :: Int -> Int -> Move move from to = Move $ fromIntegral from .|. fromIntegral to `unsafeShiftL` 6 @@ -234,14 +351,15 @@ _ -> Nothing -- | Parse a move in the format used by the Universal Chess Interface protocol. -fromUCI :: String -> Maybe Move -fromUCI (fmap (splitAt 2) . splitAt 2 -> (from, (to, promo))) - | length from == 2 && length to == 2 && length promo == 0 - = move <$> readCoord from <*> readCoord to +fromUCI :: Position -> String -> Maybe Move +fromUCI pos (fmap (splitAt 2) . splitAt 2 -> (from, (to, promo))) + | length from == 2 && length to == 2 && null promo + = move <$> readCoord from <*> readCoord to >>= relativeTo pos | length from == 2 && length to == 2 && length promo == 1 = (\f t p -> move f t `promoteTo` p) <$> readCoord from <*> readCoord to <*> readPromo promo + >>= relativeTo pos where readCoord [f,r] | inRange ('a','h') f && inRange ('1','8') r @@ -252,12 +370,13 @@ readPromo "b" = Just Bishop readPromo "n" = Just Knight readPromo _ = Nothing +fromUCI _ _ = Nothing -- | Convert a move to the format used by the Universal Chess Interface protocol. toUCI :: Move -> String toUCI (unpack -> (from, to, promo)) = coord from <> coord to <> p where coord x = let (r,f) = x `divMod` 8 in - chr (f + (ord 'a')) : [chr (r + (ord '1'))] + chr (f + ord 'a') : [chr (r + ord '1')] p = case promo of Just Queen -> "q" Just Rook -> "r" @@ -267,7 +386,7 @@ -- | Validate that a certain move is legal in the given position. relativeTo :: Position -> Move -> Maybe Move -relativeTo pos m | m `elem` (moves pos) = Just m +relativeTo pos m | m `elem` moves pos = Just m | otherwise = Nothing shiftN, shiftNNE, shiftNE, shiftENE, shiftE, shiftESE, shiftSE, shiftSSE, shiftS, shiftSSW, shiftSW, shiftWSW, shiftW, shiftWNW, shiftNW, shiftNNW :: Word64 -> Word64 @@ -289,31 +408,36 @@ shiftNNW w = w `unsafeShiftL` 15 .&. notHFile applyMove :: Position -> Move -> Position -applyMove pos m@(unpack -> (from, to, promo)) +applyMove p m + | m `elem` moves p = unsafeApplyMove p m + | otherwise = error "Game.Chess.applyMove: Illegal move" + +unsafeApplyMove :: Position -> Move -> Position +unsafeApplyMove pos m@(unpack -> (from, to, promo)) | m == wKscm && flags pos `testMask` crwKs = pos { board = bb { wK = wK bb `xor` mask - , wR = wR bb `xor` (bit (fromEnum H1) `setBit` (fromEnum F1)) + , wR = wR bb `xor` (bit (fromEnum H1) `setBit` fromEnum F1) } , color = opponent (color pos) , flags = flags pos `clearMask` (rank1 .|. epMask) } | m == wQscm && flags pos `testMask` crwQs = pos { board = bb { wK = wK bb `xor` mask - , wR = wR bb `xor` (bit (fromEnum A1) `setBit` (fromEnum D1)) + , wR = wR bb `xor` (bit (fromEnum A1) `setBit` fromEnum D1) } , color = opponent (color pos) , flags = flags pos `clearMask` (rank1 .|. epMask) } | m == bKscm && flags pos `testMask` crbKs = pos { board = bb { bK = bK bb `xor` mask - , bR = bR bb `xor` (bit (fromEnum H8) `setBit` (fromEnum F8)) + , bR = bR bb `xor` (bit (fromEnum H8) `setBit` fromEnum F8) } , color = opponent (color pos) , flags = flags pos `clearMask` (rank8 .|. epMask) } | m == bQscm && flags pos `testMask` crbQs = pos { board = bb { bK = bK bb `xor` mask - , bR = bR bb `xor` (bit (fromEnum A8) `setBit` (fromEnum D8)) + , bR = bR bb `xor` (bit (fromEnum A8) `setBit` fromEnum D8) } , color = opponent (color pos) , flags = flags pos `clearMask` (rank8 .|. epMask) @@ -423,8 +547,9 @@ Black | bit from .&. rank7 .&. bP bb /= 0 && from - 16 == to -> bit (from - 8) _ -> 0 +-- | Generate a list of possible moves for the given position. moves :: Position -> [Move] -moves pos@Position{color} = filter (not . legal) $ +moves pos@Position{color} = filter (not . check) $ pawnMoves pos <> slideMoves Bishop pos <> slideMoves Rook pos @@ -432,7 +557,7 @@ <> knightMoves pos <> kingMoves pos where - legal m = let board' = board (applyMove pos m) in case color of + check m = let board' = board (unsafeApplyMove pos m) in case color of White -> let kSq = bitScanForward (wK board') in attackedBy Black kSq board' Black -> let kSq = bitScanForward (bK board') in @@ -440,16 +565,16 @@ pawnMoves :: Position -> [Move] pawnMoves (Position bb White flags _ _) = - wPawnMoves (wP bb) (empty bb) (occupiedBy Black bb .|. (flags .&. epMask)) + wPawnMoves (wP bb) (notOccupied bb) (occupiedBy Black bb .|. (flags .&. epMask)) pawnMoves (Position bb Black flags _ _) = - bPawnMoves (bP bb) (empty bb) (occupiedBy White bb .|. (flags .&. epMask)) + bPawnMoves (bP bb) (notOccupied bb) (occupiedBy White bb .|. (flags .&. epMask)) wPawnMoves :: Word64 -> Word64 -> Word64 -> [Move] -wPawnMoves pawns empty opponentPieces = +wPawnMoves pawns emptySquares opponentPieces = foldBits (mkMove 9) (foldBits (mkMove 7) (foldBits (mkMove 8) (foldBits (mkMove 16) [] doublePushTargets) singlePushTargets) westCaptureTargets) eastCaptureTargets where - doublePushTargets = shiftN singlePushTargets .&. empty .&. rank4 - singlePushTargets = shiftN pawns .&. empty + doublePushTargets = shiftN singlePushTargets .&. emptySquares .&. rank4 + singlePushTargets = shiftN pawns .&. emptySquares eastCaptureTargets = shiftNE pawns .&. opponentPieces westCaptureTargets = shiftNW pawns .&. opponentPieces mkMove diff ms tsq @@ -458,11 +583,11 @@ where m = move (tsq - diff) tsq bPawnMoves :: Word64 -> Word64 -> Word64 -> [Move] -bPawnMoves pawns empty opponentPieces = +bPawnMoves pawns emptySquares opponentPieces = foldBits (mkMove 9) (foldBits (mkMove 7) (foldBits (mkMove 8) (foldBits (mkMove 16) [] doublePushTargets) singlePushTargets) eastCaptureTargets) westCaptureTargets where - doublePushTargets = shiftS singlePushTargets .&. empty .&. rank5 - singlePushTargets = shiftS pawns .&. empty + doublePushTargets = shiftS singlePushTargets .&. emptySquares .&. rank5 + singlePushTargets = shiftS pawns .&. emptySquares eastCaptureTargets = shiftSE pawns .&. opponentPieces westCaptureTargets = shiftSW pawns .&. opponentPieces mkMove diff ms tsq @@ -626,6 +751,7 @@ SW -> (bitScanReverse, attackSW) W -> (bitScanReverse, attackW) +attackDir :: (Word64 -> Word64) -> Vector Word64 attackDir s = Vector.generate 64 $ \sq -> foldr (.|.) 0 $ take 7 $ tail $ iterate s (bit sq) diff --git a/src/Game/Chess/UCI.hs b/src/Game/Chess/UCI.hs new file mode 100644 --- /dev/null +++ b/src/Game/Chess/UCI.hs @@ -0,0 +1,299 @@ +module Game.Chess.UCI ( + UCIException +, Engine, name, author, options, game +, currentPosition, readInfo, tryReadInfo, readBestMove, tryReadBestMove +, start, start', isready +, Option(..), getOption, setOptionSpinButton +, Info(..) +, send +, addMove, move +, quit, quit' +) where + +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.STM +import Control.Concurrent.STM.TChan +import Control.Exception +import Control.Monad +import Data.Attoparsec.Combinator +import Data.Attoparsec.ByteString.Char8 +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Functor +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.IORef +import Data.Ix +import Data.List +import Data.Maybe +import Data.String +import Game.Chess +import System.Exit +import System.IO +import System.Process +import System.Timeout (timeout) + +data Engine = Engine { + inH :: Handle +, outH :: Handle +, procH :: ProcessHandle +, outputStrLn :: String -> IO () +, infoThread :: Maybe ThreadId +, name :: Maybe ByteString +, author :: Maybe ByteString +, options :: HashMap ByteString Option +, isReady :: MVar () +, infoChan :: TChan [Info] +, bestMoveChan :: TChan (Move, Maybe Move) +, game :: IORef (Position, [Move]) +} + +readInfo :: Engine -> STM [Info] +readInfo = readTChan . infoChan + +tryReadInfo :: Engine -> STM (Maybe [Info]) +tryReadInfo = tryReadTChan . infoChan + +readBestMove :: Engine -> STM (Move, Maybe Move) +readBestMove = readTChan . bestMoveChan + +tryReadBestMove :: Engine -> STM (Maybe (Move, Maybe Move)) +tryReadBestMove = tryReadTChan . bestMoveChan + +data UCIException = SANError String deriving Show + + +instance Exception UCIException + +data Command = Name ByteString + | Author ByteString + | Option ByteString Option + | UCIOk + | ReadyOK + | Info [Info] + | BestMove !(Move, (Maybe Move)) + deriving (Show) + +data Info = PV [Move] + | Depth Int + | SelDepth Int + | Time Int + | MultiPV Int + | Score Int + | UpperBound + | LowerBound + | Nodes Int + | NPS Int + | TBHits Int + | HashFull Int + | CurrMove ByteString + | CurrMoveNumber Int + deriving Show + +data Option = CheckBox Bool + | ComboBox { comboBoxValue :: ByteString, comboBoxValues :: [ByteString] } + | SpinButton { spinButtonValue, spinButtonMinBound, spinButtonMaxBound :: Int } + | String ByteString + | Button + deriving (Eq, Show) + +instance IsString Option where + fromString = String . BS.pack + +command :: Position -> Parser Command +command pos = skipSpace *> choice [ + name, author, option, uciok, readyok, info, bestmove + ] <* skipSpace + where + name = fmap Name $ + "id" *> skipSpace *> "name" *> skipSpace *> takeByteString + author = fmap Author $ + "id" *> skipSpace *> "author" *> skipSpace *> takeByteString + option = do + void "option" + skipSpace + void "name" + skipSpace + optName <- BS.pack <$> manyTill anyChar (skipSpace *> "type") + skipSpace + optValue <- spin <|> check <|> combo <|> str <|> button + pure $ Option optName optValue + check = + fmap CheckBox $ "check" *> skipSpace *> "default" *> skipSpace *> + ("false" $> False <|> "true" $> True) + spin = do + void "spin" + skipSpace + value <- "default" *> skipSpace *> signed decimal <* skipSpace + minValue <- "min" *> skipSpace *> signed decimal <* skipSpace + maxValue <- "max" *> skipSpace *> signed decimal + pure $ SpinButton value minValue maxValue + combo = do + void "combo" + skipSpace + def <- fmap BS.pack $ "default" *> skipSpace *> manyTill anyChar var + (vars, lastVar) <- (,) <$> many (manyTill anyChar var) + <*> takeByteString + pure $ ComboBox def (map BS.pack vars <> [lastVar]) + var = skipSpace *> "var" *> skipSpace + str = fmap String $ + "string" *> skipSpace *> "default" *> skipSpace *> takeByteString + button = "button" $> Button + uciok = "uciok" $> UCIOk + readyok = "readyok" $> ReadyOK + info = do + "info" + skipSpace + Info <$> sepBy1 infoItem skipSpace + infoItem = Depth <$> ("depth" *> skipSpace *> decimal) + <|> SelDepth <$> ("seldepth" *> skipSpace *> decimal) + <|> MultiPV <$> ("multipv" *> skipSpace *> decimal) + <|> Score <$> ("score" *> skipSpace *> "cp" *> skipSpace *> signed decimal) + <|> UpperBound <$ "upperbound" + <|> LowerBound <$ "lowerbound" + <|> Nodes <$> ("nodes" *> skipSpace *> decimal) + <|> NPS <$> ("nps" *> skipSpace *> decimal) + <|> HashFull <$> ("hashfull" *> skipSpace *> decimal) + <|> TBHits <$> ("tbhits" *> skipSpace *> decimal) + <|> Time <$> ("time" *> skipSpace *> decimal) + <|> pv + <|> CurrMove <$> ("currmove" *> skipSpace *> mv) + <|> CurrMoveNumber <$> ("currmovenumber" *> skipSpace *> decimal) + pv = do + xs <- (fmap . fmap) BS.unpack $ "pv" *> skipSpace *> sepBy mv skipSpace + PV . snd <$> foldM toMove (pos, []) xs + toMove (pos, xs) s = do + case fromUCI pos s of + Just m -> pure (applyMove pos m, xs <> [m]) + Nothing -> fail $ "Failed to parse move " <> s + mv = fmap fst $ match $ satisfy f *> satisfy r *> satisfy f *> satisfy r *> optional (satisfy p) where + f = inRange ('a','h') + r = inRange ('1', '8') + p 'q' = True + p 'r' = True + p 'b' = True + p 'n' = True + p _ = False + bestmove = do + void "bestmove" + skipSpace + m <- BS.unpack <$> mv + ponder <- (fmap . fmap) BS.unpack $ + optional (skipSpace *> "ponder" *> skipSpace *> mv) + case fromUCI pos m of + Just m' -> case ponder of + Nothing -> pure $ BestMove (m', Nothing) + Just p -> case fromUCI (applyMove pos m') p of + Just p' -> pure $ BestMove (m', (Just p')) + Nothing -> fail $ "Failed to parse ponder move " <> p + Nothing -> fail $ "Failed to parse best move " <> m + +start :: String -> [String] -> IO (Maybe Engine) +start = start' 2000000 putStrLn + +start' :: Int -> (String -> IO ()) -> String -> [String] -> IO (Maybe Engine) +start' usec outputStrLn cmd args = do + (Just inH, Just outH, Nothing, procH) <- createProcess (proc cmd args) { + std_in = CreatePipe, std_out = CreatePipe + } + hSetBuffering inH LineBuffering + e <- Engine inH outH procH outputStrLn Nothing Nothing Nothing HashMap.empty <$> + newEmptyMVar <*> newTChanIO <*> newTChanIO <*> newIORef (startpos, []) + send "uci" e + timeout usec (initialise e) >>= \case + Just e' -> do + tid <- forkIO . infoReader $ e' + pure . Just $ e' { infoThread = Just tid } + Nothing -> quit e $> Nothing + +initialise :: Engine -> IO Engine +initialise c@Engine{outH, outputStrLn, game} = do + l <- BS.hGetLine outH + pos <- fst <$> readIORef game + if BS.null l then initialise c else case parseOnly (command pos <* endOfInput) l of + Left err -> do + outputStrLn . BS.unpack $ l + initialise c + Right (Name n) -> initialise (c { name = Just n }) + Right (Author a) -> initialise (c { author = Just a }) + Right (Option name opt) -> initialise (c { options = HashMap.insert name opt $ options c }) + Right UCIOk -> pure c + +infoReader :: Engine -> IO () +infoReader e@Engine{..} = forever $ do + l <- BS.hGetLine outH + pos <- currentPosition e + case parseOnly (command pos <* endOfInput) l of + Left err -> do + outputStrLn $ err <> ":" <> show l + Right ReadyOK -> putMVar isReady () + Right (Info i) -> atomically $ writeTChan infoChan i + Right (BestMove bm) -> atomically $ writeTChan bestMoveChan bm + +isready :: Engine -> IO () +isready e@Engine{isReady} = do + send "isready" e + takeMVar isReady + +send :: ByteString -> Engine -> IO () +send s Engine{inH, procH} = do + BS.hPutStrLn inH s + getProcessExitCode procH >>= \case + Nothing -> pure () + Just ec -> throwIO ec + +getOption :: ByteString -> Engine -> Maybe Option +getOption n = HashMap.lookup n . options + +setOptionSpinButton :: ByteString -> Int -> Engine -> IO Engine +setOptionSpinButton n v c + | Just (SpinButton _ minValue maxValue) <- getOption n c + , inRange (minValue, maxValue) v + = do + send ("setoption name " <> n <> " value " <> BS.pack (show v)) c + pure $ c { options = HashMap.update (set v) n $ options c } + where + set v opt@SpinButton{} = Just $ opt { spinButtonValue = v } + +currentPosition :: Engine -> IO Position +currentPosition Engine{game} = + uncurry (foldl' applyMove) <$> readIORef game + +nextMove :: Engine -> IO Color +nextMove Engine{game} = do + (initialPosition, history) <- readIORef game + pure $ if even . length $ history then color initialPosition else opponent . color $ initialPosition + +move :: Engine -> String -> IO () +move e@Engine{game} san = do + pos <- currentPosition e + case fromSAN pos san of + Left err -> throwIO $ SANError err + Right m -> do + addMove e m + sendPosition e + +addMove :: Engine -> Move -> IO () +addMove e@Engine{game} m = + atomicModifyIORef' game \g -> (fmap (<> [m]) g, ()) + +sendPosition :: Engine -> IO () +sendPosition e@Engine{game} = do + readIORef game >>= (flip send) e . cmd + where + cmd (p, h) = "position fen " <> BS.pack (toFEN p) <> line h + line h + | null h = "" + | otherwise = " moves " <> BS.unwords (BS.pack . toUCI <$> h) + +quit :: Engine -> IO (Maybe ExitCode) +quit = quit' 1000000 + +quit' :: Int -> Engine -> IO (Maybe ExitCode) +quit' usec c@Engine{procH, infoThread} = (pure . Just) `handle` do + maybe (pure ()) killThread infoThread + send "quit" c + timeout usec (waitForProcess procH) >>= \case + Just ec -> pure $ Just ec + Nothing -> terminateProcess procH $> Nothing diff --git a/src/Game/Debug.hs b/src/Game/Debug.hs deleted file mode 100644 --- a/src/Game/Debug.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Game.Debug where - -import Data.Bits -import Data.List -import Numeric - -newtype Hex a = Hex { bless :: a } -instance (Integral a, Show a) => Show (Hex a) where - show (Hex a) = showHex a "" - -newtype BitBoard a = BitBoard a -instance (Bits a) => Show (BitBoard a) where - show (BitBoard v) = intercalate "\n" $ map row [7,6..0] where - row r = map (cell r) [0..7] - cell r f | testBit v (r*8+f) = 'o' - | otherwise = '.' diff --git a/test/Perft.hs b/test/Perft.hs --- a/test/Perft.hs +++ b/test/Perft.hs @@ -15,7 +15,7 @@ main = do start <- getCurrentTime exists <- doesFileExist "perftsuite.epd" - ok <- if exists + result <- if exists then do suite <- readTestSuite "perftsuite.epd" runTestSuite suite @@ -23,10 +23,15 @@ for_ [0..6] $ \n -> do putStrLn $ showResult n (perft n startpos) hFlush stdout - pure False + pure Nothing end <- getCurrentTime + case result of + Just PerftResult{nodes} -> putStrLn $ + "nps: " <> + show (floor (realToFrac (fromIntegral nodes) / realToFrac (diffUTCTime end start))) + _ -> pure () putStrLn $ "Time: " <> show (diffUTCTime end start) - exitWith $ if ok then ExitSuccess else ExitFailure 1 + exitWith $ if isJust result then ExitSuccess else ExitFailure 1 data PerftResult = PerftResult { nodes :: !Integer } deriving (Eq, Generic, Show) instance NFData PerftResult @@ -43,28 +48,28 @@ perft :: Int -> Position -> PerftResult perft 0 _ = PerftResult 1 perft 1 p = PerftResult . fromIntegral . length $ - applyMove p <$> moves p -perft 2 p = fold . map (perft 1) $ applyMove p <$> moves p + unsafeApplyMove p <$> moves p +perft 2 p = fold . map (perft 1) $ unsafeApplyMove p <$> moves p perft n p = fold . withStrategy (parList rdeepseq) . map (perft $ pred n) $ - applyMove p <$> moves p + unsafeApplyMove p <$> moves p -runTestSuite :: [(Position, [(Int, PerftResult)])] -> IO Bool -runTestSuite = fmap (all id) . traverse (uncurry test) where - test pos ((depth, expected) : more) +runTestSuite :: [(Position, [(Int, PerftResult)])] -> IO (Maybe PerftResult) +runTestSuite = fmap fold . traverse (uncurry (test mempty)) where + test sum pos ((depth, expected) : more) | result == expected = do putStrLn $ "OK " <> fen <> " ;D" <> show depth <> " " <> show (nodes expected) hFlush stdout - test pos more + test (sum <> result) pos more | otherwise = do putStrLn $ "FAIL " <> fen <> " ;D" <> show depth <> " " <> show (nodes expected) <> " /= " <> show (nodes result) - pure False + pure Nothing where result = perft depth pos fen = toFEN pos - test _ [] = pure True + test sum _ [] = pure (Just sum) readTestSuite :: FilePath -> IO [(Position, [(Int, PerftResult)])] readTestSuite fp = do