diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# hchesslib + +[![Build Status](https://travis-ci.org/nablaa/hchesslib.png?branch=master)](https://travis-ci.org/nablaa/hchesslib) + +hchesslib is a simple chess library for Haskell. 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/hchesslib.cabal b/hchesslib.cabal new file mode 100644 --- /dev/null +++ b/hchesslib.cabal @@ -0,0 +1,66 @@ +-- Initial hirchess.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: hchesslib +version: 0.1.0.0 +synopsis: Chess library +description: Library implementing chess rules. +license: GPL-2 +license-file: LICENSE +author: Miika-Petteri Matikainen +maintainer: miikapetteri@gmail.com +homepage: https://github.com/nablaa/hchesslib +-- copyright: +category: Game +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/nablaa/hchesslib + +Library + Default-Language: Haskell2010 + Hs-Source-Dirs: src + + exposed-modules: Chess, Chess.FEN + + other-modules: Chess.Internal.Piece, + Chess.Internal.Board, + Chess.Internal.Move, + Chess.Internal.FEN, + Chess.Internal.Notation + Chess.Internal.Game + + Build-depends: base >= 4 && < 5 + , array >= 0.4 + , containers >= 0.4 + , attoparsec + , text + +Test-Suite spec + Type: exitcode-stdio-1.0 + Default-Language: Haskell2010 + Hs-Source-Dirs: src, test, test/Chess + Ghc-Options: -Wall -Werror + Main-Is: Spec.hs + + Build-Depends: base >= 4 && < 5 + , hspec >= 1.5 + , QuickCheck + , array >= 0.4 + , containers >= 0.4 + , attoparsec + , text + , hchesslib + +Test-suite hlint + type: exitcode-stdio-1.0 + Default-language: Haskell2010 + Hs-source-dirs: src, test, test/Chess + Main-is: HLint.hs + + Build-depends: base >= 4 && < 5 + , hlint >= 1.8 + , hchesslib diff --git a/src/Chess.hs b/src/Chess.hs new file mode 100644 --- /dev/null +++ b/src/Chess.hs @@ -0,0 +1,91 @@ +-- | +-- Module : Chess +-- Copyright : Miika-Petteri Matikainen 2014 +-- License : GPL-2 +-- +-- Maintainer : miikapetteri@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- Simple chess library for implementing chess games. +module Chess ( + Chess.Internal.Board.Board, + Chess.Internal.Board.Coordinates, + Chess.Internal.Board.Square(..), + Chess.Internal.Move.GameState, + Chess.Internal.Move.currentPlayer, + Chess.Internal.Piece.Color(..), + Chess.Internal.Piece.Piece(..), + Chess.Internal.Piece.PieceType(..), + board, + fullMoveNumber, + isCheckmate, + isDraw, + isLegalMove, + isStalemate, + move, + newGame, + pieceAt, + winner, + ) where + +import Chess.Internal.Board +import Chess.Internal.Move +import Chess.Internal.Piece +import qualified Chess.Internal.Game as G +import qualified Chess.Internal.Notation as N + +-- | Has the game ended in checkmate +isCheckmate :: GameState -> Bool +isCheckmate = G.isCheckmate + +-- | Has the game ended in stalemate +isStalemate :: GameState -> Bool +isStalemate = G.isStalemate + +-- | Is the game draw? I.e. is the game stalemate or is the game draw by +-- insufficient material. +isDraw :: GameState -> Bool +isDraw = G.isDraw + +-- | Returns the winner of the game if any +winner :: GameState -> Maybe Color +winner = G.getWinner + +-- | Is the given move legal. The only supported move format at the moment +-- is coordinate notation. +isLegalMove :: GameState + -> String -- ^ Move in coordinate notation. E.g. "e2-e4" or "b1-c3" + -> Bool +isLegalMove game moveStr = case N.parseMove game moveStr of + Just m -> m `elem` generateAllMoves game + Nothing -> False + +-- | Make a move. The only supported move format at the moment is coordinate +-- notation. +move :: GameState + -> String -- ^ Move in coordinate notation. E.g. "e2-e4" or "b1-c3" + -> Maybe GameState +move game moveStr = do m <- N.parseMove game moveStr + case G.applyMove game m of + Left _ -> Nothing + Right game' -> Just game' + +-- | Current board state in the game +board :: GameState -> Board +board = stateBoard + +-- | Get initial game state +newGame :: GameState +newGame = initialState + +-- | Get the piece at the given coordinate +pieceAt :: Board + -> String -- ^ Square coordinate. E.g. "e4" + -> Maybe Piece +pieceAt b coordinateStr = do coords <- parseCoordinate coordinateStr + getPiece b coords + +-- | Full move number. Incremented after black's move. +fullMoveNumber :: GameState -> Integer +fullMoveNumber = moveNumber diff --git a/src/Chess/FEN.hs b/src/Chess/FEN.hs new file mode 100644 --- /dev/null +++ b/src/Chess/FEN.hs @@ -0,0 +1,36 @@ +-- | +-- Module : Chess.FEN +-- Copyright : Miika-Petteri Matikainen 2014 +-- License : GPL-2 +-- +-- Maintainer : miikapetteri@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- Parsing chess games from FEN notation +-- (https://en.wikipedia.org/wiki/Forsyth%E2%80%93Edwards_Notation). +module Chess.FEN (writeFEN, readFEN) where + +import Chess.Internal.Move +import Chess.Internal.FEN + +-- | Write the current game state as FEN notation +writeFEN :: GameState -> String +writeFEN state = unwords [writeBoard (stateBoard state), + writePlayer (currentPlayer state), + writeCastlings (whiteCastlingsPossible state) (blackCastlingsPossible state), + writeEnPassant (enPassantSquare state), + show (halfmoveClock state), + show (moveNumber state)] + +-- | Parse game state from FEN notation +readFEN :: String -> Maybe GameState +readFEN str | length parts /= 6 = Nothing + | otherwise = do board' <- readBoard $ head parts + player <- readPlayer $ parts !! 1 + castlings <- readCastlings $ parts !! 2 + enPassant <- readEnPassant $ parts !! 3 + halfmoves <- readNumberWithLimit 0 $ parts !! 4 + moves <- readNumberWithLimit 1 $ parts !! 5 + return $ uncurry (State board' player) castlings enPassant halfmoves moves + where parts = words str diff --git a/src/Chess/Internal/Board.hs b/src/Chess/Internal/Board.hs new file mode 100644 --- /dev/null +++ b/src/Chess/Internal/Board.hs @@ -0,0 +1,214 @@ +module Chess.Internal.Board (Board, Coordinates, initialBoard, emptyBoard, printBoardCompact, + parseCoordinate, isInsideBoard, getPiece, movePiece, + parseBoardCompact, printCoordinate, isEmpty, isOpponentSquare, + firstPieceInSquareList, iterateDirectionInsideBoard, + getKingSquare, rookPattern, bishopPattern, knightPattern, + queenPattern, isSquareThreatened, sumSquares, + isCheck, getSquaresWithOwner, addPiece, removePiece, + getPlayerPieces, getSquareColor, getSquaresWithPieces, Square(..)) where + +import Data.Array +import Data.Char +import Data.List +import Data.Maybe +import Chess.Internal.Piece + +data Square = Square Piece | Empty + deriving (Eq, Show) + + +-- | Coordinate format: +-- +-- @ +-- (rank, file) +-- (0,0) (0,7) +-- +---> file +-- | +-- | +-- v +-- rank +-- (7,0) (7,7) +-- - +-- +-------+-------+-------+-------+-------+-------+-------+-------+ +-- 8 | (0,0) | (0,1) | (0,2) | (0,3) | (0,4) | (0,5) | (0,6) | (0,7) | +-- +-------+-------+-------+-------+-------+-------+-------+-------+ +-- 7 | (1,0) | (1,1) | (1,2) | (1,3) | (1,4) | (1,5) | (1,6) | (1,7) | +-- +-------+-------+-------+-------+-------+-------+-------+-------+ +-- 6 | (2,0) | (2,1) | (2,2) | (2,3) | (2,4) | (2,5) | (2,6) | (2,7) | +-- +-------+-------+-------+-------+-------+-------+-------+-------+ +-- 5 | (3,0) | (3,1) | (3,2) | (3,3) | (3,4) | (3,5) | (3,6) | (3,7) | +-- +-------+-------+-------+-------+-------+-------+-------+-------+ +-- 4 | (4,0) | (4,1) | (4,2) | (4,3) | (4,4) | (4,5) | (4,6) | (4,7) | +-- +-------+-------+-------+-------+-------+-------+-------+-------+ +-- 3 | (5,0) | (5,1) | (5,2) | (5,3) | (5,4) | (5,5) | (5,6) | (5,7) | +-- +-------+-------+-------+-------+-------+-------+-------+-------+ +-- 2 | (6,0) | (6,1) | (6,2) | (6,3) | (6,4) | (6,5) | (6,6) | (6,7) | +-- +-------+-------+-------+-------+-------+-------+-------+-------+ +-- 1 | (7,0) | (7,1) | (7,2) | (7,3) | (7,4) | (7,5) | (7,6) | (7,7) | +-- +-------+-------+-------+-------+-------+-------+-------+-------+ +-- a b c d e f g h +-- @ +-- +type Coordinates = (Int, Int) +type Board = Array Coordinates Square + +initialBoard :: Board +initialBoard = listArray ((0, 0), (7, 7)) rows + where officerRow color = map (Square . Piece color) [Rook, Knight, Bishop, Queen, King, Bishop, Knight, Rook] + pawnRow color = replicate 8 $ (Square . Piece color) Pawn + rows = officerRow Black ++ pawnRow Black ++ replicate 32 Empty ++ pawnRow White ++ officerRow White + +emptyBoard :: Board +emptyBoard = listArray ((0, 0), (7, 7)) (repeat Empty) + +squareToChar :: Square -> Char +squareToChar Empty = ' ' +squareToChar (Square p) = head $ printPiece p + +printBoardCompact :: Board -> String +printBoardCompact board = toLines $ foldr f "" (elems board) + where f = (:) . squareToChar + toLines [] = [] + toLines str = take 8 str ++ "\n" ++ toLines (drop 8 str) + +isInsideBoard :: Coordinates -> Bool +isInsideBoard (i, j) = i >= 0 && i <= 7 && j >= 0 && j <= 7 + +parseCoordinate :: String -> Maybe Coordinates +parseCoordinate (column:row:[]) | isInsideBoard coordinates = Just coordinates + | otherwise = Nothing + where coordinates = (ord '8' - ord row, ord column - ord 'a') +parseCoordinate _ = Nothing + +printCoordinate :: Coordinates -> String +printCoordinate (r, c) = [chr (ord 'a' + c), intToDigit (8 - r)] + +movePiece :: Coordinates -> Coordinates -> Board -> Maybe Board +movePiece start end _ | not (isInsideBoard start) || not (isInsideBoard end) = Nothing +movePiece start end board = case startPiece of + Nothing -> Nothing + Just piece -> Just $ addPiece board' end piece + where startPiece = getPiece board start + board' = removePiece board start + +addPiece :: Board -> Coordinates -> Piece -> Board +addPiece board coordinates = updateBoard board coordinates . Square + +removePiece :: Board -> Coordinates -> Board +removePiece board coordinates = updateBoard board coordinates Empty + +updateBoard :: Board -> Coordinates -> Square -> Board +updateBoard board coordinates square = board // [(coordinates, square)] + +getPiece :: Board -> Coordinates -> Maybe Piece +getPiece board coordinates | inRange (bounds board) coordinates = f $ board ! coordinates + where f Empty = Nothing + f (Square piece) = Just piece +getPiece _ _ = Nothing + +isEmpty :: Board -> Coordinates -> Bool +isEmpty board coordinates = isNothing $ getPiece board coordinates + +isPlayerSquare :: Board -> Color -> Coordinates -> Bool +isPlayerSquare board player coordinates = case getPiece board coordinates of + Nothing -> False + Just (Piece color _) -> color == player + +isOpponentSquare :: Board -> Coordinates -> Color -> Bool +isOpponentSquare board coordinates player = isPlayerSquare board (opponent player) coordinates + +parseBoardCompact :: String -> Maybe Board +parseBoardCompact str | length str /= 72 = Nothing + | length rows /= 8 || nub (map length rows) /= [8] = Nothing + | otherwise = squares >>= boardFromSquares + where rows = lines str + squares = mapM parseSquare (concat rows) + +parseSquare :: Char -> Maybe Square +parseSquare ' ' = Just Empty +parseSquare c = case parsePiece c of + Nothing -> Nothing + Just piece -> Just $ Square piece + +boardFromSquares :: [Square] -> Maybe Board +boardFromSquares squares | length squares /= 64 = Nothing + | otherwise = Just $ listArray ((0, 0), (7, 7)) squares + +firstPieceInSquareList :: Board -> [Coordinates] -> Maybe Piece +firstPieceInSquareList board coordinates = case firstNonEmpty of + [] -> Nothing + (coordinate:_) -> getPiece board coordinate + where firstNonEmpty = dropWhile (isEmpty board) coordinates + +iterateDirectionInsideBoard :: Coordinates -> (Int, Int) -> [Coordinates] +iterateDirectionInsideBoard start direction = tail $ takeWhile isInsideBoard $ iterate (sumSquares direction) start + +sumSquares :: (Int, Int) -> (Int, Int) -> (Int, Int) +sumSquares (x1, y1) (x2, y2) = (x1 + x2, y1 + y2) + +getKingSquare :: Board -> Color -> Coordinates +getKingSquare board player = fromJust $ rlookup (Square (Piece player King)) $ assocs board + where rlookup x = lookup x . map swap + swap (x, y) = (y, x) + +rookPattern :: [(Int, Int)] +rookPattern = [(-1, 0), (1, 0), (0, -1), (0, 1)] + +bishopPattern :: [(Int, Int)] +bishopPattern = [(-1, -1), (-1, 1), (1, -1), (1, 1)] + +queenPattern :: [(Int, Int)] +queenPattern = rookPattern ++ bishopPattern + +knightPattern :: [(Int, Int)] +knightPattern = [(-2, -1), (-1, -2), (1, -2), (2, -1), (-2, 1), (-1, 2), (1, 2), (2, 1)] + +isSquareThreatened :: Board -> Color -> Coordinates -> Bool +isSquareThreatened board opponentPlayer coords = knightsThreaten || pawnsThreaten || otherPiecesThreaten || kingsThreaten || rookOrQueenThreatens || bishopOrQueenThreatens + where knightSquares = map (sumSquares coords) knightPattern + knightsThreaten = any isOpponentKnight knightSquares + isOpponentKnight square = case getPiece board square of + Just (Piece player Knight) -> player == opponentPlayer + _ -> False + pawnsThreaten = any isOpponentPawn $ map (sumSquares coords) pawnSquares + pawnSquares = case opponentPlayer of + White -> [(1, -1), (1, 1)] + Black -> [(-1, -1), (-1, 1)] + isOpponentPawn square = case getPiece board square of + Just (Piece player Pawn) -> player == opponentPlayer + _ -> False + otherPiecesThreaten = False + kingSquares = map (sumSquares coords) queenPattern + kingsThreaten = any isOpponentKing kingSquares + isOpponentKing square = case getPiece board square of + Just (Piece player King) -> player == opponentPlayer + _ -> False + potentialOpponentRookQueenPieces = mapMaybe (firstPieceInSquareList board . iterateDirectionInsideBoard coords) rookPattern + rookOrQueenThreatens = any isOpponentRookOrQueen potentialOpponentRookQueenPieces + isOpponentRookOrQueen (Piece color piecetype) = color == opponentPlayer && piecetype `elem` [Rook, Queen] + potentialOpponentBishopQueenPieces = mapMaybe (firstPieceInSquareList board . iterateDirectionInsideBoard coords) bishopPattern + bishopOrQueenThreatens = any isOpponentBishopOrQueen potentialOpponentBishopQueenPieces + isOpponentBishopOrQueen (Piece color piecetype) = color == opponentPlayer && piecetype `elem` [Bishop, Queen] + +isCheck :: Board -> Color -> Bool +isCheck board player = isSquareThreatened board (opponent player) kingSquare + where kingSquare = getKingSquare board player + +getSquaresWithOwner :: Board -> Color -> [Coordinates] +getSquaresWithOwner board player = filter (isPlayerSquare board player) (indices board) + +getSquaresWithPieces :: Board -> PieceType -> [Coordinates] +getSquaresWithPieces board piecetype = filter (isPieceSquare board piecetype) (indices board) + +isPieceSquare :: Board -> PieceType -> Coordinates -> Bool +isPieceSquare board piecetype square = case getPiece board square of + Just (Piece _ t) -> t == piecetype + Nothing -> False + +getPlayerPieces :: Board -> Color -> [PieceType] +getPlayerPieces board player = map (typeFromPiece . fromJust . getPiece board) (getSquaresWithOwner board player) + where typeFromPiece (Piece _ pieceType) = pieceType + +getSquareColor :: Coordinates -> Color +getSquareColor (row, column) | (row + column) `mod` 2 == 0 = White + | otherwise = Black diff --git a/src/Chess/Internal/FEN.hs b/src/Chess/Internal/FEN.hs new file mode 100644 --- /dev/null +++ b/src/Chess/Internal/FEN.hs @@ -0,0 +1,83 @@ +module Chess.Internal.FEN where + +import Chess.Internal.Move +import Chess.Internal.Board +import Chess.Internal.Piece +import Data.List +import Data.Char +import Data.Maybe + +writeBoard :: Board -> String +writeBoard = intercalate "/" . lines . concatMap emptyToNum . group . printBoardCompact + where emptyToNum str@(' ':_) = show $ length str + emptyToNum str = str + +writePlayer :: Color -> String +writePlayer White = "w" +writePlayer Black = "b" + +writeCastlings :: [CastlingType] -> [CastlingType] -> String +writeCastlings [] [] = "-" +writeCastlings white black = sort (map (castlingToChar White) white ++ map (castlingToChar Black) black) + where castlingToChar White Long = 'Q' + castlingToChar White Short = 'K' + castlingToChar Black Long = 'q' + castlingToChar Black Short = 'k' + +writeEnPassant :: Maybe Coordinates -> String +writeEnPassant Nothing = "-" +writeEnPassant (Just coordinate) = printCoordinate coordinate + +readBoard :: String -> Maybe Board +readBoard str | length parts /= 8 = Nothing + | otherwise = parseBoardCompact $ unlines parts + where numToEmpty x | isNumber x = replicate (digitToInt x) ' ' + | otherwise = [x] + parts = split (== '/') $ concatMap numToEmpty str + +readPlayer :: String -> Maybe Color +readPlayer "w" = Just White +readPlayer "b" = Just Black +readPlayer _ = Nothing + +readCastlings :: String -> Maybe ([CastlingType], [CastlingType]) +readCastlings "-" = Just ([], []) +readCastlings str = case readCastlings' str of + Nothing -> Nothing + Just (whites, blacks) -> if castlingCountValid whites && castlingCountValid blacks then Just (whites, blacks) + else Nothing + where castlingCountValid castlings = sort (nub castlings) == sort castlings + +readCastlings' :: String -> Maybe ([CastlingType], [CastlingType]) +readCastlings' str = do whiteCastlings <- mapM toCastling whites + blackCastlings <- mapM toCastling blacks + return (whiteCastlings, blackCastlings) + where whites = filter isUpper str + blacks = filter isLower str + toCastling 'q' = Just Long + toCastling 'k' = Just Short + toCastling 'Q' = Just Long + toCastling 'K' = Just Short + toCastling _ = Nothing + +readEnPassant :: String -> Maybe (Maybe Coordinates) +readEnPassant "-" = Just Nothing +readEnPassant str = case parseCoordinate str of + Nothing -> Nothing + coordinate -> Just coordinate + +readNumberWithLimit :: (Ord a, Read a) => a -> String -> Maybe a +readNumberWithLimit limit str = case readMaybe str of + Nothing -> Nothing + Just number -> if number >= limit + then Just number + else Nothing + +readMaybe :: Read a => String -> Maybe a +readMaybe = fmap fst . listToMaybe . filter (null . snd) . reads + +split :: (Char -> Bool) -> String -> [String] +split p str = case dropWhile p str of + "" -> [] + str' -> w : split p str'' + where (w, str'') = break p str' diff --git a/src/Chess/Internal/Game.hs b/src/Chess/Internal/Game.hs new file mode 100644 --- /dev/null +++ b/src/Chess/Internal/Game.hs @@ -0,0 +1,107 @@ +module Chess.Internal.Game (applyMove, isCheckmate, isStalemate, isInsufficientMaterial, + isDraw, getWinner) where + +import Data.List +import Chess.Internal.Piece +import Chess.Internal.Move +import Chess.Internal.Board +import Data.Maybe + +applyMove :: GameState -> Move -> Either MoveError GameState +applyMove game move = case moveError of + Just mError -> Left mError + Nothing -> Right newGame + where moveError = isMoveError game move + newGame = State (updateBoard game move) + (updatePlayer game) + (updateWhiteCastlings game move) + (updateBlackCastlings game move) + (updateEnPassantSquare move) + (updateHalfMoveClock game move) + (updateMoveNumber game) + +updateBoard :: GameState -> Move -> Board +updateBoard game move = fromJust $ boardAfterMove (stateBoard game) move + +updatePlayer :: GameState -> Color +updatePlayer game = opponent (currentPlayer game) + +updateWhiteCastlings :: GameState -> Move -> [CastlingType] +updateWhiteCastlings (State _ _ castlings _ _ _ _) (Movement (Piece White Rook) (7, 0) _) = delete Long castlings +updateWhiteCastlings (State _ _ castlings _ _ _ _) (Movement (Piece White Rook) (7, 7) _) = delete Short castlings +updateWhiteCastlings (State _ _ castlings _ _ _ _) (Capture (Piece White Rook) (7, 0) _) = delete Long castlings +updateWhiteCastlings (State _ _ castlings _ _ _ _) (Capture (Piece White Rook) (7, 7) _) = delete Short castlings +updateWhiteCastlings (State _ _ castlings _ _ _ _) (Capture (Piece Black _) _ (7, 0)) = delete Long castlings +updateWhiteCastlings (State _ _ castlings _ _ _ _) (Capture (Piece Black _) _ (7, 7)) = delete Short castlings +updateWhiteCastlings (State _ _ castlings _ _ _ _) (Promotion (Piece Black _) _ (7, 0) _) = delete Long castlings +updateWhiteCastlings (State _ _ castlings _ _ _ _) (Promotion (Piece Black _) _ (7, 7) _) = delete Short castlings +updateWhiteCastlings (State _ _ castlings _ _ _ _) move = updateCastlings White castlings move + +updateBlackCastlings :: GameState -> Move -> [CastlingType] +updateBlackCastlings (State _ _ _ castlings _ _ _) (Movement (Piece Black Rook) (0, 0) _) = delete Long castlings +updateBlackCastlings (State _ _ _ castlings _ _ _) (Movement (Piece Black Rook) (0, 7) _) = delete Short castlings +updateBlackCastlings (State _ _ _ castlings _ _ _) (Capture (Piece Black Rook) (0, 0) _) = delete Long castlings +updateBlackCastlings (State _ _ _ castlings _ _ _) (Capture (Piece Black Rook) (0, 7) _) = delete Short castlings +updateBlackCastlings (State _ _ _ castlings _ _ _) (Capture (Piece White _) _ (0, 0)) = delete Long castlings +updateBlackCastlings (State _ _ _ castlings _ _ _) (Capture (Piece White _) _ (0, 7)) = delete Short castlings +updateBlackCastlings (State _ _ _ castlings _ _ _) (Promotion (Piece White _) _ (0, 0) _) = delete Long castlings +updateBlackCastlings (State _ _ _ castlings _ _ _) (Promotion (Piece White _) _ (0, 7) _) = delete Short castlings +updateBlackCastlings (State _ _ _ castlings _ _ _) move = updateCastlings Black castlings move + +updateCastlings :: Color -> [CastlingType] -> Move -> [CastlingType] +updateCastlings player _ (Castling movePlayer _) | player == movePlayer = [] +updateCastlings player _ (Movement (Piece movePlayer King) _ _) | player == movePlayer = [] +updateCastlings player _ (Capture (Piece movePlayer King) _ _) | player == movePlayer = [] +updateCastlings _ castlings _ = castlings + +updateEnPassantSquare :: Move -> Maybe Coordinates +updateEnPassantSquare (PawnDoubleMove (Piece White Pawn) _ (row, col)) = Just (row + 1, col) +updateEnPassantSquare (PawnDoubleMove (Piece Black Pawn) _ (row, col)) = Just (row - 1, col) +updateEnPassantSquare _ = Nothing + +updateHalfMoveClock :: GameState -> Move -> Integer +updateHalfMoveClock _ Capture{} = 0 +updateHalfMoveClock _ (Movement (Piece _ Pawn) _ _) = 0 +updateHalfMoveClock _ (PawnDoubleMove (Piece _ Pawn) _ _) = 0 +updateHalfMoveClock _ (Promotion (Piece _ Pawn) _ _ _) = 0 +updateHalfMoveClock (State _ _ _ _ _ number _) _ = number + 1 + +updateMoveNumber :: GameState -> Integer +updateMoveNumber (State _ White _ _ _ _ number) = number +updateMoveNumber (State _ Black _ _ _ _ number) = number + 1 + +isCheckmate :: GameState -> Bool +isCheckmate game@(State board player _ _ _ _ _) = null (generateAllMoves game) && isCheck board player + +isStalemate :: GameState -> Bool +isStalemate game@(State board player _ _ _ _ _) = null (generateAllMoves game) && not (isCheck board player) + +isInsufficientMaterial :: GameState -> Bool +isInsufficientMaterial game = isInsufficientMaterialByPieces whitePieces blackPieces || isInsufficientMaterialWithBishops board whitePieces blackPieces + where board = stateBoard game + whitePieces = delete King $ getPlayerPieces board White + blackPieces = delete King $ getPlayerPieces board Black + +isInsufficientMaterialByPieces :: [PieceType] -> [PieceType] -> Bool +isInsufficientMaterialByPieces [] [] = True +isInsufficientMaterialByPieces [Bishop] [] = True +isInsufficientMaterialByPieces [Knight] [] = True +isInsufficientMaterialByPieces [] [Bishop] = True +isInsufficientMaterialByPieces [] [Knight] = True +isInsufficientMaterialByPieces _ _ = False + +isInsufficientMaterialWithBishops :: Board -> [PieceType] -> [PieceType] -> Bool +isInsufficientMaterialWithBishops _ white black | not (onlyBishops white && onlyBishops black) = False + where onlyBishops pieces = not (any (/= Bishop) pieces) +isInsufficientMaterialWithBishops board _ _ = bishopsOnWhite /= bishopsOnBlack + where whiteSquaresWithBishops = filter (\x -> getSquareColor x == White) $ getSquaresWithPieces board Bishop + blackSquaresWithBishops = filter (\x -> getSquareColor x == Black) $ getSquaresWithPieces board Bishop + bishopsOnWhite = not (null whiteSquaresWithBishops) + bishopsOnBlack = not (null blackSquaresWithBishops) + +isDraw :: GameState -> Bool +isDraw game = isStalemate game || isInsufficientMaterial game + +getWinner :: GameState -> Maybe Color +getWinner game | isCheckmate game = Just $ opponent $ currentPlayer game + | otherwise = Nothing diff --git a/src/Chess/Internal/Move.hs b/src/Chess/Internal/Move.hs new file mode 100644 --- /dev/null +++ b/src/Chess/Internal/Move.hs @@ -0,0 +1,254 @@ +module Chess.Internal.Move (GameState(..), Move(..), CastlingType(..), + MoveError(..), isRightPlayerMove, + isMoveError, initialState, + isCorrectStartPiece, areCoordinatesValid, + generateAllRookMoves, iterateMovementSquares, + iterateDirection, generateAllBishopMoves, + generateAllQueenMoves, generateAllKnightMoves, + generateAllKingMoves, generateAllPawnMoves, + generateAllPotentialMoves, boardAfterMove, + generateAllMoves) where + +import Chess.Internal.Piece +import Chess.Internal.Board +import Data.Maybe + +data GameState = State { + stateBoard :: Board + , currentPlayer :: Color + , whiteCastlingsPossible :: [CastlingType] + , blackCastlingsPossible :: [CastlingType] + , enPassantSquare :: Maybe Coordinates + , halfmoveClock :: Integer + , moveNumber :: Integer + } deriving (Eq, Show) + +data Move = Movement Piece Coordinates Coordinates + | Capture Piece Coordinates Coordinates + | Castling Color CastlingType + | EnPassant Piece Coordinates Coordinates + | Promotion Piece Coordinates Coordinates PieceType + | PawnDoubleMove Piece Coordinates Coordinates + deriving (Show, Eq) + +data CastlingType = Short | Long + deriving (Show, Eq, Ord) + +data MoveError = WrongPlayer | WrongPiece | InvalidMove | InCheck | InvalidCoordinates + deriving (Show, Eq) + +initialState :: GameState +initialState = State initialBoard White [Short, Long] [Short, Long] Nothing 0 1 + +generateAllMoves :: GameState -> [Move] +generateAllMoves game = filter isLegalMove $ generateAllPotentialMoves game + where isLegalMove move = isNothing (isMoveError game move) + +isInCheckAfterMove :: GameState -> Move -> Bool +isInCheckAfterMove game move = case newBoard of + Nothing -> False + Just b -> isCheck b (currentPlayer game) + where board = stateBoard game + newBoard = boardAfterMove board move + +isCorrectPiece :: GameState -> Move -> Bool +isCorrectPiece (State board _ _ _ _ _ _) (Movement piece start _) = isCorrectStartPiece board piece start +isCorrectPiece (State board _ _ _ _ _ _) (Capture piece start _) = isCorrectStartPiece board piece start +isCorrectPiece (State board _ _ _ _ _ _) (EnPassant piece start _) = isCorrectStartPiece board piece start +isCorrectPiece (State board _ _ _ _ _ _) (Promotion piece start _ _) = isCorrectStartPiece board piece start +isCorrectPiece (State board _ _ _ _ _ _) (PawnDoubleMove piece start _) = isCorrectStartPiece board piece start +isCorrectPiece _ (Castling _ _) = True + +isMoveError :: GameState -> Move -> Maybe MoveError +isMoveError game move | not (isCorrectPlayer game move) = Just WrongPlayer + | not (isCorrectPiece game move) = Just WrongPiece + | not (isCorrectBoardMove game move) = Just InvalidCoordinates + | isInCheckAfterMove game move = Just InCheck + | move `notElem` generateAllPotentialMoves game = Just InvalidMove + | otherwise = Nothing + +isCorrectBoardMove :: GameState -> Move -> Bool +isCorrectBoardMove game move = isJust (boardAfterMove (stateBoard game) move) + +isCorrectStartPiece :: Board -> Piece -> Coordinates -> Bool +isCorrectStartPiece board (Piece color pieceType) coordinates + = case boardPiece of + Nothing -> False + Just (Piece color' pieceType') -> color == color' && pieceType == pieceType' + where boardPiece = getPiece board coordinates + +isCorrectPlayer :: GameState -> Move -> Bool +isCorrectPlayer game = isRightPlayerMove (currentPlayer game) + +isRightPlayerMove :: Color -> Move -> Bool +isRightPlayerMove player (Movement (Piece color _) _ _) = player == color +isRightPlayerMove player (Capture (Piece color _) _ _) = player == color +isRightPlayerMove player (Castling color _) = player == color +isRightPlayerMove player (EnPassant (Piece color _) _ _) = player == color +isRightPlayerMove player (Promotion (Piece color _) _ _ _) = player == color +isRightPlayerMove player (PawnDoubleMove (Piece color _) _ _) = player == color + +areCoordinatesValid :: Coordinates -> Coordinates -> Maybe MoveError +areCoordinatesValid start end | start == end = Just InvalidCoordinates + | not (isInsideBoard start) || not (isInsideBoard end) = Just InvalidCoordinates + | otherwise = Nothing + +generateAllRookMoves :: GameState -> Coordinates -> [Move] +generateAllRookMoves game coords = patternMoves game coords rookPattern + +generateAllBishopMoves :: GameState -> Coordinates -> [Move] +generateAllBishopMoves game coords = patternMoves game coords bishopPattern + +generateAllQueenMoves :: GameState -> Coordinates -> [Move] +generateAllQueenMoves game coords = patternMoves game coords queenPattern + +generateAllKnightMoves :: GameState -> Coordinates -> [Move] +generateAllKnightMoves game coords = map (Movement piece coords) emptySquares + ++ map (Capture piece coords) opponentSquares + where squares = filter isInsideBoard [sumSquares coords jump | jump <- knightPattern] + board = stateBoard game + emptySquares = filter (isEmpty board) squares + piece@(Piece player _) = fromJust $ getPiece board coords + opponentSquares = filter (\square -> isOpponentSquare board square player) squares + +generateAllKingMoves :: GameState -> Coordinates -> [Move] +generateAllKingMoves game coords = map (Movement piece coords) moveSquares + ++ map (Capture piece coords) captureSquares + ++ kingCastlingMoves game coords + where board = stateBoard game + piece = fromJust $ getPiece board coords + moveSquares = kingMoveSquares game coords + captureSquares = kingCaptureSquares game coords + +generateAllPawnMoves :: GameState -> Coordinates -> [Move] +generateAllPawnMoves game coords@(row, _) = move ++ doubleMove ++ captures ++ promotions ++ enpassant + where board = stateBoard game + (Piece player _) = fromJust $ getPiece board coords + isOnStartRow = case player of + White -> row == 6 + Black -> row == 1 + isNextToPromotionRow = case player of + White -> row == 1 + Black -> row == 6 + moveDirection = case player of + White -> -1 + Black -> 1 + moveSquare = sumSquares coords (moveDirection, 0) + doubleMoveSquare = sumSquares coords (moveDirection * 2, 0) + captureSquares = map (sumSquares coords) [(moveDirection, -1), (moveDirection, 1)] + move = [Movement (Piece player Pawn) coords moveSquare | isEmpty board moveSquare && not isNextToPromotionRow] + doubleMove = [PawnDoubleMove (Piece player Pawn) coords doubleMoveSquare | isEmpty board moveSquare && isEmpty board doubleMoveSquare && isOnStartRow] + capture square = [Capture (Piece player Pawn) coords square | isOpponentSquare board square player && not isNextToPromotionRow] + captures = concatMap capture captureSquares + promotionCapture square = if isOpponentSquare board square player + then map (Promotion (Piece player Pawn) coords square) [Rook, Bishop, Knight, Queen] + else [] + promotionMove square = if isEmpty board square + then map (Promotion (Piece player Pawn) coords square) [Rook, Bishop, Knight, Queen] + else [] + promotions = if isNextToPromotionRow + then concatMap promotionCapture captureSquares ++ promotionMove moveSquare + else [] + epSquare = enPassantSquare game + enpassant = case epSquare of + Just square -> [EnPassant (Piece player Pawn) coords square | square `elem` captureSquares] + Nothing -> [] + +kingMoveSquares :: GameState -> Coordinates -> [Coordinates] +kingMoveSquares game start = emptySquares + where allSquares = map (sumSquares start) queenPattern + board = stateBoard game + emptySquares = filter (isEmpty board) $ filter isInsideBoard allSquares + +kingCaptureSquares :: GameState -> Coordinates -> [Coordinates] +kingCaptureSquares game start = opponentSquares + where allSquares = map (sumSquares start) queenPattern + board = stateBoard game + (Piece player _) = fromJust $ getPiece board start + opponentSquares = filter (\square -> isOpponentSquare board square player) $ filter isInsideBoard allSquares + +kingCastlingMoves :: GameState -> Coordinates -> [Move] +kingCastlingMoves game coords = map (Castling player) $ filter (isCastlingPossible game player) [Long, Short] + where board = stateBoard game + (Piece player _) = fromJust $ getPiece board coords + +isCastlingPossible :: GameState -> Color -> CastlingType -> Bool +isCastlingPossible game player castling = castling `elem` possibleCastlings player && all (isEmpty board) squares && traverseSquaresNotThreatened + where squares = castlingSquares player castling + board = stateBoard game + possibleCastlings White = whiteCastlingsPossible game + possibleCastlings Black = blackCastlingsPossible game + kingSquare = if player == White then (7, 4) else (0, 4) + traverseSquaresNotThreatened = not $ any (isSquareThreatened board (opponent player)) (kingSquare : squares) + +castlingSquares :: Color -> CastlingType -> [Coordinates] +castlingSquares White Long = [(7, 1), (7, 2), (7, 3)] +castlingSquares White Short = [(7, 5), (7, 6)] +castlingSquares Black Long = [(0, 1), (0, 2), (0, 3)] +castlingSquares Black Short = [(0, 5), (0, 6)] + +patternMoves :: GameState -> Coordinates -> [(Int, Int)] -> [Move] +patternMoves game start pattern + = concat [movementsInDirection game start dir | dir <- pattern] + ++ concat [capturesInDirection game start dir | dir <- pattern] + +movementsInDirection :: GameState -> Coordinates -> (Int, Int) -> [Move] +movementsInDirection game start direction = map (Movement piece start) squares + where piece = fromJust $ getPiece (stateBoard game) start + squares = iterateMovementSquares game start direction + +capturesInDirection :: GameState -> Coordinates -> (Int, Int) -> [Move] +capturesInDirection game start direction = map (Capture piece start) squares + where piece = fromJust $ getPiece (stateBoard game) start + squares = iterateCaptureSquares game start direction + +iterateMovementSquares :: GameState -> Coordinates -> (Int, Int) -> [Coordinates] +iterateMovementSquares = iterateDirection isEmptySquare + where isEmptySquare game' = isEmpty (stateBoard game') + +iterateCaptureSquares :: GameState -> Coordinates -> (Int, Int) -> [Coordinates] +iterateCaptureSquares game start direction = case squaresNotEmpty of + [] -> [] + (first:_) -> [first | isOpponentSquare board first player] + where squares = iterateDirectionInsideBoard start direction + board = stateBoard game + (Piece player _) = fromJust $ getPiece board start + squaresNotEmpty = dropWhile (isEmpty board) squares + +iterateDirection :: (GameState -> Coordinates -> Bool) -> GameState -> Coordinates -> (Int, Int) -> [Coordinates] +iterateDirection condition game start direction = takeWhile (condition game) squares + where squares = iterateDirectionInsideBoard start direction + +generateAllPotentialMoves :: GameState -> [Move] +generateAllPotentialMoves game = concatMap (generateSquareMoves game) squares + where player = currentPlayer game + board = stateBoard game + squares = getSquaresWithOwner board player + +generateSquareMoves :: GameState -> Coordinates -> [Move] +generateSquareMoves game coordinates = case getPiece board coordinates of + Nothing -> [] + Just (Piece _ Pawn) -> generateAllPawnMoves game coordinates + Just (Piece _ Rook) -> generateAllRookMoves game coordinates + Just (Piece _ Bishop) -> generateAllBishopMoves game coordinates + Just (Piece _ Queen) -> generateAllQueenMoves game coordinates + Just (Piece _ King) -> generateAllKingMoves game coordinates + Just (Piece _ Knight) -> generateAllKnightMoves game coordinates + where board = stateBoard game + +boardAfterMove :: Board -> Move -> Maybe Board +boardAfterMove board (Movement _ from to) = movePiece from to board +boardAfterMove board (Capture _ from to) = movePiece from to board +boardAfterMove board (PawnDoubleMove _ from to) = movePiece from to board +boardAfterMove board (Castling White Long) = movePiece (7, 0) (7, 3) board >>= movePiece (7, 4) (7, 2) +boardAfterMove board (Castling White Short) = movePiece (7, 7) (7, 5) board >>= movePiece (7, 4) (7, 6) +boardAfterMove board (Castling Black Long) = movePiece (0, 0) (0, 3) board >>= movePiece (0, 4) (0, 2) +boardAfterMove board (Castling Black Short) = movePiece (0, 7) (0, 5) board >>= movePiece (0, 4) (0, 6) +boardAfterMove board (EnPassant (Piece player _) from to@(row, col)) = movePiece from to (removePiece board (epSquare player)) + where epSquare White = (row + 1, col) + epSquare Black = (row - 1, col) + +boardAfterMove board (Promotion (Piece player _) from to promotiontype) = + case movePiece from to board of + Just newboard -> Just $ addPiece newboard to (Piece player promotiontype) + Nothing -> Nothing diff --git a/src/Chess/Internal/Notation.hs b/src/Chess/Internal/Notation.hs new file mode 100644 --- /dev/null +++ b/src/Chess/Internal/Notation.hs @@ -0,0 +1,82 @@ +module Chess.Internal.Notation (parseMove, parseCoordinateNotation, parseCoordinateStringWithPromotion) where + +import Chess.Internal.Move +import Chess.Internal.Board +import Chess.Internal.Piece +import Data.List +import Data.Char +import Data.Attoparsec.Text +import qualified Data.Text as T +import Control.Applicative + +parseMove :: GameState -> String -> Maybe Move +parseMove = parseCoordinateNotation + +parseCoordinateNotation :: GameState -> String -> Maybe Move +parseCoordinateNotation game moveString = case parseOnly parseCoordinateStringWithPromotion (T.pack moveString) of + Left _ -> Nothing + Right (start, end, promotion) -> findMoveForCoordinates game start end promotion + +findMoveForCoordinates :: GameState -> Coordinates -> Coordinates -> Maybe PieceType -> Maybe Move +findMoveForCoordinates game start end Nothing | length moves == 1 = Just $ head moves + where moves = findMovesMatchingCoordinates game start end +findMoveForCoordinates game start end (Just promotion) = findPromotionMove start end promotion moves + where moves = findMovesMatchingCoordinates game start end +findMoveForCoordinates _ _ _ _ = Nothing + +findPromotionMove :: Coordinates -> Coordinates -> PieceType -> [Move] -> Maybe Move +findPromotionMove start end promotion = find matchPromotionMove + where matchPromotionMove (Promotion _ s e p) = s == start && e == end && p == promotion + matchPromotionMove _ = False + +findMovesMatchingCoordinates :: GameState -> Coordinates -> Coordinates -> [Move] +findMovesMatchingCoordinates game start end = filter (coordinatesMatch start end) allMoves + where allMoves = generateAllMoves game + +coordinatesMatch :: Coordinates -> Coordinates -> Move -> Bool +coordinatesMatch start end (Movement _ from to) = from == start && to == end +coordinatesMatch start end (Capture _ from to) = from == start && to == end +coordinatesMatch start end (EnPassant _ from to) = from == start && to == end +coordinatesMatch start end (PawnDoubleMove _ from to) = from == start && to == end +coordinatesMatch start end (Promotion _ from to _) = from == start && to == end +coordinatesMatch start end (Castling White Short) = start == (7, 4) && end == (7, 6) +coordinatesMatch start end (Castling White Long) = start == (7, 4) && end == (7, 2) +coordinatesMatch start end (Castling Black Short) = start == (0, 4) && end == (0, 6) +coordinatesMatch start end (Castling Black Long) = start == (0, 4) && end == (0, 2) + +parseCoordinateStringWithPromotion :: Parser (Coordinates, Coordinates, Maybe PieceType) +parseCoordinateStringWithPromotion = do (coord1, coord2) <- parseCoordinateString + promotion <- parsePromotion + endOfInput + return (coord1, coord2, promotion) + +parseCoordinateString :: Parser (Coordinates, Coordinates) +parseCoordinateString = do coord1 <- parseCoordinates + _ <- char '-' + coord2 <- parseCoordinates + return (coord1, coord2) + +parseCoordinates :: Parser Coordinates +parseCoordinates = do column <- letter + row <- digit + case parseCoordinate [toLower column, row] of + Just coordinates -> return coordinates + Nothing -> fail "Could not parse coordinate" + +parsePromotion :: Parser (Maybe PieceType) +parsePromotion = (Just <$> parsePromotionEqualSign) <|> (Just <$> parsePromotionParenthesis) <|> return Nothing + +parsePromotionEqualSign :: Parser PieceType +parsePromotionEqualSign = do _ <- char '=' + promotionChar <- satisfy (`elem` "NBRQ") + case parsePieceType promotionChar of + Just piece -> return piece + Nothing -> fail "Invalid promotion piecetype" + +parsePromotionParenthesis :: Parser PieceType +parsePromotionParenthesis = do _ <- char '(' + promotionChar <- satisfy (`elem` "NBRQ") + _ <- char ')' + case parsePieceType promotionChar of + Just piece -> return piece + Nothing -> fail "Invalid promotion piecetype" diff --git a/src/Chess/Internal/Piece.hs b/src/Chess/Internal/Piece.hs new file mode 100644 --- /dev/null +++ b/src/Chess/Internal/Piece.hs @@ -0,0 +1,36 @@ +module Chess.Internal.Piece (Piece(..), Color(..), PieceType(..), opponent, printPiece, + parsePiece, parsePieceType) where + +import Data.Char + +data Piece = Piece Color PieceType + deriving (Show, Eq) + +data Color = White | Black + deriving (Show, Eq) + +data PieceType = Pawn | Knight | Bishop | Rook | Queen | King + deriving (Show, Eq) + +opponent :: Color -> Color +opponent White = Black +opponent Black = White + +pieceChars :: [(PieceType, Char)] +pieceChars = [(Pawn, 'P'), (Knight, 'N'), (Bishop, 'B'), (Rook, 'R'), (Queen, 'Q'), (King, 'K')] + +printPiece :: Piece -> String +printPiece (Piece color pieceType) = case color of + White -> [toUpper c] + Black -> [toLower c] + where (Just c) = lookup pieceType pieceChars + +parsePiece :: Char -> Maybe Piece +parsePiece c = do + pieceType <- parsePieceType c + return (if isUpper c then Piece White pieceType else Piece Black pieceType) + +parsePieceType :: Char -> Maybe PieceType +parsePieceType c = rlookup (toUpper c) pieceChars + where rlookup x = lookup x . map swap + swap (x, y) = (y, x) diff --git a/test/HLint.hs b/test/HLint.hs new file mode 100644 --- /dev/null +++ b/test/HLint.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import Language.Haskell.HLint (hlint) +import System.Exit (exitFailure, exitSuccess) + +arguments :: [String] +arguments = + [ "src" + , "test" + ] + +main :: IO () +main = do + hints <- hlint arguments + if null hints then exitSuccess else exitFailure diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,15 @@ +import Test.Hspec +import GameTests +import NotationTests +import BoardTests +import FENTests +import MoveTests +import PieceTests + +main :: IO () +main = do gameSpec + notationSpec + boardSpec + fenSpec + moveSpec + pieceSpec