chessIO 0.4.0.0 → 0.5.0.0
raw patch · 15 files changed
+1280/−1086 lines, 15 filesdep −parser-combinatorsdep ~megaparsec
Dependencies removed: parser-combinators
Dependency ranges changed: megaparsec
Files
- CHANGELOG.md +14/−0
- README.md +30/−0
- README.rst +0/−30
- app/cboard.hs +66/−45
- app/polyplay.hs +94/−85
- book/twic-9g.bin too large to diff
- chessIO.cabal +21/−18
- src/Game/Chess.hs +5/−883
- src/Game/Chess/Internal.hs +658/−0
- src/Game/Chess/PGN.hs +5/−4
- src/Game/Chess/QuadBitboard.hs +42/−3
- src/Game/Chess/SAN.hs +305/−0
- src/Game/Chess/Tree.hs +17/−0
- src/Game/Chess/UCI.hs +16/−14
- test/Perft.hs +7/−4
+ CHANGELOG.md view
@@ -0,0 +1,14 @@+# Releases++## chessIO 0.5.0.0++- Split SAN parsing code into a separate module.+- Adapt to VisualStream change in Megaparsec >= 9.+- Use Maybe to indicate that bestmove in UCI can be empty.+- instance Storable QuadBitboard++## chessIO 0.4.0.0++- Support for letting UCI engines ponder.+- Avoid a branch to further speed up move generation.+
+ README.md view
@@ -0,0 +1,30 @@+# A Haskell chess library and console UCI frontend program++`chessIO` is a Haskell library for working with chess positions and moves,+and a console frontend program (cboard) to work with UCI compatible+chess engines.++## The Library++The main module provided by the library is+[Game.Chess](https://hackage.haskell.org/package/chessIO/docs/Game-Chess.html),+which defines data types and functions for working with chess positions+and moves. It offers a fully compliant move generator and parsing for+and printing positions in [Forsyth-Edwards+Notation](https://en.wikipedia.org/wiki/Forsyth%E2%80%93Edwards_Notation)+and moves in [Algebraic+Notation](https://en.wikipedia.org/wiki/Algebraic_notation_(chess)).++Module+[Game.Chess.UCI](https://hackage.haskell.org/package/chessIO/docs/Game-Chess-UCI.html)+provides functionality to run an external process which understands the+Universal Chess Interface protocol from within Haskell.++## Console frontend for the Universal Chess Interface protocl++`cboard` is a simple console (text-mode) frontend for interacting with+chess engines (like stockfish or glaurung) which make use of the UCI+protocol.++To launch a chess engine, simply pass its executable name and arguments+to cboard. For instance, `cboard stockfish`.
− README.rst
@@ -1,30 +0,0 @@-chessIO -- A Haskell chess library and console UCI frontend program-===================================================================--chessIO is a Haskell library for working with chess positions and moves, and a-console frontend program (cboard) to work with UCI compatible chess engines.--The Library--------------The main module provided by the library is Game.Chess_, which defines-data types and functions for working with chess positions and moves.-It offers a fully compliant move generator and parsing for and printing-positions in `Forsyth-Edwards Notation`_ and moves in `Algebraic Notation`_.--Module Game.Chess.UCI_ provides functionality to run an external process-which understands the Universal Chess Interface protocol from within Haskell.--cboard -- Console frontend for the Universal Chess Interface protocl-----------------------------------------------------------------------cboard is a simple console (text-mode) frontend for interacting with chess engines-(like stockfish or glaurung) which make use of the UCI protocol.--To launch a chess engine, simply pass its executable name and arguments-to cboard. For instance, `cboard stockfish`.--.. _`Forsyth-Edwards Notation`: https://en.wikipedia.org/wiki/Forsyth%E2%80%93Edwards_Notation-.. _`Algebraic Notation`: https://en.wikipedia.org/wiki/Algebraic_notation_(chess)-.. _Game.Chess: https://hackage.haskell.org/package/chessIO/docs/Game-Chess.html-.. _Game.Chess.UCI: https://hackage.haskell.org/package/chessIO/docs/Game-Chess-UCI.html
app/cboard.hs view
@@ -1,24 +1,54 @@ module Main where import Control.Arrow ((&&&))-import Control.Concurrent-import Control.Concurrent.STM-import Control.Monad-import Control.Monad.Extra hiding (loop)-import Control.Monad.IO.Class-import Control.Monad.Random+import Control.Concurrent ( forkIO, killThread, ThreadId )+import Control.Concurrent.STM ( atomically, readTChan, TChan )+import Control.Monad ( forever, void )+import Control.Monad.Extra ( ifM, unlessM )+import Control.Monad.IO.Class ( MonadIO(..) )+import Control.Monad.Random ( evalRandIO, MonadTrans(lift) ) import Control.Monad.State.Strict-import Data.Char-import Data.IORef-import Data.List-import Data.List.Extra+ ( StateT, evalStateT, gets, modify, modify' )+import Data.Char ( toLower, toUpper )+import Data.IORef ( newIORef, readIORef, writeIORef, IORef )+import Data.List ( find, isPrefixOf )+import Data.List.Extra ( chunksOf ) import Game.Chess-import Game.Chess.Polyglot.Book (PolyglotBook, defaultBook, readPolyglotFile, bookPlies, bookPly)+ ( fromFEN, fromUCI, isDark, legalPlies, pieceAt, startpos, fromSAN, toSAN,+ unsafeToSAN, Color(Black, White),+ PieceType(King, Pawn, Knight, Bishop, Rook, Queen),+ Ply, Position, Sq(H8, A1), varToSAN )+import Game.Chess.Polyglot.Book+ ( PolyglotBook, defaultBook, readPolyglotFile, bookPlies, bookPly ) import Game.Chess.UCI-import System.Console.Haskeline hiding (catch, handle)-import System.Exit-import System.Environment-import Time.Units+ ( addPly,+ currentPosition,+ infinite,+ movetime,+ quit,+ search,+ searching,+ setPosition,+ start,+ stop,+ Engine,+ BestMove, Info(Score, PV) )+import System.Console.Haskeline+ ( defaultSettings,+ getExternalPrint,+ getInputLine,+ outputStr,+ outputStrLn,+ completeWord,+ simpleCompletion,+ runInputT,+ setComplete,+ Completion(isFinished),+ CompletionFunc,+ InputT )+import System.Exit ( ExitCode(ExitFailure), exitSuccess, exitWith )+import System.Environment ( getArgs )+import Time.Units ( ms, sec ) data S = S { engine :: Engine@@ -77,10 +107,12 @@ pl <- liftIO . evalRandIO $ r addPly e pl (bmc, _) <- search e [movetime (ms 100)]- liftIO $ do- (bm, _) <- atomically . readTChan $ bmc- addPly e bm- midgame+ bm <- liftIO . atomically . readTChan $ bmc+ case bm of+ Just (bm', _) -> do+ addPly e bm'+ midgame+ Nothing -> outputBoard Nothing -> outputBoard outputBoard :: InputT (StateT S IO) ()@@ -125,12 +157,14 @@ info <- atomically . readTChan $ ic case (find isScore &&& find isPV) info of (Just (Score s Nothing), Just (PV pv)) ->- externalPrint $ show s <> ": " <> varToString pos pv+ externalPrint $ show s <> ": " <> varToSAN pos pv _ -> pure () tid <- liftIO . forkIO $ do- (bm, _) <- atomically . readTChan $ bmc+ bm <- atomically . readTChan $ bmc killThread itid- externalPrint $ "Best move: " <> toSAN pos bm+ case bm of+ Just (bm', _) -> externalPrint $ "Best move: " <> toSAN pos bm'+ Nothing -> pure () lift $ modify' $ \s -> s { mover = Just tid } loop | "stop" == input -> do@@ -174,22 +208,6 @@ tid <- liftIO . forkIO $ doBestMove externalPrint hr bmc e lift $ modify' $ \s -> s { mover = Just tid } -varToString :: Position -> [Ply] -> String-varToString _ [] = ""-varToString pos plies- | color pos == Black && length plies == 1- = show (moveNumber pos) <> "..." <> toSAN pos (head plies)- | color pos == Black- = show (moveNumber pos) <> "..." <> toSAN pos (head plies) <> " " <> fromWhite (doPly pos (head plies)) (tail plies)- | otherwise- = fromWhite pos plies- where- fromWhite pos' = unwords . concat- . zipWith f [moveNumber pos' ..] . chunksOf 2 . snd- . mapAccumL (curry (uncurry doPly &&& uncurry toSAN)) pos'- f n (x:xs) = (show n <> "." <> x):xs- f _ [] = []- parseMove :: Position -> String -> Either String Ply parseMove pos s = case fromUCI pos s of Just m -> pure m@@ -217,16 +235,19 @@ doBestMove :: (String -> IO ()) -> IORef (Maybe Ply)- -> TChan (Ply, Maybe Ply)+ -> TChan BestMove -> Engine -> IO () doBestMove externalPrint hintRef bmc e = do- (bm, pndr) <- atomically . readTChan $ bmc- pos <- currentPosition e- externalPrint $ "< " <> toSAN pos bm- addPly e bm- currentPosition e >>= printBoard externalPrint- writeIORef hintRef pndr+ bm <- atomically . readTChan $ bmc+ case bm of+ Just (bm', pndr) -> do+ pos <- currentPosition e+ externalPrint $ "< " <> toSAN pos bm'+ addPly e bm'+ currentPosition e >>= printBoard externalPrint+ writeIORef hintRef pndr+ Nothing -> pure () printPV :: (String -> IO ()) -> TChan [Info] -> IO () printPV externalPrint ic = forever $ do
app/polyplay.hs view
@@ -4,7 +4,6 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Random-import Data.Maybe (isJust, maybe) import Data.IORef import Data.List import Data.String@@ -17,6 +16,7 @@ import Game.Chess.Polyglot.Book import Game.Chess.UCI import Options.Applicative+import System.IO (hPutStrLn, stderr) import Time.Units data Clock = Clock !Color !NominalDiffTime !NominalDiffTime !UTCTime@@ -60,14 +60,14 @@ data Runtime = Runtime { book :: PolyglotBook , history :: (Position, [Ply])-, active :: Player Active-, passive :: Player Passive+, active :: !(Player Active)+, passive :: !(Player Passive) , clock :: !Clock } data Player s = Player Engine (Maybe s)-data Active = Searching (TChan (Ply, Maybe Ply)) (TChan [Info])-data Passive = Pondering Ply (TChan (Ply, Maybe Ply)) (TChan [Info])+data Active = Searching (TChan BestMove) (TChan [Info])+data Passive = Pondering Ply (TChan BestMove) (TChan [Info]) opts :: Parser Polyplay opts = Polyplay <$> option auto (long "hash" <> metavar "MB" <> value 1024)@@ -84,8 +84,8 @@ run :: (Runtime -> IO ()) -> Polyplay -> IO () run f Polyplay{..} = do book <- readPolyglotFile bookFile- start engineProgram engineArgs >>= \case- Nothing -> putStrLn "Engine failed to start."+ start' (sec 30) putLog engineProgram engineArgs >>= \case+ Nothing -> putLog "Engine failed to start." Just e1 -> do _ <- setOptionSpinButton "Hash" hashSize e1 _ <- setOptionSpinButton "Threads" threadCount e1@@ -93,8 +93,8 @@ Just fp -> void $ setOptionString "SyzygyPath" (fromString fp) e1 Nothing -> pure () isready e1- start engineProgram engineArgs >>= \case- Nothing -> putStrLn "Engine failed to start secondary engine."+ start' (sec 30) putLog engineProgram engineArgs >>= \case+ Nothing -> putLog "Engine failed to start secondary engine." Just e2 -> do _ <- setOptionSpinButton "Hash" hashSize e2 _ <- setOptionSpinButton "Threads" threadCount e2@@ -120,88 +120,94 @@ putDoc (gameDoc breadthFirst g) pure () -done :: Position -> Bool-done = null . legalPlies+checkmate, stalemate, draw :: Position -> Bool+checkmate pos = null (legalPlies pos) && inCheck (color pos) pos+stalemate pos = null (legalPlies pos) && not (inCheck (color pos) pos)+draw pos = insufficientMaterial pos || stalemate pos play :: Runtime -> IO ([Ply], Outcome) play rt@Runtime{book, history, active, passive, clock} = do- let pos = uncurry (foldl' doPly) history+ let pos = uncurry (foldl' unsafeDoPly) history+ let poss = snd $ uncurry (mapAccumL (\p pl -> (unsafeDoPly p pl, p))) history clockRemaining clock (color pos) >>= \case Nothing -> pure (snd history, Win . opponent . color $ pos) Just _ ->- if done pos- then pure (snd history, Win . opponent . color $ pos)- else- case bookPly book pos of- Just r -> do- pl <- evalRandIO r- let history' = fmap (<> [pl]) history- p2 <- case active of- Player e1 Nothing -> do- addPly e1 pl- pure $ Player e1 Nothing- Player e1 (Just (Searching bmc ic)) -> do- stop e1- atomically . readTChan $ bmc- addPly e1 pl- pure $ Player e1 Nothing- p1 <- case passive of- Player e2 Nothing -> do- addPly e2 pl- pure $ Player e2 Nothing- Player e2 (Just (Pondering _ bmc ic)) -> do- stop e2- atomically . readTChan $ bmc- replacePly e2 pl- pure $ Player e2 Nothing- clock' <- flipClock clock- putStrLn $ "Book: " <> toSAN pos pl- play (rt { history = history', active = p1, passive = p2, clock = clock' })- Nothing -> do- case active of- Player e1 Nothing -> do- let (Just wt, Just bt) = clockTimes clock- (bmc, ic) <- search e1 [timeleft White wt, timeleft Black bt]- play $ rt { active = Player e1 (Just (Searching bmc ic)) }- Player e1 (Just (Searching bmc ic)) -> do- sc <- newIORef Nothing- itid <- liftIO . forkIO . forever $ do- i <- atomically . readTChan $ ic- case find isScore i of- Just (Score s _) -> writeIORef sc (Just s)- _ -> pure ()- (bm, pndr) <- atomically . readTChan $ bmc- killThread itid- sc <- readIORef sc- let history' = fmap (<> [bm]) history- clock' <- flipClock clock- addPly e1 bm- p1 <- case passive of- Player e2 Nothing -> do- addPly e2 bm- putStrLn $ "Move: " <> toSAN pos bm <> " (" <> show sc <> ")"- pure $ Player e2 Nothing- Player e2 (Just (Pondering pndr bmc ic)) -> do- if bm == pndr- then do- ponderhit e2- putStrLn $ "Ponderhit: " <> toSAN pos bm <> " (" <> show sc <> ")"- pure $ Player e2 (Just (Searching bmc ic))- else do- stop e2- atomically . readTChan $ bmc- replacePly e2 bm- putStrLn $ "Pondermiss: " <> toSAN pos bm <> " (" <> show sc <> ")"- pure $ Player e2 Nothing- p2 <- case pndr of- Just pndr -> do- addPly e1 pndr- let (Just wt, Just bt) = clockTimes clock'- (bmc, ic) <- search e1 [ponder, timeleft White wt, timeleft Black bt]- pure $ Player e1 (Just (Pondering pndr bmc ic))- Nothing -> - pure $ Player e1 Nothing- play $ rt { history = history', active = p1, passive = p2, clock = clock' }+ if | draw pos -> pure (snd history, Draw)+ | checkmate pos -> pure (snd history, Win . opponent . color $ pos)+ | Just (n, _) <- repetitions poss+ , n >= 3 -> pure (snd history, Draw)+ | otherwise -> case bookPly book pos of+ Just r -> do+ pl <- evalRandIO r+ let history' = fmap (<> [pl]) history+ p2 <- case active of+ Player e1 Nothing -> do+ addPly e1 pl+ pure $ Player e1 Nothing+ Player e1 (Just (Searching bmc _ic)) -> do+ stop e1+ void . atomically . readTChan $ bmc+ addPly e1 pl+ pure $ Player e1 Nothing+ p1 <- case passive of+ Player e2 Nothing -> do+ addPly e2 pl+ pure $ Player e2 Nothing+ Player e2 (Just (Pondering _ bmc _ic)) -> do+ stop e2+ void . atomically . readTChan $ bmc+ replacePly e2 pl+ pure $ Player e2 Nothing+ clock' <- flipClock clock+ putLog $ "Book: " <> toSAN pos pl+ play (rt { history = history', active = p1, passive = p2, clock = clock' })+ Nothing -> do+ case active of+ Player e1 Nothing -> do+ let (Just wt, Just bt) = clockTimes clock+ (bmc, ic) <- search e1 [timeleft White wt, timeleft Black bt]+ play $ rt { active = Player e1 (Just (Searching bmc ic)) }+ Player e1 (Just (Searching bmc ic)) -> do+ sc <- newIORef Nothing+ itid <- liftIO . forkIO . forever $ do+ i <- atomically . readTChan $ ic+ case find isScore i of+ Just (Score s _) -> writeIORef sc (Just s)+ _ -> pure ()+ mbm <- atomically . readTChan $ bmc+ killThread itid+ sc <- readIORef sc+ case mbm of+ Just (bm, pndr) -> do+ let history' = fmap (<> [bm]) history+ clock' <- flipClock clock+ addPly e1 bm+ p1 <- case passive of+ Player e2 Nothing -> do+ addPly e2 bm+ putLog $ "Move: " <> toSAN pos bm <> " (" <> show sc <> ")"+ pure $ Player e2 Nothing+ Player e2 (Just (Pondering pndr bmc ic)) -> do+ if bm == pndr+ then do+ ponderhit e2+ putLog $ "Ponderhit: " <> toSAN pos bm <> " (" <> show sc <> ")"+ pure $ Player e2 (Just (Searching bmc ic))+ else do+ stop e2+ atomically . readTChan $ bmc+ replacePly e2 bm+ putLog $ "Pondermiss: " <> toSAN pos bm <> " (" <> show sc <> ")"+ pure $ Player e2 Nothing+ p2 <- case pndr of+ Just pndr -> do+ addPly e1 pndr+ let (Just wt, Just bt) = clockTimes clock'+ (bmc, ic) <- search e1 [ponder, timeleft White wt, timeleft Black bt]+ pure $ Player e1 (Just (Pondering pndr bmc ic))+ Nothing -> pure $ Player e1 Nothing+ play $ rt { history = history', active = p1, passive = p2, clock = clock' }+ Nothing -> pure (snd history, Win . opponent . color $ pos) toForest :: [Ply] -> Forest Ply toForest [] = []@@ -210,3 +216,6 @@ isScore :: Info -> Bool isScore Score{} = True isScore _ = False++putLog :: String -> IO ()+putLog = hPutStrLn stderr
book/twic-9g.bin view
file too large to diff
chessIO.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 42d3baaf01a58ef1a5dea2e87a5e4d8253721c3718f0f1a2ac8678ae0d61d446+-- hash: 3c2f1e5481309fb4c13b0565acd9d7bb18a1777df7e299c595bac1605cdc1b11 name: chessIO-version: 0.4.0.0+version: 0.5.0.0 synopsis: Basic chess library description: A simple library for generating legal chess moves. Also includes a module for communication with external processes that speak the UCI (Universal Chess Interface) protocol, a PGN parser/pretty printer, and Polyglot opening book support. On top of that, provides a console frontend program (cboard) that can be used to interactively play against UCI engines. category: Game@@ -20,7 +20,8 @@ license-file: LICENSE build-type: Simple extra-source-files:- README.rst+ README.md+ CHANGELOG.md book/twic-9g.bin source-repository head@@ -36,10 +37,13 @@ Game.Chess.QuadBitboard Game.Chess.UCI other-modules:+ Game.Chess.Internal+ Game.Chess.SAN+ Game.Chess.Tree Paths_chessIO hs-source-dirs: src- default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns+ default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns ghc-options: -Wall -O2 build-depends: MonadRandom@@ -48,10 +52,10 @@ , binary , bytestring , containers+ , extra , file-embed- , megaparsec+ , megaparsec >=9.0 , o-clock- , parser-combinators , prettyprinter , process , random@@ -67,7 +71,7 @@ Paths_chessIO hs-source-dirs: app- default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns+ default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns ghc-options: -Wall -O2 -threaded build-depends: MonadRandom@@ -80,10 +84,9 @@ , extra , file-embed , haskeline- , megaparsec+ , megaparsec >=9.0 , mtl , o-clock- , parser-combinators , prettyprinter , process , random@@ -99,7 +102,7 @@ Paths_chessIO hs-source-dirs: app- default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns+ default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns ghc-options: -Wall -O2 build-depends: MonadRandom@@ -109,10 +112,10 @@ , bytestring , chessIO , containers+ , extra , file-embed- , megaparsec+ , megaparsec >=9.0 , o-clock- , parser-combinators , prettyprinter , process , random@@ -128,7 +131,7 @@ Paths_chessIO hs-source-dirs: app- default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns+ default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns ghc-options: -Wall -O2 build-depends: MonadRandom@@ -138,11 +141,11 @@ , bytestring , chessIO , containers+ , extra , file-embed- , megaparsec+ , megaparsec >=9.0 , o-clock , optparse-applicative- , parser-combinators , prettyprinter , process , random@@ -160,7 +163,7 @@ Paths_chessIO hs-source-dirs: test- default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns+ default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N -s" build-depends: MonadRandom@@ -171,11 +174,11 @@ , chessIO , containers , directory+ , extra , file-embed- , megaparsec+ , megaparsec >=9.0 , o-clock , parallel- , parser-combinators , prettyprinter , process , random
src/Game/Chess.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE PolyKinds, FlexibleInstances, GADTs, ScopedTypeVariables #-} {-| Module : Game.Chess Description : Basic data types and functions related to the game of chess@@ -22,6 +21,7 @@ , PieceType(..), Castle(..) , Position, startpos, color, moveNumber, halfMoveClock, pieceAt, inCheck , castlingRights, canCastleKingside, canCastleQueenside+, insufficientMaterial, repetitions -- ** Converting from/to Forsyth-Edwards-Notation , fromFEN, toFEN -- ** Position tree@@ -29,7 +29,7 @@ -- * Chess moves , Ply(..) -- ** Converting from/to algebraic notation-, strictSAN, relaxedSAN, fromSAN, toSAN, unsafeToSAN, fromUCI, toUCI+, strictSAN, relaxedSAN, fromSAN, toSAN, unsafeToSAN, varToSAN, fromUCI, toUCI , fromPolyglot, toPolyglot -- ** Move generation , legalPlies@@ -39,884 +39,6 @@ , plyTree, plyForest ) where -import Control.Applicative-import Control.Applicative.Combinators-import Data.Bits-import qualified Data.ByteString as Strict (ByteString)-import qualified Data.ByteString.Lazy as Lazy (ByteString)-import Data.Char-import Data.Functor (($>))-import Data.Ix-import Data.List-import Data.Maybe-import Data.Ord (Down(..))-import Data.Proxy-import Data.String-import qualified Data.Text as Strict (Text)-import qualified Data.Text.Lazy as Lazy (Text)-import Data.Vector.Unboxed (Vector, (!))-import Data.Void-import qualified Data.Vector.Unboxed as Vector-import Data.Word-import Game.Chess.QuadBitboard (QuadBitboard)-import qualified Game.Chess.QuadBitboard as QBB-import Text.Megaparsec-import Text.Read (readMaybe)-import Data.Tree--positionTree :: Position -> Tree Position-positionTree pos = Node pos $ positionForest pos-positionForest :: Position -> Forest Position-positionForest pos = positionTree . unsafeDoPly pos <$> legalPlies pos-plyForest :: Position -> Forest Ply-plyForest pos = plyTree pos <$> legalPlies pos-plyTree :: Position -> Ply -> Tree Ply-plyTree pos ply = Node ply . plyForest $ unsafeDoPly pos ply--type Parser s = Parsec Void s--castling :: (Stream s, IsString (Tokens s))- => Position -> Parser s Ply-castling pos- | ccks && ccqs = queenside <|> kingside- | ccks = kingside- | ccqs = queenside- | otherwise = empty- where- ccks = canCastleKingside pos- ccqs = canCastleQueenside pos- kingside = chunk "O-O" $> castleMove Kingside- queenside = chunk "O-O-O" $> castleMove Queenside- castleMove Kingside | color pos == White = wKscm- | otherwise = bKscm- castleMove Queenside | color pos == White = wQscm- | otherwise = bQscm--data From = File Int- | Rank Int- | Square Int- deriving (Show)--capturing :: Position -> Ply -> Maybe PieceType-capturing pos@Position{flags} (unpack -> (_, to, _))- | (flags .&. epMask) `testBit` to = Just Pawn- | otherwise = snd <$> pieceAt pos to--isCapture :: Position -> Ply -> Bool-isCapture pos = isJust . capturing pos--data SANStatus = Check | Checkmate deriving (Eq, Read, Show)--class SANToken a where- sanPieceToken :: a -> Maybe PieceType- fileToken :: a -> Maybe Int- rankToken :: a -> Maybe Int- promotionPieceToken :: a -> Maybe PieceType- statusToken :: a -> Maybe SANStatus--sanPiece :: (Stream s, SANToken (Token s)) => Parser s PieceType-sanPiece = token sanPieceToken mempty <?> "piece"--fileP, rankP, squareP :: (Stream s, SANToken (Token s)) => Parser s Int-fileP = token fileToken mempty <?> "file"-rankP = token rankToken mempty <?> "rank"-squareP = liftA2 (\f r -> r*8+f) fileP rankP <?> "square"--promotionPiece :: (Stream s, SANToken (Token s)) => Parser s PieceType-promotionPiece = token promotionPieceToken mempty <?> "Q, R, B, N"--sanStatus :: (Stream s, SANToken (Token s)) => Parser s SANStatus-sanStatus = token statusToken mempty <?> "+, #"--instance SANToken Char where- sanPieceToken = \case- 'N' -> Just Knight- 'B' -> Just Bishop- 'R' -> Just Rook- 'Q' -> Just Queen- 'K' -> Just King- _ -> Nothing- fileToken c | c >= 'a' && c <= 'h' = Just $ ord c - ord 'a'- | otherwise = Nothing- rankToken c | c >= '1' && c <= '8' = Just $ ord c - ord '1'- | otherwise = Nothing- promotionPieceToken = \case- 'N' -> Just Knight- 'B' -> Just Bishop- 'R' -> Just Rook- 'Q' -> Just Queen- _ -> Nothing- statusToken = \case- '+' -> Just Check- '#' -> Just Checkmate- _ -> Nothing--instance SANToken Word8 where- sanPieceToken = \case- 78 -> Just Knight- 66 -> Just Bishop- 82 -> Just Rook- 81 -> Just Queen- 75 -> Just King- _ -> Nothing- rankToken c | c >= 49 && c <= 56 = Just . fromIntegral $ c - 49- | otherwise = Nothing- fileToken c | c >= 97 && c <= 104 = Just . fromIntegral $ c - 97- | otherwise = Nothing- promotionPieceToken = \case- 78 -> Just Knight- 66 -> Just Bishop- 82 -> Just Rook- 81 -> Just Queen- _ -> Nothing- statusToken = \case- 43 -> Just Check- 35 -> Just Checkmate- _ -> Nothing--strictSAN :: forall s. (Stream s, SANToken (Token s), IsString (Tokens s))- => Position -> Parser s Ply-strictSAN pos = case legalPlies pos of- [] -> fail "No legal moves in this position"- ms -> (castling pos <|> normal ms) >>= checkStatus- where- normal ms = do- p <- sanPiece <|> pure Pawn- case filter (pieceFrom p) ms of- [] -> fail $ show (color pos) <> " has no " <> show p <> " which could be moved"- ms' -> target p ms'- pieceFrom p (moveFrom -> from) = p == snd (fromJust (pieceAt pos from))- moveFrom (unpack -> (from, _, _)) = from- target p ms = coords p ms >>= \m@(unpack -> (_, to, _)) -> case p of- Pawn | lastRank to -> promoteTo m <$> promotion- _ -> pure m- coords p ms = choice $ fmap (uncurry (<$) . fmap chunk) $- sortOn (Down . chunkLength (Proxy :: Proxy s) . snd) $- (\m -> (m, sanCoords pos (p,ms) m)) <$> ms- promotion = chunk "=" *> promotionPiece- lastRank i = i >= 56 || i <= 7- checkStatus m- | inCheck (color nextPos) nextPos && null (legalPlies nextPos)- = chunk "#" $> m- | inCheck (color nextPos) nextPos- = chunk "+" $> m- | otherwise- = pure m- where- nextPos = unsafeDoPly pos m--relaxedSAN :: (Stream s, SANToken (Token s), IsString (Tokens s))- => Position -> Parser s Ply-relaxedSAN pos = (castling pos <|> normal) <* optional sanStatus where- normal = do- pc <- sanPiece <|> pure Pawn- (from, _, to) <- conv <$> location- prm <- optional $ optional (chunk "=") *> promotionPiece- case possible pc from to prm of- [m] -> pure m- [] -> fail "Illegal move"- _ -> fail "Ambiguous move"- conv (Nothing, Nothing, cap, to) = (Nothing, cap, to)- conv (Just f, Nothing, cap, to) = (Just (File f), cap, to)- conv (Nothing, Just r, cap, to) = (Just (Rank r), cap, to)- conv (Just f, Just r, cap, to) = (Just (Square (r*8+f)), cap, to)- location = try ((,Nothing,,) <$> (Just <$> fileP) <*> capture <*> squareP)- <|> try ((Nothing,,,) <$> (Just <$> rankP) <*> capture <*> squareP)- <|> try ((,,,) <$> (Just <$> fileP) <*> (Just <$> rankP)- <*> capture <*> squareP)- <|> (Nothing,Nothing,,) <$> capture <*> squareP- capture = option False $ chunk "x" $> True- ms = legalPlies pos- possible pc from to prm = filter (f from) ms where- f (Just (Square from)) (unpack -> (from', to', prm')) =- pAt from' == pc && from' == from && to' == to && prm' == prm- f (Just (File ff)) (unpack -> (from', to', prm')) =- pAt from' == pc && from' `mod` 8 == ff && to == to' && prm == prm'- f (Just (Rank fr)) (unpack -> (from', to', prm')) =- pAt from' == pc && from' `div` 8 == fr && to == to' && prm == prm'- f Nothing (unpack -> (from', to', prm')) =- pAt from' == pc && to == to' && prm == prm'- pAt = snd . fromJust . pieceAt pos--fromSAN :: (Stream s, SANToken (Token s), IsString (Tokens s))- => Position -> s -> Either String Ply-fromSAN pos s = case parse (relaxedSAN pos) "" s of- Right m -> Right m- Left err -> Left $ errorBundlePretty err--toSAN :: Position -> Ply -> String-toSAN pos m | m `elem` legalPlies pos = unsafeToSAN pos m- | otherwise = error "Game.Chess.toSAN: Illegal move"--sanCoords :: IsString s => Position -> (PieceType, [Ply]) -> Ply -> s-sanCoords pos (pc,lms) m@(unpack -> (from, to, _)) =- fromString $ source <> target- where- capture = isCapture pos m- source- | pc == Pawn && capture- = [fileChar from]- | pc == Pawn- = []- | length ms == 1- = []- | length (filter fEq ms) == 1- = [fileChar from]- | length (filter rEq ms) == 1- = [rankChar from]- | otherwise- = toCoord from- target- | capture = "x" <> toCoord to- | otherwise = toCoord to- ms = filter (isMoveTo to) lms- isMoveTo to (unpack -> (_, to', _)) = to == to'- fEq (unpack -> (from', _, _)) = from' `mod` 8 == fromFile- rEq (unpack -> (from', _, _)) = from' `div` 8 == fromRank- (fromRank, fromFile) = toRF from- fileChar i = chr $ (i `mod` 8) + ord 'a'- rankChar i = chr $ (i `div` 8) + ord '1'--unsafeToSAN :: Position -> Ply -> String-unsafeToSAN pos m@(unpack -> (from, to, promo)) =- moveStr <> status- where- moveStr = case piece of- Pawn | capture -> fileChar from : target <> promotion- | otherwise -> target <> promotion- King | color pos == White && m == wKscm -> "O-O"- | color pos == White && m == wQscm -> "O-O-O"- | color pos == Black && m == bKscm -> "O-O"- | color pos == Black && m == bQscm -> "O-O-O"- | otherwise -> 'K' : target- Knight -> 'N' : source <> target- Bishop -> 'B' : source <> target- Rook -> 'R' : source <> target- Queen -> 'Q' : source <> target- piece = fromJust $ snd <$> pieceAt pos from- capture = isCapture pos m- source- | length ms == 1 = []- | length (filter fEq ms) == 1 = [fileChar from]- | length (filter rEq ms) == 1 = [rankChar from]- | otherwise = toCoord from- target- | capture = "x" <> toCoord to- | otherwise = toCoord to- promotion = case promo of- Just Knight -> "N"- Just Bishop -> "B"- Just Rook -> "R"- Just Queen -> "Q"- _ -> ""- status | inCheck (color nextPos) nextPos && null (legalPlies nextPos)- = "#"- | inCheck (color nextPos) nextPos- = "+"- | otherwise- = ""- nextPos = unsafeDoPly pos m- ms = filter movesTo $ legalPlies pos- movesTo (unpack -> (from', to', _)) =- fmap snd (pieceAt pos from') == Just piece && to' == to- fEq (unpack -> (from', _, _)) = from' `mod` 8 == fromFile- rEq (unpack -> (from', _, _)) = from' `div` 8 == fromRank- (fromRank, fromFile) = toRF from- fileChar i = chr $ (i `mod` 8) + ord 'a'- rankChar i = chr $ (i `div` 8) + ord '1'---- | The starting position as given by the FEN string--- "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1".-startpos :: Position-startpos = fromJust $- fromFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1"--data PieceType = Pawn | Knight | Bishop | Rook | Queen | King deriving (Eq, Ix, Ord, Show)--data Color = Black | White deriving (Eq, Ix, Ord, Show)--pieceAt :: IsSquare sq => Position -> sq -> Maybe (Color, PieceType)-pieceAt Position{qbb} (toIndex -> sq) = case qbb QBB.! sq of- QBB.WhitePawn -> Just (White, Pawn)- QBB.WhiteKnight -> Just (White, Knight)- QBB.WhiteBishop -> Just (White, Bishop)- QBB.WhiteRook -> Just (White, Rook)- QBB.WhiteQueen -> Just (White, Queen)- QBB.WhiteKing -> Just (White, King)- QBB.BlackPawn -> Just (Black, Pawn)- QBB.BlackKnight -> Just (Black, Knight)- QBB.BlackBishop -> Just (Black, Bishop)- QBB.BlackRook -> Just (Black, Rook)- QBB.BlackQueen -> Just (Black, Queen)- QBB.BlackKing -> Just (Black, King)- _ -> Nothing--opponent :: Color -> Color-opponent White = Black-opponent Black = White--data Piece = Piece !Color !PieceType deriving (Eq, Show)--data Sq = A1 | B1 | C1 | D1 | E1 | F1 | G1 | H1- | A2 | B2 | C2 | D2 | E2 | F2 | G2 | H2- | A3 | B3 | C3 | D3 | E3 | F3 | G3 | H3- | A4 | B4 | C4 | D4 | E4 | F4 | G4 | H4- | A5 | B5 | C5 | D5 | E5 | F5 | G5 | H5- | A6 | B6 | C6 | D6 | E6 | F6 | G6 | H6- | A7 | B7 | C7 | D7 | E7 | F7 | G7 | H7- | A8 | B8 | C8 | D8 | E8 | F8 | G8 | H8- deriving (Bounded, Enum, Eq, Ix, Ord, Show)--class IsSquare sq where- toIndex :: sq -> Int--toRF :: IsSquare sq => sq -> (Int, Int)-toRF sq = toIndex sq `divMod` 8--toCoord :: (IsSquare sq, IsString s) => sq -> s-toCoord (toRF -> (r,f)) = fromString [chr (f + ord 'a'), chr (r + ord '1')]--instance IsSquare Sq where- toIndex = fromEnum--instance IsSquare Int where- toIndex = id--isDark :: IsSquare sq => sq -> Bool-isDark (toIndex -> sq) = (0xaa55aa55aa55aa55 :: Word64) `testBit` sq--isLight :: IsSquare sq => sq -> Bool-isLight = not . isDark--data Position = Position {- qbb :: {-# UNPACK #-} !QuadBitboard-, color :: !Color- -- ^ active color-, flags :: !Word64-, halfMoveClock :: !Int-, moveNumber :: !Int- -- ^ number of the full move-}--instance Eq Position where- a == b = qbb a == qbb b && color a == color b && flags a == flags b---- | Construct a position from Forsyth-Edwards-Notation.-fromFEN :: String -> Maybe Position-fromFEN fen- | length parts /= 6- = Nothing- | otherwise =- Position <$> Just (fromString (parts !! 0))- <*> readColor (parts !! 1)- <*> readFlags (parts !! 2) (parts !! 3)- <*> readMaybe (parts !! 4)- <*> readMaybe (parts !! 5)- where- parts = words fen- readColor "w" = Just White- readColor "b" = Just Black- readColor _ = Nothing-- readFlags cst ep = (.|.) <$> readCst cst <*> readEP ep where- readCst "-" = Just 0- readCst x = go x where- go ('K':xs) = (crwKs .|.) <$> go xs- go ('Q':xs) = (crwQs .|.) <$> go xs- go ('k':xs) = (crbKs .|.) <$> go xs- go ('q':xs) = (crbQs .|.) <$> go xs- go [] = Just 0- go _ = Nothing- readEP "-" = Just 0- readEP [f,r]- | inRange ('a','h') f && (r == '3' || r == '6')- = Just $ bit ((ord r - ord '1') * 8 + (ord f - ord 'a'))- readEP _ = Nothing---- | Convert a position to Forsyth-Edwards-Notation.-toFEN :: Position -> String-toFEN (Position bb c flgs hm mn) = unwords [- QBB.toString bb- , showColor c, showCst (flgs `clearMask` epMask), showEP (flgs .&. epMask), show hm, show mn- ]- where- showColor White = "w"- showColor Black = "b"- showCst 0 = "-"- showCst x = snd . wks . wqs . bks . bqs $ (x, "") where- wks (v, xs) | v `testMask` crwKs = (v, 'K':xs)- | otherwise = (v, xs)- wqs (v, xs) | v `testMask` crwQs = (v, 'Q':xs)- | otherwise = (v, xs)- bks (v, xs) | v `testMask` crbKs = (v, 'k':xs)- | otherwise = (v, xs)- bqs (v, xs) | v `testMask` crbQs = (v, 'q':xs)- | otherwise = (v, xs)- showEP 0 = "-"- showEP x = chr (f + ord 'a') : [chr (r + ord '1')] where- (r, f) = toRF $ bitScanForward x--occupiedBy :: Color -> QuadBitboard -> Word64-occupiedBy White = QBB.white-occupiedBy Black = QBB.black--occupied :: QuadBitboard -> Word64-occupied = QBB.occupied--foldBits :: (a -> Int -> a) -> a -> Word64 -> a-foldBits _ a 0 = a-foldBits f !a n = foldBits f (f a lsb) (n .&. (n-1)) where- !lsb = countTrailingZeros n--bitScanForward, bitScanReverse :: Word64 -> Int-bitScanForward = countTrailingZeros-bitScanReverse = (63 -) . countLeadingZeros--newtype Ply = Ply Word16 deriving (Eq)--instance Show Ply where- show = toUCI--move :: (IsSquare from, IsSquare to) => from -> to -> Ply-move (toIndex -> from) (toIndex -> to) =- Ply $ fromIntegral to .|. fromIntegral from `unsafeShiftL` 6--promoteTo :: Ply -> PieceType -> Ply-promoteTo (Ply x) = Ply . set where- set Knight = x .&. 0xfff .|. 0x1000- set Bishop = x .&. 0xfff .|. 0x2000- set Rook = x .&. 0xfff .|. 0x3000- set Queen = x .&. 0xfff .|. 0x4000- set _ = x--unpack :: Ply -> (Int, Int, Maybe PieceType)-unpack (Ply x) = ( fromIntegral ((x `unsafeShiftR` 6) .&. 0b111111)- , fromIntegral (x .&. 0b111111)- , piece)- where- !piece = case x `unsafeShiftR` 12 of- 1 -> Just Knight- 2 -> Just Bishop- 3 -> Just Rook- 4 -> Just Queen- _ -> Nothing--fromPolyglot :: Position -> Ply -> Ply-fromPolyglot pos pl@(unpack -> (from, to, _)) = case color pos of- White | from == toIndex E1 && canCastleKingside pos && to == toIndex H1- -> from `move` G1- | from == toIndex E1 && canCastleQueenside pos && to == toIndex A1- -> from `move` C1- Black | from == toIndex E8 && canCastleKingside pos && to == toIndex H8- -> from `move` G8- | from == toIndex E8 && canCastleQueenside pos && to == toIndex A8- -> from `move` C8- _ -> pl--toPolyglot :: Position -> Ply -> Ply-toPolyglot pos pl@(unpack -> (from, to, _)) = case color pos of- White | from == toIndex E1 && canCastleKingside pos && to == toIndex G1- -> from `move` H1- | from == toIndex E1 && canCastleQueenside pos && to == toIndex C1- -> from `move` A1- Black | from == toIndex E8 && canCastleKingside pos && to == toIndex G8- -> from `move` H8- | from == toIndex E8 && canCastleQueenside pos && to == toIndex C8- -> from `move` A8- _ -> pl---- | Parse a move in the format used by the Universal Chess Interface protocol.-fromUCI :: Position -> String -> Maybe Ply-fromUCI pos (fmap (splitAt 2) . splitAt 2 -> (from, (to, promo)))- | length from == 2 && length to == 2 && null promo- = move <$> readCoord from <*> readCoord to >>= relativeTo pos- | length from == 2 && length to == 2 && length promo == 1- = (\f t p -> move f t `promoteTo` p) <$> readCoord from- <*> readCoord to- <*> readPromo promo- >>= relativeTo pos- where- readCoord [f,r]- | inRange ('a','h') f && inRange ('1','8') r- = Just $ (ord r - ord '1') * 8 + (ord f - ord 'a')- readCoord _ = Nothing- readPromo "q" = Just Queen- readPromo "r" = Just Rook- readPromo "b" = Just Bishop- readPromo "n" = Just Knight- readPromo _ = Nothing-fromUCI _ _ = Nothing---- | Convert a move to the format used by the Universal Chess Interface protocol.-toUCI :: Ply -> String-toUCI (unpack -> (from, to, promo)) = coord from <> coord to <> p where- coord x = let (r,f) = toRF x in- chr (f + ord 'a') : [chr (r + ord '1')]- p = case promo of- Just Queen -> "q"- Just Rook -> "r"- Just Bishop -> "b"- Just Knight -> "n"- _ -> ""---- | Validate that a certain move is legal in the given position.-relativeTo :: Position -> Ply -> Maybe Ply-relativeTo pos m | m `elem` legalPlies pos = Just m- | otherwise = Nothing--shiftN, shiftNNE, shiftNE, shiftENE, shiftE, shiftESE, shiftSE, shiftSSE, shiftS, shiftSSW, shiftSW, shiftWSW, shiftW, shiftWNW, shiftNW, shiftNNW :: Word64 -> Word64-shiftN w = w `unsafeShiftL` 8-shiftNNE w = w `unsafeShiftL` 17 .&. notAFile-shiftNE w = w `unsafeShiftL` 9 .&. notAFile-shiftENE w = w `unsafeShiftL` 10 .&. notABFile-shiftE w = w `unsafeShiftL` 1 .&. notAFile-shiftESE w = w `unsafeShiftR` 6 .&. notABFile-shiftSE w = w `unsafeShiftR` 7 .&. notAFile-shiftSSE w = w `unsafeShiftR` 15 .&. notAFile-shiftS w = w `unsafeShiftR` 8-shiftSSW w = w `unsafeShiftR` 17 .&. notHFile-shiftSW w = w `unsafeShiftR` 9 .&. notHFile-shiftWSW w = w `unsafeShiftR` 10 .&. notGHFile-shiftW w = w `unsafeShiftR` 1 .&. notHFile-shiftWNW w = w `unsafeShiftL` 6 .&. notGHFile-shiftNW w = w `unsafeShiftL` 7 .&. notHFile-shiftNNW w = w `unsafeShiftL` 15 .&. notHFile---- | Apply a move to the given position.------ This function checks if the move is actually legal and throws and error--- if it isn't. See 'unsafeDoPly' for a version that omits the legality check.-doPly :: Position -> Ply -> Position-doPly p m- | m `elem` legalPlies p = unsafeDoPly p m- | otherwise = error "Game.Chess.doPly: Illegal move"---- | An unsafe version of 'doPly'. Only use this if you are sure the given move--- can be applied to the position. This is useful if the move has been generated--- by the 'moves' function.-unsafeDoPly :: Position -> Ply -> Position-unsafeDoPly pos@Position{color = White, halfMoveClock} m =- (unsafeDoPly' pos m) { color = Black, halfMoveClock = succ halfMoveClock }-unsafeDoPly pos@Position{color = Black, moveNumber, halfMoveClock} m =- (unsafeDoPly' pos m) { color = White, moveNumber = succ moveNumber, halfMoveClock = succ halfMoveClock }--unsafeDoPly' :: Position -> Ply -> Position-unsafeDoPly' pos@Position{qbb, flags} m@(unpack -> (from, to, promo))- | m == wKscm && flags `testMask` crwKs- = pos { qbb = qbb <> QBB.whiteKingsideCastle- , flags = flags `clearMask` (rank1 .|. epMask)- }- | m == wQscm && flags `testMask` crwQs- = pos { qbb = qbb <> QBB.whiteQueensideCastle- , flags = flags `clearMask` (rank1 .|. epMask)- }- | m == bKscm && flags `testMask` crbKs- = pos { qbb = qbb <> QBB.blackKingsideCastle- , flags = flags `clearMask` (rank8 .|. epMask)- }- | m == bQscm && flags `testMask` crbQs- = pos { qbb = qbb <> QBB.blackQueensideCastle- , flags = flags `clearMask` (rank8 .|. epMask)- }- | Just piece <- promo- = case color pos of- White -> case piece of- Queen -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteQueen- , flags = flags `clearMask` (epMask .|. bit to)- }- Rook -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteRook- , flags = flags `clearMask` (epMask .|. bit to)- }- Bishop -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteBishop- , flags = flags `clearMask` (epMask .|. bit to)- }- Knight -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteKnight- , flags = flags `clearMask` (epMask .|. bit to)- }- _ -> error "Impossible: White tried to promote to Pawn"- Black -> case piece of- Queen -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackQueen- , flags = flags `clearMask` (epMask .|. bit to)- } - Rook -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackRook- , flags = flags `clearMask` (epMask .|. bit to)- }- Bishop -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackBishop- , flags = flags `clearMask` (epMask .|. bit to)- }- Knight -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackKnight- , flags = flags `clearMask` (epMask .|. bit to)- }- _ -> error "Impossible: Black tried to promote to Pawn"- | QBB.pawns qbb `testMask` fromMask &&- toMask .&. (rank3 .|. rank6) .&. flags /= 0- = pos { qbb = qbb <> QBB.enPassant from to- , flags = flags `clearMask` toMask- }- | otherwise- = pos { qbb = QBB.move qbb from to- , flags = (flags `clearMask` (epMask .|. mask)) .|. dpp- }- where- !fromMask = 1 `unsafeShiftL` from- !toMask = 1 `unsafeShiftL` to- !mask = fromMask .|. toMask- dpp = case color pos of- White | fromMask .&. rank2 .&. QBB.wPawns qbb /= 0 && from + 16 == to -> shiftN fromMask- Black | fromMask .&. rank7 .&. QBB.bPawns qbb /= 0 && from - 16 == to -> shiftS fromMask- _ -> 0---- | Generate a list of possible moves for the given position.-legalPlies :: Position -> [Ply]-legalPlies pos@Position{color, qbb, flags} = filter legalPly $- kingMoves- . knightMoves- . slideMoves Queen pos notOurs occ- . slideMoves Rook pos notOurs occ- . slideMoves Bishop pos notOurs occ- . pawnMoves- $ []- where- legalPly = not . inCheck color . unsafeDoPly' pos- !ours = occupiedBy color qbb- !them = occupiedBy (opponent color) qbb- !notOurs = complement ours- !occ = ours .|. them- (!pawnMoves, !knightMoves, !kingMoves) = case color of- White ->- ( wPawnMoves (QBB.wPawns qbb) (complement occ) (them .|. (flags .&. epMask))- , flip (foldBits genNMoves) (QBB.wKnights qbb)- , flip (foldBits genKMoves) (QBB.wKings qbb) . wShort . wLong)- Black ->- ( bPawnMoves (QBB.bPawns qbb) (complement occ) (them .|. (flags .&. epMask))- , flip (foldBits genNMoves) (QBB.bKnights qbb)- , flip (foldBits genKMoves) (QBB.bKings qbb) . bShort . bLong)- genNMoves ms sq = foldBits (mkM sq) ms ((knightAttacks ! sq) .&. notOurs)- genKMoves ms sq = foldBits (mkM sq) ms ((kingAttacks ! sq) .&. notOurs)- wShort ml | canCastleKingside' pos occ = wKscm : ml- | otherwise = ml- wLong ml | canCastleQueenside' pos occ = wQscm : ml- | otherwise = ml- bShort ml | canCastleKingside' pos occ = bKscm : ml- | otherwise = ml- bLong ml | canCastleQueenside' pos occ = bQscm : ml- | otherwise = ml- mkM !from ms !to = move from to : ms---- | Returns 'True' if 'Color' is in check in the given position.-inCheck :: Color -> Position -> Bool-inCheck White Position{qbb} =- attackedBy Black qbb (occupied qbb) (bitScanForward (QBB.wKings qbb))-inCheck Black Position{qbb} =- attackedBy White qbb (occupied qbb) (bitScanForward (QBB.bKings qbb))--wPawnMoves :: Word64 -> Word64 -> Word64 -> [Ply] -> [Ply]-wPawnMoves !pawns !emptySquares !opponentPieces =- flip (foldBits $ mkPly 9) eastCaptureTargets- . flip (foldBits $ mkPly 7) westCaptureTargets- . flip (foldBits $ mkPly 8) singlePushTargets- . flip (foldBits $ mkPly 16) doublePushTargets- where- doublePushTargets = shiftN singlePushTargets .&. emptySquares .&. rank4- singlePushTargets = shiftN pawns .&. emptySquares- eastCaptureTargets = shiftNE pawns .&. opponentPieces- westCaptureTargets = shiftNW pawns .&. opponentPieces- mkPly diff ms tsq- | tsq >= 56 = (promoteTo m <$> [Queen, Rook, Bishop, Knight]) <> ms- | otherwise = m : ms- where m = move (tsq - diff) tsq--bPawnMoves :: Word64 -> Word64 -> Word64 -> [Ply] -> [Ply]-bPawnMoves !pawns !emptySquares !opponentPieces =- flip (foldBits $ mkPly 9) westCaptureTargets- . flip (foldBits $ mkPly 7) eastCaptureTargets- . flip (foldBits $ mkPly 8) singlePushTargets- . flip (foldBits $ mkPly 16) doublePushTargets- where- doublePushTargets = shiftS singlePushTargets .&. emptySquares .&. rank5- singlePushTargets = shiftS pawns .&. emptySquares- eastCaptureTargets = shiftSE pawns .&. opponentPieces- westCaptureTargets = shiftSW pawns .&. opponentPieces- mkPly diff ms tsq- | tsq <= 7 = (promoteTo m <$> [Queen, Rook, Bishop, Knight]) <> ms- | otherwise = m : ms- where m = move (tsq + diff) tsq--slideMoves :: PieceType -> Position -> Word64 -> Word64 -> [Ply] -> [Ply]-slideMoves piece (Position bb c _ _ _) !notOurs !occ =- flip (foldBits gen) pieces- where- gen ms from = foldBits (mkPly from) ms (targets from)- mkPly from ms to = move from to : ms- targets sq = case piece of- Rook -> rookTargets sq occ .&. notOurs- Bishop -> bishopTargets sq occ .&. notOurs- Queen -> queenTargets sq occ .&. notOurs- _ -> error "Not a sliding piece"- pieces = case (c, piece) of- (White, Bishop) -> QBB.wBishops bb- (Black, Bishop) -> QBB.bBishops bb- (White, Rook) -> QBB.wRooks bb- (Black, Rook) -> QBB.bRooks bb- (White, Queen) -> QBB.wQueens bb- (Black, Queen) -> QBB.bQueens bb- _ -> 0--data Castle = Kingside | Queenside deriving (Eq, Ix, Ord, Show)--castlingRights :: Position -> [(Color, Castle)]-castlingRights Position{flags} = wks . wqs . bks . bqs $ [] where- wks xs | flags `testMask` crwKs = (White, Kingside):xs- | otherwise = xs- wqs xs | flags `testMask` crwQs = (White, Queenside):xs- | otherwise = xs- bks xs | flags `testMask` crbKs = (Black, Kingside):xs- | otherwise = xs- bqs xs | flags `testMask` crbQs = (Black, Queenside):xs- | otherwise = xs--canCastleKingside, canCastleQueenside :: Position -> Bool-canCastleKingside pos@Position{qbb} = canCastleKingside' pos (occupied qbb)-canCastleQueenside pos@Position{qbb} = canCastleQueenside' pos (occupied qbb)--canCastleKingside', canCastleQueenside' :: Position -> Word64 -> Bool-canCastleKingside' Position{qbb, color = White, flags} !occ =- flags `testMask` crwKs && occ .&. crwKe == 0 &&- not (any (attackedBy Black qbb occ) [E1, F1, G1])-canCastleKingside' Position{qbb, color = Black, flags} !occ = - flags `testMask` crbKs && occ .&. crbKe == 0 &&- not (any (attackedBy White qbb occ) [E8, F8, G8])-canCastleQueenside' Position{qbb, color = White, flags} !occ =- flags `testMask` crwQs && occ .&. crwQe == 0 &&- not (any (attackedBy Black qbb occ) [E1, D1, C1])-canCastleQueenside' Position{qbb, color = Black, flags} !occ =- flags `testMask` crbQs && occ .&. crbQe == 0 &&- not (any (attackedBy White qbb occ) [E8, D8, C8])--wKscm, wQscm, bKscm, bQscm :: Ply-wKscm = move E1 G1-wQscm = move E1 C1-bKscm = move E8 G8-bQscm = move E8 C8--attackedBy :: IsSquare sq => Color -> QuadBitboard -> Word64 -> sq -> Bool-attackedBy White qbb !occ (toIndex -> sq)- | (wPawnAttacks ! sq) .&. QBB.wPawns qbb /= 0 = True- | (knightAttacks ! sq) .&. QBB.wKnights qbb /= 0 = True- | bishopTargets sq occ .&. QBB.wBishops qbb /= 0 = True- | rookTargets sq occ .&. QBB.wRooks qbb /= 0 = True- | queenTargets sq occ .&. QBB.wQueens qbb /= 0 = True- | (kingAttacks ! sq) .&. QBB.wKings qbb /= 0 = True- | otherwise = False-attackedBy Black qbb !occ (toIndex -> sq)- | (bPawnAttacks ! sq) .&. QBB.bPawns qbb /= 0 = True- | (knightAttacks ! sq) .&. QBB.bKnights qbb /= 0 = True- | bishopTargets sq occ .&. QBB.bBishops qbb /= 0 = True- | rookTargets sq occ .&. QBB.bRooks qbb /= 0 = True- | queenTargets sq occ .&. QBB.bQueens qbb /= 0 = True- | (kingAttacks ! sq) .&. QBB.bKings qbb /= 0 = True- | otherwise = False--notAFile, notABFile, notGHFile, notHFile, rank1, rank2, rank3, rank4, rank5, rank6, rank7, rank8 :: Word64-notAFile = 0xfefefefefefefefe-notABFile = 0xfcfcfcfcfcfcfcfc-notGHFile = 0x3f3f3f3f3f3f3f3f-notHFile = 0x7f7f7f7f7f7f7f7f-rank1 = 0x00000000000000ff-rank2 = 0x000000000000ff00-rank3 = 0x0000000000ff0000-rank4 = 0x00000000ff000000-rank5 = 0x000000ff00000000-rank6 = 0x0000ff0000000000-rank7 = 0x00ff000000000000-rank8 = 0xff00000000000000--epMask, crwKs, crwQs, crwKe, crwQe, crbKs, crbQs, crbKe, crbQe :: Word64-epMask = rank3 .|. rank6 -- mask for en passant-crwKs = 0x0000000000000090 -- white: king & rook position for kingside castle-crwQs = 0x0000000000000011 -- white: king & rook pisition for queenside castle^M-crwKe = 0x0000000000000060 -- white: empty fields for kingside castle-crwQe = 0x000000000000000e -- white: empty fields for queenside castle-crbKs = 0x9000000000000000 -- black: king & rook position for kingside castle-crbQs = 0x1100000000000000 -- black: king & rook position for queenside castle^M-crbKe = 0x6000000000000000 -- black: empty fields for kingside castle-crbQe = 0x0e00000000000000 -- black: empty fields for queenside castle--kingAttacks, knightAttacks, wPawnAttacks, bPawnAttacks :: Vector Word64-kingAttacks = Vector.generate 64 $ \sq -> let b = bit sq in- shiftN b .|. shiftNE b .|. shiftE b .|. shiftSE b .|.- shiftS b .|. shiftSW b .|. shiftW b .|. shiftNW b-knightAttacks = Vector.generate 64 $ \sq -> let b = bit sq in- shiftNNE b .|. shiftENE b .|.- shiftESE b .|. shiftSSE b .|.- shiftSSW b .|. shiftWSW b .|.- shiftWNW b .|. shiftNNW b-wPawnAttacks = Vector.generate 64 $ \sq -> let b = bit sq in- shiftSE b .|. shiftSW b-bPawnAttacks = Vector.generate 64 $ \sq -> let b = bit sq in- shiftNE b .|. shiftNW b--data Direction = N | NE | E | SE | S | SW | W | NW deriving (Eq, Show)--rookTargets, bishopTargets, queenTargets :: Int -> Word64 -> Word64-rookTargets !sq !occ = getRayTargets sq N occ .|. getRayTargets sq E occ- .|. getRayTargets sq S occ .|. getRayTargets sq W occ-bishopTargets !sq !occ = getRayTargets sq NW occ .|. getRayTargets sq NE occ- .|. getRayTargets sq SE occ .|. getRayTargets sq SW occ-queenTargets sq occ = rookTargets sq occ .|. bishopTargets sq occ--getRayTargets :: Int -> Direction -> Word64 -> Word64-getRayTargets sq dir occ = blocked $ attacks .&. occ where- blocked 0 = attacks- blocked bb = attacks `xor` (ray ! bitScan bb)- attacks = ray ! sq- (bitScan, ray) = case dir of- NW -> (bitScanForward, attackNW)- N -> (bitScanForward, attackN)- NE -> (bitScanForward, attackNE)- E -> (bitScanForward, attackE)- SE -> (bitScanReverse, attackSE)- S -> (bitScanReverse, attackS)- SW -> (bitScanReverse, attackSW)- W -> (bitScanReverse, attackW)--attackDir :: (Word64 -> Word64) -> Vector Word64-attackDir s = Vector.generate 64 $ \sq ->- foldr (.|.) 0 $ take 7 $ tail $ iterate s (bit sq)--attackNW, attackN, attackNE, attackE, attackSE, attackS, attackSW, attackW :: Vector Word64-attackNW = attackDir shiftNW-attackN = attackDir shiftN-attackNE = attackDir shiftNE-attackE = attackDir shiftE-attackSE = attackDir shiftSE-attackS = attackDir shiftS-attackSW = attackDir shiftSW-attackW = attackDir shiftW--clearMask :: Bits a => a -> a -> a-clearMask a b = a .&. complement b--testMask :: Bits a => a -> a -> Bool-testMask a b = a .&. b == b--{-# INLINE clearMask #-}-{-# INLINE testMask #-}-{-# INLINE attackedBy #-}-{-# INLINE slideMoves #-}-{-# INLINE wPawnMoves #-}-{-# INLINE bPawnMoves #-}-{-# INLINE unpack #-}-{-# INLINE foldBits #-}-{-# INLINE bitScanForward #-}-{-# INLINE bitScanReverse #-}-{-# SPECIALISE relaxedSAN :: Position -> Parser Strict.ByteString Ply #-}-{-# SPECIALISE relaxedSAN :: Position -> Parser Lazy.ByteString Ply #-}-{-# SPECIALISE relaxedSAN :: Position -> Parser Strict.Text Ply #-}-{-# SPECIALISE relaxedSAN :: Position -> Parser Lazy.Text Ply #-}-{-# SPECIALISE relaxedSAN :: Position -> Parser String Ply #-}-{-# SPECIALISE strictSAN :: Position -> Parser Strict.ByteString Ply #-}-{-# SPECIALISE strictSAN :: Position -> Parser Lazy.ByteString Ply #-}-{-# SPECIALISE strictSAN :: Position -> Parser Strict.Text Ply #-}-{-# SPECIALISE strictSAN :: Position -> Parser Lazy.Text Ply #-}-{-# SPECIALISE strictSAN :: Position -> Parser String Ply #-}+import Game.Chess.Internal+import Game.Chess.SAN+import Game.Chess.Tree
+ src/Game/Chess/Internal.hs view
@@ -0,0 +1,658 @@+{-|+Module : Game.Chess+Description : Basic data types and functions related to the game of chess+Copyright : (c) Mario Lang, 2020+License : BSD3+Maintainer : mlang@blind.guru+Stability : experimental++A small collection of data types and functions to represent Chess positions+and moves including move generation and parsing from external sources.++This module does deliberately not implement+any search or evaluation functionality. It is intended to be used+to lay the ground for communicating with other programs or players, hence the+package name chessIO.+-}+module Game.Chess.Internal where++import Data.Bits+ ( Bits((.&.), testBit, unsafeShiftR, unsafeShiftL, xor, (.|.), bit, complement),+ FiniteBits(countLeadingZeros, countTrailingZeros) )+import Data.Char ( ord, chr )+import Data.Ix ( Ix(inRange) )+import Data.List (nub, sortOn)+import Data.Maybe ( fromJust, isJust, listToMaybe )+import Data.Ord (Down(..))+import Data.String ( IsString(..) )+import Data.Vector.Unboxed (Vector, (!))+import qualified Data.Vector.Unboxed as Vector+import Data.Word ( Word16, Word64 )+import Foreign.Storable+import Game.Chess.QuadBitboard (QuadBitboard)+import qualified Game.Chess.QuadBitboard as QBB+import Text.Read (readMaybe)++capturing :: Position -> Ply -> Maybe PieceType+capturing pos@Position{flags} (unpack -> (_, to, _))+ | (flags .&. epMask) `testBit` to = Just Pawn+ | otherwise = snd <$> pieceAt pos to++isCapture :: Position -> Ply -> Bool+isCapture pos = isJust . capturing pos++-- | The starting position as given by the FEN string+-- "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1".+startpos :: Position+startpos = fromJust $+ fromFEN "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1"++data PieceType = Pawn | Knight | Bishop | Rook | Queen | King deriving (Eq, Ix, Ord, Show)++data Color = Black | White deriving (Eq, Ix, Ord, Show)++pieceAt :: IsSquare sq => Position -> sq -> Maybe (Color, PieceType)+pieceAt Position{qbb} (toIndex -> sq) = case qbb QBB.! sq of+ QBB.WhitePawn -> Just (White, Pawn)+ QBB.WhiteKnight -> Just (White, Knight)+ QBB.WhiteBishop -> Just (White, Bishop)+ QBB.WhiteRook -> Just (White, Rook)+ QBB.WhiteQueen -> Just (White, Queen)+ QBB.WhiteKing -> Just (White, King)+ QBB.BlackPawn -> Just (Black, Pawn)+ QBB.BlackKnight -> Just (Black, Knight)+ QBB.BlackBishop -> Just (Black, Bishop)+ QBB.BlackRook -> Just (Black, Rook)+ QBB.BlackQueen -> Just (Black, Queen)+ QBB.BlackKing -> Just (Black, King)+ _ -> Nothing++opponent :: Color -> Color+opponent White = Black+opponent Black = White++data Piece = Piece !Color !PieceType deriving (Eq, Show)++data Sq = A1 | B1 | C1 | D1 | E1 | F1 | G1 | H1+ | A2 | B2 | C2 | D2 | E2 | F2 | G2 | H2+ | A3 | B3 | C3 | D3 | E3 | F3 | G3 | H3+ | A4 | B4 | C4 | D4 | E4 | F4 | G4 | H4+ | A5 | B5 | C5 | D5 | E5 | F5 | G5 | H5+ | A6 | B6 | C6 | D6 | E6 | F6 | G6 | H6+ | A7 | B7 | C7 | D7 | E7 | F7 | G7 | H7+ | A8 | B8 | C8 | D8 | E8 | F8 | G8 | H8+ deriving (Bounded, Enum, Eq, Ix, Ord, Show)++class IsSquare sq where+ toIndex :: sq -> Int++toRF :: IsSquare sq => sq -> (Int, Int)+toRF sq = toIndex sq `divMod` 8++toCoord :: (IsSquare sq, IsString s) => sq -> s+toCoord (toRF -> (r,f)) = fromString [chr (f + ord 'a'), chr (r + ord '1')]++instance IsSquare Sq where+ toIndex = fromEnum++instance IsSquare Int where+ toIndex = id++isDark :: IsSquare sq => sq -> Bool+isDark (toIndex -> sq) = (0xaa55aa55aa55aa55 :: Word64) `testBit` sq++isLight :: IsSquare sq => sq -> Bool+isLight = not . isDark++data Position = Position {+ qbb :: {-# UNPACK #-} !QuadBitboard+, color :: !Color+ -- ^ active color+, flags :: !Word64+, halfMoveClock :: !Int+, moveNumber :: !Int+ -- ^ number of the full move+}++-- Article 9.2 states that a position is considered+-- identical to another if the same player is on move, the same types of+-- pieces of the same colors occupy the same squares, and the same moves+-- are available to each player; in particular, each player has the same+-- castling and en passant capturing rights.+instance Eq Position where+ a == b = qbb a == qbb b && color a == color b && flags a == flags b++repetitions :: [Position] -> Maybe (Int, Position)+repetitions p = listToMaybe . sortOn (Down . fst) $ fmap f (nub p) where+ f x = (count x p, x)+ count x = length . filter (== x)++instance Show Position where+ show p = '"' : toFEN p <> ['"']++insufficientMaterial :: Position -> Bool+insufficientMaterial Position{qbb} = QBB.insufficientMaterial qbb++-- | Construct a position from Forsyth-Edwards-Notation.+fromFEN :: String -> Maybe Position+fromFEN fen+ | length parts /= 6+ = Nothing+ | otherwise =+ Position <$> Just (fromString (parts !! 0))+ <*> readColor (parts !! 1)+ <*> readFlags (parts !! 2) (parts !! 3)+ <*> readMaybe (parts !! 4)+ <*> readMaybe (parts !! 5)+ where+ parts = words fen+ readColor "w" = Just White+ readColor "b" = Just Black+ readColor _ = Nothing++ readFlags cst ep = (.|.) <$> readCst cst <*> readEP ep where+ readCst "-" = Just 0+ readCst x = go x where+ go ('K':xs) = (crwKs .|.) <$> go xs+ go ('Q':xs) = (crwQs .|.) <$> go xs+ go ('k':xs) = (crbKs .|.) <$> go xs+ go ('q':xs) = (crbQs .|.) <$> go xs+ go [] = Just 0+ go _ = Nothing+ readEP "-" = Just 0+ readEP [f,r]+ | inRange ('a','h') f && (r == '3' || r == '6')+ = Just $ bit ((ord r - ord '1') * 8 + (ord f - ord 'a'))+ readEP _ = Nothing++-- | Convert a position to Forsyth-Edwards-Notation.+toFEN :: Position -> String+toFEN (Position bb c flgs hm mn) = unwords [+ QBB.toString bb+ , showColor c, showCst (flgs `clearMask` epMask), showEP (flgs .&. epMask), show hm, show mn+ ]+ where+ showColor White = "w"+ showColor Black = "b"+ showCst 0 = "-"+ showCst x = snd . wks . wqs . bks . bqs $ (x, "") where+ wks (v, xs) | v `testMask` crwKs = (v, 'K':xs)+ | otherwise = (v, xs)+ wqs (v, xs) | v `testMask` crwQs = (v, 'Q':xs)+ | otherwise = (v, xs)+ bks (v, xs) | v `testMask` crbKs = (v, 'k':xs)+ | otherwise = (v, xs)+ bqs (v, xs) | v `testMask` crbQs = (v, 'q':xs)+ | otherwise = (v, xs)+ showEP 0 = "-"+ showEP x = chr (f + ord 'a') : [chr (r + ord '1')] where+ (r, f) = toRF $ bitScanForward x++occupiedBy :: Color -> QuadBitboard -> Word64+occupiedBy White = QBB.white+occupiedBy Black = QBB.black++occupied :: QuadBitboard -> Word64+occupied = QBB.occupied++foldBits :: (a -> Int -> a) -> a -> Word64 -> a+foldBits _ a 0 = a+foldBits f !a n = foldBits f (f a $ countTrailingZeros n) $ n .&. pred n++bitScanForward, bitScanReverse :: Word64 -> Int+bitScanForward = countTrailingZeros+bitScanReverse = (63 -) . countLeadingZeros++newtype Ply = Ply Word16 deriving (Eq, Storable)++instance Show Ply where+ show = toUCI++move :: (IsSquare from, IsSquare to) => from -> to -> Ply+move (toIndex -> from) (toIndex -> to) =+ Ply $ fromIntegral to .|. fromIntegral from `unsafeShiftL` 6++promoteTo :: Ply -> PieceType -> Ply+promoteTo (Ply x) = Ply . set where+ set Knight = x .&. 0xfff .|. 0x1000+ set Bishop = x .&. 0xfff .|. 0x2000+ set Rook = x .&. 0xfff .|. 0x3000+ set Queen = x .&. 0xfff .|. 0x4000+ set _ = x++unpack :: Ply -> (Int, Int, Maybe PieceType)+unpack (Ply x) = ( fromIntegral ((x `unsafeShiftR` 6) .&. 0b111111)+ , fromIntegral (x .&. 0b111111)+ , piece)+ where+ !piece = case x `unsafeShiftR` 12 of+ 1 -> Just Knight+ 2 -> Just Bishop+ 3 -> Just Rook+ 4 -> Just Queen+ _ -> Nothing++fromPolyglot :: Position -> Ply -> Ply+fromPolyglot pos pl@(unpack -> (from, to, _)) = case color pos of+ White | from == toIndex E1+ , canCastleKingside pos+ , to == toIndex H1+ -> wKscm+ | from == toIndex E1+ , canCastleQueenside pos+ , to == toIndex A1+ -> wQscm+ Black | from == toIndex E8+ , canCastleKingside pos+ , to == toIndex H8+ -> bKscm+ | from == toIndex E8+ , canCastleQueenside pos+ , to == toIndex A8+ -> bQscm+ _ -> pl++toPolyglot :: Position -> Ply -> Ply+toPolyglot pos pl@(unpack -> (from, to, _)) = case color pos of+ White | from == toIndex E1+ , canCastleKingside pos+ , to == toIndex G1+ -> from `move` H1+ | from == toIndex E1+ , canCastleQueenside pos+ , to == toIndex C1+ -> from `move` A1+ Black | from == toIndex E8+ , canCastleKingside pos+ , to == toIndex G8+ -> from `move` H8+ | from == toIndex E8+ , canCastleQueenside pos+ , to == toIndex C8+ -> from `move` A8+ _ -> pl++-- | Parse a move in the format used by the Universal Chess Interface protocol.+fromUCI :: Position -> String -> Maybe Ply+fromUCI pos (fmap (splitAt 2) . splitAt 2 -> (from, (to, promo)))+ | null promo+ = move <$> readCoord from <*> readCoord to >>= relativeTo pos+ | otherwise+ = (\f t p -> move f t `promoteTo` p) <$> readCoord from+ <*> readCoord to+ <*> readPromo promo+ >>= relativeTo pos+ where+ readCoord [f,r]+ | inRange ('a','h') f && inRange ('1','8') r+ = Just $ (ord r - ord '1') * 8 + (ord f - ord 'a')+ readCoord _ = Nothing+ readPromo "q" = Just Queen+ readPromo "r" = Just Rook+ readPromo "b" = Just Bishop+ readPromo "n" = Just Knight+ readPromo _ = Nothing++-- | Convert a move to the format used by the Universal Chess Interface protocol.+toUCI :: Ply -> String+toUCI (unpack -> (from, to, promo)) = coord from <> coord to <> p where+ coord x = let (r,f) = toRF x in+ chr (f + ord 'a') : [chr (r + ord '1')]+ p = case promo of+ Just Queen -> "q"+ Just Rook -> "r"+ Just Bishop -> "b"+ Just Knight -> "n"+ _ -> ""++-- | Validate that a certain move is legal in the given position.+relativeTo :: Position -> Ply -> Maybe Ply+relativeTo pos m | m `elem` legalPlies pos = Just m+ | otherwise = Nothing++shiftN, shiftNNE, shiftNE, shiftENE, shiftE, shiftESE, shiftSE, shiftSSE, shiftS, shiftSSW, shiftSW, shiftWSW, shiftW, shiftWNW, shiftNW, shiftNNW :: Word64 -> Word64+shiftN w = w `unsafeShiftL` 8+shiftNNE w = w `unsafeShiftL` 17 .&. notAFile+shiftNE w = w `unsafeShiftL` 9 .&. notAFile+shiftENE w = w `unsafeShiftL` 10 .&. notABFile+shiftE w = w `unsafeShiftL` 1 .&. notAFile+shiftESE w = w `unsafeShiftR` 6 .&. notABFile+shiftSE w = w `unsafeShiftR` 7 .&. notAFile+shiftSSE w = w `unsafeShiftR` 15 .&. notAFile+shiftS w = w `unsafeShiftR` 8+shiftSSW w = w `unsafeShiftR` 17 .&. notHFile+shiftSW w = w `unsafeShiftR` 9 .&. notHFile+shiftWSW w = w `unsafeShiftR` 10 .&. notGHFile+shiftW w = w `unsafeShiftR` 1 .&. notHFile+shiftWNW w = w `unsafeShiftL` 6 .&. notGHFile+shiftNW w = w `unsafeShiftL` 7 .&. notHFile+shiftNNW w = w `unsafeShiftL` 15 .&. notHFile++-- | Apply a move to the given position.+--+-- This function checks if the move is actually legal and throws and error+-- if it isn't. See 'unsafeDoPly' for a version that omits the legality check.+doPly :: Position -> Ply -> Position+doPly p m+ | m `elem` legalPlies p = unsafeDoPly p m+ | otherwise = error "Game.Chess.doPly: Illegal move"++-- | An unsafe version of 'doPly'. Only use this if you are sure the given move+-- can be applied to the position. This is useful if the move has been generated+-- by the 'moves' function.+unsafeDoPly :: Position -> Ply -> Position+unsafeDoPly pos@Position{color = White, halfMoveClock} m =+ (unsafeDoPly' pos m) { color = Black, halfMoveClock = succ halfMoveClock }+unsafeDoPly pos@Position{color = Black, moveNumber, halfMoveClock} m =+ (unsafeDoPly' pos m) { color = White, moveNumber = succ moveNumber, halfMoveClock = succ halfMoveClock }++unsafeDoPly' :: Position -> Ply -> Position+unsafeDoPly' pos@Position{qbb, flags} m@(unpack -> (from, to, promo))+ | m == wKscm && flags `testMask` crwKs+ = pos { qbb = qbb <> QBB.whiteKingsideCastle+ , flags = flags `clearMask` (rank1 .|. epMask)+ }+ | m == wQscm && flags `testMask` crwQs+ = pos { qbb = qbb <> QBB.whiteQueensideCastle+ , flags = flags `clearMask` (rank1 .|. epMask)+ }+ | m == bKscm && flags `testMask` crbKs+ = pos { qbb = qbb <> QBB.blackKingsideCastle+ , flags = flags `clearMask` (rank8 .|. epMask)+ }+ | m == bQscm && flags `testMask` crbQs+ = pos { qbb = qbb <> QBB.blackQueensideCastle+ , flags = flags `clearMask` (rank8 .|. epMask)+ }+ | Just piece <- promo+ = case color pos of+ White -> case piece of+ Queen -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteQueen+ , flags = flags `clearMask` (epMask .|. bit to)+ }+ Rook -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteRook+ , flags = flags `clearMask` (epMask .|. bit to)+ }+ Bishop -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteBishop+ , flags = flags `clearMask` (epMask .|. bit to)+ }+ Knight -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteKnight+ , flags = flags `clearMask` (epMask .|. bit to)+ }+ _ -> error "Impossible: White tried to promote to Pawn"+ Black -> case piece of+ Queen -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackQueen+ , flags = flags `clearMask` (epMask .|. bit to)+ } + Rook -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackRook+ , flags = flags `clearMask` (epMask .|. bit to)+ }+ Bishop -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackBishop+ , flags = flags `clearMask` (epMask .|. bit to)+ }+ Knight -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackKnight+ , flags = flags `clearMask` (epMask .|. bit to)+ }+ _ -> error "Impossible: Black tried to promote to Pawn"+ | QBB.pawns qbb `testMask` fromMask &&+ toMask .&. (rank3 .|. rank6) .&. flags /= 0+ = pos { qbb = qbb <> QBB.enPassant from to+ , flags = flags `clearMask` toMask+ }+ | otherwise+ = pos { qbb = QBB.move qbb from to+ , flags = (flags `clearMask` (epMask .|. mask)) .|. dpp+ }+ where+ !fromMask = 1 `unsafeShiftL` from+ !toMask = 1 `unsafeShiftL` to+ !mask = fromMask .|. toMask+ dpp = case color pos of+ White | fromMask .&. rank2 .&. QBB.wPawns qbb /= 0 && from + 16 == to -> shiftN fromMask+ Black | fromMask .&. rank7 .&. QBB.bPawns qbb /= 0 && from - 16 == to -> shiftS fromMask+ _ -> 0++-- | Generate a list of possible moves for the given position.+legalPlies :: Position -> [Ply]+legalPlies pos@Position{color, qbb, flags} = filter legalPly $+ kingMoves+ . knightMoves+ . slideMoves Queen pos notOurs occ+ . slideMoves Rook pos notOurs occ+ . slideMoves Bishop pos notOurs occ+ . pawnMoves+ $ []+ where+ legalPly = not . inCheck color . unsafeDoPly' pos+ !ours = occupiedBy color qbb+ !them = occupiedBy (opponent color) qbb+ !notOurs = complement ours+ !occ = ours .|. them+ (!pawnMoves, !knightMoves, !kingMoves) = case color of+ White ->+ ( wPawnMoves (QBB.wPawns qbb) (complement occ) (them .|. (flags .&. epMask))+ , flip (foldBits genNMoves) (QBB.wKnights qbb)+ , flip (foldBits genKMoves) (QBB.wKings qbb) . wShort . wLong)+ Black ->+ ( bPawnMoves (QBB.bPawns qbb) (complement occ) (them .|. (flags .&. epMask))+ , flip (foldBits genNMoves) (QBB.bKnights qbb)+ , flip (foldBits genKMoves) (QBB.bKings qbb) . bShort . bLong)+ genNMoves ms sq = foldBits (mkM sq) ms ((knightAttacks ! sq) .&. notOurs)+ genKMoves ms sq = foldBits (mkM sq) ms ((kingAttacks ! sq) .&. notOurs)+ wShort ml | canCastleKingside' pos occ = wKscm : ml+ | otherwise = ml+ wLong ml | canCastleQueenside' pos occ = wQscm : ml+ | otherwise = ml+ bShort ml | canCastleKingside' pos occ = bKscm : ml+ | otherwise = ml+ bLong ml | canCastleQueenside' pos occ = bQscm : ml+ | otherwise = ml+ mkM !from ms !to = move from to : ms++-- | Returns 'True' if 'Color' is in check in the given position.+inCheck :: Color -> Position -> Bool+inCheck White Position{qbb} =+ attackedBy Black qbb (occupied qbb) (bitScanForward (QBB.wKings qbb))+inCheck Black Position{qbb} =+ attackedBy White qbb (occupied qbb) (bitScanForward (QBB.bKings qbb))++wPawnMoves :: Word64 -> Word64 -> Word64 -> [Ply] -> [Ply]+wPawnMoves !pawns !emptySquares !opponentPieces =+ flip (foldBits $ mkPly 9) eastCaptureTargets+ . flip (foldBits $ mkPly 7) westCaptureTargets+ . flip (foldBits $ mkPly 8) singlePushTargets+ . flip (foldBits $ mkPly 16) doublePushTargets+ where+ doublePushTargets = shiftN singlePushTargets .&. emptySquares .&. rank4+ singlePushTargets = shiftN pawns .&. emptySquares+ eastCaptureTargets = shiftNE pawns .&. opponentPieces+ westCaptureTargets = shiftNW pawns .&. opponentPieces+ mkPly diff ms tsq+ | tsq >= 56 = (promoteTo m <$> [Queen, Rook, Bishop, Knight]) <> ms+ | otherwise = m : ms+ where m = move (tsq - diff) tsq++bPawnMoves :: Word64 -> Word64 -> Word64 -> [Ply] -> [Ply]+bPawnMoves !pawns !emptySquares !opponentPieces =+ flip (foldBits $ mkPly 9) westCaptureTargets+ . flip (foldBits $ mkPly 7) eastCaptureTargets+ . flip (foldBits $ mkPly 8) singlePushTargets+ . flip (foldBits $ mkPly 16) doublePushTargets+ where+ doublePushTargets = shiftS singlePushTargets .&. emptySquares .&. rank5+ singlePushTargets = shiftS pawns .&. emptySquares+ eastCaptureTargets = shiftSE pawns .&. opponentPieces+ westCaptureTargets = shiftSW pawns .&. opponentPieces+ mkPly diff ms tsq+ | tsq <= 7 = (promoteTo m <$> [Queen, Rook, Bishop, Knight]) <> ms+ | otherwise = m : ms+ where m = move (tsq + diff) tsq++slideMoves :: PieceType -> Position -> Word64 -> Word64 -> [Ply] -> [Ply]+slideMoves piece (Position bb c _ _ _) !notOurs !occ =+ flip (foldBits gen) pieces+ where+ gen ms from = foldBits (mkPly from) ms (targets from)+ mkPly from ms to = move from to : ms+ targets sq = case piece of+ Rook -> rookTargets sq occ .&. notOurs+ Bishop -> bishopTargets sq occ .&. notOurs+ Queen -> queenTargets sq occ .&. notOurs+ _ -> error "Not a sliding piece"+ pieces = case (c, piece) of+ (White, Bishop) -> QBB.wBishops bb+ (Black, Bishop) -> QBB.bBishops bb+ (White, Rook) -> QBB.wRooks bb+ (Black, Rook) -> QBB.bRooks bb+ (White, Queen) -> QBB.wQueens bb+ (Black, Queen) -> QBB.bQueens bb+ _ -> 0++data Castle = Kingside | Queenside deriving (Eq, Ix, Ord, Show)++castlingRights :: Position -> [(Color, Castle)]+castlingRights Position{flags} = wks . wqs . bks . bqs $ [] where+ wks xs | flags `testMask` crwKs = (White, Kingside):xs+ | otherwise = xs+ wqs xs | flags `testMask` crwQs = (White, Queenside):xs+ | otherwise = xs+ bks xs | flags `testMask` crbKs = (Black, Kingside):xs+ | otherwise = xs+ bqs xs | flags `testMask` crbQs = (Black, Queenside):xs+ | otherwise = xs++canCastleKingside, canCastleQueenside :: Position -> Bool+canCastleKingside pos@Position{qbb} = canCastleKingside' pos (occupied qbb)+canCastleQueenside pos@Position{qbb} = canCastleQueenside' pos (occupied qbb)++canCastleKingside', canCastleQueenside' :: Position -> Word64 -> Bool+canCastleKingside' Position{qbb, color = White, flags} !occ =+ flags `testMask` crwKs && occ .&. crwKe == 0 &&+ not (any (attackedBy Black qbb occ) [E1, F1, G1])+canCastleKingside' Position{qbb, color = Black, flags} !occ = + flags `testMask` crbKs && occ .&. crbKe == 0 &&+ not (any (attackedBy White qbb occ) [E8, F8, G8])+canCastleQueenside' Position{qbb, color = White, flags} !occ =+ flags `testMask` crwQs && occ .&. crwQe == 0 &&+ not (any (attackedBy Black qbb occ) [E1, D1, C1])+canCastleQueenside' Position{qbb, color = Black, flags} !occ =+ flags `testMask` crbQs && occ .&. crbQe == 0 &&+ not (any (attackedBy White qbb occ) [E8, D8, C8])++wKscm, wQscm, bKscm, bQscm :: Ply+wKscm = move E1 G1+wQscm = move E1 C1+bKscm = move E8 G8+bQscm = move E8 C8++attackedBy :: IsSquare sq => Color -> QuadBitboard -> Word64 -> sq -> Bool+attackedBy White qbb !occ (toIndex -> sq)+ | (wPawnAttacks ! sq) .&. QBB.wPawns qbb /= 0 = True+ | (knightAttacks ! sq) .&. QBB.wKnights qbb /= 0 = True+ | bishopTargets sq occ .&. QBB.wBishops qbb /= 0 = True+ | rookTargets sq occ .&. QBB.wRooks qbb /= 0 = True+ | queenTargets sq occ .&. QBB.wQueens qbb /= 0 = True+ | (kingAttacks ! sq) .&. QBB.wKings qbb /= 0 = True+ | otherwise = False+attackedBy Black qbb !occ (toIndex -> sq)+ | (bPawnAttacks ! sq) .&. QBB.bPawns qbb /= 0 = True+ | (knightAttacks ! sq) .&. QBB.bKnights qbb /= 0 = True+ | bishopTargets sq occ .&. QBB.bBishops qbb /= 0 = True+ | rookTargets sq occ .&. QBB.bRooks qbb /= 0 = True+ | queenTargets sq occ .&. QBB.bQueens qbb /= 0 = True+ | (kingAttacks ! sq) .&. QBB.bKings qbb /= 0 = True+ | otherwise = False++notAFile, notABFile, notGHFile, notHFile, rank1, rank2, rank3, rank4, rank5, rank6, rank7, rank8 :: Word64+notAFile = 0xfefefefefefefefe+notABFile = 0xfcfcfcfcfcfcfcfc+notGHFile = 0x3f3f3f3f3f3f3f3f+notHFile = 0x7f7f7f7f7f7f7f7f+rank1 = 0x00000000000000ff+rank2 = 0x000000000000ff00+rank3 = 0x0000000000ff0000+rank4 = 0x00000000ff000000+rank5 = 0x000000ff00000000+rank6 = 0x0000ff0000000000+rank7 = 0x00ff000000000000+rank8 = 0xff00000000000000++epMask, crwKs, crwQs, crwKe, crwQe, crbKs, crbQs, crbKe, crbQe :: Word64+epMask = rank3 .|. rank6 -- mask for en passant+crwKs = 0x0000000000000090 -- white: king & rook position for kingside castle+crwQs = 0x0000000000000011 -- white: king & rook pisition for queenside castle^M+crwKe = 0x0000000000000060 -- white: empty fields for kingside castle+crwQe = 0x000000000000000e -- white: empty fields for queenside castle+crbKs = 0x9000000000000000 -- black: king & rook position for kingside castle+crbQs = 0x1100000000000000 -- black: king & rook position for queenside castle^M+crbKe = 0x6000000000000000 -- black: empty fields for kingside castle+crbQe = 0x0e00000000000000 -- black: empty fields for queenside castle++kingAttacks, knightAttacks, wPawnAttacks, bPawnAttacks :: Vector Word64+kingAttacks = Vector.generate 64 $ \sq -> let b = bit sq in+ shiftN b .|. shiftNE b .|. shiftE b .|. shiftSE b .|.+ shiftS b .|. shiftSW b .|. shiftW b .|. shiftNW b+knightAttacks = Vector.generate 64 $ \sq -> let b = bit sq in+ shiftNNE b .|. shiftENE b .|.+ shiftESE b .|. shiftSSE b .|.+ shiftSSW b .|. shiftWSW b .|.+ shiftWNW b .|. shiftNNW b+wPawnAttacks = Vector.generate 64 $ \sq -> let b = bit sq in+ shiftSE b .|. shiftSW b+bPawnAttacks = Vector.generate 64 $ \sq -> let b = bit sq in+ shiftNE b .|. shiftNW b++data Direction = N | NE | E | SE | S | SW | W | NW deriving (Eq, Show)++rookTargets, bishopTargets, queenTargets :: Int -> Word64 -> Word64+rookTargets !sq !occ = getRayTargets sq N occ .|. getRayTargets sq E occ+ .|. getRayTargets sq S occ .|. getRayTargets sq W occ+bishopTargets !sq !occ = getRayTargets sq NW occ .|. getRayTargets sq NE occ+ .|. getRayTargets sq SE occ .|. getRayTargets sq SW occ+queenTargets sq occ = rookTargets sq occ .|. bishopTargets sq occ++getRayTargets :: Int -> Direction -> Word64 -> Word64+getRayTargets sq dir occ = blocked $ attacks .&. occ where+ blocked 0 = attacks+ blocked bb = attacks `xor` (ray ! bitScan bb)+ attacks = ray ! sq+ (bitScan, ray) = case dir of+ NW -> (bitScanForward, attackNW)+ N -> (bitScanForward, attackN)+ NE -> (bitScanForward, attackNE)+ E -> (bitScanForward, attackE)+ SE -> (bitScanReverse, attackSE)+ S -> (bitScanReverse, attackS)+ SW -> (bitScanReverse, attackSW)+ W -> (bitScanReverse, attackW)++attackDir :: (Word64 -> Word64) -> Vector Word64+attackDir s = Vector.generate 64 $ \sq ->+ foldr (.|.) 0 $ take 7 $ tail $ iterate s (bit sq)++attackNW, attackN, attackNE, attackE, attackSE, attackS, attackSW, attackW :: Vector Word64+attackNW = attackDir shiftNW+attackN = attackDir shiftN+attackNE = attackDir shiftNE+attackE = attackDir shiftE+attackSE = attackDir shiftSE+attackS = attackDir shiftS+attackSW = attackDir shiftSW+attackW = attackDir shiftW++clearMask :: Bits a => a -> a -> a+clearMask a b = a .&. complement b++testMask :: Bits a => a -> a -> Bool+testMask a b = a .&. b == b++{-# INLINE clearMask #-}+{-# INLINE testMask #-}+{-# INLINE attackedBy #-}+{-# INLINE slideMoves #-}+{-# INLINE wPawnMoves #-}+{-# INLINE bPawnMoves #-}+{-# INLINE unpack #-}+{-# INLINE foldBits #-}+{-# INLINE bitScanForward #-}+{-# INLINE bitScanReverse #-}
src/Game/Chess/PGN.hs view
@@ -181,7 +181,7 @@ e c = T.singleton c moveDoc :: RAVOrder (Doc ann) -> Position -> (Outcome, Forest PlyData) -> Doc ann-moveDoc ro pos (o,ts) = fillSep (go pos True ts <> [pretty o]) <> line where+moveDoc ro p (o,f) = fillSep (go p True f <> [pretty o]) <> line where go _ _ [] = [] go pos pmn (t:ts) | color pos == White || pmn@@ -192,11 +192,11 @@ pl = ply . rootLabel $ t san = pretty $ unsafeToSAN pos pl pos' = unsafeDoPly pos pl- pnag = nag <$> prefixNAG (rootLabel t)+ pnag = prettynag <$> prefixNAG (rootLabel t) mn = pretty (moveNumber pos) <> if color pos == White then "." else "..." rav = ro (parens . fillSep . go pos True) ts- snag = nag <$> suffixNAG (rootLabel t)- nag n = "$" <> pretty n+ snag = prettynag <$> suffixNAG (rootLabel t)+ prettynag n = "$" <> pretty n weightedForest :: PGN -> Forest (Rational, Ply) weightedForest (PGN games) = merge . concatMap rate $ snd <$> filter ok games@@ -206,6 +206,7 @@ w c | o == Win c = 1 | o == Win (opponent c) = -1 | o == Draw = 1 % 2+ | otherwise = 0 f pos (Node a ts') = Node (w (color pos), ply a) $ f (unsafeDoPly pos (ply a)) <$> ts' trunk [] = []
src/Game/Chess/QuadBitboard.hs view
@@ -5,6 +5,7 @@ , pawns, knights, bishops, rooks, queens, kings , wPawns, wKnights, wBishops, wRooks, wQueens, wKings , bPawns, bKnights, bBishops, bRooks, bQueens, bKings+, insufficientMaterial , toString -- * Square codes , Word4(..)@@ -30,16 +31,26 @@ ) where import Control.Applicative (liftA2)-import Data.Binary+import Data.Binary ( Word8, Word64, Binary(put, get) ) import Data.Bits+ ( Bits(xor, complement, bit, unsafeShiftR, (.&.), unsafeShiftL,+ (.|.), testBit, setBit, clearBit, popCount),+ FiniteBits(..) ) import Data.Char (ord, toLower)-import Data.Ix+import Data.Ix ( Ix(inRange) ) import Data.List (groupBy, intercalate) import Data.String (IsString(..)) import qualified Data.Vector.Generic as G import qualified Data.Vector.Generic.Mutable as M import Data.Vector.Unboxed (Vector, MVector, Unbox)+import Foreign.Storable import GHC.Enum+ ( boundedEnumFrom,+ boundedEnumFromThen,+ predError,+ succError,+ toEnumError )+import GHC.Ptr (castPtr, plusPtr) import Numeric (showHex) data QuadBitboard = QBB { black :: {-# UNPACK #-} !Word64@@ -48,6 +59,34 @@ , rqk :: {-# UNPACK #-} !Word64 } deriving (Eq) +insufficientMaterial :: QuadBitboard -> Bool+insufficientMaterial qbb@QBB{black, pbq, nbk, rqk} =+ noPawnsNorQueens && eachSideHasOneKing && noRooks &&+ (oneSideHasAtMostOneMinorPiece || opposingBishopsOnEquallyColoredSquares)+ where+ eachSideHasOneKing = popCount (wKings qbb) == 1 && popCount (bKings qbb) == 1+ noPawnsNorQueens = pbq `xor` bishops qbb == 0+ noRooks = popCount rqk == 2+ oneSideHasAtMostOneMinorPiece =+ (popCount (nbk .&. complement black) == 1 && atMostOneMinorPiece black) ||+ (popCount (nbk .&. black) == 1 && atMostOneMinorPiece (complement black))+ opposingBishopsOnEquallyColoredSquares =+ popCount (knights qbb) == 0 &&+ popCount (nbk .&. black) == 2 && popCount (nbk .&. complement black) == 2 &&+ even (countTrailingZeros (wBishops qbb)) ==+ even (countTrailingZeros (bBishops qbb))+ atMostOneMinorPiece mask = popCount (nbk .&. mask) `elem` [1,2]++instance Storable QuadBitboard where+ sizeOf _ = 32+ alignment _ = 8+ peek p = QBB <$> peek (castPtr p) <*> peek (castPtr $ p `plusPtr` 8) <*> peek (castPtr $ p `plusPtr` 16) <*> peek (castPtr $ p `plusPtr` 24)+ poke p QBB{black, pbq, nbk, rqk} = do+ poke (castPtr $ p) black+ poke (castPtr $ p `plusPtr` 8) pbq+ poke (castPtr $ p `plusPtr` 16) nbk+ poke (castPtr $ p `plusPtr` 24) rqk+ newtype instance MVector s QuadBitboard = MV_QuadBitboard (MVector s (Word64, Word64, Word64, Word64)) newtype instance Vector QuadBitboard = V_QuadBitboard (Vector (Word64, Word64, Word64, Word64)) instance Unbox QuadBitboard@@ -193,7 +232,7 @@ (!) :: QuadBitboard -> Int -> Word4 (!) QBB{..} sq = fromIntegral $ f black 0 .|. f pbq 1 .|. f nbk 2 .|. f rqk 3 where- f bb n = ((bb `unsafeShiftR` sq) .&. 1) `unsafeShiftL` n+ f !bb !n = ((bb `unsafeShiftR` sq) .&. 1) `unsafeShiftL` n setNibble :: Bits nibble => QuadBitboard -> Int -> nibble -> QuadBitboard setNibble QBB{..} sq nb = QBB (f 0 black) (f 1 pbq) (f 2 nbk) (f 3 rqk) where
+ src/Game/Chess/SAN.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE PolyKinds, FlexibleInstances, GADTs, ScopedTypeVariables #-}+module Game.Chess.SAN (+ strictSAN, relaxedSAN, fromSAN,+ toSAN, unsafeToSAN, varToSAN+) where++import Control.Applicative (Applicative(liftA2))+import Control.Arrow ((&&&))+import Data.Bifunctor (first)+import qualified Data.ByteString as Strict (ByteString)+import qualified Data.ByteString.Lazy as Lazy (ByteString)+import Data.Char (chr, ord)+import Data.Functor (($>))+import Data.List (sortOn)+import Data.List.Extra (chunksOf)+import Data.Maybe (fromJust)+import Data.Ord (Down(..))+import Data.Proxy ( Proxy(..) )+import Data.String (IsString(fromString))+import qualified Data.Text as Strict (Text)+import qualified Data.Text.Lazy as Lazy (Text)+import Data.Traversable (mapAccumL)+import Data.Void (Void)+import Data.Word ( Word8 )+import Game.Chess.Internal ( Castle(Queenside, Kingside),+ Ply, Position(color, moveNumber), Color(Black, White),+ PieceType(..), isCapture, pieceAt, toRF, toCoord,+ promoteTo, unpack, doPly, unsafeDoPly, legalPlies,+ inCheck, canCastleKingside, canCastleQueenside,+ wKscm, wQscm, bKscm, bQscm )+import Text.Megaparsec ( optional, (<|>), empty, (<?>), chunk, parse,+ errorBundlePretty, choice, option, Parsec,+ MonadParsec(try, token),+ Stream, TraversableStream, VisualStream,+ Token, Tokens, chunkLength )++type Parser s = Parsec Void s++castling :: (Stream s, IsString (Tokens s))+ => Position -> Parser s Ply+castling pos+ | ccks && ccqs = queenside <|> kingside+ | ccks = kingside+ | ccqs = queenside+ | otherwise = empty+ where+ ccks = canCastleKingside pos+ ccqs = canCastleQueenside pos+ kingside = chunk "O-O" $> castleMove Kingside+ queenside = chunk "O-O-O" $> castleMove Queenside+ castleMove Kingside | color pos == White = wKscm+ | otherwise = bKscm+ castleMove Queenside | color pos == White = wQscm+ | otherwise = bQscm++data From = File Int+ | Rank Int+ | Square Int+ deriving (Eq, Show)++data SANStatus = Check | Checkmate deriving (Eq, Read, Show)++class SANToken a where+ sanPieceToken :: a -> Maybe PieceType+ fileToken :: a -> Maybe Int+ rankToken :: a -> Maybe Int+ promotionPieceToken :: a -> Maybe PieceType+ statusToken :: a -> Maybe SANStatus++sanPiece :: (Stream s, SANToken (Token s)) => Parser s PieceType+sanPiece = token sanPieceToken mempty <?> "piece"++fileP, rankP, squareP :: (Stream s, SANToken (Token s)) => Parser s Int+fileP = token fileToken mempty <?> "file"+rankP = token rankToken mempty <?> "rank"+squareP = liftA2 (\f r -> r*8+f) fileP rankP <?> "square"++promotionPiece :: (Stream s, SANToken (Token s)) => Parser s PieceType+promotionPiece = token promotionPieceToken mempty <?> "Q, R, B, N"++sanStatus :: (Stream s, SANToken (Token s)) => Parser s SANStatus+sanStatus = token statusToken mempty <?> "+, #"++instance SANToken Char where+ sanPieceToken = \case+ 'N' -> Just Knight+ 'B' -> Just Bishop+ 'R' -> Just Rook+ 'Q' -> Just Queen+ 'K' -> Just King+ _ -> Nothing+ fileToken c | c >= 'a' && c <= 'h' = Just $ ord c - ord 'a'+ | otherwise = Nothing+ rankToken c | c >= '1' && c <= '8' = Just $ ord c - ord '1'+ | otherwise = Nothing+ promotionPieceToken = \case+ 'N' -> Just Knight+ 'B' -> Just Bishop+ 'R' -> Just Rook+ 'Q' -> Just Queen+ _ -> Nothing+ statusToken = \case+ '+' -> Just Check+ '#' -> Just Checkmate+ _ -> Nothing++instance SANToken Word8 where+ sanPieceToken = \case+ 78 -> Just Knight+ 66 -> Just Bishop+ 82 -> Just Rook+ 81 -> Just Queen+ 75 -> Just King+ _ -> Nothing+ rankToken c | c >= 49 && c <= 56 = Just . fromIntegral $ c - 49+ | otherwise = Nothing+ fileToken c | c >= 97 && c <= 104 = Just . fromIntegral $ c - 97+ | otherwise = Nothing+ promotionPieceToken = \case+ 78 -> Just Knight+ 66 -> Just Bishop+ 82 -> Just Rook+ 81 -> Just Queen+ _ -> Nothing+ statusToken = \case+ 43 -> Just Check+ 35 -> Just Checkmate+ _ -> Nothing++strictSAN :: forall s. (Stream s, SANToken (Token s), IsString (Tokens s))+ => Position -> Parser s Ply+strictSAN pos = case legalPlies pos of+ [] -> fail "No legal moves in this position"+ ms -> (castling pos <|> normal ms) >>= checkStatus+ where+ normal ms = do+ p <- sanPiece <|> pure Pawn+ case filter (pieceFrom p) ms of+ [] -> fail $ show (color pos) <> " has no " <> show p <> " which could be moved"+ ms' -> target p ms'+ pieceFrom p (moveFrom -> from) = p == snd (fromJust (pieceAt pos from))+ moveFrom (unpack -> (from, _, _)) = from+ target p ms = coords p ms >>= \m@(unpack -> (_, to, _)) -> case p of+ Pawn | lastRank to -> promoteTo m <$> promotion+ _ -> pure m+ coords p ms = choice $ fmap (uncurry (<$) . fmap chunk) $+ sortOn (Down . chunkLength (Proxy :: Proxy s) . snd) $+ (\m -> (m, sanCoords pos (p,ms) m)) <$> ms+ promotion = chunk "=" *> promotionPiece+ lastRank i = i >= 56 || i <= 7+ checkStatus m+ | inCheck (color nextPos) nextPos && null (legalPlies nextPos)+ = chunk "#" $> m+ | inCheck (color nextPos) nextPos+ = chunk "+" $> m+ | otherwise+ = pure m+ where+ nextPos = unsafeDoPly pos m++relaxedSAN :: (Stream s, SANToken (Token s), IsString (Tokens s))+ => Position -> Parser s Ply+relaxedSAN pos = (castling pos <|> normal) <* optional sanStatus where+ normal = do+ pc <- sanPiece <|> pure Pawn+ (from, _, to) <- conv <$> location+ prm <- optional $ optional (chunk "=") *> promotionPiece+ case possible pc from to prm of+ [m] -> pure m+ [] -> fail "Illegal move"+ _ -> fail "Ambiguous move"+ conv (Nothing, Nothing, cap, to) = (Nothing, cap, to)+ conv (Just f, Nothing, cap, to) = (Just (File f), cap, to)+ conv (Nothing, Just r, cap, to) = (Just (Rank r), cap, to)+ conv (Just f, Just r, cap, to) = (Just (Square (r*8+f)), cap, to)+ location = try ((,Nothing,,) <$> (Just <$> fileP) <*> capture <*> squareP)+ <|> try ((Nothing,,,) <$> (Just <$> rankP) <*> capture <*> squareP)+ <|> try ((,,,) <$> (Just <$> fileP) <*> (Just <$> rankP)+ <*> capture <*> squareP)+ <|> (Nothing,Nothing,,) <$> capture <*> squareP+ capture = option False $ chunk "x" $> True+ ms = legalPlies pos+ possible pc from to prm = filter (f from) ms where+ f (Just (Square sq)) (unpack -> (from', to', prm')) =+ pAt from' == pc && from' == sq && to' == to && prm' == prm+ f (Just (File ff)) (unpack -> (from', to', prm')) =+ pAt from' == pc && from' `mod` 8 == ff && to == to' && prm == prm'+ f (Just (Rank fr)) (unpack -> (from', to', prm')) =+ pAt from' == pc && from' `div` 8 == fr && to == to' && prm == prm'+ f Nothing (unpack -> (from', to', prm')) =+ pAt from' == pc && to == to' && prm == prm'+ pAt = snd . fromJust . pieceAt pos++fromSAN :: (VisualStream s, TraversableStream s, SANToken (Token s), IsString (Tokens s))+ => Position -> s -> Either String Ply+fromSAN pos = first errorBundlePretty . parse (relaxedSAN pos) ""++toSAN :: IsString s => Position -> Ply -> s+toSAN pos m+ | m `elem` legalPlies pos = fromString $ unsafeToSAN pos m+ | otherwise = error "Game.Chess.toSAN: Illegal move"++varToSAN :: IsString s => Position -> [Ply] -> s+varToSAN _ [] = ""+varToSAN pos plies+ | color pos == Black && length plies == 1+ = fromString $ show (moveNumber pos) <> "..." <> toSAN pos (head plies)+ | color pos == Black+ = fromString $ show (moveNumber pos) <> "..." <> toSAN pos (head plies) <> " " <> fromWhite (doPly pos (head plies)) (tail plies)+ | otherwise+ = fromString $ fromWhite pos plies+ where+ fromWhite pos' = unwords . concat+ . zipWith f [moveNumber pos' ..] . chunksOf 2 . snd+ . mapAccumL (curry (uncurry doPly &&& uncurry toSAN)) pos'+ f n (x:xs) = (show n <> "." <> x):xs+ f _ [] = []++sanCoords :: IsString s => Position -> (PieceType, [Ply]) -> Ply -> s+sanCoords pos (pc,lms) m@(unpack -> (from, to, _)) =+ fromString $ source <> target+ where+ capture = isCapture pos m+ source+ | pc == Pawn && capture+ = [fileChar from]+ | pc == Pawn+ = []+ | length ms == 1+ = []+ | length (filter fEq ms) == 1+ = [fileChar from]+ | length (filter rEq ms) == 1+ = [rankChar from]+ | otherwise+ = toCoord from+ target+ | capture = "x" <> toCoord to+ | otherwise = toCoord to+ ms = filter (isMoveTo to) lms+ isMoveTo sq (unpack -> (_, to', _)) = sq == to'+ fEq (unpack -> (from', _, _)) = from' `mod` 8 == fromFile+ rEq (unpack -> (from', _, _)) = from' `div` 8 == fromRank+ (fromRank, fromFile) = toRF from+ fileChar i = chr $ (i `mod` 8) + ord 'a'+ rankChar i = chr $ (i `div` 8) + ord '1'++unsafeToSAN :: Position -> Ply -> String+unsafeToSAN pos m@(unpack -> (from, to, promo)) =+ moveStr <> status+ where+ moveStr = case piece of+ Pawn | capture -> fileChar from : target <> promotion+ | otherwise -> target <> promotion+ King | color pos == White && m == wKscm -> "O-O"+ | color pos == White && m == wQscm -> "O-O-O"+ | color pos == Black && m == bKscm -> "O-O"+ | color pos == Black && m == bQscm -> "O-O-O"+ | otherwise -> 'K' : target+ Knight -> 'N' : source <> target+ Bishop -> 'B' : source <> target+ Rook -> 'R' : source <> target+ Queen -> 'Q' : source <> target+ piece = fromJust $ snd <$> pieceAt pos from+ capture = isCapture pos m+ source+ | length ms == 1 = []+ | length (filter fEq ms) == 1 = [fileChar from]+ | length (filter rEq ms) == 1 = [rankChar from]+ | otherwise = toCoord from+ target+ | capture = "x" <> toCoord to+ | otherwise = toCoord to+ promotion = case promo of+ Just Knight -> "N"+ Just Bishop -> "B"+ Just Rook -> "R"+ Just Queen -> "Q"+ _ -> ""+ status | inCheck (color nextPos) nextPos && null (legalPlies nextPos)+ = "#"+ | inCheck (color nextPos) nextPos+ = "+"+ | otherwise+ = ""+ nextPos = unsafeDoPly pos m+ ms = filter movesTo $ legalPlies pos+ movesTo (unpack -> (from', to', _)) =+ fmap snd (pieceAt pos from') == Just piece && to' == to+ fEq (unpack -> (from', _, _)) = from' `mod` 8 == fromFile+ rEq (unpack -> (from', _, _)) = from' `div` 8 == fromRank+ (fromRank, fromFile) = toRF from+ fileChar i = chr $ (i `mod` 8) + ord 'a'+ rankChar i = chr $ (i `div` 8) + ord '1'++{-# SPECIALISE relaxedSAN :: Position -> Parser Strict.ByteString Ply #-}+{-# SPECIALISE relaxedSAN :: Position -> Parser Lazy.ByteString Ply #-}+{-# SPECIALISE relaxedSAN :: Position -> Parser Strict.Text Ply #-}+{-# SPECIALISE relaxedSAN :: Position -> Parser Lazy.Text Ply #-}+{-# SPECIALISE relaxedSAN :: Position -> Parser String Ply #-}+{-# SPECIALISE strictSAN :: Position -> Parser Strict.ByteString Ply #-}+{-# SPECIALISE strictSAN :: Position -> Parser Lazy.ByteString Ply #-}+{-# SPECIALISE strictSAN :: Position -> Parser Strict.Text Ply #-}+{-# SPECIALISE strictSAN :: Position -> Parser Lazy.Text Ply #-}+{-# SPECIALISE strictSAN :: Position -> Parser String Ply #-}
+ src/Game/Chess/Tree.hs view
@@ -0,0 +1,17 @@+module Game.Chess.Tree where++import Data.Tree ( Tree(Node), Forest )+import Game.Chess.Internal++positionTree :: Position -> Tree Position+positionTree pos = Node pos $ positionForest pos++positionForest :: Position -> Forest Position+positionForest pos = positionTree . unsafeDoPly pos <$> legalPlies pos++plyForest :: Position -> Forest Ply+plyForest pos = plyTree pos <$> legalPlies pos++plyTree :: Position -> Ply -> Tree Ply+plyTree pos ply = Node ply . plyForest $ unsafeDoPly pos ply+
src/Game/Chess/UCI.hs view
@@ -2,7 +2,7 @@ -- * Exceptions UCIException(..) -- * The Engine data type-, Engine, name, author+, Engine, BestMove, name, author -- * Starting a UCI engine , start, start' -- * Engine options@@ -24,7 +24,7 @@ import Control.Applicative import Control.Concurrent-import Control.Concurrent.STM+import Control.Concurrent.STM hiding (check) import Control.Exception import Control.Monad import Control.Monad.IO.Class@@ -49,6 +49,8 @@ import Time.Rational import Time.Units +type BestMove = Maybe (Ply, Maybe Ply)+ data Engine = Engine { inH :: Handle , outH :: Handle@@ -61,7 +63,7 @@ , isReady :: MVar () , isSearching :: IORef Bool , infoChan :: TChan [Info]-, bestMoveChan :: TChan (Ply, Maybe Ply)+, bestMoveChan :: TChan BestMove , game :: IORef (Position, [Ply]) } @@ -80,13 +82,13 @@ instance Exception UCIException -data Command = Name ByteString- | Author ByteString- | Option ByteString Option+data Command = Name !ByteString+ | Author !ByteString+ | Option !ByteString !Option | UCIOk | ReadyOK | Info [Info]- | BestMove !(Ply, Maybe Ply)+ | BestMove !BestMove deriving (Show) data Info = PV [Ply]@@ -129,7 +131,7 @@ , "uciok" $> UCIOk , "readyok" $> ReadyOK , "info" `kv` fmap Info (sepBy1 infoItem skipSpace)- , "bestmove" `kv` bestmove+ , "bestmove" `kv` ("(none)" $> BestMove Nothing <|> bestmove) ] <* skipSpace where name = Name <$> kv "name" takeByteString@@ -170,7 +172,7 @@ <|> NPS <$> kv "nps" decimal <|> HashFull <$> kv "hashfull" decimal <|> TBHits <$> kv "tbhits" decimal- <|> Elapsed . ms . fromIntegral <$> kv "time" decimal+ <|> Elapsed . ms . fromInteger <$> kv "time" decimal <|> kv "pv" pv <|> kv "currmove" currmove <|> CurrMoveNumber <$> kv "currmovenumber" decimal@@ -182,9 +184,9 @@ <|> LowerBound <$ "lowerbound" ) pure $ Score s b- pv = fmap (PV . snd) $ foldM toPly (pos, []) =<< sepBy mv skipSpace+ pv = fmap (PV . reverse . snd) $ foldM toPly (pos, []) =<< sepBy mv skipSpace toPly (pos, xs) s = case fromUCI pos s of- Just m -> pure (doPly pos m, xs <> [m])+ Just m -> pure (unsafeDoPly pos m, m : xs) Nothing -> fail $ "Failed to parse move " <> s currmove = fmap (fromUCI pos) mv >>= \case Just m -> pure $ CurrMove m@@ -202,9 +204,9 @@ ponder <- optional (skipSpace *> kv "ponder" mv) case fromUCI pos m of Just m' -> case ponder of- Nothing -> pure $ BestMove (m', Nothing)+ Nothing -> pure . BestMove . Just $ (m', Nothing) Just p -> case fromUCI (doPly pos m') p of- Just p' -> pure $ BestMove (m', Just p')+ Just p' -> pure . BestMove . Just $ (m', Just p') Nothing -> fail $ "Failed to parse ponder move " <> p Nothing -> fail $ "Failed to parse best move " <> m kv k v = k *> skipSpace *> v@@ -320,7 +322,7 @@ -- | Instruct the engine to begin searching. search :: MonadIO m => Engine -> [SearchParam]- -> m (TChan (Ply, Maybe Ply), TChan [Info])+ -> m (TChan BestMove, TChan [Info]) search e@Engine{isSearching} params = liftIO $ do chans <- atomically $ (,) <$> dupTChan (bestMoveChan e) <*> dupTChan (infoChan e)
test/Perft.hs view
@@ -12,6 +12,9 @@ import System.Exit import System.IO +type Depth = Int+type Testsuite = [(Position, [(Depth, PerftResult)])]+ main :: IO () main = do start <- getCurrentTime@@ -43,10 +46,10 @@ instance Monoid PerftResult where mempty = PerftResult 0 -showResult :: Int -> PerftResult -> String+showResult :: Depth -> PerftResult -> String showResult depth PerftResult{nodes} = show depth <> " " <> show nodes -perft :: Int -> Position -> PerftResult+perft :: Depth -> Position -> PerftResult perft 0 _ = PerftResult 1 perft 1 p = PerftResult . fromIntegral . length $ legalPlies p perft n p@@ -55,7 +58,7 @@ | otherwise = fold . parMap rdeepseq (perft (pred n) . unsafeDoPly p) $ legalPlies p -runTestSuite :: [(Position, [(Int, PerftResult)])] -> IO (Maybe PerftResult)+runTestSuite :: Testsuite -> IO (Maybe PerftResult) runTestSuite = fmap (getAp . foldMap Ap) . traverse (uncurry (test mempty)) where test sum pos ((depth, expected) : more) | result == expected@@ -73,7 +76,7 @@ fen = toFEN pos test sum _ [] = pure (Just sum) -readTestSuite :: FilePath -> IO [(Position, [(Int, PerftResult)])]+readTestSuite :: FilePath -> IO Testsuite readTestSuite fp = do epd <- readFile fp pure $ fmap readData . (\ws -> (fromJust (fromFEN (unwords $ take 6 ws)), drop 6 ws)) . words <$> lines epd