diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,3 +3,17 @@ [![Build Status](https://travis-ci.org/nablaa/hchesslib.png?branch=master)](https://travis-ci.org/nablaa/hchesslib) hchesslib is a simple chess library for Haskell. + +## Building + +Building the library inside cabal sandbox: + + cabal sandbox init + cabal install --only-dependencies --enable-tests + cabal build + +## Running tests + +Running unit tests after the library has been built: + + cabal test diff --git a/hchesslib.cabal b/hchesslib.cabal --- a/hchesslib.cabal +++ b/hchesslib.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: hchesslib -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Chess library description: Library implementing chess rules. license: GPL-2 @@ -24,7 +24,7 @@ Default-Language: Haskell2010 Hs-Source-Dirs: src - exposed-modules: Chess, Chess.FEN + exposed-modules: Chess, Chess.FEN, Chess.UI other-modules: Chess.Internal.Piece, Chess.Internal.Board, @@ -43,8 +43,26 @@ Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: src, test, test/Chess - Ghc-Options: -Wall -Werror + Ghc-Options: -Wall Main-Is: Spec.hs + + Other-modules: BoardTests, + Chess, + Chess.FEN, + Chess.UI, + Chess.Internal.Board, + Chess.Internal.FEN, + Chess.Internal.Game, + Chess.Internal.Move, + Chess.Internal.Notation, + Chess.Internal.Piece, + FENTests, + GameTests, + MoveTests, + NotationTests, + PieceTests, + TestUtils, + UITests Build-Depends: base >= 4 && < 5 , hspec >= 1.5 diff --git a/src/Chess.hs b/src/Chess.hs --- a/src/Chess.hs +++ b/src/Chess.hs @@ -17,6 +17,7 @@ Chess.Internal.Piece.Color(..), Chess.Internal.Piece.Piece(..), Chess.Internal.Piece.PieceType(..), + Chess.Internal.Move.Move, board, fullMoveNumber, isCheckmate, @@ -27,6 +28,8 @@ newGame, pieceAt, winner, + legalMoves, + applyMove, ) where import Chess.Internal.Board @@ -67,9 +70,7 @@ -> String -- ^ Move in coordinate notation. E.g. "e2-e4" or "b1-c3" -> Maybe GameState move game moveStr = do m <- N.parseMove game moveStr - case G.applyMove game m of - Left _ -> Nothing - Right game' -> Just game' + applyMove game m -- | Current board state in the game board :: GameState -> Board @@ -89,3 +90,13 @@ -- | Full move number. Incremented after black's move. fullMoveNumber :: GameState -> Integer fullMoveNumber = moveNumber + +-- | Get all legal moves in the position +legalMoves :: GameState -> [Move] +legalMoves = generateAllMoves + +-- | Apply a move +applyMove :: GameState -> Move -> Maybe GameState +applyMove game m = case G.applyMove game m of + Left _ -> Nothing + Right game' -> Just game' diff --git a/src/Chess/Internal/Board.hs b/src/Chess/Internal/Board.hs --- a/src/Chess/Internal/Board.hs +++ b/src/Chess/Internal/Board.hs @@ -75,8 +75,8 @@ isInsideBoard (i, j) = i >= 0 && i <= 7 && j >= 0 && j <= 7 parseCoordinate :: String -> Maybe Coordinates -parseCoordinate (column:row:[]) | isInsideBoard coordinates = Just coordinates - | otherwise = Nothing +parseCoordinate [column, row] | isInsideBoard coordinates = Just coordinates + | otherwise = Nothing where coordinates = (ord '8' - ord row, ord column - ord 'a') parseCoordinate _ = Nothing @@ -170,7 +170,7 @@ isOpponentKnight square = case getPiece board square of Just (Piece player Knight) -> player == opponentPlayer _ -> False - pawnsThreaten = any isOpponentPawn $ map (sumSquares coords) pawnSquares + pawnsThreaten = any (isOpponentPawn . sumSquares coords) pawnSquares pawnSquares = case opponentPlayer of White -> [(1, -1), (1, 1)] Black -> [(-1, -1), (-1, 1)] @@ -210,5 +210,5 @@ where typeFromPiece (Piece _ pieceType) = pieceType getSquareColor :: Coordinates -> Color -getSquareColor (row, column) | (row + column) `mod` 2 == 0 = White +getSquareColor (row, column) | even (row + column) = White | otherwise = Black diff --git a/src/Chess/Internal/FEN.hs b/src/Chess/Internal/FEN.hs --- a/src/Chess/Internal/FEN.hs +++ b/src/Chess/Internal/FEN.hs @@ -5,7 +5,6 @@ import Chess.Internal.Piece import Data.List import Data.Char -import Data.Maybe writeBoard :: Board -> String writeBoard = intercalate "/" . lines . concatMap emptyToNum . group . printBoardCompact @@ -74,7 +73,7 @@ else Nothing readMaybe :: Read a => String -> Maybe a -readMaybe = fmap fst . listToMaybe . filter (null . snd) . reads +readMaybe = fmap fst . find (null . snd) . reads split :: (Char -> Bool) -> String -> [String] split p str = case dropWhile p str of diff --git a/src/Chess/Internal/Move.hs b/src/Chess/Internal/Move.hs --- a/src/Chess/Internal/Move.hs +++ b/src/Chess/Internal/Move.hs @@ -188,9 +188,9 @@ castlingSquares Black Short = [(0, 5), (0, 6)] patternMoves :: GameState -> Coordinates -> [(Int, Int)] -> [Move] -patternMoves game start pattern - = concat [movementsInDirection game start dir | dir <- pattern] - ++ concat [capturesInDirection game start dir | dir <- pattern] +patternMoves game start pattern' + = concat [movementsInDirection game start dir | dir <- pattern'] + ++ concat [capturesInDirection game start dir | dir <- pattern'] movementsInDirection :: GameState -> Coordinates -> (Int, Int) -> [Move] movementsInDirection game start direction = map (Movement piece start) squares diff --git a/src/Chess/Internal/Piece.hs b/src/Chess/Internal/Piece.hs --- a/src/Chess/Internal/Piece.hs +++ b/src/Chess/Internal/Piece.hs @@ -1,5 +1,5 @@ module Chess.Internal.Piece (Piece(..), Color(..), PieceType(..), opponent, printPiece, - parsePiece, parsePieceType) where + parsePiece, pieceChars, parsePieceType) where import Data.Char diff --git a/src/Chess/UI.hs b/src/Chess/UI.hs new file mode 100644 --- /dev/null +++ b/src/Chess/UI.hs @@ -0,0 +1,81 @@ +-- | +-- Module : Chess +-- Copyright : Miika-Petteri Matikainen 2021 +-- License : GPL-2 +-- +-- Maintainer : miikapetteri@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- Visualize chess games +module Chess.UI ( + printBoard, + coordinateNotation + ) where + +import Data.Array +import Data.List +import Data.Char +import Data.Maybe +import Chess.Internal.Board +import Chess.Internal.Piece +import Chess.Internal.Move + +-- | Prints the board in ASCII. +-- +-- Example for the initial position: +-- @ +-- +-- +---+---+---+---+---+---+---+---+ +-- 8 | r | n | b | q | k | b | n | r | +-- +---+---+---+---+---+---+---+---+ +-- 7 | p | p | p | p | p | p | p | p | +-- +---+---+---+---+---+---+---+---+ +-- 6 | | | | | | | | | +-- +---+---+---+---+---+---+---+---+ +-- 5 | | | | | | | | | +-- +---+---+---+---+---+---+---+---+ +-- 4 | | | | | | | | | +-- +---+---+---+---+---+---+---+---+ +-- 3 | | | | | | | | | +-- +---+---+---+---+---+---+---+---+ +-- 2 | P | P | P | P | P | P | P | P | +-- +---+---+---+---+---+---+---+---+ +-- 1 | R | N | B | Q | K | B | N | R | +-- +---+---+---+---+---+---+---+---+ +-- a b c d e f g h +-- @ +printBoard :: Board -> String +printBoard = addCoordinates . printRows . intoRows . elems + where intoRows [] = [] + intoRows xs = take 8 xs : intoRows (drop 8 xs) + +addCoordinates :: String -> String +addCoordinates str = unlines (zipWith (++) numbers (lines str)) ++ chars + where numbers = lines $ unlines $ [" \n" ++ intToDigit n : " " | n <- reverse [1..8]] ++ [" "] + chars = " a b c d e f g h\n" + +printRows :: [[Square]] -> String +printRows rows = line ++ intercalate line (map printRow rows) ++ line + where line = concat (replicate 8 "+---") ++ "+" ++ "\n" + +printRow :: [Square] -> String +printRow row = sep ++ intercalate sep (map printSquare row) ++ sep ++ "\n" + where sep = "|" + +printSquare :: Square -> String +printSquare Empty = " " +printSquare (Square p) = " " ++ printPiece p ++ " " + +-- | Prints the move in coordinate notation. +-- E.g. "e2-e4", "g1-g3", "b2-c1q" +coordinateNotation :: Move -> String +coordinateNotation (Movement _ c1 c2) = printCoordinate c1 ++ "-" ++ printCoordinate c2 +coordinateNotation (Capture _ c1 c2) = printCoordinate c1 ++ "-" ++ printCoordinate c2 +coordinateNotation (EnPassant _ c1 c2) = printCoordinate c1 ++ "-" ++ printCoordinate c2 +coordinateNotation (PawnDoubleMove _ c1 c2) = printCoordinate c1 ++ "-" ++ printCoordinate c2 +coordinateNotation (Promotion _ c1 c2 p) = printCoordinate c1 ++ "-" ++ printCoordinate c2 ++ [toLower (fromJust (lookup p pieceChars))] +coordinateNotation (Castling White Short) = "e1-g1" +coordinateNotation (Castling White Long) = "e1-c1" +coordinateNotation (Castling Black Short) = "e8-g8" +coordinateNotation (Castling Black Long) = "e8-c8" diff --git a/test/Chess/BoardTests.hs b/test/Chess/BoardTests.hs new file mode 100644 --- /dev/null +++ b/test/Chess/BoardTests.hs @@ -0,0 +1,306 @@ +module BoardTests where + +import Chess.Internal.Piece +import Chess.Internal.Board +import Data.Maybe +import TestUtils +import Test.Hspec + +boardSpec :: IO () +boardSpec = hspec $ + describe "Board" $ do + boardPrintingSpec + isInsideBoardSpec + parseCoordinateSpec + printCoordinateSpec + getPieceSpec + movePieceSpec + parseBoardCompactSpec + isEmptySpec + isOpponentSquareSpec + firstPieceInSquareListSpec + iterateDirectionInsideBoardSpec + getKingSquareSpec + isSquareThreatenedSpec + isCheckSpec + getSquaresWithOwnerSpec + getPlayerPiecesSpec + getSquareColorSpec + getSquaresWithPiecesSpec + +boardPrintingSpec :: Spec +boardPrintingSpec = + describe "printBoardCompact" $ do + it "should print initial board position correctly" $ + printBoardCompact initialBoard `shouldBe` "rnbqkbnr\npppppppp\n \n \n \n \nPPPPPPPP\nRNBQKBNR\n" + + it "should print empty board correctly" $ + printBoardCompact emptyBoard `shouldBe` " \n \n \n \n \n \n \n \n" + +isInsideBoardSpec :: Spec +isInsideBoardSpec = + describe "isInsideBoard" $ + it "should detect correctly whether given coordinates are inside board bounds" $do + isInsideBoard (0, 0) `shouldBe` True + isInsideBoard (7, 7) `shouldBe` True + isInsideBoard (3, 5) `shouldBe` True + isInsideBoard (-1, 5) `shouldBe` False + isInsideBoard (3, -1) `shouldBe` False + isInsideBoard (8, 5) `shouldBe` False + isInsideBoard (3, 8) `shouldBe` False + +parseCoordinateSpec :: Spec +parseCoordinateSpec = + describe "parseCoordinate" $ do + it "should parse legal coordinates correctly" $ do + parseCoordinate "a8" `shouldBe` Just (0, 0) + parseCoordinate "b8" `shouldBe` Just (0, 1) + parseCoordinate "c8" `shouldBe` Just (0, 2) + parseCoordinate "a7" `shouldBe` Just (1, 0) + parseCoordinate "a6" `shouldBe` Just (2, 0) + parseCoordinate "a1" `shouldBe` Just (7, 0) + parseCoordinate "h8" `shouldBe` Just (0, 7) + parseCoordinate "h1" `shouldBe` Just (7, 7) + parseCoordinate "f5" `shouldBe` Just (3, 5) + + it "should parse not parse invalid coordinates" $ do + parseCoordinate "B5" `shouldBe` Nothing + parseCoordinate "F5" `shouldBe` Nothing + parseCoordinate "12" `shouldBe` Nothing + parseCoordinate "i1" `shouldBe` Nothing + parseCoordinate "a9" `shouldBe` Nothing + parseCoordinate "a-1" `shouldBe` Nothing + parseCoordinate "foobar" `shouldBe` Nothing + +printCoordinateSpec :: Spec +printCoordinateSpec = + describe "printCoordinate" $ + it "should print legal coordinates correctly" $ do + printCoordinate (0, 0) `shouldBe` "a8" + printCoordinate (0, 1) `shouldBe` "b8" + printCoordinate (0, 2) `shouldBe` "c8" + printCoordinate (1, 0) `shouldBe` "a7" + printCoordinate (2, 0) `shouldBe` "a6" + printCoordinate (3, 5) `shouldBe` "f5" + +getPieceSpec :: Spec +getPieceSpec = + describe "getPiece" $ do + it "should return Nothing for invalid coordinates" $ do + getPiece initialBoard (-1, -1) `shouldBe` Nothing + getPiece initialBoard (8, 8) `shouldBe` Nothing + + it "should return Nothing for empty squares" $ + getPiece initialBoard (4, 4) `shouldBe` Nothing + + it "should return piece for squares that have pieces" $ do + getPiece initialBoard (0, 0) `shouldBe` Just (Piece Black Rook) + getPiece initialBoard (0, 3) `shouldBe` Just (Piece Black Queen) + getPiece initialBoard (7, 4) `shouldBe` Just (Piece White King) + +movePieceSpec :: Spec +movePieceSpec = + describe "movePiece" $ do + it "should return Nothing for invalid coordinates" $ do + movePiece (0, 0) (8, 8) initialBoard `shouldBe` Nothing + movePiece (-1, -1) (7, 7) initialBoard `shouldBe` Nothing + + it "should return Nothing when start square does not have a piece" $ + movePiece (4, 4) (0, 0) initialBoard `shouldBe` Nothing + + it "should return new board when start square has a piece and end coordinate is valid" $ do + printBoardCompact (fromJust (movePiece (0, 0) (4, 4) initialBoard)) `shouldBe` " nbqkbnr\npppppppp\n \n \n r \n \nPPPPPPPP\nRNBQKBNR\n" + printBoardCompact (fromJust (movePiece (0, 0) (0, 0) initialBoard)) `shouldBe` "rnbqkbnr\npppppppp\n \n \n \n \nPPPPPPPP\nRNBQKBNR\n" + printBoardCompact (fromJust (movePiece (0, 0) (0, 1) initialBoard)) `shouldBe` " rbqkbnr\npppppppp\n \n \n \n \nPPPPPPPP\nRNBQKBNR\n" + +parseBoardCompactSpec :: Spec +parseBoardCompactSpec = + describe "parseBoardCompact" $ do + it "should be able to parse the initial board" $ + parseBoardCompact (printBoardCompact initialBoard) `shouldBe` Just initialBoard + + it "should be able to parse the empty board" $ + parseBoardCompact " \n \n \n \n \n \n \n \n" `shouldBe` Just emptyBoard + + it "should return Nothing with invalid board (too short row)" $ + parseBoardCompact " \n \n \n \n \n \n \n \n \n" `shouldBe` Nothing + + it "should return Nothing with invalid board (too few rows)" $ + parseBoardCompact " \n \n \n \n \n \n \n \n" `shouldBe` Nothing + + it "should return Nothing with empty input" $ + parseBoardCompact "" `shouldBe` Nothing + + it "should return Nothing with garbage input" $ + parseBoardCompact "foobar" `shouldBe` Nothing + + it "should return Nothing with invalid board (invalid pieces)" $ do + parseBoardCompact " \n xxx \n \n \n \n \n \n \n" `shouldBe` Nothing + parseBoardCompact "rnbqkbnr\nppxppppp\n \n \n \n \nPPPPPPPP\nRNBQKBNR\n" `shouldBe` Nothing + + it "should return Nothing with invalid board (empty row)" $ + parseBoardCompact "rnbqkbnr\npppppppp\n \n\n \n \n \nPPPPPPPP\nRNBQKBNR\n" `shouldBe` Nothing + + it "should return Nothing with invalid board (missing row)" $ + parseBoardCompact "pppppppp\n \n \n \n \nPPPPPPPP\nRNBQKBNR\n" `shouldBe` Nothing + +isEmptySpec :: Spec +isEmptySpec = + describe "isEmpty" $ do + it "should return True for empty squares" $ + isEmpty initialBoard (4, 4) `shouldBe` True + + it "should return True for squares out of bounds" $ do + isEmpty initialBoard (-1, -1) `shouldBe` True + isEmpty initialBoard (8, 8) `shouldBe` True + + it "should return False for squares containing pieces" $ do + isEmpty initialBoard (0, 0) `shouldBe` False + isEmpty initialBoard (0, 3) `shouldBe` False + isEmpty initialBoard (7, 4) `shouldBe` False + +isOpponentSquareSpec :: Spec +isOpponentSquareSpec = + describe "isOpponentSquare" $ do + it "should return False for empty squares" $ + isOpponentSquare initialBoard (4, 4) White `shouldBe` False + + it "should return False for squares out of bounds" $ do + isOpponentSquare initialBoard (-1, -1) Black `shouldBe` False + isOpponentSquare initialBoard (8, 8) White `shouldBe` False + + it "should return False for squares that have own pieces" $ do + isOpponentSquare initialBoard (0, 0) Black `shouldBe` False + isOpponentSquare initialBoard (7, 4) White `shouldBe` False + + it "should return True for squares that have opponent pieces" $ do + isOpponentSquare initialBoard (0, 3) White `shouldBe` True + isOpponentSquare initialBoard (7, 4) Black `shouldBe` True + +firstPieceInSquareListSpec :: Spec +firstPieceInSquareListSpec = + describe "firstPieceInSquareList" $ do + it "should return Nothing if none of the coordinates contain any piece" $ + firstPieceInSquareList initialBoard [(4, 1), (4, 2), (4, 3)] `shouldBe` Nothing + + it "should return the piece of the first coordinate from the list that contains a piece" $ do + firstPieceInSquareList initialBoard [(4, 1), (5, 2), (6, 3), (7, 4)] `shouldBe` Just (Piece White Pawn) + firstPieceInSquareList initialBoard [(7, 4), (0, 4)] `shouldBe` Just (Piece White King) + +iterateDirectionInsideBoardSpec :: Spec +iterateDirectionInsideBoardSpec = + describe "iterateDirectionInsideBoard" $ do + it "should return empty list for square next to border with direction towards border" $ + iterateDirectionInsideBoard (4, 0) (0, -1) `shouldBe` [] + + it "should return the list of coordinates that you get when you start walking from a square towards a certain direction" $ do + iterateDirectionInsideBoard (4, 1) (-1, 0) `shouldBe` [(3,1),(2,1),(1,1),(0,1)] + iterateDirectionInsideBoard (4, 1) (1, 1) `shouldBe` [(5,2),(6,3),(7,4)] + +getKingSquareSpec :: Spec +getKingSquareSpec = + describe "getKingSquare" $ + it "should return the coordinates of the square where king is currently" $ do + getKingSquare initialBoard White `shouldBe` coord "e1" + getKingSquare initialBoard Black `shouldBe` coord "e8" + +isSquareThreatenedSpec :: Spec +isSquareThreatenedSpec = + describe "isSquareThreatened" $ do + it "should return False for player square if no opponent piece threatens the given square" $ do + isSquareThreatened initialBoard Black (coord "e1") `shouldBe` False + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "g2") `shouldBe` False + + it "should return False for empty square if no opponent piece threatens the given square" $ do + isSquareThreatened initialBoard Black (coord "e4") `shouldBe` False + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "h5") `shouldBe` False + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "d8") `shouldBe` False + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") Black (coord "f4") `shouldBe` False + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "d8") `shouldBe` False + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "h6") `shouldBe` False + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "b5") `shouldBe` False + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "c4") `shouldBe` False + + it "should return True for player square if player piece threatens the given square" $ + isSquareThreatened initialBoard White (coord "e1") `shouldBe` True + + it "should not consider Pawn movement square threatened" $ do + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "c6") `shouldBe` False + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "e5") `shouldBe` False + + it "should detect when Pawn threatens a square" $ do + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") Black (coord "f1") `shouldBe` True + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") Black (coord "h1") `shouldBe` True + + it "should detect when Knight threatens a square" $ do + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "g5") `shouldBe` True + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "b4") `shouldBe` True + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "f4") `shouldBe` True + + it "should detect when Bishop threatens a square" $ + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "g8") `shouldBe` True + + it "should detect when Queen threatens a square" $ + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") Black (coord "b1") `shouldBe` True + + it "should detect when King threatens a square" $ + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") Black (coord "d8") `shouldBe` True + + it "should detect when multiple pieces threaten a square" $ do + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "d5") `shouldBe` True + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "g4") `shouldBe` True + isSquareThreatened (fenBoard "rnb1kb1r/ppp1p2p/4Bp2/2Pp4/1q2P1n1/7N/P1NP1PpP/R1BQK2R w KQkq - 0 1") White (coord "f1") `shouldBe` True + +isCheckSpec :: Spec +isCheckSpec = + describe "isCheck" $ do + it "should return False for initial board" $ do + isCheck initialBoard White `shouldBe` False + isCheck initialBoard Black `shouldBe` False + + it "should return True when opponent threatens the king square" $ do + isCheck (fenBoard "rnbqkbnr/pppp2pp/5p2/4p2Q/4P3/3P4/PPP2PPP/RNB1KBNR b KQkq - 1 3") Black `shouldBe` True + isCheck (fenBoard "rnbqk2r/pppp2bp/3N2pn/4pp1Q/4P3/3P4/PPP2PPP/RNB1KB1R b KQkq - 1 7") Black `shouldBe` True + isCheck (fenBoard "rnbq3r/pppp2bp/3Nk1pn/3Ppp1Q/4P3/8/PPP2PPP/RNB1KB1R b KQ - 0 9") Black `shouldBe` True + isCheck (fenBoard "8/5r2/4K1q1/4p3/3k4/8/8/8 w - - 0 7") White `shouldBe` True + isCheck (fenBoard "r3k2r/ppp2p1p/2n1p1p1/8/2B2P1q/2NPb1n1/PP4PP/R2Q3K w kq - 0 8") White `shouldBe` True + + it "should return False when king square is not threatened by the opponent" $ do + isCheck (fenBoard "rnbqkbnr/pppp2pp/5p2/4p2Q/4P3/3P4/PPP2PPP/RNB1KBNR b KQkq - 1 3") White `shouldBe` False + isCheck (fenBoard "8/5r2/4K1q1/4p3/3k4/8/8/8 w - - 0 7") Black `shouldBe` False + +getSquaresWithOwnerSpec :: Spec +getSquaresWithOwnerSpec = + describe "getSquaresWithOwner" $ + it "should return coordinates which have player pieces" $ do + getSquaresWithOwner (fenBoard "8/k7/8/8/6p1/7P/6PK/8 w - - 0 1") Black `shouldMatchList` [coord "a7", coord "g4"] + getSquaresWithOwner (fenBoard "8/k7/8/8/6p1/7P/6PK/8 w - - 0 1") White `shouldMatchList` [coord "g2", coord "h2", coord "h3"] + +getPlayerPiecesSpec :: Spec +getPlayerPiecesSpec = + describe "getPlayerPieces" $ + it "should return list of pieces a player owns" $ do + getPlayerPieces (fenBoard "4k3/8/5np1/8/8/2BB4/2Q5/4K3 w - - 0 1") White `shouldMatchList` [Bishop, Bishop, Queen, King] + getPlayerPieces (fenBoard "4k3/8/5np1/8/8/2BB4/2Q5/4K3 w - - 0 1") Black `shouldMatchList` [Knight, Pawn, King] + +getSquareColorSpec :: Spec +getSquareColorSpec = + describe "getSquareColor" $ + it "should return the color of the square in the given coordinate" $ do + getSquareColor (coord "a1") `shouldBe` Black + getSquareColor (coord "c1") `shouldBe` Black + getSquareColor (coord "g5") `shouldBe` Black + getSquareColor (coord "d8") `shouldBe` Black + getSquareColor (coord "h8") `shouldBe` Black + getSquareColor (coord "a2") `shouldBe` White + getSquareColor (coord "b5") `shouldBe` White + getSquareColor (coord "f3") `shouldBe` White + getSquareColor (coord "h1") `shouldBe` White + getSquareColor (coord "a8") `shouldBe` White + +getSquaresWithPiecesSpec :: Spec +getSquaresWithPiecesSpec = + describe "getSquaresWithPieces" $ + it "should return list of coordinates that have given piecetype on them" $ do + getSquaresWithPieces initialBoard Rook `shouldMatchList` map coord ["a1", "h1", "a8", "h8"] + getSquaresWithPieces initialBoard Queen `shouldMatchList` map coord ["d1", "d8"] diff --git a/test/Chess/FENTests.hs b/test/Chess/FENTests.hs new file mode 100644 --- /dev/null +++ b/test/Chess/FENTests.hs @@ -0,0 +1,68 @@ +module FENTests where + +import Chess.Internal.Piece +import Chess.Internal.Board +import Chess.FEN +import Chess.Internal.Move +import Test.Hspec + +fenSpec :: IO () +fenSpec = hspec $ + describe "FEN" $ do + writeFENSpec + readFENSpec + +writeFENSpec :: Spec +writeFENSpec = + describe "writeFEN" $ do + it "should serialize initial game state correctly" $ + writeFEN initialState `shouldBe` "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1" + + it "should serialize En Passant move and move counters correctly" $ + writeFEN (Chess.Internal.Move.State initialBoard Black [] [] (parseCoordinate "e3") 4 14) `shouldBe` "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR b - e3 4 14" + + it "should serialize castlings correctly" $ do + writeFEN (Chess.Internal.Move.State initialBoard White [] [Long] (parseCoordinate "c6") 0 9) `shouldBe` "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w q c6 0 9" + writeFEN (Chess.Internal.Move.State initialBoard White [Long] [Short] (parseCoordinate "c6") 0 9) `shouldBe` "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w Qk c6 0 9" + +readFENSpec :: Spec +readFENSpec = + describe "readFEN" $ do + it "should read initial game state FEN correctly" $ + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1" `shouldBe` Just initialState + + it "should read FEN with castlings, En Passant and move counters correctly" $ do + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w Kq e3 7 14" `shouldBe` Just (Chess.Internal.Move.State initialBoard White [Short] [Long] (parseCoordinate "e3") 7 14) + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w - - 10 42" `shouldBe` Just (Chess.Internal.Move.State initialBoard White [] [] Nothing 10 42) + + it "should not read FEN with missing castling information" $ + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w - 0 1" `shouldBe` Nothing + + it "should not read FEN with invalid player information" $ + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR K KQkq - 0 1" `shouldBe` Nothing + + it "should not read FEN with invalid move counter information" $ do + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - a 1" `shouldBe` Nothing + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 a" `shouldBe` Nothing + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w - - -1 1" `shouldBe` Nothing + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w - - 0 0" `shouldBe` Nothing + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w - - 0 -1" `shouldBe` Nothing + + it "should not read FEN with invalid board" $ do + readFEN "rnbqkbnr/pppppppp/8/8/7/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1" `shouldBe` Nothing + readFEN "nbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1" `shouldBe` Nothing + + it "should not read FEN with invalid castling information" $ do + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KKkq - 0 1" `shouldBe` Nothing + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w qKqQ - 0 1" `shouldBe` Nothing + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkK - 0 1" `shouldBe` Nothing + + it "should not read FEN with invalid En Passant square" $ do + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq a9 0 1" `shouldBe` Nothing + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq i8 0 1" `shouldBe` Nothing + readFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq 44 0 1" `shouldBe` Nothing + + it "should not read garbage" $ do + readFEN "foobar" `shouldBe` Nothing + readFEN "" `shouldBe` Nothing + readFEN "1 2 3 4 5 6" `shouldBe` Nothing diff --git a/test/Chess/GameTests.hs b/test/Chess/GameTests.hs new file mode 100644 --- /dev/null +++ b/test/Chess/GameTests.hs @@ -0,0 +1,173 @@ +module GameTests where + +import Chess.FEN +import Chess.Internal.Piece +import Chess.Internal.Move +import Chess.Internal.Game +import TestUtils +import Test.Hspec + +gameSpec :: IO () +gameSpec = hspec $ + describe "Game" $ do + applyMoveSpec + isCheckmateSpec + isStalemateSpec + isInsufficientMaterialSpec + isDrawSpec + getWinnerSpec + +applyMoveSpec :: Spec +applyMoveSpec = + describe "applyMove" $ do + it "should update board, player and full move counter correctly" $ + testApplyingMove "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1" (Movement (Piece White Pawn) (coord "e2") (coord "e3")) "rnbqkbnr/pppppppp/8/8/8/4P3/PPPP1PPP/RNBQKBNR b KQkq - 0 1" + + it "should update en passant square for white correctly" $ + testApplyingMove "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1" (PawnDoubleMove (Piece White Pawn) (coord "e2") (coord "e4")) "rnbqkbnr/pppppppp/8/8/4P3/8/PPPP1PPP/RNBQKBNR b KQkq e3 0 1" + + it "should update en passant square for black correctly" $ + testApplyingMove "rnbqkbnr/pppppppp/8/8/4P3/8/PPPP1PPP/RNBQKBNR b KQkq e3 0 1" (PawnDoubleMove (Piece Black Pawn) (coord "c7") (coord "c5")) "rnbqkbnr/pp1ppppp/8/2p5/4P3/8/PPPP1PPP/RNBQKBNR w KQkq c6 0 2" + + it "should update halfmove counter when no capture of pawn advance" $ + testApplyingMove "rnbqkbnr/pp1ppppp/8/2p5/4P3/8/PPPP1PPP/RNBQKBNR w KQkq c6 0 2" (Movement (Piece White Knight) (coord "g1") (coord "f3")) "rnbqkbnr/pp1ppppp/8/2p5/4P3/5N2/PPPP1PPP/RNBQKB1R b KQkq - 1 2" + + it "should zero halfmove counter piece is captured" $ + testApplyingMove "r1bqkb1r/pppppppp/2n2n2/4N3/8/2N5/PPPPPPPP/R1BQKB1R b KQkq - 5 3" (Capture (Piece Black Knight) (coord "c6") (coord "e5")) "r1bqkb1r/pppppppp/5n2/4n3/8/2N5/PPPPPPPP/R1BQKB1R w KQkq - 0 4" + + it "should zero halfmove counter when pawn moves" $ + testApplyingMove "r1bqkb1r/pppp1ppp/2n2n2/4p3/2B1P3/2N2N2/PPPP1PPP/R1BQK2R b KQkq - 5 4" (Movement (Piece Black Pawn) (coord "d7") (coord "d6")) "r1bqkb1r/ppp2ppp/2np1n2/4p3/2B1P3/2N2N2/PPPP1PPP/R1BQK2R w KQkq - 0 5" + + it "should zero halfmove counter when pawn promotes" $ + testApplyingMove "rnbqkbnr/ppp2ppp/B7/4N3/8/2N5/PPPP2pP/R1BQK2R b KQkq - 1 6" (Promotion (Piece Black Pawn) (coord "g2") (coord "g1") Queen) "rnbqkbnr/ppp2ppp/B7/4N3/8/2N5/PPPP3P/R1BQK1qR w KQkq - 0 7" + + it "should zero halfmove counter when pawn promotes and captures" $ + testApplyingMove "rnbqkbnr/ppp2ppp/B7/4N3/8/2N5/PPPP2pP/R1BQK2R b KQkq - 1 6" (Promotion (Piece Black Pawn) (coord "g2") (coord "h1") Queen) "rnbqkbnr/ppp2ppp/B7/4N3/8/2N5/PPPP3P/R1BQK2q w Qkq - 0 7" + + it "should invalidate short castling when kingside rook moves" $ + testApplyingMove "rnbqk1nr/pppp2pp/5p2/2b5/2B1Pp2/5N2/PPPP2PP/RNBQK2R w KQkq - 0 5" (Movement (Piece White Rook) (coord "h1") (coord "g1")) "rnbqk1nr/pppp2pp/5p2/2b5/2B1Pp2/5N2/PPPP2PP/RNBQK1R1 b Qkq - 1 5" + + it "should invalidate long castling when queenside rook moves" $ + testApplyingMove "r3k1nr/pppq2pp/2npbp2/2b5/2B1PB2/2NP1N2/PPP1Q1PP/R3K1R1 b Qkq - 0 9" (Movement (Piece Black Rook) (coord "a8") (coord "d8")) "3rk1nr/pppq2pp/2npbp2/2b5/2B1PB2/2NP1N2/PPP1Q1PP/R3K1R1 w Qk - 1 10" + + it "should invalidate both castlings when king moves" $ + testApplyingMove "rnb1kbnr/ppppqppp/8/4p3/2B1P3/8/PPPP1PPP/RNBQK1NR w KQkq - 2 3" (Movement (Piece White King) (coord "e1") (coord "e2")) "rnb1kbnr/ppppqppp/8/4p3/2B1P3/8/PPPPKPPP/RNBQ2NR b kq - 3 3" + + it "should invalidate long castling when queenside rook is captured" $ + testApplyingMove "r1b1kbnr/1p1npppp/R2q4/p1pp4/P7/8/1PPPPPPP/1NBQKBNR w Kkq - 4 6" (Capture (Piece White Rook) (coord "a6") (coord "a8")) "R1b1kbnr/1p1npppp/3q4/p1pp4/P7/8/1PPPPPPP/1NBQKBNR b Kk - 0 6" + +isCheckmateSpec :: Spec +isCheckmateSpec = + describe "isCheckmate" $ do + it "should not consider initial state as checkmate" $ + isCheckmate initialState `shouldBe` False + + it "should not consider check a checkmate" $ + isCheckmate (game "rnbqkb1r/ppp2ppp/3p1n2/1B2p3/4P3/2N2N2/PPPP1PPP/R1BQK2R b KQkq - 1 4") `shouldBe` False + + it "should not consider stalemates a checkmate" $ do + isCheckmate (game "1R6/8/8/8/8/8/7R/k6K b - - 0 1") `shouldBe` False + isCheckmate (game "8/8/5k2/p4p1p/P4K1P/1r6/8/8 w - - 0 2") `shouldBe` False + + it "should detect checkmate correctly" $ do + isCheckmate (game "8/5r2/4K1q1/4p3/3k4/8/8/8 w - - 0 7") `shouldBe` True + isCheckmate (game "4r2r/p6p/1pnN2p1/kQp5/3pPq2/3P4/PPP3PP/R5K1 b - - 0 2") `shouldBe` True + isCheckmate (game "r3k2r/ppp2p1p/2n1p1p1/8/2B2P1q/2NPb1n1/PP4PP/R2Q3K w kq - 0 8") `shouldBe` True + isCheckmate (game "8/6R1/pp1r3p/6p1/P3R1Pk/1P4P1/7K/8 b - - 0 4") `shouldBe` True + +isStalemateSpec :: Spec +isStalemateSpec = + describe "isStalemate" $ do + it "should not consider initial state as stalemate" $ + isStalemate initialState `shouldBe` False + + it "should not consider check a stalemate" $ + isStalemate (game "rnbqkb1r/ppp2ppp/3p1n2/1B2p3/4P3/2N2N2/PPPP1PPP/R1BQK2R b KQkq - 1 4") `shouldBe` False + + it "should detect stalemate correctly" $ do + isStalemate (game "1R6/8/8/8/8/8/7R/k6K b - - 0 1") `shouldBe` True + isStalemate (game "8/8/5k2/p4p1p/P4K1P/1r6/8/8 w - - 0 2") `shouldBe` True + +isInsufficientMaterialSpec :: Spec +isInsufficientMaterialSpec = + describe "isInsufficientMaterial" $ do + it "should not consider initial state as insufficient material" $ + isInsufficientMaterial initialState `shouldBe` False + + it "should not consider queen+king vs. queen+king as insufficient material" $ + isInsufficientMaterial (game "3qk3/8/8/8/8/8/8/3QK3 w - - 0 10") `shouldBe` False + + it "should not consider rook+king vs. king as insufficient material" $ do + isInsufficientMaterial (game "4k3/8/8/8/8/8/8/3RK3 w - - 0 10") `shouldBe` False + isInsufficientMaterial (game "4k3/2r5/8/8/8/8/8/4K3 w - - 0 1") `shouldBe` False + + it "should not consider pawn+king vs. king as insufficient material" $ do + isInsufficientMaterial (game "4k3/8/8/8/8/8/1P6/4K3 w - - 0 10") `shouldBe` False + isInsufficientMaterial (game "4k3/2p5/8/8/8/8/8/4K3 w - - 0 1") `shouldBe` False + + it "should not consider knight+bishop+king vs. king as insufficient material" $ + isInsufficientMaterial (game "4k3/8/8/8/8/8/2BN4/4K3 w - - 0 1") `shouldBe` False + + it "should not consider bishop+bishop+king vs. king as insufficient material if bishops are on different colored squares" $ + isInsufficientMaterial (game "4k3/8/8/8/8/8/2BB4/4K3 w - - 0 1") `shouldBe` False + + it "should consider bishop+bishop+king vs. king as insufficient material if bishops are on same colored squares" $ + isInsufficientMaterial (game "4k3/8/8/8/8/2B5/3B4/4K3 w - - 0 1") `shouldBe` True + + it "should not consider knight+knight+king vs. king as insufficient material" $ + isInsufficientMaterial (game "4k3/8/8/8/8/8/2NN4/4K3 w - - 0 1") `shouldBe` False + + it "should consider king vs. king as insufficient material" $ + isInsufficientMaterial (game "4k3/8/8/8/8/8/8/4K3 w - - 0 10") `shouldBe` True + + it "should consider bishop+king vs. king as insufficient material" $ do + isInsufficientMaterial (game "4k3/8/8/8/8/8/8/3BK3 w - - 0 10") `shouldBe` True + isInsufficientMaterial (game "4k3/2b5/8/8/8/8/8/4K3 w - - 0 1") `shouldBe` True + + it "should consider knight+king vs. king as insufficient material" $ do + isInsufficientMaterial (game "4k3/8/8/8/8/8/8/3NK3 w - - 0 10") `shouldBe` True + isInsufficientMaterial (game "4k3/2n5/8/8/8/8/8/4K3 w - - 0 1") `shouldBe` True + + it "should consider bishop+king vs. bishop+king as insufficient material if both bishops are on same color square" $ + isInsufficientMaterial (game "4k3/8/3b4/8/8/8/1B6/4K3 w - - 0 10") `shouldBe` True + + it "should consider n*bishop+king vs. n*bishop+king as insufficient material if bishop pairs are on same color square" $ + isInsufficientMaterial (game "8/b1B1b1B1/1b1B1b1B/8/8/8/8/1k5K w - - 0 1") `shouldBe` True + + it "should not consider n*bishop+king vs. n*bishop+king as insufficient material if bishop pairs are on different color square" $ + isInsufficientMaterial (game "8/bB2b1B1/1b1B1b1B/8/8/8/8/1k5K w - - 0 1") `shouldBe` False + + it "should not consider bishop+king vs. bishop+king as insufficient material if both bishops are on different color square" $ + isInsufficientMaterial (game "4k3/8/4b3/8/8/8/1B6/4K3 w - - 0 10") `shouldBe` False + +isDrawSpec :: Spec +isDrawSpec = + describe "isDraw" $ do + it "should not detect normal game as draw" $ + isDraw initialState `shouldBe` False + + it "should not detect checkmate as draw" $ + isDraw (game "8/5r2/4K1q1/4p3/3k4/8/8/8 w - - 0 7") `shouldBe` False + + it "should detect stalemate as draw" $ + isDraw (game "1R6/8/8/8/8/8/7R/k6K b - - 0 1") `shouldBe` True + + it "should detect insufficient material as draw" $ + isDraw (game "4k3/8/8/8/8/8/8/4K3 w - - 0 10") `shouldBe` True + +testApplyingMove :: String -> Move -> String -> Expectation +testApplyingMove beforeFen move afterFen = writeFEN newGame `shouldBe` afterFen + where Right newGame = applyMove (game beforeFen) move + +getWinnerSpec :: Spec +getWinnerSpec = + describe "getWinner" $ do + it "should not give winner if there is no checkmate" $ + getWinner (game "rnbqkb1r/ppp2ppp/3p1n2/1B2p3/4P3/2N2N2/PPPP1PPP/R1BQK2R b KQkq - 1 4") `shouldBe` Nothing + + it "should not give winner if the game is draw" $ + getWinner (game "1R6/8/8/8/8/8/7R/k6K b - - 0 1") `shouldBe` Nothing + + it "should return correct winner if the game is checkmate" $ do + getWinner (game "8/5r2/4K1q1/4p3/3k4/8/8/8 w - - 0 7") `shouldBe` Just Black + getWinner (game "4r2r/p6p/1pnN2p1/kQp5/3pPq2/3P4/PPP3PP/R5K1 b - - 0 2") `shouldBe` Just White diff --git a/test/Chess/MoveTests.hs b/test/Chess/MoveTests.hs new file mode 100644 --- /dev/null +++ b/test/Chess/MoveTests.hs @@ -0,0 +1,339 @@ +module MoveTests where + +import Chess.Internal.Piece +import Chess.Internal.Board +import Chess.Internal.Move +import TestUtils +import Test.Hspec + +moveSpec :: IO () +moveSpec = hspec $ + describe "Move" $ do + isCorrectStartPieceSpec + isRightPlayerMoveSpec + areCoordinatesValidSpec + generateAllRookMovesSpec + generateAllBishopMovesSpec + generateAllQueenMovesSpec + generateAllKnightMovesSpec + generateAllKingMovesSpec + generateAllPawnMovesSpec + generateAllPotentialMovesSpec + boardAfterMoveSpec + generateAllMovesSpec + +isCorrectStartPieceSpec :: Spec +isCorrectStartPieceSpec = + describe "isCorrectStartPiece" $ + it "should detect whether the piece in the coordinates matches the given piece information" $ do + isCorrectStartPiece initialBoard (Piece White Pawn) (coord "e2") `shouldBe` True + isCorrectStartPiece initialBoard (Piece White Knight) (coord "b1") `shouldBe` True + isCorrectStartPiece initialBoard (Piece Black Pawn) (coord "e2") `shouldBe` False + isCorrectStartPiece initialBoard (Piece White Bishop) (coord "e2") `shouldBe` False + isCorrectStartPiece initialBoard (Piece White Pawn) (coord "e3") `shouldBe` False + +isRightPlayerMoveSpec :: Spec +isRightPlayerMoveSpec = + describe "isRightPlayerMove" $ + it "should detect whether the movement is by given player" $ do + isRightPlayerMove White (Movement (Piece White Pawn) (coord "e2") (coord "e3")) `shouldBe` True + isRightPlayerMove White (Movement (Piece Black Pawn) (coord "e7") (coord "e6")) `shouldBe` False + isRightPlayerMove Black (Capture (Piece Black Queen) (coord "a1") (coord "a2")) `shouldBe` True + isRightPlayerMove Black (Capture (Piece White Queen) (coord "a1") (coord "a2")) `shouldBe` False + isRightPlayerMove White (Castling White Short) `shouldBe` True + isRightPlayerMove Black (Castling White Long) `shouldBe` False + isRightPlayerMove White (EnPassant (Piece White Pawn) (coord "e2") (coord "d3")) `shouldBe` True + isRightPlayerMove Black (EnPassant (Piece White Pawn) (coord "e2") (coord "d3")) `shouldBe` False + isRightPlayerMove Black (Promotion (Piece Black Pawn) (coord "e2") (coord "e1") Queen) `shouldBe` True + isRightPlayerMove White (Promotion (Piece Black Pawn) (coord "e2") (coord "e1") Queen) `shouldBe` False + isRightPlayerMove White (PawnDoubleMove (Piece White Pawn) (coord "e2") (coord "e4")) `shouldBe` True + isRightPlayerMove Black (PawnDoubleMove (Piece White Pawn) (coord "e2") (coord "e4")) `shouldBe` False + +areCoordinatesValidSpec :: Spec +areCoordinatesValidSpec = + describe "areCoordinatesValid" $ do + it "should return Nothing if both coordinates are inside bounds" $ do + areCoordinatesValid (0, 0) (1, 2) `shouldBe` Nothing + areCoordinatesValid (4, 4) (0, 7) `shouldBe` Nothing + + it "should return InvalidCoordinates error if at least one coordinate is out of bounds" $ do + areCoordinatesValid (3, 3) (3, 3) `shouldBe` Just InvalidCoordinates + areCoordinatesValid (-1, 0) (3, 3) `shouldBe` Just InvalidCoordinates + areCoordinatesValid (7, 0) (7, 8) `shouldBe` Just InvalidCoordinates + +generateAllRookMovesSpec :: Spec +generateAllRookMovesSpec = + describe "generateAllRookMoves" $ do + it "should return all movement and capture moves for a rook in a square" $ + generateAllRookMoves (game "k4b1r/p7/7p/4P3/1n2P2R/8/P2B1P2/3K2N1 w - - 6 9") (coord "h4") `shouldMatchList` + [ Movement (Piece White Rook) (coord "h4") (coord "h5") + , Movement (Piece White Rook) (coord "h4") (coord "g4") + , Movement (Piece White Rook) (coord "h4") (coord "f4") + , Movement (Piece White Rook) (coord "h4") (coord "h3") + , Movement (Piece White Rook) (coord "h4") (coord "h2") + , Movement (Piece White Rook) (coord "h4") (coord "h1") + , Capture (Piece White Rook) (coord "h4") (coord "h6")] + + it "should return empty list of moves if no move is possible" $ + generateAllRookMoves (game "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1") (coord "a1") `shouldMatchList` [] + +generateAllBishopMovesSpec :: Spec +generateAllBishopMovesSpec = + describe "generateAllBishopMoves" $ do + it "should return all movement and capture moves for a bishop in a square" $ + generateAllBishopMoves (game "rnb1kbnr/pppp1ppp/8/5p2/8/3B4/PPPP3P/Rq1QKN2 w Qkq - 4 12") (coord "d3") `shouldMatchList` + [ Movement (Piece White Bishop) (coord "d3") (coord "c4") + , Movement (Piece White Bishop) (coord "d3") (coord "b5") + , Movement (Piece White Bishop) (coord "d3") (coord "a6") + , Movement (Piece White Bishop) (coord "d3") (coord "e4") + , Movement (Piece White Bishop) (coord "d3") (coord "e2") + , Capture (Piece White Bishop) (coord "d3") (coord "f5")] + + it "should return empty list of moves if no move is possible" $ + generateAllBishopMoves (game "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1") (coord "c1") `shouldMatchList` [] + +generateAllQueenMovesSpec :: Spec +generateAllQueenMovesSpec = + describe "generateAllQueenMoves" $ do + it "should return all movement and capture moves for a queen in a square" $ do + generateAllQueenMoves (game "rnb1kbnr/pppp1ppp/8/5p2/8/3B4/PPPP3P/Rq1QKN2 b Qkq - 4 12") (coord "b1") `shouldMatchList` + [ Movement (Piece Black Queen) (coord "b1") (coord "c1") + , Capture (Piece Black Queen) (coord "b1") (coord "a1") + , Capture (Piece Black Queen) (coord "b1") (coord "a2") + , Capture (Piece Black Queen) (coord "b1") (coord "b2") + , Capture (Piece Black Queen) (coord "b1") (coord "c2") + , Capture (Piece Black Queen) (coord "b1") (coord "d1")] + generateAllQueenMoves (game "r2qkb1r/ppnp2pp/4pp1n/4b3/2Q2P2/1P2P3/1P2BPPP/RPB1K1NR w KQkq - 2 13") (coord "c4") `shouldMatchList` + [ Movement (Piece White Queen) (coord "c4") (coord "b5") + , Movement (Piece White Queen) (coord "c4") (coord "a6") + , Movement (Piece White Queen) (coord "c4") (coord "d5") + , Movement (Piece White Queen) (coord "c4") (coord "d3") + , Movement (Piece White Queen) (coord "c4") (coord "b4") + , Movement (Piece White Queen) (coord "c4") (coord "a4") + , Movement (Piece White Queen) (coord "c4") (coord "c5") + , Movement (Piece White Queen) (coord "c4") (coord "c6") + , Movement (Piece White Queen) (coord "c4") (coord "d4") + , Movement (Piece White Queen) (coord "c4") (coord "e4") + , Movement (Piece White Queen) (coord "c4") (coord "c3") + , Movement (Piece White Queen) (coord "c4") (coord "c2") + , Capture (Piece White Queen) (coord "c4") (coord "c7") + , Capture (Piece White Queen) (coord "c4") (coord "e6")] + + it "should return empty list of moves if no move is possible" $ + generateAllQueenMoves (game "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1") (coord "d1") `shouldMatchList` [] + +generateAllKnightMovesSpec :: Spec +generateAllKnightMovesSpec = + describe "generateAllKnightMoves" $ + it "should return all movement and capture moves for a knight in a square" $ do + generateAllKnightMoves (game "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1") (coord "b1") `shouldMatchList` + [ Movement (Piece White Knight) (coord "b1") (coord "a3") + , Movement (Piece White Knight) (coord "b1") (coord "c3")] + generateAllKnightMoves (game "r2qkbnr/2p1pppp/ppp5/bn6/3P4/2P5/PP2PPPP/RNBQKBNR b - - 3 7") (coord "b5") `shouldMatchList` + [ Movement (Piece Black Knight) (coord "b5") (coord "d6") + , Movement (Piece Black Knight) (coord "b5") (coord "a7") + , Movement (Piece Black Knight) (coord "b5") (coord "a3") + , Capture (Piece Black Knight) (coord "b5") (coord "c3") + , Capture (Piece Black Knight) (coord "b5") (coord "d4")] + +generateAllKingMovesSpec :: Spec +generateAllKingMovesSpec = + describe "generateAllKingMoves" $ do + it "should return empty list of moves if no move is possible" $ + generateAllKingMoves (game "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1") (coord "e1") `shouldMatchList` [] + + it "should return all movement and capture moves for a king in a square" $ + generateAllKingMoves (game "2b5/pkp1prpp/8/rpn5/1K6/2P5/PP2N1PR/N1Q5 w - - 2 15") (coord "b4") `shouldMatchList` + [ Movement (Piece White King) (coord "b4") (coord "a4") + , Movement (Piece White King) (coord "b4") (coord "a3") + , Movement (Piece White King) (coord "b4") (coord "b3") + , Movement (Piece White King) (coord "b4") (coord "c4") + , Capture (Piece White King) (coord "b4") (coord "a5") + , Capture (Piece White King) (coord "b4") (coord "b5") + , Capture (Piece White King) (coord "b4") (coord "c5")] + + it "should return castling moves when castling is possible" $ + generateAllKingMoves (game "1rq1kbr1/pppbnn1p/8/8/8/3N4/PPPP2PP/R3K2R w KQ - 0 10") (coord "e1") `shouldMatchList` + [ Movement (Piece White King) (coord "e1") (coord "d1") + , Movement (Piece White King) (coord "e1") (coord "e2") + , Movement (Piece White King) (coord "e1") (coord "f2") + , Movement (Piece White King) (coord "e1") (coord "f1") + , Castling White Long + , Castling White Short] + + it "should not return castling move if the castling has been invalidated" $ do + generateAllKingMoves (game "r3k2r/ppppp1pp/2n2p2/3b4/8/2B2PPB/PPPPP2P/R3K2R w Qk - 5 14") (coord "e1") `shouldMatchList` + [ Movement (Piece White King) (coord "e1") (coord "d1") + , Movement (Piece White King) (coord "e1") (coord "f2") + , Movement (Piece White King) (coord "e1") (coord "f1") + , Castling White Long] + generateAllKingMoves (game "r3k2r/ppppp1pp/2n2p2/3b4/8/2B2PPB/PPPPP2P/R3K2R w Qk - 5 14") (coord "e8") `shouldMatchList` + [ Movement (Piece Black King) (coord "e8") (coord "d8") + , Movement (Piece Black King) (coord "e8") (coord "f7") + , Movement (Piece Black King) (coord "e8") (coord "f8") + , Castling Black Short] + + it "should not return castling move if there is piece between castling line" $ + generateAllKingMoves (game "4k3/n7/8/8/8/5N2/P1N2PPP/R1n1K1R1 w Q - 0 16") (coord "e1") `shouldMatchList` + [ Movement (Piece White King) (coord "e1") (coord "d1") + , Movement (Piece White King) (coord "e1") (coord "d2") + , Movement (Piece White King) (coord "e1") (coord "e2") + , Movement (Piece White King) (coord "e1") (coord "f1")] + + it "should not return castling move if there is an opponent piece threatening castling end square" $ + generateAllKingMoves (game "3rk1r1/5p2/8/8/3b2N1/5P2/1PP1P1PP/4K2R w K - 2 20") (coord "e1") `shouldMatchList` + [ Movement (Piece White King) (coord "e1") (coord "d1") + , Movement (Piece White King) (coord "e1") (coord "d2") + , Movement (Piece White King) (coord "e1") (coord "f1") + , Movement (Piece White King) (coord "e1") (coord "f2")] + + it "should not return castling move if there is an opponent piece threatening a castling line square" $ + generateAllKingMoves (game "3rk3/5p2/5r2/8/3P2N1/8/1PP1P1PP/4K2R w K - 0 12") (coord "e1") `shouldMatchList` + [ Movement (Piece White King) (coord "e1") (coord "d1") + , Movement (Piece White King) (coord "e1") (coord "d2") + , Movement (Piece White King) (coord "e1") (coord "f1") + , Movement (Piece White King) (coord "e1") (coord "f2")] + + it "castling out of check should not be legal" $ + generateAllKingMoves (game "3rk3/5p2/4r3/8/3P2N1/8/1PP2PPP/4K2R w K - 0 12") (coord "e1") `shouldMatchList` + [ Movement (Piece White King) (coord "e1") (coord "d1") + , Movement (Piece White King) (coord "e1") (coord "d2") + , Movement (Piece White King) (coord "e1") (coord "e2") + , Movement (Piece White King) (coord "e1") (coord "f1")] + + it "castling when rook is threatened should be possible" $ + generateAllKingMoves (game "3rk3/5p2/7r/8/3P2N1/8/1PP2PP1/4K2R w K - 0 12") (coord "e1") `shouldMatchList` + [ Movement (Piece White King) (coord "e1") (coord "d1") + , Movement (Piece White King) (coord "e1") (coord "d2") + , Movement (Piece White King) (coord "e1") (coord "e2") + , Movement (Piece White King) (coord "e1") (coord "f1") + , Castling White Short] + +generateAllPawnMovesSpec :: Spec +generateAllPawnMovesSpec = + describe "generateAllPawnMoves" $ do + it "should return both normal movement and double move when possible" $ do + generateAllPawnMoves (game "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1") (coord "e2") `shouldMatchList` + [ Movement (Piece White Pawn) (coord "e2") (coord "e3") + , PawnDoubleMove (Piece White Pawn) (coord "e2") (coord "e4")] + generateAllPawnMoves (game "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR b KQkq - 0 1") (coord "a7") `shouldMatchList` + [ Movement (Piece Black Pawn) (coord "a7") (coord "a6") + , PawnDoubleMove (Piece Black Pawn) (coord "a7") (coord "a5")] + + it "should return empty list when no moves are possible" $ do + generateAllPawnMoves (game "rnbqkbnr/pppp1ppp/8/4p3/4P3/8/PPP2PPP/RNBQKBNR w KQkq - 0 1") (coord "e4") `shouldMatchList` [] + generateAllPawnMoves (game "rnbqkbnr/pppp1ppp/8/4p3/4P3/8/PPP2PPP/RNBQKBNR b KQkq - 0 1") (coord "e5") `shouldMatchList` [] + + it "should return both movement and capture moves when possible" $ + generateAllPawnMoves (game "rnbqkbnr/pppp1ppp/8/4p3/4PP2/8/PPP5/RNBQKBNR w KQkq - 0 1") (coord "f4") `shouldMatchList` + [ Movement (Piece White Pawn) (coord "f4") (coord "f5") + , Capture (Piece White Pawn) (coord "f4") (coord "e5")] + + it "should return only capture when normal movement is not possible" $ + generateAllPawnMoves (game "rnbqkbnr/pppp1ppp/8/4p3/4PP2/8/PPP5/RNBQKBNR w KQkq - 0 1") (coord "e5") `shouldMatchList` + [ Capture (Piece Black Pawn) (coord "e5") (coord "f4")] + + it "should return normal movement when capture is not possible" $ + generateAllPawnMoves (game "rnbqkbnr/pppp1p1p/8/4pPp1/4P3/8/PPPP2PP/RNBQKBNR w KQkq - 0 4") (coord "f5") `shouldMatchList` + [ Movement (Piece White Pawn) (coord "f5") (coord "f6")] + + it "should return en passant when it is possible" $ do + generateAllPawnMoves (game "rnbqkbnr/ppp1p1pp/8/3pPp2/8/8/PPPP1PPP/RNBQKBNR w KQkq f6 0 3") (coord "e5") `shouldMatchList` + [ Movement (Piece White Pawn) (coord "e5") (coord "e6") + , EnPassant (Piece White Pawn) (coord "e5") (coord "f6")] + generateAllPawnMoves (game "rnbqkbnr/ppp1pppp/8/8/2PpPP2/8/PP1P2PP/RNBQKBNR b KQkq c3 0 3") (coord "d4") `shouldMatchList` + [ Movement (Piece Black Pawn) (coord "d4") (coord "d3") + , EnPassant (Piece Black Pawn) (coord "d4") (coord "c3")] + + it "should not return en passant when en passant square is not one of the capture squares" $ + generateAllPawnMoves (game "rnbqkbnr/1pppp3/p5pp/3PPp2/8/8/PPP2PPP/RNBQKBNR w KQkq f6 0 5") (coord "d5") `shouldMatchList` + [ Movement (Piece White Pawn) (coord "d5") (coord "d6")] + + it "should return all promotion moves when promotion with normal movement or by capture is possible" $ do + generateAllPawnMoves (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") (coord "c7") `shouldMatchList` + [ Promotion (Piece White Pawn) (coord "c7") (coord "c8") Rook + , Promotion (Piece White Pawn) (coord "c7") (coord "c8") Knight + , Promotion (Piece White Pawn) (coord "c7") (coord "c8") Bishop + , Promotion (Piece White Pawn) (coord "c7") (coord "c8") Queen + , Promotion (Piece White Pawn) (coord "c7") (coord "b8") Rook + , Promotion (Piece White Pawn) (coord "c7") (coord "b8") Knight + , Promotion (Piece White Pawn) (coord "c7") (coord "b8") Bishop + , Promotion (Piece White Pawn) (coord "c7") (coord "b8") Queen] + generateAllPawnMoves (game "k7/8/8/8/8/8/p7/1N2K3 w - - 0 1") (coord "a2") `shouldMatchList` + [ Promotion (Piece Black Pawn) (coord "a2") (coord "a1") Rook + , Promotion (Piece Black Pawn) (coord "a2") (coord "a1") Knight + , Promotion (Piece Black Pawn) (coord "a2") (coord "a1") Bishop + , Promotion (Piece Black Pawn) (coord "a2") (coord "a1") Queen + , Promotion (Piece Black Pawn) (coord "a2") (coord "b1") Rook + , Promotion (Piece Black Pawn) (coord "a2") (coord "b1") Knight + , Promotion (Piece Black Pawn) (coord "a2") (coord "b1") Bishop + , Promotion (Piece Black Pawn) (coord "a2") (coord "b1") Queen] + + it "should not return any moves if no move is possible" $ do + generateAllPawnMoves (game "k7/8/8/8/8/8/p7/N3K3 w - - 0 1") (coord "a2") `shouldMatchList` [] + generateAllPawnMoves (game "k7/8/8/8/8/4b3/4P3/K7 w - - 0 1") (coord "e2") `shouldMatchList` [] + + it "should generate normal movement correctly" $ + generateAllPawnMoves (game "6k1/8/8/8/8/3P4/8/4K3 w - - 0 1") (coord "d3") `shouldMatchList` + [ Movement (Piece White Pawn) (coord "d3") (coord "d4")] + +generateAllPotentialMovesSpec :: Spec +generateAllPotentialMovesSpec = + describe "generateAllPotentialMoves" $ + it "should return all potential moves for all pieces of the current player" $ do + generateAllPotentialMoves (game "8/k7/8/8/6p1/7P/6PK/8 w - - 0 1") `shouldMatchList` + [ Movement (Piece White Pawn) (coord "g2") (coord "g3") + , Movement (Piece White Pawn) (coord "h3") (coord "h4") + , Capture (Piece White Pawn) (coord "h3") (coord "g4") + , Movement (Piece White King) (coord "h2") (coord "g3") + , Movement (Piece White King) (coord "h2") (coord "h1") + , Movement (Piece White King) (coord "h2") (coord "g1")] + generateAllPotentialMoves (game "8/k7/8/8/6p1/7P/6PK/8 b - - 0 1") `shouldMatchList` + [ Capture (Piece Black Pawn) (coord "g4") (coord "h3") + , Movement (Piece Black Pawn) (coord "g4") (coord "g3") + , Movement (Piece Black King) (coord "a7") (coord "a8") + , Movement (Piece Black King) (coord "a7") (coord "a6") + , Movement (Piece Black King) (coord "a7") (coord "b8") + , Movement (Piece Black King) (coord "a7") (coord "b7") + , Movement (Piece Black King) (coord "a7") (coord "b6")] + +boardAfterMoveSpec :: Spec +boardAfterMoveSpec = + describe "boardAfterMove" $ do + it "should make pawn double move correctly" $ do + boardAfterMove (fenBoard "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1") (PawnDoubleMove (Piece White Pawn) (coord "e2") (coord "e4")) `shouldBe` Just (fenBoard "rnbqkbnr/pppppppp/8/8/4P3/8/PPPP1PPP/RNBQKBNR w KQkq - 0 1") + boardAfterMove (fenBoard "rnbqkbnr/p1pp1ppp/p7/4p3/4P3/5N2/PPPP1PPP/RNBQ1RK1 b kq - 1 1") (PawnDoubleMove (Piece Black Pawn) (coord "c7") (coord "c5")) `shouldBe` Just (fenBoard "rnbqkbnr/p2p1ppp/p7/2p1p3/4P3/5N2/PPPP1PPP/RNBQ1RK1 w kq c6 0 2") + boardAfterMove (fenBoard "rnbqkbnr/p2p1ppp/p7/4N3/2p1P3/8/PPPP1PPP/RNBQ1RK1 w kq - 0 3") (PawnDoubleMove (Piece White Pawn) (coord "d2") (coord "d4")) `shouldBe` Just (fenBoard "rnbqkbnr/p2p1ppp/p7/4N3/2pPP3/8/PPP2PPP/RNBQ1RK1 b kq d3 0 3") + + it "should make pawn normal move correctly" $ do + boardAfterMove (fenBoard "rnbqkbnr/pppp1ppp/8/4p3/4P3/8/PPPP1PPP/RNBQKBNR w KQkq - 0 1") (Movement (Piece White Knight) (coord "g1") (coord "f3")) `shouldBe` Just (fenBoard "rnbqkbnr/pppp1ppp/8/4p3/4P3/5N2/PPPP1PPP/RNBQKB1R w KQkq - 0 1") + boardAfterMove (fenBoard "rnbqkbnr/p2p1ppp/p7/2p1N3/4P3/8/PPPP1PPP/RNBQ1RK1 b kq - 0 2") (Movement (Piece Black Pawn) (coord "c5") (coord "c4")) `shouldBe` Just (fenBoard "rnbqkbnr/p2p1ppp/p7/4N3/2p1P3/8/PPPP1PPP/RNBQ1RK1 w kq - 0 3") + + it "should make pawn capture move correctly" $ + boardAfterMove (fenBoard "rnbqkbnr/pppp1ppp/B7/4p3/4P3/5N2/PPPP1PPP/RNBQK2R w KQkq - 0 1") (Capture (Piece Black Pawn) (coord "b7") (coord "a6")) `shouldBe` Just (fenBoard "rnbqkbnr/p1pp1ppp/p7/4p3/4P3/5N2/PPPP1PPP/RNBQK2R w KQkq - 0 1") + + it "should move king and rook correctly in castling move" $ + boardAfterMove (fenBoard "rnbqkbnr/p1pp1ppp/p7/4p3/4P3/5N2/PPPP1PPP/RNBQK2R w KQkq - 0 1") (Castling White Short) `shouldBe` Just (fenBoard "rnbqkbnr/p1pp1ppp/p7/4p3/4P3/5N2/PPPP1PPP/RNBQ1RK1 b kq - 1 1") + + it "should make knight's capture move correctly" $ + boardAfterMove (fenBoard "rnbqkbnr/p2p1ppp/p7/2p1p3/4P3/5N2/PPPP1PPP/RNBQ1RK1 w kq c6 0 2") (Capture (Piece White Knight) (coord "f3") (coord "e5")) `shouldBe` Just (fenBoard "rnbqkbnr/p2p1ppp/p7/2p1N3/4P3/8/PPPP1PPP/RNBQ1RK1 b kq - 0 2") + + it "should make en passant move correctly" $ + boardAfterMove (fenBoard "rnbqkbnr/p2p1ppp/p7/4N3/2pPP3/8/PPP2PPP/RNBQ1RK1 b kq d3 0 3") (EnPassant (Piece Black Pawn) (coord "c4") (coord "d3")) `shouldBe` Just (fenBoard "rnbqkbnr/p2p1ppp/p7/4N3/4P3/3p4/PPP2PPP/RNBQ1RK1 w kq - 0 4") + +generateAllMovesSpec :: Spec +generateAllMovesSpec = + describe "generateAllMoves" $ do + it "should generate all legal moves for the current player in a given game state" $ + generateAllMoves (game "rnbqkb1r/pp1p1Bpp/5n2/2p1p3/4P3/2P5/PP1P1PPP/RNBQK1NR b KQkq - 0 4") `shouldMatchList` + [Movement (Piece Black King) (0,4) (1,4), Capture (Piece Black King) (0,4) (1,5)] + + it "should not give any legal moves in checkmate" $ do + generateAllMoves (game "8/5r2/4K1q1/4p3/3k4/8/8/8 w - - 0 7") `shouldBe` [] + generateAllMoves (game "4r2r/p6p/1pnN2p1/kQp5/3pPq2/3P4/PPP3PP/R5K1 b - - 0 2") `shouldBe` [] + generateAllMoves (game "r3k2r/ppp2p1p/2n1p1p1/8/2B2P1q/2NPb1n1/PP4PP/R2Q3K w kq - 0 8") `shouldBe` [] + generateAllMoves (game "8/6R1/pp1r3p/6p1/P3R1Pk/1P4P1/7K/8 b - - 0 4") `shouldBe` [] + + it "should not give any legal moves in stalemate" $ do + generateAllMoves (game "1R6/8/8/8/8/8/7R/k6K b - - 0 1") `shouldBe` [] + generateAllMoves (game "8/8/5k2/p4p1p/P4K1P/1r6/8/8 w - - 0 2") `shouldBe` [] diff --git a/test/Chess/NotationTests.hs b/test/Chess/NotationTests.hs new file mode 100644 --- /dev/null +++ b/test/Chess/NotationTests.hs @@ -0,0 +1,64 @@ +module NotationTests where + +import Chess.Internal.Piece +import Chess.Internal.Move +import Chess.Internal.Notation +import TestUtils +import Test.Hspec + +notationSpec :: IO () +notationSpec = hspec $ + describe "Notation" parseCoordinateNotationSpec + +parseCoordinateNotationSpec :: Spec +parseCoordinateNotationSpec = + describe "parseCoordinateNotation" $ do + it "should not parse invalid input" $ do + parseCoordinateNotation initialState "" `shouldBe` Nothing + parseCoordinateNotation initialState "e" `shouldBe` Nothing + parseCoordinateNotation initialState "e2" `shouldBe` Nothing + parseCoordinateNotation initialState "e2-" `shouldBe` Nothing + parseCoordinateNotation initialState "e2-e" `shouldBe` Nothing + parseCoordinateNotation initialState "e2-4" `shouldBe` Nothing + parseCoordinateNotation initialState "fooba" `shouldBe` Nothing + parseCoordinateNotation initialState "i2-i4" `shouldBe` Nothing + parseCoordinateNotation initialState "12-34" `shouldBe` Nothing + + it "should not parse illegal moves" $ do + parseCoordinateNotation initialState "b1-d2" `shouldBe` Nothing + parseCoordinateNotation initialState "e7-e5" `shouldBe` Nothing + + it "should not parse moves with extra input" $ do + parseCoordinateNotation initialState "e2-e4foo" `shouldBe` Nothing + parseCoordinateNotation initialState "e2-e4=Qfoo" `shouldBe` Nothing + + it "should parse correctly pawn moves" $ do + parseCoordinateNotation initialState "e2-e4" `shouldBe` Just (PawnDoubleMove (Piece White Pawn) (coord "e2") (coord "e4")) + parseCoordinateNotation initialState "D2-D3" `shouldBe` Just (Movement (Piece White Pawn) (coord "d2") (coord "d3")) + parseCoordinateNotation initialState "H2-H4" `shouldBe` Just (PawnDoubleMove (Piece White Pawn) (coord "h2") (coord "h4")) + parseCoordinateNotation (game "r1bqkbnr/pppp1ppp/2n5/4p3/3PP3/5N2/PPP2PPP/RNBQKB1R b KQkq d3 0 3") "e5-d4" `shouldBe` Just (Capture (Piece Black Pawn) (coord "e5") (coord "d4")) + + it "should parse correctly knight moves" $ + parseCoordinateNotation initialState "b1-c3" `shouldBe` Just (Movement (Piece White Knight) (coord "b1") (coord "c3")) + + it "should parse correctly castling moves" $ do + parseCoordinateNotation (game "r1b1k2r/pppq1ppp/2np1n2/2b1p3/2BPPB2/2N2N2/PPP2PPP/R2QK2R w KQkq - 4 7") "e1-g1" `shouldBe` Just (Castling White Short) + parseCoordinateNotation (game "r1b1k2r/p1pq1ppp/1pnp1n2/2b1p3/2BPPB2/2N2N2/PPPQ1PPP/R3K2R w KQkq - 0 8") "e1-c1" `shouldBe` Just (Castling White Long) + + it "should parse correctly pawn promotion moves" $ do + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8=N" `shouldBe` Just (Promotion (Piece White Pawn) (coord "c7") (coord "c8") Knight) + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8=Q" `shouldBe` Just (Promotion (Piece White Pawn) (coord "c7") (coord "c8") Queen) + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-b8=Q" `shouldBe` Just (Promotion (Piece White Pawn) (coord "c7") (coord "b8") Queen) + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8(N)" `shouldBe` Just (Promotion (Piece White Pawn) (coord "c7") (coord "c8") Knight) + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8(Q)" `shouldBe` Just (Promotion (Piece White Pawn) (coord "c7") (coord "c8") Queen) + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8(Q" `shouldBe` Nothing + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8Q" `shouldBe` Nothing + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8(Q))" `shouldBe` Nothing + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8=" `shouldBe` Nothing + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8" `shouldBe` Nothing + + it "should not parse pawn promotion moves with illegal promotion piece" $ do + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8=A" `shouldBe` Nothing + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8=n" `shouldBe` Nothing + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8=K" `shouldBe` Nothing + parseCoordinateNotation (game "1r5k/2P5/8/8/8/8/8/4K2N w - - 0 1") "c7-c8=P" `shouldBe` Nothing diff --git a/test/Chess/PieceTests.hs b/test/Chess/PieceTests.hs new file mode 100644 --- /dev/null +++ b/test/Chess/PieceTests.hs @@ -0,0 +1,43 @@ +module PieceTests where + +import Chess.Internal.Piece +import Test.Hspec + +pieceSpec :: IO () +pieceSpec = hspec $ + describe "Piece" $ do + printPieceSpec + parsePieceSpec + +printPieceSpec :: Spec +printPieceSpec = + describe "printPiece" $ do + it "should print white player pieces uppercase" $ do + printPiece (Piece White King) `shouldBe` "K" + printPiece (Piece White Rook) `shouldBe` "R" + printPiece (Piece White Knight) `shouldBe` "N" + + it "should print black player pieces lowercase" $ do + printPiece (Piece Black Queen) `shouldBe` "q" + printPiece (Piece Black Pawn) `shouldBe` "p" + printPiece (Piece Black Bishop) `shouldBe` "b" + +parsePieceSpec :: Spec +parsePieceSpec = + describe "parsePiece" $ do + it "should parse legal piecetypes correctly" $ do + parsePiece 'k' `shouldBe` Just (Piece Black King) + parsePiece 'Q' `shouldBe` Just (Piece White Queen) + parsePiece 'P' `shouldBe` Just (Piece White Pawn) + parsePiece 'r' `shouldBe` Just (Piece Black Rook) + parsePiece 'R' `shouldBe` Just (Piece White Rook) + parsePiece 'B' `shouldBe` Just (Piece White Bishop) + parsePiece 'n' `shouldBe` Just (Piece Black Knight) + + it "should not parse invalid piecetypes" $ do + parsePiece 'a' `shouldBe` Nothing + parsePiece 'c' `shouldBe` Nothing + parsePiece 'd' `shouldBe` Nothing + parsePiece '0' `shouldBe` Nothing + parsePiece '5' `shouldBe` Nothing + parsePiece '!' `shouldBe` Nothing diff --git a/test/Chess/TestUtils.hs b/test/Chess/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/Chess/TestUtils.hs @@ -0,0 +1,15 @@ +module TestUtils (coord, game, fenBoard) where + +import Chess.Internal.Board +import Chess.Internal.Move +import Chess.FEN +import Data.Maybe + +coord :: String -> Coordinates +coord = fromJust . parseCoordinate + +game :: String -> GameState +game = fromJust . readFEN + +fenBoard :: String -> Board +fenBoard = stateBoard . fromJust . readFEN diff --git a/test/Chess/UITests.hs b/test/Chess/UITests.hs new file mode 100644 --- /dev/null +++ b/test/Chess/UITests.hs @@ -0,0 +1,39 @@ +module UITests where + +import Chess +import Chess.UI +import Chess.Internal.Move +import Test.Hspec + +uiSpec :: IO () +uiSpec = hspec $ + describe "UI" $ do + printBoardSpec + printMoveSpec + +printBoardSpec :: Spec +printBoardSpec = + describe "printBoard" $ do + it "should print the initial board correctly" $ + printBoard (board newGame) `shouldBe` newGamePrint + +newGamePrint :: String +newGamePrint = " +---+---+---+---+---+---+---+---+\n8 | r | n | b | q | k | b | n | r |\n +---+---+---+---+---+---+---+---+\n7 | p | p | p | p | p | p | p | p |\n +---+---+---+---+---+---+---+---+\n6 | | | | | | | | |\n +---+---+---+---+---+---+---+---+\n5 | | | | | | | | |\n +---+---+---+---+---+---+---+---+\n4 | | | | | | | | |\n +---+---+---+---+---+---+---+---+\n3 | | | | | | | | |\n +---+---+---+---+---+---+---+---+\n2 | P | P | P | P | P | P | P | P |\n +---+---+---+---+---+---+---+---+\n1 | R | N | B | Q | K | B | N | R |\n +---+---+---+---+---+---+---+---+\n a b c d e f g h\n" + +printMoveSpec :: Spec +printMoveSpec = + describe "printMove" $ do + it "should print normal moves correctly" $ do + coordinateNotation (Movement (Piece White Pawn) (6, 4) (5, 4)) `shouldBe` "e2-e3" + coordinateNotation (Capture (Piece White Pawn) (6, 4) (5, 5)) `shouldBe` "e2-f3" + coordinateNotation (Capture (Piece Black Knight) (0, 1) (2, 2)) `shouldBe` "b8-c6" + coordinateNotation (Castling White Short) `shouldBe` "e1-g1" + coordinateNotation (Castling White Long) `shouldBe` "e1-c1" + coordinateNotation (Castling Black Short) `shouldBe` "e8-g8" + coordinateNotation (Castling Black Long) `shouldBe` "e8-c8" + coordinateNotation (EnPassant (Piece White Pawn) (3, 4) (2, 5)) `shouldBe` "e5-f6" + coordinateNotation (PawnDoubleMove (Piece White Pawn) (6, 1) (4, 1)) `shouldBe` "b2-b4" + + it "should print promotion moves correctly" $ do + coordinateNotation (Promotion (Piece White Pawn) (1, 0) (0, 0) Queen) `shouldBe` "a7-a8q" + coordinateNotation (Promotion (Piece Black Pawn) (6, 1) (7, 2) Knight) `shouldBe` "b2-c1n" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,10 +1,10 @@ -import Test.Hspec import GameTests import NotationTests import BoardTests import FENTests import MoveTests import PieceTests +import UITests main :: IO () main = do gameSpec @@ -13,3 +13,4 @@ fenSpec moveSpec pieceSpec + uiSpec