Add test structure and refactor rays

Change-type: patch
Signed-off-by: Giovanni Garufi <[email protected]>

hask-chess.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: e5ce64ce3d436cb5e4ec0523273b64d7547515aea1c7e107f4638fe6001afca4
+-- hash: e48ee55cfa4e32067f315e9b1e605d91e835d46939b5495eccd42614505ed5be
 
 name:           hask-chess
 version:        0.1.0.0
@@ -38,7 +38,8 @@ library
   hs-source-dirs:
       src
   build-depends:
-      base >=4.7 && <5
+      HUnit
+    , base >=4.7 && <5
     , containers
     , mtl
     , parsec
@@ -53,7 +54,8 @@ executable hask-chess-exe
       app
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >=4.7 && <5
+      HUnit
+    , base >=4.7 && <5
     , containers
     , hask-chess
     , mtl
@@ -70,7 +72,8 @@ test-suite hask-chess-test
       test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
-      base >=4.7 && <5
+      HUnit
+    , base >=4.7 && <5
     , containers
     , hask-chess
     , mtl

package.yaml

@@ -25,6 +25,7 @@ dependencies:
 - mtl
 - parsec
 - containers
+- HUnit
 
 library:
   source-dirs: src

src/Board.hs

@@ -12,12 +12,12 @@ data PieceType = King | Queen | Rook | Bishop | Knight | Pawn deriving Eq
 data Colour = White | Black deriving (Show, Eq, Ord)
 
 data Piece = Piece Colour PieceType deriving Eq
-data Move = Move Position Position | Castle Colour CastleType | Promote Position PieceType deriving Show
+data Move = Move Position Position | Castle Colour CastleType | Promote Position PieceType deriving (Eq, Show)
 
 newtype Board = Board (V.Vector (Maybe Piece))
 
 type Position = (Column, Row)
-data Column = A | B | C | D | E | F | G | H deriving Show
+data Column = A | B | C | D | E | F | G | H deriving (Show, Eq)
 
 toInt :: Column -> Int
 toInt A = 0

src/MoveGen.hs

@@ -158,44 +158,48 @@ genAllRookMoves :: Board -> Colour -> [Move]
 genAllRookMoves board col = concat $ V.toList $ V.map (genRookMoves board col) rooks
   where rooks = pieceIndexes (Piece col Rook) board
 
+rookRays :: Board -> Colour -> Position -> [[Position]]
+rookRays board colour (row, col) = [north, south, east, west]
+  where
+    north = genNorthRay board colour (row,col)
+    south = genSouthRay board colour (row,col)
+    east = genEastRay board colour (row,col)
+    west = genWestRay board colour (row,col)
+
+bishopRays :: Board -> Colour -> Position -> [[Position]]
+bishopRays board colour (row, col) = [northEast, northWest, southEast, southWest]
+  where
+    northEast = genNorthEastRay board colour (row,col)
+    northWest = genNorthWestRay board colour (row,col)
+    southEast = genSouthEastRay board colour (row,col)
+    southWest = genSouthWestRay board colour (row,col)
+
 genRookMoves :: Board -> Colour -> Int -> [Move]
 genRookMoves board colour i = north ++ south ++ east ++ west
   where
     (row, col) = indexToPosition i
-    north = rayToMoves (row,col) $ genNorthRay board colour (row,col)
-    south = rayToMoves (row,col) $ genSouthRay board colour (row,col)
-    east = rayToMoves (row,col) $ genEastRay board colour (row,col)
-    west = rayToMoves (row,col) $ genWestRay board colour (row,col)
+    [north, south, east, west] = fmap (rayToMoves (row,col)) $ rookRays board colour (row, col)
 
 genAllQueenMoves :: Board -> Colour -> [Move]
 genAllQueenMoves board col = concat $ V.toList $ V.map (genQueenMoves board col) queens
   where queens = pieceIndexes (Piece col Queen) board
 
 genQueenMoves :: Board -> Colour -> Int -> [Move]
-genQueenMoves board colour i = north ++ south ++ east ++ west ++ northeast ++ northwest ++ southeast ++ southwest
+genQueenMoves board colour i = north ++ south ++ east ++ west ++ northEast ++ northWest ++ southEast ++ southWest
   where
     (row, col) = indexToPosition i
-    north = rayToMoves (row,col) $ genNorthRay board colour (row,col)
-    south = rayToMoves (row,col) $ genSouthRay board colour (row,col)
-    east = rayToMoves (row,col) $ genEastRay board colour (row,col)
-    west = rayToMoves (row,col) $ genWestRay board colour (row,col)
-    northeast = rayToMoves (row,col) $ genNorthEastRay board colour (row,col)
-    northwest = rayToMoves (row,col) $ genNorthWestRay board colour (row,col)
-    southeast = rayToMoves (row,col) $ genSouthEastRay board colour (row,col)
-    southwest = rayToMoves (row,col) $ genSouthWestRay board colour (row,col)
+    [north, south, east, west] = fmap (rayToMoves (row,col)) $ rookRays board colour (row, col)
+    [northEast, northWest, southEast, southWest] = fmap (rayToMoves (row,col)) $ bishopRays board colour (row, col)
 
 genAllBishopMoves :: Board -> Colour -> [Move]
 genAllBishopMoves board col = concat $ V.toList $ V.map (genBishopMoves board col) bishops
   where bishops = pieceIndexes (Piece col Bishop) board
 
 genBishopMoves :: Board -> Colour -> Int -> [Move]
-genBishopMoves board colour i = northeast ++ northwest ++ southeast ++ southwest
+genBishopMoves board colour i = northEast ++ northWest ++ southEast ++ southWest
   where
     (row, col) = indexToPosition i
-    northeast = rayToMoves (row,col) $ genNorthEastRay board colour (row,col)
-    northwest = rayToMoves (row,col) $ genNorthWestRay board colour (row,col)
-    southeast = rayToMoves (row,col) $ genSouthEastRay board colour (row,col)
-    southwest = rayToMoves (row,col) $ genSouthWestRay board colour (row,col)
+    [northEast, northWest, southEast, southWest] = fmap (rayToMoves (row,col)) $ bishopRays board colour (row, col)
 
 genAllKingMoves :: GameState -> Colour -> [Move]
 genAllKingMoves gs col = concat $ V.toList $ V.map (genKingMoves gs col) kings

src/Uci.hs

@@ -64,7 +64,7 @@ parseUCIMoves = moves <|> none
 toUCI :: Move -> String
 toUCI (Move (sCol, sRow) (dCol, dRow)) = (map toLower $ show sCol) ++ (show sRow) ++ (map toLower $ show dCol) ++ (show dRow)
 toUCI (Castle White Short) = "e1g1"
-toUCI (Castle White Long)  = "e1c8"
+toUCI (Castle White Long)  = "e1c1"
 toUCI (Castle Black Short) = "e8g8"
 toUCI (Castle Black Long)  = "e8c8"
 toUCI (Promote (sCol, sRow) pty) = (map toLower $ show sCol) ++ show sRow ++ (map toLower $ show sCol) ++ show (sRow + 1) ++ show pty
@@ -80,7 +80,7 @@ parseUCIMove = do
     Just pt -> return $ Promote (readColumn startCol, read [startRow]) (toPt pt)
     Nothing -> case ((readColumn startCol, read [startRow]), (readColumn endCol, read [endRow])) of
       ((E,1), (G,1)) -> return $ Castle White Short
-      ((E,1), (C,8)) -> return $ Castle White Long
+      ((E,1), (C,1)) -> return $ Castle White Long
       ((E,8), (G,8)) -> return $ Castle Black Short
       ((E,8), (C,8)) -> return $ Castle Black Long
       (src, dst) -> return $ Move src dst

test/Spec.hs

@@ -1,2 +1,23 @@
+import Test.HUnit
+
+import Fen
+import Board
+import GameTree
+
+depth :: Int
+depth = 5
+
 main :: IO ()
-main = putStrLn "Test suite not yet implemented"
+main = do
+  runTestTT tests
+  return ()
+
+-- Siegbert Tarrasch vs. Max Kurschner
+-- 1. Qg6+ hxg6 2. Bxg6#
+mateInTwo = TestCase (assertEqual "1+2=3" move (Move (F,5) (G,6)))
+  where
+    board = fromFEN "r2qk2r/pb4pp/1n2Pb2/2B2Q2/p1p5/2P5/2B2PPP/RN2R1K1 w - - 1 0"
+    (gs, _) = negamax board (active board) depth
+    Just move = lastMove gs
+
+tests = TestList [TestLabel "mateInTwo" mateInTwo]