chessIO-0.9.2.0: src/Game/Chess/Internal.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module : Game.Chess
Description : Basic data types and functions related to the game of chess
Copyright : (c) Mario Lang, 2020
License : BSD3
Maintainer : mlang@blind.guru
Stability : experimental
A small collection of data types and functions to represent Chess positions
and moves including move generation and parsing from external sources.
This module does deliberately not implement
any search or evaluation functionality. It is intended to be used
to lay the ground for communicating with other programs or players, hence the
package name chessIO.
-}
module Game.Chess.Internal where
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)
import Game.Chess.Internal.QuadBitboard (QuadBitboard)
import qualified Game.Chess.Internal.QuadBitboard as QBB
import Game.Chess.Internal.Square
import Language.Haskell.TH.Syntax (Lift)
import Text.Read (readMaybe)
ep :: Word64 -> Word64
ep flags = flags .&. 0x0000ff0000ff0000
{-# INLINE ep #-}
type Bitboard = Word64
testSquare :: Bitboard -> Square -> Bool
testSquare bb (Sq sq) = 1 `unsafeShiftL` sq .&. bb /= 0
{-# INLINE testSquare #-}
capturing :: Position -> Ply -> Maybe PieceType
capturing pos@Position{flags} (plyTarget -> to)
| ep flags `testSquare` to = Just Pawn
| otherwise = snd <$> pieceAt pos to
isCapture :: Position -> Ply -> Bool
isCapture Position{qbb, flags} =
testSquare (QBB.occupied qbb .|. ep flags) . plyTarget
{-# INLINE isCapture #-}
isPawnPush :: Position -> Ply -> Bool
isPawnPush Position{qbb} = testSquare (QBB.pawns qbb) . plySource
{-# INLINE isPawnPush #-}
-- | The starting position as given by the FEN string
-- "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1".
startpos :: Position
startpos = "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1"
instance IsString Position where fromString = fromJust . fromFEN
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
pattern Rook = PieceType 3
pattern Queen = PieceType 4
pattern King = PieceType 5
{-# COMPLETE Pawn, Knight, Bishop, Rook, Queen, King :: PieceType #-}
instance Show PieceType where
show = \case
Pawn -> "Pawn"
Knight -> "Knight"
Bishop -> "Bishop"
Rook -> "Rook"
Queen -> "Queen"
King -> "King"
data Color = Black | White deriving (Eq, Generic, Ix, Ord, Lift, Show)
instance Binary Color
instance NFData Color
instance Hashable Color
pieceAt :: Position -> Square -> Maybe (Color, PieceType)
pieceAt Position{qbb} sq = case qbb QBB.! sq of
QBB.NoPiece -> Nothing
nb -> Just
( if testBit nb 0 then Black else White
, PieceType . fromIntegral $ nb `div` 2 - 1
)
opponent :: Color -> Color
opponent White = Black
opponent Black = White
data Position = Position {
qbb :: {-# UNPACK #-} !QuadBitboard
, color :: !Color
-- ^ active color
, flags :: {-# UNPACK #-} !Word64
, halfMoveClock :: {-# UNPACK #-} !Int
, moveNumber :: {-# UNPACK #-} !Int
-- ^ number of the full move
} deriving (Generic, Lift)
instance Binary Position
instance NFData Position
-- Article 9.2 states that a position is considered
-- identical to another if the same player is on move, the same types of
-- pieces of the same colors occupy the same squares, and the same moves
-- are available to each player; in particular, each player has the same
-- castling and en passant capturing rights.
instance Eq Position where
a == b = qbb a == qbb b && color a == color b && flags a == flags b
instance Ord Position where
a `compare` b = qbb a `compare` qbb b
<> color a `compare` color b
<> flags a `compare` flags b
instance Hashable Position where
hashWithSalt s Position{qbb, color, flags} = s
`hashWithSalt` qbb
`hashWithSalt` color
`hashWithSalt` flags
repetitions :: [Position] -> Maybe (Int, Position)
repetitions xs = listToMaybe . sortOn (Down . fst) $ f <$> nub xs where
f x = (length . filter (== x) $ xs, x)
instance Show Position where
show p = '"' : toFEN p <> ['"']
insufficientMaterial :: Position -> Bool
insufficientMaterial = QBB.insufficientMaterial . qbb
-- | Construct a position from Forsyth-Edwards-Notation.
fromFEN :: String -> Maybe Position
fromFEN fen
| length parts == 6
= Position <$> pure (fromString (parts !! 0))
<*> readColor (parts !! 1)
<*> readFlags (parts !! 2) (parts !! 3)
<*> readMaybe (parts !! 4)
<*> readMaybe (parts !! 5)
| length parts == 4
= Position <$> pure (fromString (parts !! 0))
<*> readColor (parts !! 1)
<*> readFlags (parts !! 2) (parts !! 3)
<*> pure 0
<*> pure 1
| otherwise = Nothing
where
parts = words fen
readColor "w" = Just White
readColor "b" = Just Black
readColor _ = Nothing
readFlags c e = (.|.) <$> readCst c <*> readEP e where
readCst "-" = pure 0
readCst x = go x where
go ('K':xs) = (crwKs .|.) <$> go xs
go ('Q':xs) = (crwQs .|.) <$> go xs
go ('k':xs) = (crbKs .|.) <$> go xs
go ('q':xs) = (crbQs .|.) <$> go xs
go [] = pure 0
go _ = Nothing
readEP "-" = Just 0
readEP [f,r]
| inRange ('a','h') f && (r == '3' || r == '6')
= Just $ bit ((ord r - ord '1') * 8 + (ord f - ord 'a'))
readEP _ = Nothing
-- | Convert a position to Forsyth-Edwards-Notation.
toFEN :: Position -> String
toFEN Position{qbb, color, flags, halfMoveClock, moveNumber} = unwords
[ QBB.toString qbb
, showColor color
, showCst (flags `clearMask` epMask)
, showEP (ep flags)
, show halfMoveClock
, show moveNumber
]
where
showColor White = "w"
showColor Black = "b"
showCst x
| str == "" = "-"
| otherwise = str
where
str = snd . wks . wqs . bks . bqs $ (x, "")
wks (v, xs) | v `testMask` crwKs = (v, 'K':xs)
| otherwise = (v, xs)
wqs (v, xs) | v `testMask` crwQs = (v, 'Q':xs)
| otherwise = (v, xs)
bks (v, xs) | v `testMask` crbKs = (v, 'k':xs)
| otherwise = (v, xs)
bqs (v, xs) | v `testMask` crbQs = (v, 'q':xs)
| otherwise = (v, xs)
showEP 0 = "-"
showEP x = toCoord . Sq . bitScanForward $ x
occupiedBy :: Color -> QuadBitboard -> Bitboard
occupiedBy White = QBB.white
occupiedBy Black = QBB.black
occupied :: QuadBitboard -> Bitboard
occupied = QBB.occupied
bitScanForward, bitScanReverse :: Word64 -> Int
bitScanForward = countTrailingZeros
bitScanReverse bb = 63 - countLeadingZeros bb
{-# INLINE bitScanForward #-}
{-# INLINE bitScanReverse #-}
newtype Ply = Ply { unPly :: Word16 } deriving (Binary, Eq, Hashable, Ord, Lift, Storable)
instance Show Ply where
show (unpack -> (f, t, p)) = "move " <> show f <> " " <> show t <> p' where
p' = case p of
Just piece -> " `promoteTo` " <> show piece
Nothing -> ""
newtype instance MVector s Ply = MV_Ply (MVector s Word16)
newtype instance Vector Ply = V_Ply (Vector Word16)
instance M.MVector MVector Ply where
basicLength (MV_Ply v) = M.basicLength v
basicUnsafeSlice i n (MV_Ply v) = MV_Ply $ M.basicUnsafeSlice i n v
basicOverlaps (MV_Ply v1) (MV_Ply v2) = M.basicOverlaps v1 v2
basicUnsafeNew n = MV_Ply <$> M.basicUnsafeNew n
basicInitialize (MV_Ply v) = M.basicInitialize v
basicUnsafeReplicate n (Ply pl) = MV_Ply <$> M.basicUnsafeReplicate n pl
basicUnsafeRead (MV_Ply v) i = Ply <$> M.basicUnsafeRead v i
basicUnsafeWrite (MV_Ply v) i (Ply pl) = M.basicUnsafeWrite v i pl
basicClear (MV_Ply v) = M.basicClear v
basicSet (MV_Ply v) (Ply pl) = M.basicSet v pl
basicUnsafeCopy (MV_Ply v1) (MV_Ply v2) = M.basicUnsafeCopy v1 v2
basicUnsafeMove (MV_Ply v1) (MV_Ply v2) = M.basicUnsafeMove v1 v2
basicUnsafeGrow (MV_Ply v) n = MV_Ply <$> M.basicUnsafeGrow v n
instance G.Vector Vector Ply where
{-# INLINE basicUnsafeIndexM #-}
basicUnsafeFreeze (MV_Ply v) = V_Ply <$> G.basicUnsafeFreeze v
basicUnsafeThaw (V_Ply v) = MV_Ply <$> G.basicUnsafeThaw v
basicLength (V_Ply v) = G.basicLength v
basicUnsafeSlice i n (V_Ply v) = V_Ply $ G.basicUnsafeSlice i n v
basicUnsafeIndexM (V_Ply v) i = Ply <$> G.basicUnsafeIndexM v i
basicUnsafeCopy (MV_Ply mv) (V_Ply v) = G.basicUnsafeCopy mv v
elemseq _ pl z = G.elemseq (undefined :: Vector a) pl z
instance Unbox Ply
move :: Square -> Square -> Ply
move (Sq src) (Sq dst) =
Ply $ fromIntegral dst .|. fromIntegral src `unsafeShiftL` 6
promoteTo :: Ply -> PieceType -> Ply
promoteTo (Ply x) = Ply . set where
set Pawn = x
set King = x
set (PieceType v) = x .&. 0xfff .|. fromIntegral (v `unsafeShiftL` 12)
plySource, plyTarget :: Ply -> Square
plySource (Ply x) = Sq $ fromIntegral ((x `unsafeShiftR` 6) .&. 0b111111)
plyTarget (Ply x) = Sq $ fromIntegral (x .&. 0b111111)
plyPromotion :: Ply -> Maybe PieceType
plyPromotion (Ply x) = case fromIntegral $ (x `unsafeShiftR` 12) .&. 0b111 of
0 -> Nothing
n -> Just . PieceType $ n
unpack :: Ply -> (Square, Square, Maybe PieceType)
unpack pl = ( plySource pl, plyTarget pl, plyPromotion pl)
-- | Parse a move in the format used by the Universal Chess Interface protocol.
fromUCI :: Position -> String -> Maybe Ply
fromUCI pos (fmap (splitAt 2) . splitAt 2 -> (src, (dst, promo)))
| null promo
= move <$> readCoord src <*> readCoord dst >>= relativeTo pos
| otherwise
= (\f t p -> move f t `promoteTo` p) <$> readCoord src
<*> readCoord dst
<*> readPromo promo
>>= relativeTo pos
where
readCoord [f,r]
| inRange ('a','h') f && inRange ('1','8') r
= Just . view (from rankFile) $ (mkRank $ ord r - ord '1', mkFile $ ord f - ord 'a')
readCoord _ = Nothing
readPromo "q" = Just Queen
readPromo "r" = Just Rook
readPromo "b" = Just Bishop
readPromo "n" = Just Knight
readPromo _ = Nothing
-- | Convert a move to the format used by the Universal Chess Interface protocol.
toUCI :: Ply -> String
toUCI (unpack -> (src, dst, promo)) = coord src <> coord dst <> p where
coord x = let (r,f) = view rankFile x in
chr (unFile f + ord 'a') : [chr (unRank r + ord '1')]
p = case promo of
Just Queen -> "q"
Just Rook -> "r"
Just Bishop -> "b"
Just Knight -> "n"
_ -> ""
-- | Validate that a certain move is legal in the given position.
relativeTo :: Position -> Ply -> Maybe Ply
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 :: Bitboard -> Bitboard
shiftN w = w `unsafeShiftL` 8
shiftNN w = w `unsafeShiftL` 16
shiftNNE w = w `unsafeShiftL` 17 .&. notAFile
shiftNE w = w `unsafeShiftL` 9 .&. notAFile
shiftENE w = w `unsafeShiftL` 10 .&. notABFile
shiftE w = w `unsafeShiftL` 1 .&. notAFile
shiftESE w = w `unsafeShiftR` 6 .&. notABFile
shiftSE w = w `unsafeShiftR` 7 .&. notAFile
shiftSSE w = w `unsafeShiftR` 15 .&. notAFile
shiftS w = w `unsafeShiftR` 8
shiftSS w = w `unsafeShiftR` 16
shiftSSW w = w `unsafeShiftR` 17 .&. notHFile
shiftSW w = w `unsafeShiftR` 9 .&. notHFile
shiftWSW w = w `unsafeShiftR` 10 .&. notGHFile
shiftW w = w `unsafeShiftR` 1 .&. notHFile
shiftWNW w = w `unsafeShiftL` 6 .&. notGHFile
shiftNW w = w `unsafeShiftL` 7 .&. notHFile
shiftNNW w = w `unsafeShiftL` 15 .&. notHFile
{-# INLINE shiftN #-}
{-# INLINE shiftNN #-}
{-# INLINE shiftS #-}
{-# INLINE shiftSS #-}
-- | 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 'unsafeDoPly' for a version that omits the legality check.
doPly :: HasCallStack => Position -> Ply -> Position
doPly 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
-- can be applied to the position. This is useful if the move has been generated
-- by the 'legalPlies' function.
unsafeDoPly :: Position -> Ply -> Position
unsafeDoPly pos@Position{color, halfMoveClock, moveNumber} m =
(unsafeDoPly' pos m)
{ color = opponent color
, halfMoveClock = if isCapture pos m || isPawnPush pos m
then 0
else halfMoveClock + 1
, moveNumber = if color == Black
then moveNumber + 1
else moveNumber
}
unsafeDoPly' :: Position -> Ply -> Position
unsafeDoPly' pos@Position{qbb, flags} m@(unpack -> (src, dst, promo))
| m == wKscm && flags `testMask` crwKs
= pos { qbb = qbb <> QBB.whiteKingsideCastle
, flags = flags `clearMask` (rank1 .|. epMask)
}
| m == wQscm && flags `testMask` crwQs
= pos { qbb = qbb <> QBB.whiteQueensideCastle
, flags = flags `clearMask` (rank1 .|. epMask)
}
| m == bKscm && flags `testMask` crbKs
= pos { qbb = qbb <> QBB.blackKingsideCastle
, flags = flags `clearMask` (rank8 .|. epMask)
}
| m == bQscm && flags `testMask` crbQs
= pos { qbb = qbb <> QBB.blackQueensideCastle
, flags = flags `clearMask` (rank8 .|. epMask)
}
| Just piece <- promo
= case color pos of
White -> case piece of
Queen -> pos { qbb = QBB.whitePromotion qbb src dst QBB.WhiteQueen
, flags = flags `clearMask` (epMask .|. bit (unSquare dst))
}
Rook -> pos { qbb = QBB.whitePromotion qbb src dst QBB.WhiteRook
, flags = flags `clearMask` (epMask .|. bit (unSquare dst))
}
Bishop -> pos { qbb = QBB.whitePromotion qbb src dst QBB.WhiteBishop
, flags = flags `clearMask` (epMask .|. bit (unSquare dst))
}
Knight -> pos { qbb = QBB.whitePromotion qbb src dst QBB.WhiteKnight
, flags = flags `clearMask` (epMask .|. bit (unSquare dst))
}
_ -> error "Impossible: White tried to promote to Pawn"
Black -> case piece of
Queen -> pos { qbb = QBB.blackPromotion qbb src dst QBB.BlackQueen
, flags = flags `clearMask` (epMask .|. bit (unSquare dst))
}
Rook -> pos { qbb = QBB.blackPromotion qbb src dst QBB.BlackRook
, flags = flags `clearMask` (epMask .|. bit (unSquare dst))
}
Bishop -> pos { qbb = QBB.blackPromotion qbb src dst QBB.BlackBishop
, flags = flags `clearMask` (epMask .|. bit (unSquare dst))
}
Knight -> pos { qbb = QBB.blackPromotion qbb src dst QBB.BlackKnight
, flags = flags `clearMask` (epMask .|. bit (unSquare dst))
}
_ -> error "Impossible: Black tried to promote to Pawn"
| pawns `testMask` fromMask
, ep flags `testMask` toMask
= pos { qbb = qbb <> QBB.enPassant src dst
, flags = flags `clearMask` toMask
}
| otherwise
= pos { qbb = QBB.move qbb src dst
, flags = flags `clearMask` (epMask .|. mask) .|. dpp
}
where
!fromMask = 1 `unsafeShiftL` unSquare src
!toMask = 1 `unsafeShiftL` unSquare dst
!mask = fromMask .|. toMask
!pawns = QBB.pawns qbb
!dpp
| (pawns .&. (rank2 .|. rank7)) `testMask` fromMask
= if | shiftNN fromMask == toMask -> shiftN fromMask
| shiftSS fromMask == toMask -> shiftS fromMask
| 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 = 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 ->
add $ move (Sq $ dst - 16) (Sq 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 ->
add $ move (Sq $ dst + 16) (Sq 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} =
attackedBy Black qbb (QBB.occupied qbb) (Sq (bitScanForward (QBB.wKings qbb)))
inCheck Black Position{qbb} =
attackedBy White qbb (QBB.occupied qbb) (Sq (bitScanForward (QBB.bKings qbb)))
{-# INLINE inCheck #-}
data Castle = Kingside | Queenside deriving (Eq, Ix, Ord, Show)
castlingRights :: Position -> [(Color, Castle)]
castlingRights Position{flags} = wks . wqs . bks . bqs $ [] where
wks xs | flags `testMask` crwKs = (White, Kingside):xs
| otherwise = xs
wqs xs | flags `testMask` crwQs = (White, Queenside):xs
| otherwise = xs
bks xs | flags `testMask` crbKs = (Black, Kingside):xs
| otherwise = xs
bqs xs | flags `testMask` crbQs = (Black, Queenside):xs
| otherwise = xs
enPassantSquare :: Position -> Maybe Square
enPassantSquare Position{flags} = case ep flags of
0 -> Nothing
x -> Just . Sq . bitScanForward $ x
canCastleKingside, canCastleQueenside :: Position -> Bool
canCastleKingside pos@Position{qbb, color = White} =
canWhiteCastleKingside pos (occupied qbb)
canCastleKingside pos@Position{qbb, color = Black} =
canBlackCastleKingside pos (occupied qbb)
canCastleQueenside pos@Position{qbb, color = White} =
canWhiteCastleQueenside pos (occupied qbb)
canCastleQueenside pos@Position{qbb, color = Black} =
canBlackCastleQueenside pos (occupied qbb)
canWhiteCastleKingside, canBlackCastleKingside, canWhiteCastleQueenside, canBlackCastleQueenside :: Position -> Word64 -> Bool
canWhiteCastleKingside Position{qbb, flags} !occ =
flags `testMask` crwKs && occ .&. crwKe == 0 &&
not (any (attackedBy Black qbb occ) [E1, F1, G1])
canBlackCastleKingside Position{qbb, flags} !occ =
flags `testMask` crbKs && occ .&. crbKe == 0 &&
not (any (attackedBy White qbb occ) [E8, F8, G8])
canWhiteCastleQueenside Position{qbb, flags} !occ =
flags `testMask` crwQs && occ .&. crwQe == 0 &&
not (any (attackedBy Black qbb occ) [E1, D1, C1])
canBlackCastleQueenside Position{qbb, flags} !occ =
flags `testMask` crbQs && occ .&. crbQe == 0 &&
not (any (attackedBy White qbb occ) [E8, D8, C8])
wKscm, wQscm, bKscm, bQscm :: Ply
wKscm = move E1 G1
wQscm = move E1 C1
bKscm = move E8 G8
bQscm = move E8 C8
attackedBy :: Color -> QuadBitboard -> Word64 -> Square -> Bool
attackedBy White !qbb !occ (Sq sq)
| unsafeIndex wPawnAttacks sq .&. QBB.wPawns qbb /= 0 = True
| unsafeIndex knightAttacks sq .&. QBB.wKnights qbb /= 0 = True
| bishopTargets sq occ .&. QBB.wBishops qbb /= 0 = True
| rookTargets sq occ .&. QBB.wRooks qbb /= 0 = True
| queenTargets sq occ .&. QBB.wQueens qbb /= 0 = True
| unsafeIndex kingAttacks sq .&. QBB.wKings qbb /= 0 = True
| otherwise = False
attackedBy Black !qbb !occ (Sq sq)
| unsafeIndex bPawnAttacks sq .&. QBB.bPawns qbb /= 0 = True
| unsafeIndex knightAttacks sq .&. QBB.bKnights qbb /= 0 = True
| bishopTargets sq occ .&. QBB.bBishops qbb /= 0 = True
| rookTargets sq occ .&. QBB.bRooks qbb /= 0 = True
| queenTargets sq occ .&. QBB.bQueens qbb /= 0 = True
| unsafeIndex kingAttacks sq .&. QBB.bKings qbb /= 0 = True
| otherwise = False
{-# INLINE attackedBy #-}
attackedByPawn :: Square -> Position -> Bool
attackedByPawn (Sq sq) Position{qbb, color} = case color of
White -> unsafeIndex wPawnAttacks sq .&. QBB.wPawns qbb /= 0
Black -> unsafeIndex bPawnAttacks sq .&. QBB.bPawns qbb /= 0
notAFile, notABFile, notGHFile, notHFile, rank1, rank2, rank3, rank4, rank5, rank6, rank7, rank8 :: Word64
notAFile = 0xfefefefefefefefe
notABFile = 0xfcfcfcfcfcfcfcfc
notGHFile = 0x3f3f3f3f3f3f3f3f
notHFile = 0x7f7f7f7f7f7f7f7f
rank1 = 0x00000000000000ff
rank2 = 0x000000000000ff00
rank3 = 0x0000000000ff0000
rank4 = 0x00000000ff000000
rank5 = 0x000000ff00000000
rank6 = 0x0000ff0000000000
rank7 = 0x00ff000000000000
rank8 = 0xff00000000000000
epMask, crwKs, crwQs, crwKe, crwQe, crbKs, crbQs, crbKe, crbQe :: Word64
epMask = rank3 .|. rank6 -- mask for en passant
crwKs = 0x0000000000000090 -- white: king & rook position for kingside castle
crwQs = 0x0000000000000011 -- white: king & rook pisition for queenside castle^M
crwKe = 0x0000000000000060 -- white: empty fields for kingside castle
crwQe = 0x000000000000000e -- white: empty fields for queenside castle
crbKs = 0x9000000000000000 -- black: king & rook position for kingside castle
crbQs = 0x1100000000000000 -- black: king & rook position for queenside castle^M
crbKe = 0x6000000000000000 -- black: empty fields for kingside castle
crbQe = 0x0e00000000000000 -- black: empty fields for queenside castle
kingAttacks, knightAttacks, wPawnAttacks, bPawnAttacks :: Vector Word64
kingAttacks = Vector.generate 64 $ \sq -> let b = bit sq in
shiftN b .|. shiftNE b .|. shiftE b .|. shiftSE b .|.
shiftS b .|. shiftSW b .|. shiftW b .|. shiftNW b
knightAttacks = Vector.generate 64 $ \sq -> let b = bit sq in
shiftNNE b .|. shiftENE b .|.
shiftESE b .|. shiftSSE b .|.
shiftSSW b .|. shiftWSW b .|.
shiftWNW b .|. shiftNNW b
wPawnAttacks = Vector.generate 64 $ \sq -> let b = bit sq in
shiftSE b .|. shiftSW b
bPawnAttacks = Vector.generate 64 $ \sq -> let b = bit sq in
shiftNE b .|. shiftNW b
rookTargets, bishopTargets, queenTargets :: Int -> Word64 -> Word64
rookTargets !sq !occ = rayN occ sq .|. rayE occ sq
.|. rayS occ sq .|. rayW occ sq
bishopTargets !sq !occ = rayNW occ sq .|. rayNE occ sq
.|. raySE occ sq .|. raySW occ sq
queenTargets !sq !occ = rookTargets sq occ .|. bishopTargets sq occ
rayTargets :: Vector Word64 -> (Word64 -> Int) -> Word64 -> Int -> Word64
rayTargets !ray !bitScan !occ (unsafeIndex ray -> a) = case a .&. occ of
0 -> a
(bitScan -> sq) -> a `xor` unsafeIndex ray sq
{-# INLINE rayTargets #-}
rayNW, rayN, rayNE, rayE, raySE, rayS, raySW, rayW :: Word64 -> Int -> Word64
rayNW = rayTargets attackNW bitScanForward
rayN = rayTargets attackN bitScanForward
rayNE = rayTargets attackNE bitScanForward
rayE = rayTargets attackE bitScanForward
raySE = rayTargets attackSE bitScanReverse
rayS = rayTargets attackS bitScanReverse
raySW = rayTargets attackSW bitScanReverse
rayW = rayTargets attackW bitScanReverse
{-# INLINE rayNW #-}
{-# INLINE rayN #-}
{-# INLINE rayNE #-}
{-# INLINE rayE #-}
{-# INLINE raySE #-}
{-# INLINE rayS #-}
{-# INLINE raySW #-}
{-# INLINE rayW #-}
attackDir :: (Word64 -> Word64) -> Vector Word64
attackDir s = Vector.generate 64 $ \sq ->
foldr (.|.) 0 $ take 7 $ tail $ iterate s (bit sq)
attackNW, attackN, attackNE, attackE, attackSE, attackS, attackSW, attackW :: Vector Word64
attackNW = attackDir shiftNW
attackN = attackDir shiftN
attackNE = attackDir shiftNE
attackE = attackDir shiftE
attackSE = attackDir shiftSE
attackS = attackDir shiftS
attackSW = attackDir shiftSW
attackW = attackDir shiftW
clearMask :: Bits a => a -> a -> a
clearMask a b = a .&. complement b
testMask :: Bits a => a -> a -> Bool
testMask a b = a .&. b == b
{-# INLINE testMask #-}