diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Mario Lang (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Mario Lang nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/chessIO.cabal b/chessIO.cabal new file mode 100644 --- /dev/null +++ b/chessIO.cabal @@ -0,0 +1,56 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: bce4c13865f7d91aaf5bc6807f962a6263a4f6ccd6ccea79504ebac4a9f53f64 + +name: chessIO +version: 0.0.0.0 +description: A simple chess move generation library +homepage: https://github.com/mlang/chessIO#readme +bug-reports: https://github.com/mlang/chessIO/issues +author: Mario Lang +maintainer: mlang@blind.guru +copyright: 2019 Mario Lang +license: BSD3 +license-file: LICENSE +build-type: Simple + +source-repository head + type: git + location: https://github.com/mlang/chessIO + +library + exposed-modules: + Game.Chess + other-modules: + Game.Debug + Paths_chessIO + hs-source-dirs: + src + default-extensions: BangPatterns BinaryLiterals DeriveGeneric NamedFieldPuns NumericUnderscores TupleSections ViewPatterns + ghc-options: -Wall -O2 + build-depends: + base >=4.8 && <5 + , vector + default-language: Haskell2010 + +test-suite perft + type: exitcode-stdio-1.0 + main-is: Perft.hs + other-modules: + Paths_chessIO + hs-source-dirs: + test + default-extensions: BangPatterns BinaryLiterals DeriveGeneric NamedFieldPuns NumericUnderscores TupleSections ViewPatterns + ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N -s" + build-depends: + base >=4.8 && <5 + , chessIO + , directory + , parallel + , time + , vector + default-language: Haskell2010 diff --git a/src/Game/Chess.hs b/src/Game/Chess.hs new file mode 100644 --- /dev/null +++ b/src/Game/Chess.hs @@ -0,0 +1,657 @@ +{-| +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 ( + -- * Representing chess positions + Position, startpos + -- * Converting from/to Forsyth-Edwards-Notation +, fromFEN, toFEN + -- * Chess moves +, Move + -- ** Converting from/to algebraic notation used by the Universal Chess Interface +, fromUCI, toUCI + -- ** Validating that a move is actually legal in a given position +, relativeTo + -- ** Move generation +, moves + -- ** Executing moves +, applyMove +) where + +import Data.Bits +import Data.Char +import Data.Ix +import Data.List +import Data.Maybe +import Data.Vector.Unboxed (Vector, (!)) +import qualified Data.Vector.Unboxed as Vector +import Data.Word +import Text.Read + +-- | 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, Ord, Show) + +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) + +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 s + | 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 s + 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) = intercalate " " [ + 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 == ' ' = if length xs == 8 then "" else 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 + +empty :: BB -> Word64 +empty = complement . occupied + +foldBits :: (a -> Int -> a) -> a -> Word64 -> a +foldBits _ a 0 = a +foldBits f !a n = foldBits f (f a lsb) (n `clearBit` lsb) where + !lsb = countTrailingZeros n + +bitScanForward, bitScanReverse :: Word64 -> Int +bitScanForward = countTrailingZeros +bitScanReverse = (63 -) . countLeadingZeros + +newtype Move = Move Word16 deriving (Eq) + +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 :: String -> Maybe Move +fromUCI (fmap (splitAt 2) . splitAt 2 -> (from, (to, promo))) + | length from == 2 && length to == 2 && length promo == 0 + = move <$> readCoord from <*> readCoord to + | length from == 2 && length to == 2 && length promo == 1 + = (\f t p -> move f t `promoteTo` p) <$> readCoord from + <*> readCoord to + <*> readPromo promo + 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 + +-- | 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 + +applyMove :: Position -> Move -> Position +applyMove pos m@(unpack -> (from, to, promo)) + | m == wKscm && flags pos `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) + } + | m == wQscm && flags pos `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) + } + | m == bKscm && flags pos `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) + } + | m == bQscm && flags pos `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) + } + | 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 pos `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 pos `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 pos `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 pos `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 pos `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 pos `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 pos `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 pos `clearMask` (epMask .|. bit to) + } + | otherwise + = pos { board = newBoard + , color = opponent (color pos) + , flags = (flags pos `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 + _ -> 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 + } + 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 + } + !mask = bit from `setBit` to + 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 } + | 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 } + | 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) + _ -> 0 + +moves :: Position -> [Move] +moves pos@Position{color} = filter (not . legal) $ + pawnMoves pos + <> slideMoves Bishop pos + <> slideMoves Rook pos + <> slideMoves Queen pos + <> knightMoves pos + <> kingMoves pos + where + legal m = let board' = board (applyMove 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' + +pawnMoves :: Position -> [Move] +pawnMoves (Position bb White flags _ _) = + wPawnMoves (wP bb) (empty bb) (occupiedBy Black bb .|. (flags .&. epMask)) +pawnMoves (Position bb Black flags _ _) = + bPawnMoves (bP bb) (empty bb) (occupiedBy White bb .|. (flags .&. epMask)) + +wPawnMoves :: Word64 -> Word64 -> Word64 -> [Move] +wPawnMoves pawns empty opponentPieces = + foldBits (mkMove 9) (foldBits (mkMove 7) (foldBits (mkMove 8) (foldBits (mkMove 16) [] doublePushTargets) singlePushTargets) westCaptureTargets) eastCaptureTargets + where + doublePushTargets = shiftN singlePushTargets .&. empty .&. rank4 + singlePushTargets = shiftN pawns .&. empty + 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] +bPawnMoves pawns empty opponentPieces = + foldBits (mkMove 9) (foldBits (mkMove 7) (foldBits (mkMove 8) (foldBits (mkMove 16) [] doublePushTargets) singlePushTargets) eastCaptureTargets) westCaptureTargets + where + doublePushTargets = shiftS singlePushTargets .&. empty .&. rank5 + singlePushTargets = shiftS pawns .&. empty + 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 -> [Move] +slideMoves piece (Position bb c _ _ _) = + foldBits gen mempty 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" + ours = occupiedBy c bb + notOurs = complement ours + 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 + +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 + where + kMoves = foldBits gen mempty + 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 = [] + +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 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 knightMoves #-} +{-# INLINE slideMoves #-} +{-# INLINE pawnMoves #-} +{-# INLINE wPawnMoves #-} +{-# INLINE bPawnMoves #-} +{-# INLINE unpack #-} +{-# INLINE foldBits #-} diff --git a/src/Game/Debug.hs b/src/Game/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Game/Debug.hs @@ -0,0 +1,16 @@ +module Game.Debug where + +import Data.Bits +import Data.List +import Numeric + +newtype Hex a = Hex { bless :: a } +instance (Integral a, Show a) => Show (Hex a) where + show (Hex a) = showHex a "" + +newtype BitBoard a = BitBoard a +instance (Bits a) => Show (BitBoard a) where + show (BitBoard v) = intercalate "\n" $ map row [7,6..0] where + row r = map (cell r) [0..7] + cell r f | testBit v (r*8+f) = 'o' + | otherwise = '.' diff --git a/test/Perft.hs b/test/Perft.hs new file mode 100644 --- /dev/null +++ b/test/Perft.hs @@ -0,0 +1,76 @@ +module Main where + +import Control.Parallel.Strategies +import Data.Foldable +import Data.Maybe +import Data.Time.Clock +import Data.Traversable +import Game.Chess +import GHC.Generics (Generic) +import System.Directory +import System.Exit +import System.IO + +main :: IO () +main = do + start <- getCurrentTime + exists <- doesFileExist "perftsuite.epd" + ok <- if exists + then do + suite <- readTestSuite "perftsuite.epd" + runTestSuite suite + else do + for_ [0..6] $ \n -> do + putStrLn $ showResult n (perft n startpos) + hFlush stdout + pure False + end <- getCurrentTime + putStrLn $ "Time: " <> show (diffUTCTime end start) + exitWith $ if ok then ExitSuccess else ExitFailure 1 + +data PerftResult = PerftResult { nodes :: !Integer } deriving (Eq, Generic, Show) +instance NFData PerftResult + +instance Semigroup PerftResult where + PerftResult n1 <> PerftResult n2 = PerftResult $ n1 + n2 + +instance Monoid PerftResult where + mempty = PerftResult 0 + +showResult :: Int -> PerftResult -> String +showResult depth PerftResult{nodes} = show depth <> " " <> show nodes + +perft :: Int -> Position -> PerftResult +perft 0 _ = PerftResult 1 +perft 1 p = PerftResult . fromIntegral . length $ + applyMove p <$> moves p +perft 2 p = fold . map (perft 1) $ applyMove p <$> moves p +perft n p = fold . withStrategy (parList rdeepseq) . map (perft $ pred n) $ + applyMove p <$> moves p + +runTestSuite :: [(Position, [(Int, PerftResult)])] -> IO Bool +runTestSuite = fmap (all id) . traverse (uncurry test) where + test pos ((depth, expected) : more) + | result == expected + = do + putStrLn $ "OK " <> fen <> " ;D" <> show depth <> " " + <> show (nodes expected) + hFlush stdout + test pos more + | otherwise + = do + putStrLn $ "FAIL " <> fen <> " ;D" <> show depth <> " " + <> show (nodes expected) <> " /= " <> show (nodes result) + pure False + where result = perft depth pos + fen = toFEN pos + test _ [] = pure True + +readTestSuite :: FilePath -> IO [(Position, [(Int, PerftResult)])] +readTestSuite fp = do + epd <- readFile fp + pure $ fmap readData . (\ws -> (fromJust (fromFEN (unwords $ take 6 ws)), drop 6 ws)) . words <$> lines epd + where + readData [] = [] + readData ((';':'D':d):v:xs) = (read d, PerftResult $ read v) : readData xs + readData _ = error "Failed to parse test suite"