From 881231585a56ebb4ca47d3232d87e3bbdbafe3ba Mon Sep 17 00:00:00 2001 From: Giovanni Garufi Date: Tue, 26 Jan 2021 11:31:08 +0000 Subject: [PATCH] Generate knight moves ahead of time. Also adds checks when castling to see if any passed square is under attack Change-type: minor Signed-off-by: Giovanni Garufi --- src/Board.hs | 26 +++++++++++++------------- src/MoveGen.hs | 49 +++++++++++++++++++++++++++++-------------------- 2 files changed, 42 insertions(+), 33 deletions(-) diff --git a/src/Board.hs b/src/Board.hs index c1b5b78..f3fb336 100644 --- a/src/Board.hs +++ b/src/Board.hs @@ -41,6 +41,19 @@ fromInt i = case i of 7 -> H _ -> error "Column out of bounds" +data CastleType = Long | Short deriving (Eq, Show, Ord) +data CastlingRight = CastlingRight Colour CastleType deriving (Eq, Show, Ord) + +data GameState = GameState { + board :: Board, + active :: Colour, + castling :: S.Set CastlingRight, + enPassant :: Maybe Position, + halfMoveClock :: Int, + fullMove :: Int, + lastMove :: Maybe Move +} + type Row = Int positionToIndex :: Position -> Int @@ -86,19 +99,6 @@ flipColour :: Colour -> Colour flipColour White = Black flipColour Black = White -data CastleType = Long | Short deriving (Eq, Show, Ord) -data CastlingRight = CastlingRight Colour CastleType deriving (Eq, Show, Ord) - -data GameState = GameState { - board :: Board, - active :: Colour, - castling :: S.Set CastlingRight, - enPassant :: Maybe Position, - halfMoveClock :: Int, - fullMove :: Int, - lastMove :: Maybe Move -} - instance Show PieceType where show King = "k" show Queen = "q" diff --git a/src/MoveGen.hs b/src/MoveGen.hs index adcaef7..04ded9d 100644 --- a/src/MoveGen.hs +++ b/src/MoveGen.hs @@ -3,8 +3,25 @@ module MoveGen where import Board import qualified Data.Vector as V import Data.List (delete) -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromJust) import qualified Data.Set as S +import qualified Data.IntMap.Strict as M + +type KnightMap = M.IntMap [Position] + +knightMap :: KnightMap +knightMap = foldl (\m k -> M.insert k (go k m) m) M.empty [0..63] + where + go k m = map (\(a,b) -> (fromInt a, b)) $ filter inbounds allMoves + where + (col, row) = indexToPosition k + c = toInt col + r = row + allMoves = [(c-1, r-2), (c-2, r-1) + , (c-2, r+1), (c-1, r+2) + , (c+1, r+2), (c+2, r+1) + , (c+2, r-1), (c+1, r-2)] + inbounds (a,b) = (a >= 0 && a <= 7) && (b >= 1 && b <= 8) genMoves :: GameState -> Colour -> [Move] genMoves gs col = @@ -92,8 +109,6 @@ loosesCastlingRights b (Move src dst) activeRights | S.null activeRights = S.emp Just (Piece colour ty) = b `atPosition` src (col, _) = src - - genAllPawnMoves :: GameState -> Colour -> [Move] genAllPawnMoves gs col = concat $ V.toList $ V.map (genPawnMoves b col) pawns where @@ -144,17 +159,10 @@ containsOpponentPiece b c i | i < 0 || i > 63 = error "debug: containsOpponentPi Nothing -> False Just (Piece c' p) -> c /= c' -knightMoves :: Board -> Colour -> Position -> [Position] -knightMoves board colour (col, row) = map (\(a,b) -> (fromInt a, b)) $ filter canMove $ filter inbounds allMoves +knightMoves :: Board -> Colour -> Int -> [Position] +knightMoves board colour i = filter canMove $ fromJust $ M.lookup i knightMap where - c = toInt col - r = row - allMoves = [(c-1, r-2), (c-2, r-1) - , (c-2, r+1), (c-1, r+2) - , (c+1, r+2), (c+2, r+1) - , (c+2, r-1), (c+1, r-2)] - inbounds (a,b) = (a >= 0 && a <= 7) && (b >= 1 && b <= 8) - canMove (a,b) = case board `atPosition` (fromInt a, b) of + canMove pos = case board `atPosition` pos of Nothing -> True Just (Piece c p) -> c /= colour @@ -181,7 +189,7 @@ genAllKnightMoves gs col = concat $ V.toList $ V.map (genKnightMoves b col) knig knights = pieceIndexes (Piece col Knight) b genKnightMoves :: Board -> Colour -> Int -> [Move] -genKnightMoves board colour i = map moveFromCurr $ knightMoves board colour (col, row) +genKnightMoves board colour i = map moveFromCurr $ knightMoves board colour i where (col,row) = indexToPosition i moveFromCurr (a,b) = Move (col,row) (a, b) @@ -249,25 +257,26 @@ genKingMoves gs colour i = (map moveFromCurr $ filter canMove $ filter inbounds canCastle :: GameState -> Colour -> CastleType -> Bool canCastle gs White cty = case cty of - Long -> CastlingRight White Long `elem` activeRights && all (isEmpty b) [1,2,3] - Short -> CastlingRight White Short `elem` activeRights && all (isEmpty b) [5,6] + Long -> CastlingRight White Long `elem` activeRights && all (isEmpty b) [1,2,3] && all null (map (attackers White (board gs)) [1,2,3]) + Short -> CastlingRight White Short `elem` activeRights && all (isEmpty b) [5,6] && all null (map (attackers White (board gs)) [5,6]) where b = board gs activeRights = castling gs canCastle gs Black cty = case cty of - Long -> CastlingRight Black Long `elem` activeRights && all (isEmpty b) [57,58,59] - Short -> CastlingRight Black Short `elem` activeRights && all (isEmpty b) [61,62] + Long -> CastlingRight Black Long `elem` activeRights && all (isEmpty b) [57,58,59] && all null (map (attackers White (board gs)) [57,58,59]) + Short -> CastlingRight Black Short `elem` activeRights && all (isEmpty b) [61,62] && all null (map (attackers White (board gs)) [61,62]) where b = board gs activeRights = castling gs -attackers :: Int -> Colour -> Board -> [Piece] -attackers i colour board = inLOS +attackers :: Colour -> Board -> Int -> [Piece] +attackers colour board i = inLOS ++ knights where (col, row) = indexToPosition i inLOS = catMaybes $ fmap ((board `atPosition`) . last) $ straight ++ diag straight = filter (/= []) $ rookRays board colour (col, row) diag = filter (/= []) $ bishopRays board colour (col, row) + knights = catMaybes $ filter (== (Just $ Piece (flipColour colour) Knight)) $ map (board `atPosition`) $ fromJust $ M.lookup i knightMap rayToMoves :: Position -> [Position] -> [Move] rayToMoves src dests = uncurry Move <$> [(src, dest) | dest <- dests]