chessIO 0.9.0.0 → 0.9.1.0

raw patch · 8 files changed

+168/−115 lines, 8 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• chessIO.cabal +1/−1
• src/Game/Chess.hs +1/−1
• src/Game/Chess/Internal.hs +138/−98
• src/Game/Chess/Internal/Square.hs +9/−4
• src/Game/Chess/Polyglot.hs +1/−2
• src/Game/Chess/SAN.hs +7/−6
• test/perft/Perft.hs +5/−3

@@ -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:

@@ -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

@@ -52,7 +52,7 @@   -- ** Convertion , fromUCI, toUCI   -- ** Move generation-, legalPlies+, legalPlies, legalPlies'   -- ** Executing moves , doPly, unsafeDoPly ) where

@@ -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) 

@@ -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

@@ -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

@@ -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')) =

@@ -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