chessIO 0.1.0.0 → 0.2.0.0
raw patch · 5 files changed
+321/−175 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Game.Chess.UCI: game :: Engine -> IORef (Position, [Move])
- Game.Chess.UCI: isready :: Engine -> IO ()
+ Game.Chess: inCheck :: Color -> Position -> Bool
+ Game.Chess: toSAN :: Position -> Move -> String
+ Game.Chess: unsafeToSAN :: Position -> Move -> String
+ Game.Chess.UCI: IllegalMove :: Move -> UCIException
+ Game.Chess.UCI: SANError :: String -> UCIException
+ Game.Chess.UCI: setPosition :: Engine -> Position -> IO ()
Files
- README.rst +30/−0
- app/cboard.hs +41/−20
- chessIO.cabal +7/−5
- src/Game/Chess.hs +186/−135
- src/Game/Chess/UCI.hs +57/−15
+ README.rst view
@@ -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
app/cboard.hs view
@@ -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
chessIO.cabal view
@@ -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
src/Game/Chess.hs view
@@ -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 #-}
src/Game/Chess/UCI.hs view
@@ -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