Refactor Move and complete fromUCIMove parser

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

app/Main.hs

@@ -1,7 +1,7 @@
 module Main where
 
 import Board
-import Move
+import MoveGen
 import Fen
 import GameTree
 import Text.Parsec
@@ -46,14 +46,13 @@ processLine depth gs = do
     Right (FEN gs') -> processLine depth gs'
     Right (STARTPOS moves) -> processLine depth (sequenceMoves initialGameState moves)
     Right GO -> do
-      putStrLn "here we go"
       let (gs', score) = negamax gs (active gs) depth
       putStrLn $ show gs'
       logLine $ show gs'
       logLine $ show (lastMove gs')
       logLine $ show score
       printAndLog $ "bestmove " ++ (toUCI (fromJust $ lastMove gs'))
-
+      processLine depth gs'
     Left _ -> do
       logLine $ "unkown command " ++ l
       processLine depth gs
@@ -80,7 +79,6 @@ parseNewGame = do
   string "ucinewgame"
   return NEWGAME
 
-
 parsePosition = do
   string "position"
   space
@@ -109,6 +107,4 @@ parseUCIMoves = moves <|> none
 parseGo = do
   string "go"
   many anyChar
-  return GO
--- main = do
---   putStrLn $ show $ negamax initialGameState White 6
+  return GO

hask-chess.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 0f7a09c50c2c497cdd4f745648955f2a3be259f68806f13bd4f6de7d471a14d0
+-- hash: 4c4960cf688660898028592e7bd61ada9b381cbff756af228e2b657dd269f5c5
 
 name:           hask-chess
 version:        0.1.0.0
@@ -31,7 +31,7 @@ library
       Evaluation
       Fen
       GameTree
-      Move
+      MoveGen
   other-modules:
       Paths_hask_chess
   hs-source-dirs:

src/Board.hs

@@ -12,10 +12,10 @@ 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 Show
 
 toUCI :: Move -> String
-toUCI (Move ((sCol, sRow), (dCol, dRow))) = (map toLower $ show sCol) ++ (show sRow) ++ (map toLower $ show dCol) ++ (show dRow)
+toUCI (Move (sCol, sRow) (dCol, dRow)) = (map toLower $ show sCol) ++ (show sRow) ++ (map toLower $ show dCol) ++ (show dRow)
 
 newtype Board = Board (V.Vector (Maybe Piece))
 

src/Fen.hs

@@ -1,6 +1,5 @@
 module Fen where
 
-import Move
 import Board
 import qualified Data.Vector as V
 import qualified Data.Set as S
@@ -113,4 +112,21 @@ parseUCIMove = do
   startRow <- digit
   endCol <- letter
   endRow <- digit
-  return $ Move ((readColumn startCol, read [startRow]), (readColumn endCol, read [endRow]))
+  mbPromote <- (Just <$> try letter) <|> pure Nothing
+  case mbPromote of
+    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,8), (G,8)) -> return $ Castle Black Short
+      ((E,8), (C,8)) -> return $ Castle Black Long
+      (src, dst) -> return $ Move src dst
+
+
+
+  where
+    toPt 'q' = Queen
+    toPt 'r' = Rook
+    toPt 'n' = Knight
+    toPt 'b' = Bishop
+    toPt _   = error "Unknown piece type in parseUCIMove"

src/GameTree.hs

@@ -1,7 +1,7 @@
 module GameTree where
 
 import Board
-import Move
+import MoveGen
 import Evaluation
 
 negamax :: GameState -> Colour -> Int -> (GameState, Int)

src/Move.hs → src/MoveGen.hs

@@ -1,4 +1,4 @@
-module Move where
+module MoveGen where
 
 import Board
 import qualified Data.Vector as V
@@ -18,7 +18,7 @@ applyAll :: GameState -> [Move] -> [GameState]
 applyAll gs moves = map (apply gs) moves
 
 apply :: GameState -> Move -> GameState
-apply gs m@(Move (src, dst)) = gs {
+apply gs m@(Move src dst) = gs {
     board=move src dst (board gs)
   , castling=loosesCastlingRights (board gs) m (castling gs)
   , fullMove=(fullMove gs) + 1
@@ -71,7 +71,7 @@ removeCastlingRightsFor :: S.Set CastlingRight -> Colour -> S.Set CastlingRight
 removeCastlingRightsFor crs col = S.filter (\(CastlingRight c ty) -> c /= col) crs
 
 loosesCastlingRights :: Board -> Move -> S.Set CastlingRight -> S.Set CastlingRight
-loosesCastlingRights b (Move (src, dst)) activeRights | S.null activeRights = S.empty 
+loosesCastlingRights b (Move src dst) activeRights | S.null activeRights = S.empty 
                                                       | otherwise = case ty of
     King -> activeRights `removeCastlingRightsFor` colour
     Rook -> case (colour, col) of
@@ -103,8 +103,8 @@ genPawnForwardMoves b c i = if isInStartingPosition then singleStep ++ doubleSte
     doubleStepSquare = if c == White then (col, row+2) else (col, row-2)
     inbounds i = i >= 0 && i <= 63
     promotion = map (Promote (indexToPosition i)) [Queen, Knight]
-    singleStep = if inbounds (positionToIndex singleStepSquare) && isEmpty b (positionToIndex singleStepSquare) then [Move ((col, row), singleStepSquare)] else []
-    doubleStep = if inbounds (positionToIndex doubleStepSquare) && isEmpty b (positionToIndex singleStepSquare) && isEmpty b (positionToIndex doubleStepSquare) then [Move ((col, row), doubleStepSquare)] else []
+    singleStep = if inbounds (positionToIndex singleStepSquare) && isEmpty b (positionToIndex singleStepSquare) then [Move (col, row) singleStepSquare] else []
+    doubleStep = if inbounds (positionToIndex doubleStepSquare) && isEmpty b (positionToIndex singleStepSquare) && isEmpty b (positionToIndex doubleStepSquare) then [Move (col, row) doubleStepSquare] else []
 
 genPawnTakes :: Board -> Colour -> Int -> [Move]
 genPawnTakes b c i = 
@@ -116,8 +116,8 @@ genPawnTakes b c i =
       else checkLeftTake ++ checkRightTake
 
   where
-    checkRightTake = if (inbounds rightTake && containsOpponentPiece b c rightTake) then [Move (current, indexToPosition rightTake)] else []
-    checkLeftTake = if (inbounds leftTake && containsOpponentPiece b c leftTake) then [Move (current, indexToPosition leftTake)] else []
+    checkRightTake = if (inbounds rightTake && containsOpponentPiece b c rightTake) then [Move current $ indexToPosition rightTake] else []
+    checkLeftTake = if (inbounds leftTake && containsOpponentPiece b c leftTake) then [Move current $ indexToPosition leftTake] else []
     inbounds i = i >= 0 && i <= 63
     rightTake = if c == White then i + 9 else i - 7
     leftTake = if c == White then i + 7 else i - 9
@@ -149,7 +149,7 @@ genKnightMoves board colour i = map moveFromCurr $ filter canMove $ filter inbou
               , (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)
-    moveFromCurr (a,b) = Move ((col,r), (fromInt a, b))
+    moveFromCurr (a,b) = Move (col,r) (fromInt a, b)
     canMove (a,b) = case board `atPosition` (fromInt a, b) of 
       Nothing -> True
       Just (Piece c p) -> c /= colour
@@ -212,7 +212,7 @@ genKingMoves gs colour i = (map moveFromCurr $ filter canMove $ filter inbounds
               , (c, r-1), (c-1, r-1)
               , (c-1, r), (c-1, r+1)]
     inbounds (a,b) = (a >= 0 && a <= 7) && (b >= 1 && b <= 8)
-    moveFromCurr (a,b) = Move ((col,r), (fromInt a, b))
+    moveFromCurr (a,b) = Move (col,r) (fromInt a, b)
 
     canMove (a,b) = case (board gs) `atPosition` (fromInt a, b) of
       Nothing -> True
@@ -235,7 +235,7 @@ canCastle gs Black cty i = i == 60 && case cty of
     activeRights = castling gs
 
 rayToMoves :: Position -> [Position] -> [Move]
-rayToMoves src dests = Move <$> [(src, dest) | dest <- dests]
+rayToMoves src dests = uncurry Move <$> [(src, dest) | dest <- dests]
 
 genRay :: Board -> Colour -> Maybe Position -> (Position -> Maybe Position) -> [Position]
 genRay b c (Just pos) fn =