From 4443c6be0a8e8f909ef6513e8bd291924a80c53c Mon Sep 17 00:00:00 2001 From: Giovanni Garufi Date: Thu, 21 Jan 2021 16:06:04 +0100 Subject: [PATCH] Add test structure and refactor rays Change-type: patch Signed-off-by: Giovanni Garufi --- hask-chess.cabal | 11 +++++++---- package.yaml | 1 + src/Board.hs | 4 ++-- src/MoveGen.hs | 40 ++++++++++++++++++++++------------------ src/Uci.hs | 4 ++-- test/Spec.hs | 23 ++++++++++++++++++++++- 6 files changed, 56 insertions(+), 27 deletions(-) diff --git a/hask-chess.cabal b/hask-chess.cabal index 30116d1..fb68526 100644 --- a/hask-chess.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index 31a8198..d31a5c8 100644 --- a/package.yaml +++ b/package.yaml @@ -25,6 +25,7 @@ dependencies: - mtl - parsec - containers +- HUnit library: source-dirs: src diff --git a/src/Board.hs b/src/Board.hs index 5621fc1..7090250 100644 --- a/src/Board.hs +++ b/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 diff --git a/src/MoveGen.hs b/src/MoveGen.hs index fc78a3c..d1168a5 100644 --- a/src/MoveGen.hs +++ b/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 diff --git a/src/Uci.hs b/src/Uci.hs index d3a1147..7fac1a1 100644 --- a/src/Uci.hs +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs index cd4753f..2eccd5a 100644 --- a/test/Spec.hs +++ b/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] \ No newline at end of file