chessIO-0.2.0.0: src/Game/Chess.hs
{-|
Module : Game.Chess
Description : Basic data types and functions related to the game of chess
Copyright : (c) Mario Lang, 2019
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 (
-- * Chess positions
Color(..), opponent
, Sq(..), isLight, isDark
, PieceType(..)
, Position, startpos, color, pieceAt, inCheck
-- ** Converting from/to Forsyth-Edwards-Notation
, fromFEN, toFEN
-- * Chess moves
, Move
-- ** Converting from/to algebraic notation
, fromSAN, toSAN, unsafeToSAN, fromUCI, toUCI
-- ** Move generation
, moves
-- ** Executing moves
, applyMove, unsafeApplyMove
) where
import Control.Applicative.Combinators
import Data.Bits
import Data.Char
import Data.Functor (($>))
import Data.Ix
import Data.List
import Data.Maybe
import Data.Vector.Unboxed (Vector, (!))
import Data.Void
import qualified Data.Vector.Unboxed as Vector
import Data.Word
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Read
type Parser = Parsec Void String
data From = File Int
| Rank Int
| Square Int
deriving (Show)
san :: Parser (PieceType, Maybe From, Bool, Int, Maybe PieceType, Maybe Char)
san = conv <$> piece
<*> location
<*> optional (optional (char '=') *> promo)
<*> optional (char '+' <|> char '#') where
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,,)
piece = char 'N' $> Knight
<|> char 'B' $> Bishop
<|> char 'R' $> Rook
<|> char 'Q' $> Queen
<|> char 'K' $> King
<|> pure Pawn
location = try ((,,,) <$> (Just <$> file)
<*> pure Nothing
<*> capture
<*> square)
<|> try ((,,,) <$> pure Nothing
<*> (Just <$> rank)
<*> capture
<*> square)
<|> try ((,,,) <$> (Just <$> file)
<*> (Just <$> rank)
<*> capture
<*> square)
<|> (,,,) <$> pure Nothing
<*> pure Nothing
<*> capture
<*> square
promo = char 'N' $> Knight
<|> char 'B' $> Bishop
<|> char 'R' $> Rook
<|> char 'Q' $> Queen
capture = option False $ char 'x' $> True
square = frToInt <$> file <*> rank
file = subtract (ord 'a') . ord <$> oneOf ['a'..'h']
rank = subtract (ord '1') . ord <$> oneOf ['1'..'8']
frToInt f r = r*8 + f
fromSAN :: Position -> String -> Either String Move
fromSAN Position{color = White, flags} s
| 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 bKscm
fromSAN Position{color = White, flags} s
| 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 bQscm
fromSAN pos s = case parse san "" s of
Right (pc, from, _, to, promo, _) ->
case ms pc from to promo of
[m] -> Right m
[] -> Left "Illegal move"
_ -> Left "Ambiguous move"
Left err -> Left $ errorBundlePretty err
where
ms pc from to prm = filter (f from) $ moves pos where
f (Just (Square from)) (unpack -> (from', to', prm')) =
pAt from' == pc && from' == from && to' == to && prm' == prm
f (Just (File ff)) (unpack -> (from', to', prm')) =
pAt from' == pc && from' `mod` 8 == ff && to == to' && prm == prm'
f (Just (Rank fr)) (unpack -> (from', to', prm')) =
pAt from' == pc && from' `div` 8 == fr && to == to' && prm == prm'
f Nothing (unpack -> (from', to', prm')) =
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
startpos = fromJust $
fromFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1"
data PieceType = Pawn | Knight | Bishop | Rook | Queen | King deriving (Eq, Show)
data Color = White | Black deriving (Eq, Show)
pieceAt :: Position -> Sq -> Maybe (Color, PieceType)
pieceAt (board -> BB{wP, wN, wB, wR, wQ, wK, bP, bN, bB, bR, bQ, bK}) (fromEnum -> sq)
| wP `testBit` sq = Just (White, Pawn)
| wN `testBit` sq = Just (White, Knight)
| wB `testBit` sq = Just (White, Bishop)
| wR `testBit` sq = Just (White, Rook)
| wQ `testBit` sq = Just (White, Queen)
| wK `testBit` sq = Just (White, King)
| bP `testBit` sq = Just (Black, Pawn)
| bN `testBit` sq = Just (Black, Knight)
| bB `testBit` sq = Just (Black, Bishop)
| bR `testBit` sq = Just (Black, Rook)
| bQ `testBit` sq = Just (Black, Queen)
| bK `testBit` sq = Just (Black, King)
| otherwise = Nothing
opponent :: Color -> Color
opponent White = Black
opponent Black = White
data Piece = Piece !Color !PieceType deriving (Eq, Show)
data Sq = A1 | B1 | C1 | D1 | E1 | F1 | G1 | H1
| A2 | B2 | C2 | D2 | E2 | F2 | G2 | H2
| A3 | B3 | C3 | D3 | E3 | F3 | G3 | H3
| A4 | B4 | C4 | D4 | E4 | F4 | G4 | H4
| A5 | B5 | C5 | D5 | E5 | F5 | G5 | H5
| A6 | B6 | C6 | D6 | E6 | F6 | G6 | H6
| A7 | B7 | C7 | D7 | E7 | F7 | G7 | H7
| A8 | B8 | C8 | D8 | E8 | F8 | G8 | H8
deriving (Bounded, Enum, Eq, Show)
isDark :: Sq -> Bool
isDark (fromEnum -> sq) = (0xaa55aa55aa55aa55 :: Word64) `testBit` sq
isLight :: Sq -> Bool
isLight = not . isDark
data Castling = Kingside | Queenside deriving (Eq, Ord, Show)
data BB = BB { wP, wN, wB, wR, wQ, wK :: !Word64
, bP, bN, bB, bR, bQ, bK :: !Word64
} deriving (Eq, Show)
data Position = Position {
board :: !BB
, color :: !Color
, flags :: !Word64
, halfMoveClock :: !Int
, moveNumber :: !Int
} deriving (Eq)
emptyBB :: BB
emptyBB = BB 0 0 0 0 0 0 0 0 0 0 0 0
-- | Construct a position from Forsyth-Edwards-Notation.
fromFEN :: String -> Maybe Position
fromFEN fen
| length parts /= 6
= Nothing
| otherwise =
Position <$> readBoard (parts !! 0)
<*> readColor (parts !! 1)
<*> readFlags (parts !! 2) (parts !! 3)
<*> readMaybe (parts !! 4)
<*> readMaybe (parts !! 5)
where
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
go rf@(r,f) bb ('b':s) = go (r, f + 1) (bb { bB = bB bb .|. rfBit rf }) s
go rf@(r,f) bb ('q':s) = go (r, f + 1) (bb { bQ = bQ bb .|. rfBit rf }) s
go rf@(r,f) bb ('k':s) = go (r, f + 1) (bb { bK = bK bb .|. rfBit rf }) s
go rf@(r,f) bb ('p':s) = go (r, f + 1) (bb { bP = bP bb .|. rfBit rf }) s
go rf@(r,f) bb ('R':s) = go (r, f + 1) (bb { wR = wR bb .|. rfBit rf }) s
go rf@(r,f) bb ('N':s) = go (r, f + 1) (bb { wN = wN bb .|. rfBit rf }) s
go rf@(r,f) bb ('B':s) = go (r, f + 1) (bb { wB = wB bb .|. rfBit rf }) s
go rf@(r,f) bb ('Q':s) = go (r, f + 1) (bb { wQ = wQ bb .|. rfBit rf }) s
go rf@(r,f) bb ('K':s) = go (r, f + 1) (bb { wK = wK bb .|. rfBit rf }) s
go rf@(r,f) bb ('P':s) = go (r, f + 1) (bb { wP = wP bb .|. rfBit rf }) s
go (r,f) bb ('1':s) = go (r, f + 1) bb s
go (r,f) bb ('2':s) = go (r, f + 2) bb s
go (r,f) bb ('3':s) = go (r, f + 3) bb s
go (r,f) bb ('4':s) = go (r, f + 4) bb s
go (r,f) bb ('5':s) = go (r, f + 5) bb s
go (r,f) bb ('6':s) = go (r, f + 6) bb s
go (r,f) bb ('7':s) = go (r, f + 7) bb s
go (r,f) bb ('8':s) = go (r, f + 8) bb s
go (r,_) bb ('/':s) = go (r - 1, 0) bb s
go _ bb [] = Just bb
go _ _ _ = Nothing
readColor "w" = Just White
readColor "b" = Just Black
readColor _ = Nothing
readFlags cst ep = (.|.) <$> readCst cst <*> readEP ep where
readCst "-" = Just 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 [] = Just 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
sqToRF :: Sq -> (Int, Int)
sqToRF sq = fromEnum sq `divMod` 8
rfBit :: Bits bits => (Int, Int) -> bits
rfBit (r,f) | inRange (0,7) r && inRange (0,7) f = bit $ r*8 + f
| otherwise = error $ "Out of range: " <> show r <> " " <> show f
-- | Convert a position to Forsyth-Edwards-Notation.
toFEN :: Position -> String
toFEN (Position bb c flgs hm mn) = unwords [
intercalate "/" (rank <$> [7,6..0])
, showColor c, showCst (flgs `clearMask` epMask), showEP (flgs .&. epMask), show hm, show mn
]
where
showColor White = "w"
showColor Black = "b"
showCst 0 = "-"
showCst x = snd . wks . wqs . bks . bqs $ (x, "") where
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 = chr (f + ord 'a') : [chr (r + ord '1')] where
(r, f) = bitScanForward x `divMod` 8
rank r = concatMap countEmpty $ groupBy (\x y -> x == y && x == ' ') $
charAt r <$> [0..7]
countEmpty xs | head xs == ' ' = show $ length xs
| otherwise = xs
charAt r f
| wP bb `testBit` b = 'P'
| wN bb `testBit` b = 'N'
| wB bb `testBit` b = 'B'
| wR bb `testBit` b = 'R'
| wQ bb `testBit` b = 'Q'
| wK bb `testBit` b = 'K'
| bP bb `testBit` b = 'p'
| bN bb `testBit` b = 'n'
| bB bb `testBit` b = 'b'
| bR bb `testBit` b = 'r'
| bQ bb `testBit` b = 'q'
| bK bb `testBit` b = 'k'
| otherwise = ' '
where b = r*8 + f
occupiedBy :: Color -> BB -> Word64
occupiedBy White bb = wP bb .|. wN bb .|. wB bb .|. wR bb .|. wQ bb .|. wK bb
occupiedBy Black bb = bP bb .|. bN bb .|. bB bb .|. bR bb .|. bQ bb .|. bK bb
occupied :: BB -> Word64
occupied bb = occupiedBy White bb .|. occupiedBy Black bb
notOccupied :: BB -> Word64
notOccupied = complement . occupied
foldBits :: (a -> Int -> a) -> a -> Word64 -> a
foldBits _ a 0 = a
foldBits f !a n = foldBits f (f a lsb) (n `xor` (1 `unsafeShiftL` lsb)) where
!lsb = countTrailingZeros n
bitScanForward, bitScanReverse :: Word64 -> Int
bitScanForward = countTrailingZeros
bitScanReverse = (63 -) . countLeadingZeros
newtype Move = Move Word16 deriving (Eq)
instance Show Move where
show = toUCI
move :: Int -> Int -> Move
move from to = Move $ fromIntegral from .|. fromIntegral to `unsafeShiftL` 6
promoteTo :: Move -> PieceType -> Move
promoteTo (Move x) = Move . set where
set Knight = x .|. 0b001_000000_000000
set Bishop = x .|. 0b010_000000_000000
set Rook = x .|. 0b011_000000_000000
set Queen = x .|. 0b100_000000_000000
set _ = x
unpack :: Move -> (Int, Int, Maybe PieceType)
unpack (Move x) = ( fromIntegral (x .&. 0b111111)
, fromIntegral ((x `unsafeShiftR` 6) .&. 0b111111)
, piece)
where
!piece = case x `unsafeShiftR` 12 of
1 -> Just Knight
2 -> Just Bishop
3 -> Just Rook
4 -> Just Queen
_ -> Nothing
-- | Parse a move in the format used by the Universal Chess Interface protocol.
fromUCI :: Position -> String -> Maybe Move
fromUCI pos (fmap (splitAt 2) . splitAt 2 -> (from, (to, promo)))
| length from == 2 && length to == 2 && null promo
= move <$> readCoord from <*> readCoord to >>= relativeTo pos
| length from == 2 && length to == 2 && length promo == 1
= (\f t p -> move f t `promoteTo` p) <$> readCoord from
<*> readCoord to
<*> readPromo promo
>>= relativeTo pos
where
readCoord [f,r]
| inRange ('a','h') f && inRange ('1','8') r
= Just $ (ord r - ord '1') * 8 + (ord f - ord 'a')
readCoord _ = Nothing
readPromo "q" = Just Queen
readPromo "r" = Just Rook
readPromo "b" = Just Bishop
readPromo "n" = Just Knight
readPromo _ = Nothing
fromUCI _ _ = Nothing
-- | Convert a move to the format used by the Universal Chess Interface protocol.
toUCI :: Move -> String
toUCI (unpack -> (from, to, promo)) = coord from <> coord to <> p where
coord x = let (r,f) = x `divMod` 8 in
chr (f + ord 'a') : [chr (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 -> Move -> Maybe Move
relativeTo pos m | m `elem` moves pos = Just m
| otherwise = Nothing
shiftN, shiftNNE, shiftNE, shiftENE, shiftE, shiftESE, shiftSE, shiftSSE, shiftS, shiftSSW, shiftSW, shiftWSW, shiftW, shiftWNW, shiftNW, shiftNNW :: Word64 -> Word64
shiftN w = w `unsafeShiftL` 8
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
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
-- | 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@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 `clearMask` (rank1 .|. epMask)
}
| 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 `clearMask` (rank1 .|. epMask)
}
| 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 `clearMask` (rank8 .|. epMask)
}
| 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 `clearMask` (rank8 .|. epMask)
}
| Just Queen <- promo
, color pos == White
= pos { board = clearB { wP = wP bb `clearBit` from
, wQ = wQ bb `setBit` to
}
, color = opponent (color pos)
, flags = flags `clearMask` (epMask .|. bit to)
}
| Just Rook <- promo
, color pos == White
= pos { board = clearB { wP = wP bb `clearBit` from
, wR = wR bb `setBit` to
}
, color = opponent (color pos)
, flags = flags `clearMask` (epMask .|. bit to)
}
| Just Bishop <- promo
, color pos == White
= pos { board = clearB { wP = wP bb `clearBit` from
, wB = wB bb `setBit` to
}
, color = opponent (color pos)
, flags = flags `clearMask` (epMask .|. bit to)
}
| Just Knight <- promo
, color pos == White
= pos { board = clearB { wP = wP bb `clearBit` from
, wN = wN bb `setBit` to
}
, color = opponent (color pos)
, flags = flags `clearMask` (epMask .|. bit to)
}
| Just Queen <- promo
, color pos == Black
= pos { board = clearW { bP = bP bb `clearBit` from
, bQ = bQ bb `setBit` to
}
, color = opponent (color pos)
, flags = flags `clearMask` (epMask .|. bit to)
}
| Just Rook <- promo
, color pos == Black
= pos { board = clearW { bP = bP bb `clearBit` from
, bR = bR bb `setBit` to
}
, color = opponent (color pos)
, flags = flags `clearMask` (epMask .|. bit to)
}
| Just Bishop <- promo
, color pos == Black
= pos { board = clearW { bP = bP bb `clearBit` from
, bB = bB bb `setBit` to
}
, color = opponent (color pos)
, flags = flags `clearMask` (epMask .|. bit to)
}
| Just Knight <- promo
, color pos == Black
= pos { board = clearW { bP = bP bb `clearBit` from
, bN = bN bb `setBit` to
}
, color = opponent (color pos)
, flags = flags `clearMask` (epMask .|. bit to)
}
| otherwise
= pos { board = newBoard
, color = opponent (color pos)
, flags = (flags `clearMask` (epMask .|. mask)) .|. dpp }
where
!bb = board pos
epBit = case color pos of
White | wP bb `testMask` fromMask -> shiftS $ flags .&. rank6 .&. toMask
Black | bP bb `testMask` fromMask -> shiftN $ flags .&. rank3 .&. toMask
_ -> 0
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 `clearMask` (toMask .|. epBit)
, bN = bN bb `clearMask` toMask
, bB = bB bb `clearMask` toMask
, bR = bR bb `clearMask` toMask
, bQ = bQ bb `clearMask` toMask
}
!fromMask = 1 `unsafeShiftL` from
!toMask = 1 `unsafeShiftL` to
!mask = fromMask .|. toMask
newBoard = case color pos of
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 `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 | 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, 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
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
-- | 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] -> [Move]
wPawnMoves pawns emptySquares opponentPieces =
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
eastCaptureTargets = shiftNE pawns .&. opponentPieces
westCaptureTargets = shiftNW pawns .&. opponentPieces
mkMove diff ms tsq
| tsq >= 56 = (promoteTo m <$> [Queen, Rook, Bishop, Knight]) <> ms
| otherwise = m : ms
where m = move (tsq - diff) tsq
bPawnMoves :: Word64 -> Word64 -> Word64 -> [Move] -> [Move]
bPawnMoves pawns emptySquares opponentPieces =
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
eastCaptureTargets = shiftSE pawns .&. opponentPieces
westCaptureTargets = shiftSW pawns .&. opponentPieces
mkMove diff ms tsq
| tsq <= 7 = (promoteTo m <$> [Queen, Rook, Bishop, Knight]) <> ms
| otherwise = m : ms
where m = move (tsq + diff) tsq
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
targets sq = case piece of
Rook -> rookTargets sq occ .&. notOurs
Bishop -> bishopTargets sq occ .&. notOurs
Queen -> queenTargets sq occ .&. notOurs
_ -> error "Not a sliding piece"
occ = ours .|. occupiedBy (opponent c) bb
pieces = case (c, piece) of
(White, Bishop) -> wB bb
(Black, Bishop) -> bB bb
(White, Rook) -> wR bb
(Black, Rook) -> bR bb
(White, Queen) -> wQ bb
(Black, Queen) -> bQ bb
_ -> 0
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 = flip (foldBits gen)
gen ms sq = foldBits (mkMove sq) ms ((kingAttacks ! sq) .&. notOurs)
mkMove from ms to = move from to : ms
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)
wQscm = move (fromEnum E1) (fromEnum C1)
bKscm = move (fromEnum E8) (fromEnum G8)
bQscm = move (fromEnum E8) (fromEnum C8)
attackedBy :: Color -> Int -> BB -> Bool
attackedBy White sq bb@BB{wP, wN, wB, wR, wQ, wK}
| (wPawnAttacks ! sq) .&. wP /= 0 = True
| (knightAttacks ! sq) .&. wN /= 0 = True
| bishopTargets sq occ .&. wB /= 0 = True
| rookTargets sq occ .&. wR /= 0 = True
| queenTargets sq occ .&. wQ /= 0 = True
| (kingAttacks ! sq) .&. wK /= 0 = True
| otherwise = False
where occ = occupied bb
attackedBy Black sq bb@BB{bP, bN, bB, bR, bQ, bK}
| (bPawnAttacks ! sq) .&. bP /= 0 = True
| (knightAttacks ! sq) .&. bN /= 0 = True
| bishopTargets sq occ .&. bB /= 0 = True
| rookTargets sq occ .&. bR /= 0 = True
| queenTargets sq occ .&. bQ /= 0 = True
| (kingAttacks ! sq) .&. bK /= 0 = True
| otherwise = False
where occ = occupied bb
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, crMask, crwKs, crwQs, crwKe, crwQe, crbKs, crbQs, crbKe, crbQe :: Word64
epMask = rank3 .|. rank6 -- mask for en passant
crMask = 0x9100000000000091 -- mask for castle rights
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
data Direction = N | NE | E | SE | S | SW | W | NW deriving (Eq, Show)
rookTargets, bishopTargets, queenTargets :: Int -> Word64 -> Word64
rookTargets sq occ = getRayTargets sq N occ .|. getRayTargets sq E occ
.|. getRayTargets sq S occ .|. getRayTargets sq W occ
bishopTargets sq occ = getRayTargets sq NW occ .|. getRayTargets sq NE occ
.|. getRayTargets sq SE occ .|. getRayTargets sq SW occ
queenTargets sq occ = rookTargets sq occ .|. bishopTargets sq occ
getRayTargets :: Int -> Direction -> Word64 -> Word64
getRayTargets sq dir occ = blocked $ attacks .&. occ where
blocked 0 = attacks
blocked bb = attacks `xor` (ray ! bitScan bb)
attacks = ray ! sq
(bitScan, ray) = case dir of
NW -> (bitScanForward, attackNW)
N -> (bitScanForward, attackN)
NE -> (bitScanForward, attackNE)
E -> (bitScanForward, attackE)
SE -> (bitScanReverse, attackSE)
S -> (bitScanReverse, attackS)
SW -> (bitScanReverse, attackSW)
W -> (bitScanReverse, attackW)
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 clearMask #-}
{-# INLINE attackedBy #-}
{-# INLINE kingMoves #-}
{-# INLINE slideMoves #-}
{-# INLINE wPawnMoves #-}
{-# INLINE bPawnMoves #-}
{-# INLINE unpack #-}
{-# INLINE foldBits #-}