Browse files

added PGN parser with test code

fixed a castling and enpassant bug
added SAN move notation
  • Loading branch information...
1 parent aeab724 commit 28cae58dd4ee8140e807b887f801a0337e2e7f55 Arno van Lumig committed Jan 30, 2012
Showing with 357 additions and 62 deletions.
  1. +122 −32 Chess.hs
  2. +24 −23 ChessTest.hs
  3. +126 −0 PGN.hs
  4. +55 −0 PGNTest.hs
  5. +4 −2 README.md
  6. +0 −3 bugs
  7. +4 −2 chesshs.cabal
  8. +22 −0 testgame.pgn
View
154 Chess.hs
@@ -1,19 +1,69 @@
-module Chess(MoveError(..), Color(..), PieceType(..), Piece(..), Board(..), pieceAt, pieceAtStr, fromFEN, toFEN, move, check, mate, stalemate) where
+module Chess(MoveError(..),
+ Color(..),
+ PieceType(..),
+ Piece(..),
+ Board(..),
+ pieceAt,
+ pieceAtStr,
+ fromFEN,
+ toFEN,
+ move,
+ moveSAN,
+ check,
+ mate,
+ stalemate,
+ defaultBoard
+ ) where
-import Control.Monad.Instances
-import Array
-import Data.Char
+import Control.Monad.Instances
+import Array
+import Data.Char
import qualified Data.List as L
-import Data.Either
-import Data.Maybe
+import Data.Either
+import Data.Maybe
+import Debug.Trace
-data MoveError = WrongTurn | NoPiece | IsCheck | CausesCheck | InvalidMove | OverPiece | CapturesOwn deriving (Eq, Show)
-data MoveType = RegularMove | KingMove | KingRookMove | QueenRookMove | DoublePawnMove | EnPassant 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 MoveError = WrongTurn
+ | NoPiece
+ | IsCheck
+ | CausesCheck
+ | InvalidMove
+ | OverPiece
+ | CapturesOwn
+ | NoParse
+ deriving (Eq, Show)
-pcsList = [('r', Rook), ('n', Knight), ('b',Bishop),('q',Queen),('k', King),('p',Pawn)]
+data MoveType = RegularMove
+ | KingMove
+ | KingRookMove
+ | QueenRookMove
+ | DoublePawnMove
+ | EnPassant
+ 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
@@ -24,12 +74,10 @@ instance Read Piece where
instance Show Piece where
show (Piece c t) = if c == White then [toUpper $ pieceName t] else [pieceName t]
-data Board = Board { turn :: Color, castlingAvail :: String, enpassant :: Maybe (Int, Int), board :: Array (Int, Int) (Maybe Piece) } deriving (Eq)
-
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<-[0..7]] where
+ show b = unlines [ [ tos (board b ! (x,y)) | x<-[0..7] ] | y<-[7,6..0]] where
tos p = fromMaybe ' ' (p >>= return . head . show)
fromFEN fen = readPosition $ words fen
@@ -45,7 +93,7 @@ fromFEN fen = readPosition $ words fen
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])
+ 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
@@ -60,7 +108,10 @@ otherColor x = if x == White then Black else White
isLeft (Left _) = True
isLeft _ = False
+posToStr (x,y) = [chr (x + 97), chr (y + 49)]
strToPos a = (ord (head a) - 97, digitToInt (head $ tail a) - 1)
+charToRow a = digitToInt a - 1
+charToCol a = ord a - 97
split [] delim = [""]
split (c:cs) delim
@@ -78,7 +129,9 @@ piecesOf clr brd = [ (x,y) | (x,y)<-(indices $ board brd), apprPiece $ pieceAt x
apprPiece Nothing = False
apprPiece (Just (Piece c p)) = c == clr
-kingCoords clr brd = listToMaybe [ i | (i, pc) <- (assocs $ board brd), pc == Just (Piece clr King) ]
+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
@@ -100,13 +153,13 @@ validMove x y x2 y2 brd = pieceAt x y brd >>= \piece -> validMove' piece where
| 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) = Just EnPassant -- en passant
+ | 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) = Just EnPassant -- en passant
+ | 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
@@ -167,7 +220,7 @@ stalemate clr brd = case kingCoords clr brd of
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=otherColor clr}
+ tmpbrd = brd {turn = clr}
mate clr brd = check clr brd && stalemate clr brd
@@ -176,31 +229,68 @@ castle brd side
| otherwise = Left InvalidMove
where
y = if turn brd == White then 0 else 7
- (rookFrom, rookTo) = if side == King then (7, 5) else (0, 2)
- (kingFrom, kingTo) = if side == King then (4, 6) else (4, 1)
+ (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
-updateCastlingAvail brd = if check (turn brd) brd then remCastle (castcase (turn brd) "kq") brd else brd
-
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)
+ 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 (updateCastlingAvail $ moveNoCheck x y x2 y2 movetype brd)
+move' x y x2 y2 brd = moveAllowed x y x2 y2 brd >>= \movetype -> return (moveNoCheck x y x2 y2 movetype brd)
move mv brd
- | mv == "0-0" = castle brd King
- | mv == "0-0-0" = castle brd Queen
+ | 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 where
+ | length mv == 4 = move' x y x2 y2 brd
+ | otherwise = error $ mv ++ " is not a valid move" where
(x,y) = strToPos (take 2 mv)
- (x2,y2) = strToPos (drop 2 mv)
+ (x2,y2) = strToPos (drop 2 mv)
+
+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)
+
+defaultFEN = "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq -"
+defaultBoard = fromFEN defaultFEN
View
47 ChessTest.hs
@@ -16,7 +16,6 @@ assertEmpty lst = assertEqual "" [] lst
must_eq actual expected = assertEqual "" expected actual
defaultFEN = "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq -"
-defaultBoard = fromFEN defaultFEN
begpos = describe "on the beginposition" [
it "should not allow moving a white piece in blacks turn"
@@ -151,7 +150,7 @@ kingCastleCheckPosB = "8/8/8/6r1/8/8/8/4K2R w KQkq -"
kingcastletest = describe "a kingside castle" [
it "must be accepted" (
let brd = fromFEN kingcastlepos in
- case move "0-0" brd of
+ case move "O-O" brd of
Right brd -> do
pieceAt 4 0 brd `must_eq` Nothing
pieceAt 7 0 brd `must_eq` Nothing
@@ -161,15 +160,15 @@ kingcastletest = describe "a kingside castle" [
),
it "must not be allowed when piece inbetween" (
let brd = fromFEN kingCastleInbetweenPos in
- not $ valid "0-0" brd
+ not $ valid "O-O" brd
),
it "must not be allowed when causes check" (
let brd = fromFEN kingCastleCheckPosA in
- not $ valid "0-0" brd
+ not $ valid "O-O" brd
),
it "must not be allowed when check inbetween" (
let brd = fromFEN kingCastleCheckPosA in
- not $ valid "0-0" brd
+ not $ valid "O-O" brd
)
]
@@ -180,24 +179,24 @@ queenCastleCheckPosB = "8/8/8/8/5b2/8/8/R3K3 w KQkq -"
queencastletest = describe "a queenside castle" [
it "must be accepted" (
let brd = fromFEN queenCastlePos :: Board in
- case move "0-0-0" brd of
+ case move "O-O-O" brd of
Right brd -> pieceAt 4 0 brd == Nothing &&
pieceAt 7 0 brd == Nothing &&
- pieceAt 2 0 brd == Just (Piece White Rook) &&
- pieceAt 1 0 brd == Just (Piece White King)
- Left err -> False
+ pieceAt 3 0 brd == Just (Piece White Rook) &&
+ pieceAt 2 0 brd == Just (Piece White King)
+ Left err -> error $ show err
),
it "must not be allowed when piece inbetween" (
let brd = fromFEN queenCastleInbetweenPos in
- not $ valid "0-0-0" brd
+ not $ valid "O-O-O" brd
),
it "must not be allowed when causes check" (
let brd = fromFEN queenCastleCheckPosA in
- not $ valid "0-0-0" brd
+ not $ valid "O-O-O" brd
),
it "must not be allowed when check inbetween" (
let brd = fromFEN queenCastleCheckPosA in
- not $ valid "0-0-0" brd
+ not $ valid "O-O-O" brd
)
]
@@ -214,26 +213,20 @@ checkmoves = describe "moves causing check" [
)
]
-kingCastleCheck = "8/8/8/3r4/3B4/8/8/R3K2R b KQkq -"
kingCastle = "8/p7/8/8/8/8/8/4K2R w KQkq -"
queenCastle = "8/p7/8/8/8/8/8/R3K3 w KQkq -"
castletest = describe "castling" [
- it "must not be allowed kingside when king was check" (do
- let brd = allowedMoves ["d5e5", "d4e3", "e5d5"] $ fromFEN kingCastleCheck
- move "0-0" brd `must_eq` Left InvalidMove
- move "0-0-0" brd `must_eq` Left InvalidMove
- ),
it "must not be allowed kingside when kingrook moved" (do
let brd = allowedMoves ["h1h2", "a7a6", "h2h1", "a6a5"] $ fromFEN kingCastle
- move "0-0" brd `must_eq` Left InvalidMove
+ move "O-O" brd `must_eq` Left InvalidMove
),
it "must not be allowed queenside when queenrook has moved" (do
let brd = allowedMoves ["a1a2", "a7a6", "a2a1", "a6a5"] $ fromFEN queenCastle
- move "0-0-0" brd `must_eq` Left InvalidMove
+ move "O-O-O" brd `must_eq` Left InvalidMove
),
it "must not be allowed when king has moved" (do
let brd = allowedMoves ["e1e2", "a7a6", "e2e1"] $ fromFEN kingCastle
- move "0-0" brd `must_eq` Left InvalidMove
+ move "O-O" brd `must_eq` Left InvalidMove
)
]
@@ -260,11 +253,11 @@ fentest = describe "fen" [
toFEN (fromFEN checkMoveA) `must_eq` checkMoveA
toFEN (fromFEN checkMoveB) `must_eq` checkMoveB
toFEN (fromFEN kingCastle) `must_eq` kingCastle
- toFEN (fromFEN kingCastleCheck) `must_eq` kingCastleCheck
toFEN (fromFEN queenCastle) `must_eq` queenCastle
toFEN (fromFEN staleMatePos) `must_eq` staleMatePos
toFEN (fromFEN queenCastleCheckPosA) `must_eq` queenCastleCheckPosA
toFEN (fromFEN queenCastleCheckPosB) `must_eq` queenCastleCheckPosB
+ toFEN (fromFEN enpasPos) `must_eq` enpasPos
)
]
@@ -282,11 +275,19 @@ matetest = describe "mate" [
)
]
+enpasPos = "rnbqkbnr/ppp2ppp/8/3pP3/8/8/PPP1PPPP/RNBQKBNR w KQkq d6"
+enpasTest = describe "read enpassant" [
+ it "Must accept e5d6 on rnbqkbnr/ppp2ppp/8/3pP3/8/8/PPP1PPPP/RNBQKBNR w KQkq d6" (
+ let brd = fromFEN enpasPos in
+ valid "e5d6" brd
+ )
+ ]
+
mulMovesExcept pcs lst = concat $ map (\x -> movesExcept x lst) pcs
movesExcept pc lst = (filter (not . flip elem lst) (allMoves pc))
allMoves pc = [pc ++ [(chr (x+97)), (intToDigit (y+1))] | x<-[0..7], y<-[0..7]]
-tests = descriptions [begpos, enumpos, pawn, rook, knight, bishop, queen, king, kingcastletest, queencastletest, checkmoves, castletest, promotion, fentest, stalematetest, matetest]
+tests = descriptions [begpos, enumpos, pawn, rook, knight, bishop, queen, king, kingcastletest, queencastletest, checkmoves, castletest, promotion, fentest, stalematetest, matetest, enpasTest]
main = do
hspec tests
View
126 PGN.hs
@@ -0,0 +1,126 @@
+{-# LANGUAGE OverloadedStrings #-}
+module 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
View
55 PGNTest.hs
@@ -0,0 +1,55 @@
+module Main where
+
+import Data.ByteString.Char8 (pack, unpack)
+import IO
+import PGN
+import Data.Attoparsec.ByteString.Char8
+import Control.Monad.Instances
+import Control.Monad
+import Chess
+import Data.Either
+
+loadTestGame = do
+ file <- openFile "testgame.pgn" ReadMode
+ pgn <- hGetContents file
+ return $ pack pgn
+
+main = do
+ pgn <- loadTestGame
+ let eithergames = parseOnly pgnParser pgn
+ case eithergames of
+ Left err -> error err
+ Right games -> do
+ mapM_ (uncurry gameprint) $ zip (map (moveSequence defaultBoard . moves) games) games
+
+-- prettyprint a game with result
+gameprint (Left err) pgn = do
+ putStrLn "========"
+ putStrLn $ (event pgn) ++ " " ++ (date pgn) ++ " (" ++ whitePlayer pgn ++ " - " ++ blackPlayer pgn ++ ") " ++ (show $ result pgn)
+ putStrLn $ "Error in game: " ++ show err
+ putStrLn "--------"
+ print pgn
+ putStrLn "========"
+gameprint (Right board) pgn = do
+ putStrLn "========"
+ putStrLn $ (event pgn) ++ " " ++ (date pgn) ++ " (" ++ whitePlayer pgn ++ " - " ++ blackPlayer pgn ++ ") " ++ (show $ result pgn)
+ putStrLn "--------"
+ putStr $ show board
+ putStrLn "--------"
+ putStrLn $ "Checkmate: " ++ matestr
+ putStrLn $ "Stalemate: " ++ stalematestr
+ putStrLn "========"
+ where matestr
+ | mate White board = "white"
+ | mate Black board = "black"
+ | otherwise = "no"
+ stalematestr
+ | stalemate (turn board) board = show $ turn board
+ | otherwise = "no"
+
+-- apply the moves to the board, giving a detailed error in case of failure
+moveSequence brd mvs = foldM (flip moveVerbose) brd mvs
+
+moveVerbose mv brd = case moveSAN mv brd of
+ Right b -> Right b
+ Left er -> Left (mv, brd, turn brd, castlingAvail brd, er)
View
6 README.md
@@ -1,5 +1,7 @@
This is a simple library for checking which moves are allowed on a given chess position. As far as I know, all chess rules have been implemented and work correctly.
-The API is quite simple. To create a chess board use the `fromFEN` function, which loads a board from a FEN string (see http://en.wikipedia.org/wiki/Forsyth%E2%80%93Edwards_Notation). You can then perform moves on the board by using the `move` function which takes a string of the form "b2b3" for regular moves, "0-0" for a kingside castle, "0-0-0" for a queenside castle, and "a7a8q" for promotion to a queen.
+The API is quite simple. To create a chess board use the `fromFEN` function, which loads a board from a FEN string (see http://en.wikipedia.org/wiki/Forsyth%E2%80%93Edwards_Notation). You can then perform moves on the board by using the `move` function which takes a string of the form "b2b3" for regular moves, "0-0" for a kingside castle, "0-0-0" for a queenside castle, and "a7a8q" for promotion to a queen. The `moveSAN` function accepts moves in standard algebraic notation, like "Nc3", "e4" and "e8Q".
-The code is quite messy and lacks documentation, so please take a look at ChessTest.hs to see how to use it.
+The `PGN` module can be used to parse PGN databases to a list of games. It will only parse the required tags, and will strip all comments, numeric annotations and recursive annotations.
+
+The code is quite messy and lacks documentation, so please take a look at ChessTest.hs and PGNTest.hs to see how to use it.
View
3 bugs
@@ -1,3 +0,0 @@
-e5d6 on rnbqkbnr/ppp2ppp/8/3pP3/8/8/PPP1PPPP/RNBQKBNR w KQkq d5
-
-should be allowed, but returns Left InvalidMove
View
6 chesshs.cabal
@@ -1,6 +1,6 @@
Name: chesshs
Version: 0.1
-Synopsis: Simple library for validating chess moves
+Synopsis: Simple library for validating chess moves and parsing PGN files
License: BSD3
License-file: LICENSE
Author: Arno van Lumig
@@ -10,9 +10,11 @@ Build-type: Simple
Cabal-version: >=1.2
Library
- Exposed-modules: Chess
+ Exposed-modules: Chess, PGN
Build-depends:
+ bytestring == 0.9.*,
+ attoparsec == 0.10.*,
base >= 4 && < 5,
containers >= 0.4,
haskell98
View
22 testgame.pgn
@@ -0,0 +1,22 @@
+[Event "CAN ch"]
+[Site "Hamilton"]
+[Date "1924.08.20"]
+[Round "6"]
+[White "Wilson, Stanley B"]
+[Black "Ewing, John M"]
+[Result "0-1"]
+[ECO "B01"]
+[PlyCount "118"]
+[EventDate "1924.08.18"]
+
+1. e4 d5 2. exd5 Qxd5 3. Nc3 Qd8 4. Nf3 c6 5. b3 Nf6 6. Bb2 Bf5 7. Be2 e6 8.
+O-O Bd6 9. Nh4 Bg6 10. h3 Nbd7 11. Rc1 Nd5 12. Nxd5 Qxh4 13. Ne3 O-O 14. d4 Nf6
+15. Bf3 Nd5 16. Nxd5 exd5 17. c4 dxc4 18. bxc4 Be4 19. Bxe4 Qxe4 20. Re1 Qf4
+21. g3 Qf5 22. Kg2 Rfe8 23. Qb3 b6 24. Re3 Rxe3 25. Qxe3 Qe6 26. Qf3 Rc8 27. d5
+Qd7 28. dxc6 Qxc6 29. Qd5 Qxd5+ 30. cxd5 Rxc1 31. Bxc1 f5 32. Kf3 Kf7 33. Ke2
+Ke7 34. Kd3 Bc5 35. Be3 Kd6 36. Kc4 Bxe3 37. fxe3 Ke5 38. a4 a6 39. a5 bxa5 40.
+Kc5 a4 41. d6 Ke6 42. Kc6 a3 43. d7 a2 44. d8=Q a1=Q 45. Qd5+ Ke7 46. Qd7+ Kf8
+47. Qd6+ (47. Qxf5+ Qf6+ 48. Qxf6+ gxf6 49. Kb6) 47... Kf7 48. Qd7+ Kg6 49.
+Qe8+ Kh6 50. Qe6+ g6 51. Kb6 Qa4 52. Qe5 a5 53. Qxa5 Qxa5+ 54. Kxa5 Kg5 55. Kb4
+h5 56. Kc3 h4 57. gxh4+ Kxh4 58. Kd3 Kxh3 59. Ke2 59... Kg2 {(Le Pion 1924)}
+0-1

0 comments on commit 28cae58

Please sign in to comment.