diff --git a/Chess.hs b/Chess.hs new file mode 100644 --- /dev/null +++ b/Chess.hs @@ -0,0 +1,278 @@ +-- | The main move validation module. FEN parsing code is in Chess.FEN and PGN parsing is in Chess.PGN +module Chess( MoveError(..) + , Color(..) + , PieceType(..) + , Piece(..) + , Board(..) + , strToPos + , pieceAt + , pieceAtStr + , move + , moveSAN + , check + , mate + , stalemate + ) where + +import Control.Monad.Instances +import Data.Array +import Data.Char +import qualified Data.List as L +import Data.Either +import Data.Maybe + +data MoveError = WrongTurn -- ^ It's not your turn + | NoPiece -- ^ There is no piece at the "from" position + | IsCheck -- ^ Your king is checked and this move doesn't solve that + | CausesCheck -- ^ After this move your king would be checked + | InvalidMove -- ^ This is not how that piece works + | OverPiece -- ^ You cannot move over other pieces + | CapturesOwn -- ^ This move captures one of your own pieces + | NoParse -- ^ I don't understand what you mean + deriving (Eq, Show) + +data MoveType = RegularMove + | KingMove -- ^ A move with the king + | KingRookMove -- ^ A move with the king-side rook + | QueenRookMove -- ^ A move with the queen-side rook + | DoublePawnMove -- ^ A move where a pawn makes two steps + | EnPassant -- ^ En-passant capture + deriving (Eq, Show) + +data Color = Black + | White + deriving (Eq, Show) + +data PieceType = Rook + | Knight + | Bishop + | Queen + | King + | Pawn + deriving (Eq, Show) + +data Piece = Piece { clr :: Color + , piece :: PieceType + } deriving (Eq) + +data Board = Board { turn :: Color + , castlingAvail :: String + , enpassant :: Maybe (Int, Int) + , board :: Array (Int, Int) (Maybe Piece) + } deriving (Eq) + +pcsList = [('r', Rook), ('n', Knight), ('b', Bishop), ('q', Queen), ('k', King), ('p', Pawn)] +pieceType a = snd $ head $ filter (\(x,y) -> toLower a == x) pcsList +pieceName a = fst $ head $ filter(\(x,y) -> y == a) pcsList + +instance Read Piece where + readsPrec _ (pc:x) = [(Piece clr $ pieceType pc, x)] where + clr = if isUpper pc then White else Black + +instance Show Piece where + show (Piece c t) = if c == White then [toUpper $ pieceName t] else [pieceName t] + +remCastle rem brd = brd { castlingAvail = (castlingAvail brd) L.\\ rem } + +instance Show Board where + show b = unlines [ [ tos (board b ! (x,y)) | x<-[0..7] ] | y<-[7,6..0]] where + tos p = fromMaybe ' ' (p >>= return . head . show) + +otherColor x = if x == White then Black else White + +isLeft (Left _) = True +isLeft _ = False + +posToStr (x,y) = [chr (x + 97), chr (y + 49)] + +-- |Takes a position like "a5" and returns the coordinates (0,4) +strToPos :: String -> (Int, Int) +strToPos a = (ord (head a) - 97, digitToInt (head $ tail a) - 1) + +charToRow a = digitToInt a - 1 +charToCol a = ord a - 97 + +-- |What piece is currently at this position on the board? +pieceAtStr :: String -> Board -> Maybe Piece +pieceAtStr a b = let (x,y) = strToPos a in pieceAt x y b + +-- |Like 'pieceAtStr', but with coordinates instead of a string +pieceAt :: Int -> Int -> Board -> Maybe Piece +pieceAt x y b = board b ! (x,y) + +piecesOf clr brd = [ (x,y) | (x,y)<-(indices $ board brd), apprPiece $ pieceAt x y brd ] where + apprPiece Nothing = False + apprPiece (Just (Piece c p)) = c == clr + +kingCoords clr brd = listToMaybe $ pieceCoords clr brd King + +pieceCoords clr brd piece = [ i | (i, pc) <- (assocs $ board brd), pc == Just (Piece clr piece) ] + +okMove x y x2 y2 brd = not $ isLeft $ moveAllowed x y x2 y2 brd + +rookValid x y x2 y2 brd + | x == 0 && y `elem` [0,7] = QueenRookMove + | x == 7 && y `elem` [0,7] = KingRookMove + | otherwise = RegularMove + +justIf cond val = if cond then Just val else Nothing + +validMove x y x2 y2 brd = pieceAt x y brd >>= \piece -> validMove' piece where + validMove' (Piece _ Rook) = justIf ((x == x2 && y /= y2) || (x /= x2 && y == y2)) (rookValid x y x2 y2 brd) + validMove' (Piece _ Knight) = justIf ((abs (x-x2) `elem` [1,2]) && (abs (y-y2) `elem` ([1,2] L.\\ [abs (x-x2)]))) RegularMove + validMove' (Piece _ Bishop) = justIf (abs (x2 - x) == abs (y2 - y)) RegularMove + validMove' (Piece _ King) = justIf ((abs (x-x2) <= 1) && (abs (y2 - y) <= 1)) KingMove + validMove' (Piece _ Queen) = justIf (abs (x2 - x) == abs (y2 - y) || + ((x == x2 && y /= y2) || (x /= x2 && y == y2))) RegularMove + validMove' (Piece White Pawn) + | x2 == x && y2 == y + 1 = Just RegularMove -- single step ahead + | x2 == x && y == 1 && y2 == y + 2 = Just DoublePawnMove -- double step ahead + | (y2 == y+1 && abs (x2-x) == 1) && (pieceAt x2 y2 brd /= Nothing) = Just RegularMove -- capture + | enpassant brd == Just (x2,y2) && (pieceAt x2 y brd /= Nothing) && abs (x2-x) == 1 && y2-y == 1 = Just EnPassant -- en passant + | otherwise = Nothing + validMove' (Piece Black Pawn) + | x2 == x && y2 == y-1 = Just RegularMove -- single step ahead + | x2 == x && y == 6 && y2 == y-2 = Just DoublePawnMove -- double step ahead + | (y2 == y-1 && abs (x2-x) == 1) && isJust (pieceAt x2 y2 brd) = Just RegularMove -- capture + | enpassant brd == Just (x2,y2) && isJust (pieceAt x2 y brd) && abs (x2-x) == 1 && y2-y == -1 = Just EnPassant -- en passant + | otherwise = Nothing + +moveAllowed x y x2 y2 brd + | isNothing $ pieceAt x y brd = Left NoPiece + | owncolor /= turn brd = Left WrongTurn + | pieceAtDest = Left CapturesOwn + | pieceInPath = Left OverPiece + | pawnIncorrectCapt = Left OverPiece + | otherwise = case validMove x y x2 y2 brd of + Nothing -> Left InvalidMove + Just mv -> if check owncolor $ moveNoCheck x y x2 y2 mv brd + then Left CausesCheck + else Right mv + where + pieceInPath = case ownpiece of + Piece _ Knight -> False + _ -> let (dx, dy) = (signum (x2 - x), signum (y2 - y)) + sqs + | dx == 0 = [(x,yy) | yy<-[y,y+dy..y2], yy /= y, yy/=y2] + | dy == 0 = [(xx,y) | xx<-[x,x+dx..x2], xx /= x, xx/=x2] + | otherwise = [(x+d*dx,y+d*dy) | d<-[1..(min (abs (y2-y)) (abs (x2-x)))-1]] + in any (\(x,y) -> isJust $ pieceAt x y brd) sqs + pieceAtDest = case pieceAt x2 y2 brd of + Just (Piece clr _) -> clr == owncolor + _ -> False + pawnIncorrectCapt = piece ownpiece == Pawn && x == x2 && (isJust $ pieceAt x2 y2 brd) + owncolor = clr ownpiece + ownpiece = fromJust $ pieceAt x y brd + +castleAllowed brd side = + pieceAt 4 y brd == Just (Piece (turn brd) King) && + all (\x -> isNothing $ pieceAt x y brd) nopc && + all (\x -> not $ check (turn brd) $ moveNoCheck 4 y x y RegularMove brd) noCheck && + castAvail `elem` castlingAvail brd + where + x = if side == King then 7 else 0 + y = if turn brd == White then 0 else 7 + nopc = if side == King then [5,6] else [1,2,3] + noCheck = if side == King then [5,6] else [2,3] + castAvail = (if turn brd == White then id else toLower) (if side == King then 'K' else 'Q') + +movePiece x y x2 y2 brd = removePiece x y $ putPiece x2 y2 (pieceAt x y brd) brd +setEnpassant x y brd = brd { enpassant = Just (x,y) } +resetEnpassant brd = brd {enpassant = Nothing } +swapTurn brd = brd { turn = otherColor $ turn brd } +putPiece x y pc brd = brd { board = (board brd) // [((x,y),pc)]} +removePiece x y = putPiece x y Nothing +castcase clr c = if clr == White then map toUpper c else map toLower c + +-- |Is the player of the given colour check? +check :: Color -> Board -> Bool +check clr brd = case kingCoords clr brd of + Just (kingX, kingY) -> any (\(x,y) -> okMove x y kingX kingY tmpbrd) otherPieces + where otherPieces = piecesOf (otherColor clr) brd + tmpbrd = brd {turn = otherColor clr} + Nothing -> False + +-- |Can the player of the given colour make any move? +stalemate :: Color -> Board -> Bool +stalemate clr brd = case kingCoords clr brd of + Just (kx,ky) -> not $ any (\(x,y) -> okMove kx ky x y tmpbrd) (km kx ky) + Nothing -> False + where + km kx ky = [(x,y)| x<-[kx-1,kx,kx+1], y<-[ky-1,ky,ky+1], x>=0, y>=0, x<8, y<8] + tmpbrd = brd {turn = clr} + +-- |Is the player with the given colour checkmate +mate :: Color -> Board -> Bool +mate clr brd = check clr brd && stalemate clr brd + +castle brd side + | castleAllowed brd side = Right (swapTurn $ resetEnpassant $ moveKing $ moveRook brd) + | otherwise = Left InvalidMove + where + y = if turn brd == White then 0 else 7 + (rookFrom, rookTo) = if side == King then (7, 5) else (0, 3) + (kingFrom, kingTo) = if side == King then (4, 6) else (4, 2) + moveKing board = movePiece kingFrom y kingTo y board + moveRook board = movePiece rookFrom y rookTo y board + +promote x y pc clr brd = case lookup (toLower pc) pcsList of + Just pct -> Right $ putPiece x y (Just $ Piece clr pct) brd + Nothing -> Left InvalidMove + +moveNoCheck x y x2 y2 moveType brd = case moveType of + KingRookMove -> let Piece clr _ = fromJust $ pieceAt x y brd + in moveNoCheck x y x2 y2 RegularMove (remCastle (castcase clr "k") brd) + QueenRookMove -> let Piece clr _ = fromJust $ pieceAt x y brd + in moveNoCheck x y x2 y2 RegularMove (remCastle (castcase clr "q") brd) + KingMove -> let Piece clr _ = fromJust $ pieceAt x y brd + in moveNoCheck x y x2 y2 RegularMove (remCastle (castcase clr "kq") brd) + RegularMove -> swapTurn $ resetEnpassant $ movePiece x y x2 y2 brd + DoublePawnMove -> swapTurn $ setEnpassant x2 ((y+y2) `div` 2) $ movePiece x y x2 y2 brd + EnPassant -> swapTurn $ resetEnpassant $ movePiece x y x2 y2 $ removePiece x2 y brd + +move' x y x2 y2 brd = moveAllowed x y x2 y2 brd >>= \movetype -> return (moveNoCheck x y x2 y2 movetype brd) + +-- | Perform a move on the board in coordinate notation like "e2e4", returning either the new board or an error +move :: [Char] -> Board -> Either MoveError Board +move mv brd + | mv == "O-O" = castle brd King + | mv == "O-O-O" = castle brd Queen + | length mv == 5 = move (init mv) brd >>= promote x2 y2 (last mv) (turn brd) + | length mv == 4 = move' x y x2 y2 brd + | otherwise = Left NoParse where + (x,y) = strToPos (take 2 mv) + (x2,y2) = strToPos (drop 2 mv) + +-- |Perform a move in SAN notation on the board and return either the new board or an error +moveSAN :: [Char] -> Board -> Either MoveError Board +moveSAN mv brd + | mv' == "O-O" = move "O-O" brd + | mv' == "O-O-O" = move "O-O-O" brd + | not $ head mv' `elem` "PRNBKQ" = moveSAN ('P':mv') brd + | last mv' `elem` "RNBQ" = moveSAN' (pieceType (head mv')) (init $ tail mv') (Just $ pieceType $ last mv') brd + | otherwise = moveSAN' (pieceType (head mv')) (tail mv') Nothing brd + where mv' = L.delete 'x' $ L.delete '+' $ L.delete '#' $ L.delete '=' mv + +moveSAN' piece mv promo brd + | length mv == 2 = -- piece and target square given + let potPcs = pieceCoords' piece in + case rights $ map (flip move brd) (potentialMoves potPcs) of + [x] -> Right x + _ -> Left NoParse + | head mv `elem` "0123456789" = -- starting rank given + let potPcs = filter (\(_,y) -> y == charToRow (head mv)) (pieceCoords' piece) in + case rights $ map (flip move brd) (potentialMoves potPcs) of + [x] -> Right x + _ -> Left NoParse + | otherwise = -- starting file given + let potPcs = filter (\(x,_) -> x == charToCol (head mv)) (pieceCoords' piece) in + case rights $ map (flip move brd) (potentialMoves potPcs) of + [x] -> Right x + _ -> Left NoParse + where pieceCoords' = pieceCoords (turn brd) brd + promoStr = case promo of + Just p -> [toUpper $ pieceName p] + Nothing -> "" + potentialMoves + | length mv == 2 = map (\x -> posToStr x ++ mv ++ promoStr) + | length mv == 3 = map (\x -> posToStr x ++ tail mv ++ promoStr) diff --git a/Chess/FEN.hs b/Chess/FEN.hs new file mode 100644 --- /dev/null +++ b/Chess/FEN.hs @@ -0,0 +1,53 @@ +module Chess.FEN ( fromFEN + , toFEN + , defaultFEN + , defaultBoard + ) where + +import Chess +import qualified Data.List as L +import Data.Char +import Data.Array +import Data.Maybe + +split [] delim = [""] +split (c:cs) delim + | c == delim = "" : rest + | otherwise = (c : head rest) : tail rest + where rest = split cs delim + +unsplit [] delim = "" +unsplit (x:[]) delim = x +unsplit (x:xs) delim = x ++ delim ++ (unsplit xs delim) + +fromFEN :: String -> Maybe Board +fromFEN fen = readPosition $ words fen + where readPosition (pieces:turn:castle:enpassant:_) = + Just $ Board (clr turn) castle enpas board where + clr x = if x == "w" then White else Black + enpas = if enpassant == "-" then Nothing else Just $ strToPos enpassant + board = listArray ((0,0),(7,7)) (concat $ L.transpose $ map makeLine (reverse boardLines)) + boardLines = split pieces '/' + makeLine ls = foldr ((++) . pcs) [] ls + pcs a = if isDigit a then replicate (digitToInt a) Nothing else [Just (read [a])] + readPosition _ = Nothing + +toFEN :: Board -> String +toFEN brd = pieces ++ " " ++ turnstr ++ " " ++ castString ++ " " ++ enpassantstr where + pieces = unsplit (map fenline $ [ [ (board brd)!(j,7-i) | j<-[0..7]] | i<-[0..7]]) "/" + turnstr = if turn brd == White then "w" else "b" + enpassantstr = fromMaybe "-" (enpassant brd >>= \(x,y) -> return [chr (x+97), intToDigit (y+1)]) + castString = if castlingAvail brd == "" then "-" else castlingAvail brd + fenline pcs = concatMap tos $ foldr com [] pcs where + tos = either show show + com a b = case a of + Just x -> (Right x) : b + Nothing -> case b of + ((Left n):xs) -> (Left (n+1)) : xs + _ -> (Left 1) : b + +defaultFEN :: String +defaultFEN = "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq -" + +defaultBoard :: Board +defaultBoard = fromJust $ fromFEN defaultFEN diff --git a/Chess/PGN.hs b/Chess/PGN.hs new file mode 100644 --- /dev/null +++ b/Chess/PGN.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} +module Chess.PGN ( pgnParser + , PGN(..) + , GameResult(..)) where + +import Chess +import Control.Applicative +import Data.Attoparsec.ByteString.Char8 +import Data.ByteString.Char8 (pack, unpack) +import Data.Map (fromList, (!)) + +type Move = String + +data PGN = PGN { event :: String + , site :: String + , date :: String + , round :: String + , whitePlayer :: String + , blackPlayer :: String + , result :: Maybe GameResult + , initialPosition :: Maybe Board + , moves :: [Move] + } deriving (Show) + +data GameResult = WhiteWon + | BlackWon + | Draw + deriving (Eq, Show) + +pgnParser = many gameParse + +gameParse = do + skipSpace + tagsTups <- many1 parseTag + let tags = fromList tagsTups + let gameResult = case tags ! "Result" of + "1/2-1/2" -> Just Draw + "1-0" -> Just WhiteWon + "0-1" -> Just BlackWon + _ -> Nothing + moves <- many parseMove + many uselessStuff + endResult + return $ PGN (unpack $ tags ! "Event") + (unpack $ tags ! "Site") + (unpack $ tags ! "Date") + (unpack $ tags ! "Round") + (unpack $ tags ! "White") + (unpack $ tags ! "Black") + gameResult + Nothing + moves + +-- todo: handle escaping +stringLiteral = do + char '"' + value <- takeTill ((==) '"') + char '"' + return value + +parseTag = do + skipSpace + char '[' + tagType <- takeTill ((==) ' ') + skipSpace + tagValue <- stringLiteral + char ']' + return (tagType, tagValue) + +moveNumber = do + decimal + many $ char '.' + whitespace + +nag = do + char '$' + decimal + whitespace + +rav = do + char '(' + scan 1 (\s a -> let news = if a == '(' + then s+1 + else (if a == ')' + then s-1 + else s) in + if news == 0 then Nothing else Just news) + char ')' + +comment = braceCmt <|> semiCmt where + braceCmt = do + char '{' + cmt <- takeTill ((==) '}') + char '}' + return cmt + semiCmt = do + char ';' + cmt <- takeTill ((==) '\n') + char '\n' + return cmt + +discard a = do + a + return () + +whitespace = discard (char ' ') <|> + discard (char '\n') <|> + discard (string "\r\n") <|> + discard (char '\t') + +uselessStuff = discard moveNumber <|> + discard comment <|> + discard whitespace <|> + discard nag <|> + discard rav + +endResult = string "1-0" <|> + string "0-1" <|> + string "1/2-1/2" <|> + string "*" + +parseMove = do + skipMany uselessStuff + movestr <- many1 $ satisfy (not . isSpace) + if movestr `elem` ["1-0", "0-1", "1/2-1/2", "*"] then + fail "end of game reached" + else + return movestr diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Arno van Lumig + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Arno van Lumig nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/chesshs.cabal b/chesshs.cabal new file mode 100644 --- /dev/null +++ b/chesshs.cabal @@ -0,0 +1,37 @@ +Name: chesshs +Version: 0.1 +Synopsis: Simple library for validating chess moves and parsing PGN files +Description: With this library you can load chess boards from FEN and PGN notation and apply moves to the boards. Moves will only be allowed if they are valid under the normal chess rules. +License: BSD3 +License-file: LICENSE +Author: Arno van Lumig +Maintainer: arno@vanlumig.com +homepage: http://arnovanlumig.com/chesshs.html +Category: Game +Build-type: Simple +Cabal-version: >=1.2 + +Flag no-pgn + Description: don't include the PGN parser, this removes the attoparsec dependency + Default: False + +Library + Exposed-modules: Chess + + if flag(no-pgn) + other-modules: + Chess.FEN + else + other-modules: + Chess.FEN + Chess.PGN + + Build-depends: + bytestring >= 0.9.0.0, + base >= 4 && < 5, + containers >= 0.4, + array >= 0.3.0.0 + + if !flag(no-pgn) + build-depends: + attoparsec >= 0.10.0.0