chessIO (empty) → 0.0.0.0
raw patch · 6 files changed
+837/−0 lines, 6 filesdep +basedep +chessIOdep +directorysetup-changed
Dependencies added: base, chessIO, directory, parallel, time, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- chessIO.cabal +56/−0
- src/Game/Chess.hs +657/−0
- src/Game/Debug.hs +16/−0
- test/Perft.hs +76/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ chessIO.cabal view
@@ -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
+ src/Game/Chess.hs view
@@ -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 #-}
+ src/Game/Debug.hs view
@@ -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 = '.'
+ test/Perft.hs view
@@ -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"