diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Releases +## chessIO 0.9.1.0 + +- Add a Binary instance for Square +- Reimplement move generator in the ST monad with unboxed vector. + New function legalPlies' and speedup of roughly 15% and 300% less allocations. + ## chessIO 0.9.0.0 - New functions: diff --git a/chessIO.cabal b/chessIO.cabal --- a/chessIO.cabal +++ b/chessIO.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: chessIO -version: 0.9.0.0 +version: 0.9.1.0 synopsis: Basic chess library description: A simple and fast library for generating legal chess moves. Also includes a module for communication with external processes that speak the UCI (Universal Chess Interface) protocol, a PGN parser/pretty printer, and Polyglot opening book support. On top of that, provides a console frontend program (cboard) that can be used to interactively play against UCI engines, and a terminal program (cbookview) to explore commonly played chess openings. category: Game diff --git a/src/Game/Chess.hs b/src/Game/Chess.hs --- a/src/Game/Chess.hs +++ b/src/Game/Chess.hs @@ -52,7 +52,7 @@ -- ** Convertion , fromUCI, toUCI -- ** Move generation -, legalPlies +, legalPlies, legalPlies' -- ** Executing moves , doPly, unsafeDoPly ) where diff --git a/src/Game/Chess/Internal.hs b/src/Game/Chess/Internal.hs --- a/src/Game/Chess/Internal.hs +++ b/src/Game/Chess/Internal.hs @@ -33,21 +33,26 @@ import Control.DeepSeq import Control.Lens (view) import Control.Lens.Iso (from) +import Control.Monad (when) +import Control.Monad.ST import Data.Binary import Data.Bits (Bits (bit, complement, testBit, unsafeShiftL, unsafeShiftR, xor, (.&.), (.|.)), FiniteBits (countLeadingZeros, countTrailingZeros)) import Data.Char (chr, ord) +import Data.Foldable (for_) import Data.Hashable import Data.Ix (Ix (inRange)) import Data.List (nub, sortOn) import Data.Maybe (fromJust, listToMaybe) import Data.Ord (Down (..)) +import Data.STRef import Data.String (IsString (..)) import qualified Data.Vector.Generic as G import qualified Data.Vector.Generic.Mutable as M import Data.Vector.Unboxed (MVector, Unbox, Vector, unsafeIndex) import qualified Data.Vector.Unboxed as Vector +import qualified Data.Vector.Unboxed.Mutable as VUM import Foreign.Storable import GHC.Generics (Generic) import GHC.Stack (HasCallStack) @@ -66,7 +71,6 @@ testSquare :: Bitboard -> Square -> Bool testSquare bb (Sq sq) = 1 `unsafeShiftL` sq .&. bb /= 0 - {-# INLINE testSquare #-} capturing :: Position -> Ply -> Maybe PieceType @@ -94,6 +98,7 @@ newtype PieceType = PieceType Int deriving (Eq, Ix, Lift, Ord) +pattern Pawn, Knight, Bishop, Rook, Queen, King :: PieceType pattern Pawn = PieceType 0 pattern Knight = PieceType 1 pattern Bishop = PieceType 2 @@ -194,7 +199,7 @@ readColor "b" = Just Black readColor _ = Nothing - readFlags cst ep = (.|.) <$> readCst cst <*> readEP ep where + readFlags c e = (.|.) <$> readCst c <*> readEP e where readCst "-" = pure 0 readCst x = go x where go ('K':xs) = (crwKs .|.) <$> go xs @@ -238,18 +243,13 @@ showEP 0 = "-" showEP x = toCoord . Sq . bitScanForward $ x -occupiedBy :: Color -> QuadBitboard -> Word64 +occupiedBy :: Color -> QuadBitboard -> Bitboard occupiedBy White = QBB.white occupiedBy Black = QBB.black -occupied :: QuadBitboard -> Word64 +occupied :: QuadBitboard -> Bitboard occupied = QBB.occupied -foldBits :: (a -> Int -> a) -> a -> Word64 -> a -foldBits f = go where - go a 0 = a - go a n = go (f a $ countTrailingZeros n) $! n .&. (n - 1) - bitScanForward, bitScanReverse :: Word64 -> Int bitScanForward = countTrailingZeros bitScanReverse bb = 63 - countLeadingZeros bb @@ -314,7 +314,6 @@ 0 -> Nothing n -> Just . PieceType $ n - unpack :: Ply -> (Square, Square, Maybe PieceType) unpack pl = ( plySource pl, plyTarget pl, plyPromotion pl) @@ -353,10 +352,10 @@ -- | Validate that a certain move is legal in the given position. relativeTo :: Position -> Ply -> Maybe Ply -relativeTo pos m | m `elem` legalPlies pos = Just m +relativeTo pos m | m `Vector.elem` legalPlies' pos = Just m | otherwise = Nothing -shiftN, shiftNN, shiftNNE, shiftNE, shiftENE, shiftE, shiftESE, shiftSE, shiftSSE, shiftS, shiftSS, shiftSSW, shiftSW, shiftWSW, shiftW, shiftWNW, shiftNW, shiftNNW :: Word64 -> Word64 +shiftN, shiftNN, shiftNNE, shiftNE, shiftENE, shiftE, shiftESE, shiftSE, shiftSSE, shiftS, shiftSS, shiftSSW, shiftSW, shiftWSW, shiftW, shiftWNW, shiftNW, shiftNNW :: Bitboard -> Bitboard shiftN w = w `unsafeShiftL` 8 shiftNN w = w `unsafeShiftL` 16 shiftNNE w = w `unsafeShiftL` 17 .&. notAFile @@ -387,7 +386,7 @@ -- if it isn't. See 'unsafeDoPly' for a version that omits the legality check. doPly :: HasCallStack => Position -> Ply -> Position doPly p m - | m `elem` legalPlies p = unsafeDoPly p m + | m `Vector.elem` legalPlies' p = unsafeDoPly p m | otherwise = error "Game.Chess.doPly: Illegal move" -- | An unsafe version of 'doPly'. Only use this if you are sure the given move @@ -474,47 +473,135 @@ | otherwise -> 0 | otherwise = 0 +forBits :: Word64 -> (Int -> ST s ()) -> ST s () +forBits w f = go w where + go 0 = pure () + go n = f (countTrailingZeros n) *> go (n .&. (n - 1)) +{-# INLINE forBits #-} + -- | Generate a list of possible moves for the given position. legalPlies :: Position -> [Ply] -legalPlies pos@Position{color, qbb, flags} = filter legalPly $ - kingMoves - . knightMoves - . slideMoves Queen pos notOurs occ - . slideMoves Rook pos notOurs occ - . slideMoves Bishop pos notOurs occ - . pawnMoves - $ [] - where - legalPly = not . inCheck color . unsafeDoPly' pos - !ours = occupiedBy color qbb - !them = ours `xor` QBB.occupied qbb - !notOurs = complement ours - !occ = ours .|. them - (# pawnMoves, knightMoves, kingMoves #) = case color of - White -> - (# - wPawnMoves (QBB.wPawns qbb) (complement occ) (them .|. ep flags), - flip (foldBits genNMoves) (QBB.wKnights qbb), - flip (foldBits genKMoves) (QBB.wKings qbb) . wShort . wLong - #) - Black -> - (# - bPawnMoves (QBB.bPawns qbb) (complement occ) (them .|. ep flags), - flip (foldBits genNMoves) (QBB.bKnights qbb), - flip (foldBits genKMoves) (QBB.bKings qbb) . bShort . bLong - #) - genNMoves ms sq = foldBits (mkM sq) ms ((unsafeIndex knightAttacks sq) .&. notOurs) - genKMoves ms sq = foldBits (mkM sq) ms ((unsafeIndex kingAttacks sq) .&. notOurs) - wShort ml | canWhiteCastleKingside pos occ = wKscm : ml - | otherwise = ml - wLong ml | canWhiteCastleQueenside pos occ = wQscm : ml - | otherwise = ml - bShort ml | canBlackCastleKingside pos occ = bKscm : ml - | otherwise = ml - bLong ml | canBlackCastleQueenside pos occ = bQscm : ml - | otherwise = ml - mkM !src ms !dst = move (Sq src) (Sq dst) : ms +legalPlies = Vector.toList . legalPlies' +legalPlies' :: Position -> Vector Ply +legalPlies' pos@Position{color, qbb, flags} = runST $ do + v <- VUM.new 100 + i <- newSTRef 0 + let add pl + | not $ inCheck color (unsafeDoPly' pos pl) = do + i' <- readSTRef i + VUM.unsafeWrite v i' pl + modifySTRef' i (+ 1) + | otherwise = pure () + {-# INLINE add #-} + + case color of + White -> do + let !us = QBB.white qbb + !them = QBB.black qbb + !notUs = complement us + !occ = us .|. them + !notOcc = complement occ + + -- Pawn + let !wPawns = QBB.wPawns qbb + let !singlePushTargets = shiftN wPawns .&. notOcc + let !doublePushTargets = shiftN singlePushTargets .&. notOcc .&. rank4 + let !captureTargets = them .|. ep flags + let !eastCaptureTargets = shiftNE wPawns .&. captureTargets + let !westCaptureTargets = shiftNW wPawns .&. captureTargets + let pawn s d + | d >= 56 + = let pl = move (Sq s) (Sq d) + in for_ [Queen, Rook, Bishop, Knight] $ \p -> + add $ pl `promoteTo` p + | otherwise + = add $ move (Sq s) (Sq d) + forBits westCaptureTargets $ \dst -> do + pawn (dst - 7) dst + forBits eastCaptureTargets $ \dst -> do + pawn (dst - 9) dst + forBits singlePushTargets $ \dst -> + pawn (dst - 8) dst + forBits doublePushTargets $ \dst -> + pawn (dst - 16) dst + + piecePlies (QBB.wKnights qbb) + (QBB.wBishops qbb) + (QBB.wRooks qbb) + (QBB.wQueens qbb) + occ notUs add + + -- King + forBits (QBB.wKings qbb) $ \src -> do + forBits (kingAttacks `unsafeIndex` src .&. notUs) $ \dst -> do + add $ move (Sq src) (Sq dst) + when (canWhiteCastleKingside pos occ) $ add wKscm + when (canWhiteCastleQueenside pos occ) $ add wQscm + + Black -> do + let !us = QBB.black qbb + !them = QBB.white qbb + !notUs = complement us + !occ = us .|. them + !notOcc = complement occ + + -- Pawn + let !bPawns = QBB.bPawns qbb + let !singlePushTargets = shiftS bPawns .&. notOcc + let !doublePushTargets = shiftS singlePushTargets .&. notOcc .&. rank5 + let !captureTargets = them .|. ep flags + let !eastCaptureTargets = shiftSE bPawns .&. captureTargets + let !westCaptureTargets = shiftSW bPawns .&. captureTargets + let pawn s d + | d <= 7 + = let pl = move (Sq s) (Sq d) + in for_ [Queen, Rook, Bishop, Knight] $ \p -> + add $ pl `promoteTo` p + | otherwise + = add $ move (Sq s) (Sq d) + forBits westCaptureTargets $ \dst -> do + pawn (dst + 9) dst + forBits eastCaptureTargets $ \dst -> do + pawn (dst + 7) dst + forBits singlePushTargets $ \dst -> + pawn (dst + 8) dst + forBits doublePushTargets $ \dst -> + pawn (dst + 16) dst + + piecePlies (QBB.bKnights qbb) + (QBB.bBishops qbb) + (QBB.bRooks qbb) + (QBB.bQueens qbb) + occ notUs add + + -- King + forBits (QBB.bKings qbb) $ \src -> do + forBits (kingAttacks `unsafeIndex` src .&. notUs) $ \dst -> do + add $ move (Sq src) (Sq dst) + when (canBlackCastleKingside pos occ) $ add bKscm + when (canBlackCastleQueenside pos occ) $ add bQscm + + Vector.unsafeFreeze =<< ($ v) . VUM.unsafeSlice 0 <$> readSTRef i + +piecePlies :: Bitboard -> Bitboard -> Bitboard -> Bitboard + -> Bitboard -> Bitboard -> (Ply -> ST s ()) + -> ST s () +piecePlies !knights !bishops !rooks !queens !occ !notUs add = do + forBits knights $ \src -> do + forBits (knightAttacks `unsafeIndex` src .&. notUs) $ \dst -> do + add $ move (Sq src) (Sq dst) + forBits bishops $ \src -> do + forBits (bishopTargets src occ .&. notUs) $ \dst -> do + add $ move (Sq src) (Sq dst) + forBits rooks $ \src -> do + forBits (rookTargets src occ .&. notUs) $ \dst -> do + add $ move (Sq src) (Sq dst) + forBits queens $ \src -> do + forBits (queenTargets src occ .&. notUs) $ \dst -> do + add $ move (Sq src) (Sq dst) +{-# INLINE piecePlies #-} + -- | Returns 'True' if 'Color' is in check in the given position. inCheck :: Color -> Position -> Bool inCheck White Position{qbb} = @@ -523,53 +610,6 @@ attackedBy White qbb (QBB.occupied qbb) (Sq (bitScanForward (QBB.bKings qbb))) {-# INLINE inCheck #-} - -wPawnMoves :: Word64 -> Word64 -> Word64 -> [Ply] -> [Ply] -wPawnMoves !pawns !emptySquares !opponentPieces = - flip (foldBits $ mkPly 9) eastCaptureTargets - . flip (foldBits $ mkPly 7) westCaptureTargets - . flip (foldBits $ mkPly 8) singlePushTargets - . flip (foldBits $ mkPly 16) doublePushTargets - where - !doublePushTargets = shiftN singlePushTargets .&. emptySquares .&. rank4 - !singlePushTargets = shiftN pawns .&. emptySquares - !eastCaptureTargets = shiftNE pawns .&. opponentPieces - !westCaptureTargets = shiftNW pawns .&. opponentPieces - mkPly diff ms tsq - | tsq >= 56 = (promoteTo m <$> [Queen, Rook, Bishop, Knight]) <> ms - | otherwise = m : ms - where m = move (Sq (tsq - diff)) (Sq tsq) - -bPawnMoves :: Word64 -> Word64 -> Word64 -> [Ply] -> [Ply] -bPawnMoves !pawns !emptySquares !opponentPieces = - flip (foldBits $ mkPly 9) westCaptureTargets - . flip (foldBits $ mkPly 7) eastCaptureTargets - . flip (foldBits $ mkPly 8) singlePushTargets - . flip (foldBits $ mkPly 16) doublePushTargets - where - !doublePushTargets = shiftS singlePushTargets .&. emptySquares .&. rank5 - !singlePushTargets = shiftS pawns .&. emptySquares - !eastCaptureTargets = shiftSE pawns .&. opponentPieces - !westCaptureTargets = shiftSW pawns .&. opponentPieces - mkPly diff ms tsq - | tsq <= 7 = (promoteTo m <$> [Queen, Rook, Bishop, Knight]) <> ms - | otherwise = m : ms - where m = move (Sq (tsq + diff)) (Sq tsq) - -slideMoves :: PieceType -> Position -> Word64 -> Word64 -> [Ply] -> [Ply] -slideMoves piece Position{qbb, color} !notOurs !occ = - flip (foldBits gen) (pieces qbb) - where - gen ms src = foldBits (mkPly src) ms (targets src occ .&. notOurs) - mkPly src ms dst = move (Sq src) (Sq dst) : ms - (# targets, pieces #) = case (# color, piece #) of - (# White, Bishop #) -> (# bishopTargets, QBB.wBishops #) - (# Black, Bishop #) -> (# bishopTargets, QBB.bBishops #) - (# White, Rook #) -> (# rookTargets, QBB.wRooks #) - (# Black, Rook #) -> (# rookTargets, QBB.bRooks #) - (# White, Queen #) -> (# queenTargets, QBB.wQueens #) - (# Black, Queen #) -> (# queenTargets, QBB.bQueens #) - _ -> error "Not a sliding piece" data Castle = Kingside | Queenside deriving (Eq, Ix, Ord, Show) diff --git a/src/Game/Chess/Internal/Square.hs b/src/Game/Chess/Internal/Square.hs --- a/src/Game/Chess/Internal/Square.hs +++ b/src/Game/Chess/Internal/Square.hs @@ -3,12 +3,13 @@ import Control.Lens (Iso', from, iso, view) import Data.Bifunctor (Bifunctor (..)) +import Data.Binary (Binary (get, put), getWord8, putWord8) import Data.Bits (Bits (testBit)) import Data.Char (chr, ord) import Data.Coerce (coerce) import Data.Ix (Ix (..)) import Data.String (IsString (fromString)) -import Data.Word +import Data.Word (Word64) import GHC.Stack (HasCallStack) newtype Rank = Rank Int deriving (Eq, Ord) @@ -97,6 +98,10 @@ newtype Square = Sq Int deriving (Eq, Ord) +instance Binary Square where + put = putWord8 . fromIntegral . unSquare + get = mkSq . fromIntegral <$> getWord8 + instance Ix Square where range (Sq i, Sq j) = [Sq k | k <- [i..j]] index (Sq i, Sq j) (Sq k) = index (i, j) k @@ -218,9 +223,9 @@ file = File . (`mod` 8) . coerce rankFile :: Iso' Square (Rank, File) -rankFile = iso f t where - f (Sq i) = bimap Rank File $ i `divMod` 8 - t (Rank r, File f) = Sq $ r*8 + f +rankFile = iso rf sq where + rf (Sq i) = bimap Rank File $ i `divMod` 8 + sq (Rank r, File f) = Sq $ r*8 + f mapRank :: (Rank -> Rank) -> Square -> Square mapRank f = view (from rankFile) . first f . view rankFile diff --git a/src/Game/Chess/Polyglot.hs b/src/Game/Chess/Polyglot.hs --- a/src/Game/Chess/Polyglot.hs +++ b/src/Game/Chess/Polyglot.hs @@ -26,10 +26,9 @@ ) where import Control.Arrow (Arrow ((&&&))) -import Control.Lens (makeLenses, (%~)) +import Control.Lens (makeLenses) import Control.Monad.Random (Rand) import qualified Control.Monad.Random as Rand -import Control.Monad.ST (ST, runST) import Data.Bits (Bits (shiftL, shiftR, (.|.))) import Data.ByteString (ByteString) import qualified Data.ByteString as BS diff --git a/src/Game/Chess/SAN.hs b/src/Game/Chess/SAN.hs --- a/src/Game/Chess/SAN.hs +++ b/src/Game/Chess/SAN.hs @@ -46,6 +46,7 @@ import qualified Data.Text as Strict (Text) import qualified Data.Text.Lazy as Lazy (Text) import Data.Traversable (mapAccumL) +import qualified Data.Vector.Unboxed as Vector import Data.Void (Void) import Data.Word (Word8) import GHC.Stack (HasCallStack) @@ -54,7 +55,7 @@ Ply, Position (color, moveNumber), bKscm, bQscm, canCastleKingside, canCastleQueenside, doPly, inCheck, - isCapture, legalPlies, + isCapture, legalPlies, legalPlies', pattern Bishop, pattern King, pattern Knight, pattern Pawn, pattern Queen, pattern Rook, @@ -202,9 +203,9 @@ (src, _, dst) <- conv <$> location prm <- optional $ optional (chunk "=") *> promotionPiece case possible pc src dst prm of - [m] -> pure m - [] -> fail "Illegal move" - _ -> fail "Ambiguous move" + cand | Vector.length cand == 1 -> pure $ Vector.unsafeIndex cand 0 + | Vector.length cand == 0 -> fail "Illegal move" + _ -> fail "Ambiguous move" conv (Nothing, Nothing, cap, to) = (Nothing, cap, to) conv (Just f, Nothing, cap, to) = (Just (F f), cap, to) conv (Nothing, Just r, cap, to) = (Just (R r), cap, to) @@ -215,8 +216,8 @@ <*> capture <*> squareP) <|> (Nothing,Nothing,,) <$> capture <*> squareP capture = option False $ chunk "x" $> True - ms = legalPlies pos - possible pc src dst prm = filter (f src) ms where + ms = legalPlies' pos + possible pc src dst prm = Vector.filter (f src) ms where f (Just (RF sq)) (unpack -> (src', dst', prm')) = pAt src' == pc && src' == sq && dst' == dst && prm' == prm f (Just (F ff)) (unpack -> (src', dst', prm')) = diff --git a/test/perft/Perft.hs b/test/perft/Perft.hs --- a/test/perft/Perft.hs +++ b/test/perft/Perft.hs @@ -3,8 +3,10 @@ module Main where import Control.Parallel.Strategies +import Data.MonoTraversable import Data.Foldable import Data.Maybe +import qualified Data.Vector.Unboxed as Vector import Data.Monoid import Data.Time.Clock import Data.Traversable @@ -54,10 +56,10 @@ perft :: Depth -> Position -> PerftResult perft 0 _ = PerftResult 1 -perft 1 p = PerftResult . fromIntegral . length $ legalPlies p +perft 1 p = PerftResult . fromIntegral . Vector.length $ legalPlies' p perft n p - | n < 4 - = foldMap (perft (pred n) . unsafeDoPly p) $ legalPlies p + | n < 5 + = Vector.foldMap' (perft (pred n) . unsafeDoPly p) $ legalPlies' p | otherwise = fold . parMap rdeepseq (perft (pred n) . unsafeDoPly p) $ legalPlies p