diff --git a/app/Main.hs b/app/Main.hs index 906ceb0..7016ed2 100644 --- a/app/Main.hs +++ b/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 \ No newline at end of file + return GO \ No newline at end of file diff --git a/hask-chess.cabal b/hask-chess.cabal index 1dcdcd3..4f2cf8c 100644 --- a/hask-chess.cabal +++ b/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: diff --git a/src/Board.hs b/src/Board.hs index be7c130..79a7933 100644 --- a/src/Board.hs +++ b/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)) diff --git a/src/Fen.hs b/src/Fen.hs index 3cccc07..6fe928e 100644 --- a/src/Fen.hs +++ b/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])) \ No newline at end of file + 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" \ No newline at end of file diff --git a/src/GameTree.hs b/src/GameTree.hs index 025d612..14d5694 100644 --- a/src/GameTree.hs +++ b/src/GameTree.hs @@ -1,7 +1,7 @@ module GameTree where import Board -import Move +import MoveGen import Evaluation negamax :: GameState -> Colour -> Int -> (GameState, Int) diff --git a/src/Move.hs b/src/MoveGen.hs similarity index 94% rename from src/Move.hs rename to src/MoveGen.hs index a4576e8..fc78a3c 100644 --- a/src/Move.hs +++ b/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 =