hchesslib (empty) → 0.1.0.0
raw patch · 14 files changed
+1345/−0 lines, 14 filesdep +QuickCheckdep +arraydep +attoparsecsetup-changed
Dependencies added: QuickCheck, array, attoparsec, base, containers, hchesslib, hlint, hspec, text
Files
- LICENSE +339/−0
- README.md +5/−0
- Setup.hs +2/−0
- hchesslib.cabal +66/−0
- src/Chess.hs +91/−0
- src/Chess/FEN.hs +36/−0
- src/Chess/Internal/Board.hs +214/−0
- src/Chess/Internal/FEN.hs +83/−0
- src/Chess/Internal/Game.hs +107/−0
- src/Chess/Internal/Move.hs +254/−0
- src/Chess/Internal/Notation.hs +82/−0
- src/Chess/Internal/Piece.hs +36/−0
- test/HLint.hs +15/−0
- test/Spec.hs +15/−0
+ LICENSE view
@@ -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.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ 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.++ <signature of Ty Coon>, 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.
+ README.md view
@@ -0,0 +1,5 @@+# hchesslib++[](https://travis-ci.org/nablaa/hchesslib)++hchesslib is a simple chess library for Haskell.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hchesslib.cabal view
@@ -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
+ src/Chess.hs view
@@ -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
+ src/Chess/FEN.hs view
@@ -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
+ src/Chess/Internal/Board.hs view
@@ -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
+ src/Chess/Internal/FEN.hs view
@@ -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'
+ src/Chess/Internal/Game.hs view
@@ -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
+ src/Chess/Internal/Move.hs view
@@ -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
+ src/Chess/Internal/Notation.hs view
@@ -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"
+ src/Chess/Internal/Piece.hs view
@@ -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)
+ test/HLint.hs view
@@ -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
+ test/Spec.hs view
@@ -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