diff --git a/README.rst b/README.rst new file mode 100644 --- /dev/null +++ b/README.rst @@ -0,0 +1,30 @@ +chessIO -- A Haskell chess library and console UCI frontend program +=================================================================== + +chessIO is a Haskell library for working with chess positions and moves, and a +console frontend program (cboard) to work with UCI compatible chess engines. + +The Library +----------- + +The main module provided by the library is Game.Chess_, which defines +data types and functions for working with chess positions and moves. +It offers a fully compliant move generator and parsing for and printing +positions in `Forsyth-Edwards Notation`_ and moves in `Algebraic Notation`_. + +Module Game.Chess.UCI_ provides functionality to run an external process +which understands the Universal Chess Interface protocol from within Haskell. + +cboard -- Console frontend for the Universal Chess Interface protocl +-------------------------------------------------------------------- + +cboard is a simple console (text-mode) frontend for interacting with chess engines +(like stockfish or glaurung) which make use of the UCI protocol. + +To launch a chess engine, simply pass its executable name and arguments +to cboard. For instance, `cboard stockfish`. + +.. _`Forsyth-Edwards Notation`: https://en.wikipedia.org/wiki/Forsyth%E2%80%93Edwards_Notation +.. _`Algebraic Notation`: https://en.wikipedia.org/wiki/Algebraic_notation_(chess) +.. _Game.Chess: https://hackage.haskell.org/package/chessIO/docs/Game-Chess.html +.. _Game.Chess.UCI: https://hackage.haskell.org/package/chessIO/docs/Game-Chess-UCI.html diff --git a/app/cboard.hs b/app/cboard.hs --- a/app/cboard.hs +++ b/app/cboard.hs @@ -22,22 +22,39 @@ , hintRef :: IORef (Maybe Move) } +main :: IO () 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 + (cmd:args) -> 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 (setComplete (completeSAN e) defaultSettings) chessIO `evalStateT` s + exitSuccess +completeSAN :: MonadIO m => UCI.Engine -> CompletionFunc m +completeSAN e = completeWord Nothing "" $ \w -> + fmap (map mkCompletion . filter (w `isPrefixOf`)) $ do + pos <- liftIO $ UCI.currentPosition e + pure $ unsafeToSAN pos <$> moves pos + where + mkCompletion s = (simpleCompletion s) { isFinished = False } + chessIO :: InputT (StateT S IO) () chessIO = do + outputStr . unlines $ [ + "" + , "Enter a FEN string to set the starting position." + , "To make a move, enter a SAN or UCI string." + , "Type \"hint\" to ask for a suggestion." + , "Empty input will redraw the board." + , "Hit Ctrl-D to quit." + , "" + ] externalPrint <- getExternalPrint e <- lift $ gets engine hr <- lift $ gets hintRef @@ -60,20 +77,21 @@ getInputLine "> " >>= \case Nothing -> pure () Just input - | null input -> loop + | null input -> outputBoard *> loop | Just position <- fromFEN input -> do - outputStrLn $ toFEN position - loop + liftIO $ UCI.setPosition e position + outputBoard *> loop | input == "hint" -> do lift (gets hintRef) >>= liftIO . readIORef >>= \case - Just hint -> outputStrLn $ "Try " <> show hint + Just hint -> do + pos <- liftIO $ UCI.currentPosition e + outputStrLn $ "Try " <> toSAN pos 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 + liftIO $ printUCIException `handle` do + UCI.move e input + UCI.send "go movetime 1000" e outputBoard loop @@ -81,7 +99,7 @@ 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 + 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' @@ -96,11 +114,13 @@ 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 + pos <- UCI.currentPosition e + externalPrint $ "< " <> toSAN pos bm UCI.addMove e bm - externalPrint $ "< " <> show bm UCI.currentPosition e >>= printBoard externalPrint writeIORef hintRef ponder @@ -115,4 +135,5 @@ isPV _ = False printUCIException :: UCI.UCIException -> IO () -printUCIException e = print e +printUCIException (UCI.SANError e) = putStrLn e +printUCIException (UCI.IllegalMove m) = putStrLn $ "Illegal move: " <> show m diff --git a/chessIO.cabal b/chessIO.cabal --- a/chessIO.cabal +++ b/chessIO.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 4e2926a2dc0dbb48166ba6817910daed6e92c23dbc6e644942c9ebcfe3922702 +-- hash: 599aad9935d6d4f50f3cc7799f7a98a7dda1a711826adbe805ab542e16f0affe name: chessIO -version: 0.1.0.0 +version: 0.2.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 @@ -19,6 +19,8 @@ license: BSD3 license-file: LICENSE build-type: Simple +extra-source-files: + README.rst source-repository head type: git @@ -33,7 +35,7 @@ hs-source-dirs: src default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns - ghc-options: -Wall + ghc-options: -Wall -O2 build-depends: attoparsec , base >=4.8 && <5 @@ -53,7 +55,7 @@ hs-source-dirs: app default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns - ghc-options: -Wall -threaded + ghc-options: -Wall -O2 -threaded build-depends: attoparsec , base >=4.8 && <5 @@ -78,7 +80,7 @@ hs-source-dirs: test default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns - ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -s" + ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N -s" build-depends: attoparsec , base >=4.8 && <5 diff --git a/src/Game/Chess.hs b/src/Game/Chess.hs --- a/src/Game/Chess.hs +++ b/src/Game/Chess.hs @@ -19,13 +19,13 @@ Color(..), opponent , Sq(..), isLight, isDark , PieceType(..) -, Position, startpos, color, pieceAt +, Position, startpos, color, pieceAt, inCheck -- ** Converting from/to Forsyth-Edwards-Notation , fromFEN, toFEN -- * Chess moves , Move -- ** Converting from/to algebraic notation -, fromSAN, fromUCI, toUCI +, fromSAN, toSAN, unsafeToSAN, fromUCI, toUCI -- ** Move generation , moves -- ** Executing moves @@ -62,7 +62,7 @@ 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,,) + 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 @@ -97,19 +97,15 @@ 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) + | s `elem` ["O-O", "0-0"] && flags `testMask` crwKs = Right wKscm fromSAN Position{color = Black, flags} s - | s `elem` ["O-O", "0-0"] && flags `testMask` crbKs - = Right $ move (fromEnum E8) (fromEnum G8) + | s `elem` ["O-O", "0-0"] && flags `testMask` crbKs = Right bKscm fromSAN Position{color = White, flags} s - | s `elem` ["O-O-O", "0-0-0"] && flags `testMask` crwQs - = Right $ move (fromEnum E1) (fromEnum C1) + | s `elem` ["O-O-O", "0-0-0"] && flags `testMask` crwQs = Right wQscm fromSAN Position{color = Black, flags} s - | s `elem` ["O-O-O", "0-0-0"] && flags `testMask` crbQs - = Right $ move (fromEnum E8) (fromEnum C8) + | s `elem` ["O-O-O", "0-0-0"] && flags `testMask` crbQs = Right bQscm fromSAN pos s = case parse san "" s of - Right (pc, from, capture, to, promo, status) -> + Right (pc, from, _, to, promo, _) -> case ms pc from to promo of [m] -> Right m [] -> Left "Illegal move" @@ -118,21 +114,68 @@ 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 + pAt 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' + pAt 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' + pAt 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 + pAt from' == pc && to == to' && prm == prm' + pAt = snd . fromJust . pieceAt pos . toEnum +toSAN :: Position -> Move -> String +toSAN pos m | m `elem` moves pos = unsafeToSAN pos m + | otherwise = error "Game.Chess.toSAN: Illegal move" + +unsafeToSAN :: Position -> Move -> String +unsafeToSAN pos@Position{flags} m@(unpack -> (from, to, promo)) = + moveStr <> status + where + moveStr = case piece of + Pawn | isCapture -> fileChar from : target <> promotion + | otherwise -> target <> promotion + King | color pos == White && m == wKscm -> "O-O" + | color pos == White && m == wQscm -> "O-O-O" + | color pos == Black && m == bKscm -> "O-O" + | color pos == Black && m == bQscm -> "O-O-O" + | otherwise -> 'K' : target + Knight -> 'N' : source <> target + Bishop -> 'B' : source <> target + Rook -> 'R' : source <> target + Queen -> 'Q' : source <> target + piece = fromJust $ snd <$> pieceAt pos (toEnum from) + isCapture = isJust (pieceAt pos $ toEnum to) || (flags .&. epMask) `testBit` to + source + | length ms == 1 = [] + | length (filter fEq ms) == 1 = [fileChar from] + | length (filter rEq ms) == 1 = [rankChar from] + | otherwise = coord from + target + | isCapture = 'x' : coord to + | otherwise = coord to + promotion = case promo of + Just Knight -> "N" + Just Bishop -> "B" + Just Rook -> "R" + Just Queen -> "Q" + _ -> "" + status | inCheck (color nextPos) nextPos && null (moves nextPos) + = "#" + | inCheck (color nextPos) nextPos + = "+" + | otherwise + = "" + nextPos = unsafeApplyMove pos m + ms = filter movesTo $ moves pos + movesTo (unpack -> (from', to', _)) = + fmap snd (pieceAt pos (toEnum from')) == Just piece && to' == to + fEq (unpack -> (from', _, _)) = from' `mod` 8 == fromFile + rEq (unpack -> (from', _, _)) = from' `div` 8 == fromRank + (fromRank, fromFile) = from `divMod` 8 + fileChar i = chr $ (i `mod` 8) + ord 'a' + rankChar i = chr $ (i `div` 8) + ord '1' + coord i = let (r,f) = i `divMod` 8 in chr (f + ord 'a') : [chr (r + ord '1')] + -- | The starting position as given by the FEN string -- "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1". startpos :: Position @@ -199,7 +242,7 @@ -- | Construct a position from Forsyth-Edwards-Notation. fromFEN :: String -> Maybe Position -fromFEN s +fromFEN fen | length parts /= 6 = Nothing | otherwise = @@ -209,7 +252,7 @@ <*> readMaybe (parts !! 4) <*> readMaybe (parts !! 5) where - parts = words s + parts = words fen readBoard = go (sqToRF A8) emptyBB where go rf@(r,f) bb ('r':s) = go (r, f + 1) (bb { bR = bR bb .|. rfBit rf }) s go rf@(r,f) bb ('n':s) = go (r, f + 1) (bb { bN = bN bb .|. rfBit rf }) s @@ -315,7 +358,7 @@ foldBits :: (a -> Int -> a) -> a -> Word64 -> a foldBits _ a 0 = a -foldBits f !a n = foldBits f (f a lsb) (n `clearBit` lsb) where +foldBits f !a n = foldBits f (f a lsb) (n `xor` (1 `unsafeShiftL` lsb)) where !lsb = countTrailingZeros n bitScanForward, bitScanReverse :: Word64 -> Int @@ -407,40 +450,47 @@ shiftNW w = w `unsafeShiftL` 7 .&. notHFile shiftNNW w = w `unsafeShiftL` 15 .&. notHFile +-- | Apply a move to the given position. +-- +-- This function checks if the move is actually legal and throws and error +-- if it isn't. See 'unsafeApplyMove' for a version that omits the legality check. applyMove :: Position -> Move -> Position applyMove p m | m `elem` moves p = unsafeApplyMove p m | otherwise = error "Game.Chess.applyMove: Illegal move" +-- | An unsafe version of 'applyMove'. Only use this if you are sure the given move +-- can be applied to the position. This is useful if the move has been generated +-- by the 'moves' function. unsafeApplyMove :: Position -> Move -> Position -unsafeApplyMove pos m@(unpack -> (from, to, promo)) - | m == wKscm && flags pos `testMask` crwKs +unsafeApplyMove pos@Position{flags} m@(unpack -> (from, to, promo)) + | m == wKscm && flags `testMask` crwKs = pos { board = bb { wK = wK bb `xor` mask , wR = wR bb `xor` (bit (fromEnum H1) `setBit` fromEnum F1) } , color = opponent (color pos) - , flags = flags pos `clearMask` (rank1 .|. epMask) + , flags = flags `clearMask` (rank1 .|. epMask) } - | m == wQscm && flags pos `testMask` crwQs + | m == wQscm && flags `testMask` crwQs = pos { board = bb { wK = wK bb `xor` mask , wR = wR bb `xor` (bit (fromEnum A1) `setBit` fromEnum D1) } , color = opponent (color pos) - , flags = flags pos `clearMask` (rank1 .|. epMask) + , flags = flags `clearMask` (rank1 .|. epMask) } - | m == bKscm && flags pos `testMask` crbKs + | m == bKscm && flags `testMask` crbKs = pos { board = bb { bK = bK bb `xor` mask , bR = bR bb `xor` (bit (fromEnum H8) `setBit` fromEnum F8) } , color = opponent (color pos) - , flags = flags pos `clearMask` (rank8 .|. epMask) + , flags = flags `clearMask` (rank8 .|. epMask) } - | m == bQscm && flags pos `testMask` crbQs + | m == bQscm && flags `testMask` crbQs = pos { board = bb { bK = bK bb `xor` mask , bR = bR bb `xor` (bit (fromEnum A8) `setBit` fromEnum D8) } , color = opponent (color pos) - , flags = flags pos `clearMask` (rank8 .|. epMask) + , flags = flags `clearMask` (rank8 .|. epMask) } | Just Queen <- promo , color pos == White @@ -448,7 +498,7 @@ , wQ = wQ bb `setBit` to } , color = opponent (color pos) - , flags = flags pos `clearMask` (epMask .|. bit to) + , flags = flags `clearMask` (epMask .|. bit to) } | Just Rook <- promo , color pos == White @@ -456,7 +506,7 @@ , wR = wR bb `setBit` to } , color = opponent (color pos) - , flags = flags pos `clearMask` (epMask .|. bit to) + , flags = flags `clearMask` (epMask .|. bit to) } | Just Bishop <- promo , color pos == White @@ -464,7 +514,7 @@ , wB = wB bb `setBit` to } , color = opponent (color pos) - , flags = flags pos `clearMask` (epMask .|. bit to) + , flags = flags `clearMask` (epMask .|. bit to) } | Just Knight <- promo , color pos == White @@ -472,7 +522,7 @@ , wN = wN bb `setBit` to } , color = opponent (color pos) - , flags = flags pos `clearMask` (epMask .|. bit to) + , flags = flags `clearMask` (epMask .|. bit to) } | Just Queen <- promo , color pos == Black @@ -480,7 +530,7 @@ , bQ = bQ bb `setBit` to } , color = opponent (color pos) - , flags = flags pos `clearMask` (epMask .|. bit to) + , flags = flags `clearMask` (epMask .|. bit to) } | Just Rook <- promo , color pos == Black @@ -488,7 +538,7 @@ , bR = bR bb `setBit` to } , color = opponent (color pos) - , flags = flags pos `clearMask` (epMask .|. bit to) + , flags = flags `clearMask` (epMask .|. bit to) } | Just Bishop <- promo , color pos == Black @@ -496,7 +546,7 @@ , bB = bB bb `setBit` to } , color = opponent (color pos) - , flags = flags pos `clearMask` (epMask .|. bit to) + , flags = flags `clearMask` (epMask .|. bit to) } | Just Knight <- promo , color pos == Black @@ -504,74 +554,86 @@ , bN = bN bb `setBit` to } , color = opponent (color pos) - , flags = flags pos `clearMask` (epMask .|. bit to) + , flags = flags `clearMask` (epMask .|. bit to) } | otherwise = pos { board = newBoard , color = opponent (color pos) - , flags = (flags pos `clearMask` (epMask .|. mask)) .|. dpp } + , flags = (flags `clearMask` (epMask .|. mask)) .|. dpp } where !bb = board pos epBit = case color pos of - White | bit from .&. wP bb /= 0 -> shiftS $ flags pos .&. rank6 .&. bit to - Black | bit from .&. bP bb /= 0 -> shiftN $ flags pos .&. rank3 .&. bit to + White | wP bb `testMask` fromMask -> shiftS $ flags .&. rank6 .&. toMask + Black | bP bb `testMask` fromMask -> shiftN $ flags .&. rank3 .&. toMask _ -> 0 - clearW = bb { wP = wP bb `clearBit` to `clearMask` epBit - , wN = wN bb `clearBit` to - , wB = wB bb `clearBit` to - , wR = wR bb `clearBit` to - , wQ = wQ bb `clearBit` to + clearW = bb { wP = wP bb `clearMask` (toMask .|. epBit) + , wN = wN bb `clearMask` toMask + , wB = wB bb `clearMask` toMask + , wR = wR bb `clearMask` toMask + , wQ = wQ bb `clearMask` toMask } - clearB = bb { bP = bP bb `clearBit` to `clearMask` epBit - , bN = bN bb `clearBit` to - , bB = bB bb `clearBit` to - , bR = bR bb `clearBit` to - , bQ = bQ bb `clearBit` to + clearB = bb { bP = bP bb `clearMask` (toMask .|. epBit) + , bN = bN bb `clearMask` toMask + , bB = bB bb `clearMask` toMask + , bR = bR bb `clearMask` toMask + , bQ = bQ bb `clearMask` toMask } - !mask = bit from `setBit` to + !fromMask = 1 `unsafeShiftL` from + !toMask = 1 `unsafeShiftL` to + !mask = fromMask .|. toMask newBoard = case color pos of - White | wP bb `testBit` from -> clearB { wP = wP bb `xor` mask } - | wN bb `testBit` from -> clearB { wN = wN bb `xor` mask } - | wB bb `testBit` from -> clearB { wB = wB bb `xor` mask } - | wR bb `testBit` from -> clearB { wR = wR bb `xor` mask } - | wQ bb `testBit` from -> clearB { wQ = wQ bb `xor` mask } + White | wP bb `testMask` fromMask -> clearB { wP = wP bb `xor` mask } + | wN bb `testMask` fromMask -> clearB { wN = wN bb `xor` mask } + | wB bb `testMask` fromMask -> clearB { wB = wB bb `xor` mask } + | wR bb `testMask` fromMask -> clearB { wR = wR bb `xor` mask } + | wQ bb `testMask` fromMask -> clearB { wQ = wQ bb `xor` mask } | otherwise -> clearB { wK = wK bb `xor` mask } - Black | bP bb `testBit` from -> clearW { bP = bP bb `xor` mask } - | bN bb `testBit` from -> clearW { bN = bN bb `xor` mask } - | bB bb `testBit` from -> clearW { bB = bB bb `xor` mask } - | bR bb `testBit` from -> clearW { bR = bR bb `xor` mask } - | bQ bb `testBit` from -> clearW { bQ = bQ bb `xor` mask } + Black | bP bb `testMask` fromMask -> clearW { bP = bP bb `xor` mask } + | bN bb `testMask` fromMask -> clearW { bN = bN bb `xor` mask } + | bB bb `testMask` fromMask -> clearW { bB = bB bb `xor` mask } + | bR bb `testMask` fromMask -> clearW { bR = bR bb `xor` mask } + | bQ bb `testMask` fromMask -> clearW { bQ = bQ bb `xor` mask } | otherwise -> clearW { bK = bK bb `xor` mask } dpp = case color pos of - White | bit from .&. rank2 .&. wP bb /= 0 && from + 16 == to -> bit (from + 8) - Black | bit from .&. rank7 .&. bP bb /= 0 && from - 16 == to -> bit (from - 8) + White | fromMask .&. rank2 .&. wP bb /= 0 && from + 16 == to -> bit (from + 8) + Black | fromMask .&. 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 . check) $ - pawnMoves pos - <> slideMoves Bishop pos - <> slideMoves Rook pos - <> slideMoves Queen pos - <> knightMoves pos - <> kingMoves pos +moves pos@Position{color, board, flags} = + filter (not . inCheck color . unsafeApplyMove pos) $ + kingMoves pos notOurs + . knightMoves + . slideMoves Queen pos ours notOurs + . slideMoves Rook pos ours notOurs + . slideMoves Bishop pos ours notOurs + . pawnMoves + $ [] where - 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 - attackedBy White kSq board' + ours = occupiedBy color board + notOurs = complement ours + (!pawnMoves, !knightMoves) = case color of + White -> + ( wPawnMoves (wP board) (notOccupied board) (occupiedBy Black board .|. (flags .&. epMask)) + , flip (foldBits genNMoves) (wN board)) + Black -> + ( bPawnMoves (bP board) (notOccupied board) (occupiedBy White board .|. (flags .&. epMask)) + , flip (foldBits genNMoves) (bN board)) + genNMoves ms sq = foldBits (mkM sq) ms ((knightAttacks ! sq) .&. notOurs) + mkM from ms to = move from to : ms -pawnMoves :: Position -> [Move] -pawnMoves (Position bb White flags _ _) = - wPawnMoves (wP bb) (notOccupied bb) (occupiedBy Black bb .|. (flags .&. epMask)) -pawnMoves (Position bb Black flags _ _) = - bPawnMoves (bP bb) (notOccupied bb) (occupiedBy White bb .|. (flags .&. epMask)) +-- | Returns 'True' if 'Color' is in check in the given position. +inCheck :: Color -> Position -> Bool +inCheck White Position{board} = attackedBy Black (bitScanForward (wK board)) board +inCheck Black Position{board} = attackedBy White (bitScanForward (bK board)) board -wPawnMoves :: Word64 -> Word64 -> Word64 -> [Move] +wPawnMoves :: Word64 -> Word64 -> Word64 -> [Move] -> [Move] wPawnMoves pawns emptySquares opponentPieces = - foldBits (mkMove 9) (foldBits (mkMove 7) (foldBits (mkMove 8) (foldBits (mkMove 16) [] doublePushTargets) singlePushTargets) westCaptureTargets) eastCaptureTargets + flip (foldBits $ mkMove 9) eastCaptureTargets + . flip (foldBits $ mkMove 7) westCaptureTargets + . flip (foldBits $ mkMove 8) singlePushTargets + . flip (foldBits $ mkMove 16) doublePushTargets where doublePushTargets = shiftN singlePushTargets .&. emptySquares .&. rank4 singlePushTargets = shiftN pawns .&. emptySquares @@ -582,9 +644,12 @@ | otherwise = m : ms where m = move (tsq - diff) tsq -bPawnMoves :: Word64 -> Word64 -> Word64 -> [Move] +bPawnMoves :: Word64 -> Word64 -> Word64 -> [Move] -> [Move] bPawnMoves pawns emptySquares opponentPieces = - foldBits (mkMove 9) (foldBits (mkMove 7) (foldBits (mkMove 8) (foldBits (mkMove 16) [] doublePushTargets) singlePushTargets) eastCaptureTargets) westCaptureTargets + flip (foldBits $ mkMove 9) westCaptureTargets + . flip (foldBits $ mkMove 7) eastCaptureTargets + . flip (foldBits $ mkMove 8) singlePushTargets + . flip (foldBits $ mkMove 16) doublePushTargets where doublePushTargets = shiftS singlePushTargets .&. emptySquares .&. rank5 singlePushTargets = shiftS pawns .&. emptySquares @@ -595,9 +660,9 @@ | otherwise = m : ms where m = move (tsq + diff) tsq -slideMoves :: PieceType -> Position -> [Move] -slideMoves piece (Position bb c _ _ _) = - foldBits gen mempty pieces +slideMoves :: PieceType -> Position -> Word64 -> Word64 -> [Move] -> [Move] +slideMoves piece (Position bb c _ _ _) ours notOurs = + flip (foldBits gen) pieces where gen ms from = foldBits (mkMove from) ms (targets from) mkMove from ms to = move from to : ms @@ -606,8 +671,6 @@ Bishop -> bishopTargets sq occ .&. notOurs Queen -> queenTargets sq occ .&. notOurs _ -> error "Not a sliding piece" - ours = occupiedBy c bb - notOurs = complement ours occ = ours .|. occupiedBy (opponent c) bb pieces = case (c, piece) of (White, Bishop) -> wB bb @@ -618,48 +681,38 @@ (Black, Queen) -> bQ bb _ -> 0 -knightMoves, kingMoves :: Position -> [Move] -knightMoves Position{board, color} = case color of - White -> nMoves (wN board) - Black -> nMoves (bN board) - where - nMoves = foldBits gen mempty - gen ms sq = foldBits (mkMove sq) ms ((knightAttacks ! sq) .&. notOurs) - mkMove from ms to = move from to : ms - notOurs = complement $ occupiedBy color board - -kingMoves pos@Position{board, color} = case color of - White -> kMoves (wK board) <> wCastleMoves pos - Black -> kMoves (bK board) <> bCastleMoves pos +kingMoves :: Position -> Word64 -> [Move] -> [Move] +kingMoves pos@Position{board, color} notOurs ml = case color of + White -> kMoves (wK board) . wCastleMoves pos $ ml + Black -> kMoves (bK board) . bCastleMoves pos $ ml where - kMoves = foldBits gen mempty + kMoves = flip (foldBits gen) gen ms sq = foldBits (mkMove sq) ms ((kingAttacks ! sq) .&. notOurs) mkMove from ms to = move from to : ms - notOurs = complement $ occupiedBy color board -wCastleMoves, bCastleMoves :: Position -> [Move] -wCastleMoves (Position board _ flags _ _) = short <> long where - short | flags `testMask` crwKs && occupied board .&. crwKe == 0 && - not (attackedBy Black (fromEnum E1) board) && - not (attackedBy Black (fromEnum F1) board) - = [wKscm] - | otherwise = [] - long | flags `testMask` crwQs && occupied board .&. crwQe == 0 && - not (attackedBy Black (fromEnum E1) board) && - not (attackedBy Black (fromEnum D1) board) - = [wQscm] - | otherwise = [] -bCastleMoves (Position board _ flags _ _) = short <> long where - short | flags `testMask` crbKs && occupied board .&. crbKe == 0 && - not (attackedBy White (fromEnum E8) board) && - not (attackedBy White (fromEnum F8) board) - = [bKscm] - | otherwise = [] - long | flags `testMask` crbQs && occupied board .&. crbQe == 0 && - not (attackedBy White (fromEnum E8) board) && - not (attackedBy White (fromEnum D8) board) - = [bQscm] - | otherwise = [] +wCastleMoves, bCastleMoves :: Position -> [Move] -> [Move] +wCastleMoves (Position board _ flags _ _) = short . long where + short ml | flags `testMask` crwKs && occupied board .&. crwKe == 0 && + not (attackedBy Black (fromEnum E1) board) && + not (attackedBy Black (fromEnum F1) board) + = wKscm : ml + | otherwise = ml + long ml | flags `testMask` crwQs && occupied board .&. crwQe == 0 && + not (attackedBy Black (fromEnum E1) board) && + not (attackedBy Black (fromEnum D1) board) + = wQscm : ml + | otherwise = ml +bCastleMoves (Position board _ flags _ _) = short . long where + short ml | flags `testMask` crbKs && occupied board .&. crbKe == 0 && + not (attackedBy White (fromEnum E8) board) && + not (attackedBy White (fromEnum F8) board) + = bKscm : ml + | otherwise = ml + long ml | flags `testMask` crbQs && occupied board .&. crbQe == 0 && + not (attackedBy White (fromEnum E8) board) && + not (attackedBy White (fromEnum D8) board) + = bQscm : ml + | otherwise = ml wKscm, wQscm, bKscm, bQscm :: Move wKscm = move (fromEnum E1) (fromEnum G1) @@ -774,9 +827,7 @@ {-# INLINE clearMask #-} {-# INLINE attackedBy #-} {-# INLINE kingMoves #-} -{-# INLINE knightMoves #-} {-# INLINE slideMoves #-} -{-# INLINE pawnMoves #-} {-# INLINE wPawnMoves #-} {-# INLINE bPawnMoves #-} {-# INLINE unpack #-} diff --git a/src/Game/Chess/UCI.hs b/src/Game/Chess/UCI.hs --- a/src/Game/Chess/UCI.hs +++ b/src/Game/Chess/UCI.hs @@ -1,13 +1,19 @@ module Game.Chess.UCI ( - UCIException -, Engine, name, author, options, game -, currentPosition, readInfo, tryReadInfo, readBestMove, tryReadBestMove -, start, start', isready -, Option(..), getOption, setOptionSpinButton -, Info(..) + -- * Exceptions + UCIException(..) + -- * The Engine data type +, Engine, name, author + -- * Starting and quitting a UCI engine +, start, start' , send -, addMove, move , quit, quit' + -- * Engine options +, Option(..), options, getOption, setOptionSpinButton + -- * Manipulating the current game information +, currentPosition, setPosition, addMove, move + -- * Reading engine output +, Info(..), readInfo, tryReadInfo +, readBestMove, tryReadBestMove ) where import Control.Applicative @@ -61,8 +67,16 @@ tryReadBestMove :: Engine -> STM (Maybe (Move, Maybe Move)) tryReadBestMove = tryReadTChan . bestMoveChan -data UCIException = SANError String deriving Show +-- | Set the starting position of the current game, also clearing any +-- pre-existing history. +setPosition :: Engine -> Position -> IO () +setPosition e@Engine{game} p = do + atomicWriteIORef game (p, []) + sendPosition e +data UCIException = SANError String + | IllegalMove Move + deriving Show instance Exception UCIException @@ -189,9 +203,15 @@ Nothing -> fail $ "Failed to parse ponder move " <> p Nothing -> fail $ "Failed to parse best move " <> m +-- | Start a UCI engine with the given executable name and command line arguments. start :: String -> [String] -> IO (Maybe Engine) start = start' 2000000 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' :: Int -> (String -> IO ()) -> String -> [String] -> IO (Maybe Engine) start' usec outputStrLn cmd args = do (Just inH, Just outH, Nothing, procH) <- createProcess (proc cmd args) { @@ -231,11 +251,16 @@ Right (Info i) -> atomically $ writeTChan infoChan i Right (BestMove bm) -> atomically $ writeTChan bestMoveChan bm +-- | Wait until the engine is ready to take more commands. isready :: Engine -> IO () isready e@Engine{isReady} = do send "isready" e takeMVar isReady +-- | Send a command to the engine. +-- +-- This function is likely going to be removed and replaced by more specific +-- functions in the future. send :: ByteString -> Engine -> IO () send s Engine{inH, procH} = do BS.hPutStrLn inH s @@ -246,6 +271,9 @@ getOption :: ByteString -> Engine -> Maybe Option getOption n = HashMap.lookup n . 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 :: ByteString -> Int -> Engine -> IO Engine setOptionSpinButton n v c | Just (SpinButton _ minValue maxValue) <- getOption n c @@ -256,6 +284,7 @@ where set v opt@SpinButton{} = Just $ opt { spinButtonValue = v } +-- | Return the final position of the currently active game. currentPosition :: Engine -> IO Position currentPosition Engine{game} = uncurry (foldl' applyMove) <$> readIORef game @@ -265,19 +294,31 @@ (initialPosition, history) <- readIORef game pure $ if even . length $ history then color initialPosition else opponent . color $ initialPosition +-- | Add the given move (in algebraic notation) to the current game. move :: Engine -> String -> IO () -move e@Engine{game} san = do +move e@Engine{game} s = do pos <- currentPosition e - case fromSAN pos san of - Left err -> throwIO $ SANError err - Right m -> do + case fromUCI pos s of + Just m -> do addMove e m sendPosition e + Nothing -> case fromSAN pos s of + Left err -> throwIO $ SANError err + Right m -> do + addMove e m + sendPosition e +-- | Add a 'Move' to the game history. +-- +-- This function checks if the move is actually legal, and throws a 'UCIException' +-- if it isn't. addMove :: Engine -> Move -> IO () -addMove e@Engine{game} m = - atomicModifyIORef' game \g -> (fmap (<> [m]) g, ()) - +addMove e@Engine{game} m = do + pos <- currentPosition e + if m `elem` moves pos + then atomicModifyIORef' game \g -> (fmap (<> [m]) g, ()) + else throwIO $ IllegalMove m + sendPosition :: Engine -> IO () sendPosition e@Engine{game} = do readIORef game >>= (flip send) e . cmd @@ -287,6 +328,7 @@ | null h = "" | otherwise = " moves " <> BS.unwords (BS.pack . toUCI <$> h) +-- | Quit the engine. quit :: Engine -> IO (Maybe ExitCode) quit = quit' 1000000