Adds data type Move to the Chess module

Addes a function `legalMoves` to get all legal moves in a position and a function `applyMove` to apply a move in a game state. Also adds a function to print out moves in coordinate notation.
nablaa · Dec 5, 2021 · cfb7adf · cfb7adf
1 parent 04c5bc0
commit cfb7adf
Show file tree

Hide file tree

Showing 4 changed files with 56 additions and 6 deletions.
diff --git a/src/Chess.hs b/src/Chess.hs
@@ -17,6 +17,7 @@ module Chess (
               Chess.Internal.Piece.Color(..),
               Chess.Internal.Piece.Piece(..),
               Chess.Internal.Piece.PieceType(..),
+              Chess.Internal.Move.Move,
               board,
               fullMoveNumber,
               isCheckmate,
@@ -27,6 +28,8 @@ module Chess (
               newGame,
               pieceAt,
               winner,
+              legalMoves,
+              applyMove,
               ) where
 
 import Chess.Internal.Board
@@ -67,9 +70,7 @@ move :: GameState
      -> 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 @@ pieceAt b coordinateStr = do coords <- parseCoordinate coordinateStr
 -- | 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/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
@@ -9,14 +9,17 @@
 --
 -- Visualize chess games
 module Chess.UI (
-             printBoard
+             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.
 --
@@ -63,3 +66,16 @@ printRow row = sep ++ intercalate sep (map printSquare row) ++ sep ++ "\n"
 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/UITests.hs b/test/Chess/UITests.hs
@@ -2,15 +2,38 @@ 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` "  +---+---+---+---+---+---+---+---+\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"
+            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"